(*  Title:       One procedure
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

section "Hoare Logics for 1 Procedure"

theory PLang imports Main begin

subsection\<open>The language\<close>

typedecl state

type_synonym bexp = "state \<Rightarrow> bool"

datatype com = Do "(state \<Rightarrow> state set)"
             | Semi  com com            ("_; _"  [60, 60] 10)
             | Cond  bexp com com     ("IF _ THEN _ ELSE _"  60)
             | While bexp com           ("WHILE _ DO _"  60)
             | CALL
             | Local "(state \<Rightarrow> state)" com "(state \<Rightarrow> state \<Rightarrow> state)"
               ("LOCAL _; _; _" [0,0,60] 60)

text\<open>\noindent There is only one parameterless procedure in the program. Hence
@{term CALL} does not even need to mention the procedure name. There
is no separate syntax for procedure declarations. Instead we declare a HOL
constant that represents the body of the one procedure in the program.\<close>

consts body :: com

text\<open>\noindent
As before, command execution is described by transitions
\<open>s -c\<rightarrow> t\<close>. The only new rule is the one for @{term CALL} ---
it requires no comment:\<close>

inductive
  exec :: "state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"  ("_/ -_\<rightarrow>/ _" [50,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c1\<rightarrow> s1; s1 -c2\<rightarrow> s2 \<rbrakk>
            \<Longrightarrow> s0 -c1;c2\<rightarrow> s2"

  | IfTrue:  "\<lbrakk> b s;  s -c1\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"
  | IfFalse: "\<lbrakk> \<not>b s; s -c2\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c\<rightarrow> s"
  | WhileTrue:  "\<lbrakk> b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"

  | "s -body\<rightarrow> t \<Longrightarrow> s -CALL\<rightarrow> t"

  | Local: "f s -c\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g\<rightarrow> g s t"

lemma [iff]: "(s -c;d\<rightarrow> u) = (\<exists>t. s -c\<rightarrow> t \<and> t -d\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -IF b THEN c ELSE d\<rightarrow> t) =
              (s -if b s then c else d\<rightarrow> t)"
apply(rule iffI)
 apply(auto elim: exec.cases intro:exec.intros)
apply(auto intro:exec.intros split:if_split_asm)
done

lemma unfold_while:
 "(s -WHILE b DO c\<rightarrow> u) =
  (s -IF b THEN c;WHILE b DO c ELSE Do(\<lambda>s. {s})\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros split:if_split_asm)

lemma [iff]: "(s -CALL\<rightarrow> t) = (s -body\<rightarrow> t)"
by(blast elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -LOCAL f; c; g\<rightarrow> u) = (\<exists>t. f s -c\<rightarrow> t \<and> u = g s t)"
by(fastforce elim: exec.cases intro:exec.intros)

lemma WhileI: "\<lbrakk>b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u\<rbrakk> \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"
by(fastforce elim:exec.WhileTrue)
(*>*)

text\<open>This semantics turns out not to be fine-grained
enough. The soundness proof for the Hoare logic below proceeds by
induction on the call depth during execution. To make this work we
define a second semantics \mbox{\<open>s -c-n\<rightarrow> t\<close>} which expresses that the
execution uses at most @{term n} nested procedure invocations, where
@{term n} is a natural number. The rules are straightforward: @{term
n} is just passed around, except for procedure calls, where it is
decremented:\<close>

inductive
  execn :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_-_\<rightarrow>/ _" [50,0,0,50] 50)
where
  "t \<in> f s \<Longrightarrow> s -Do f-n\<rightarrow> t"

| "\<lbrakk> s0 -c1-n\<rightarrow> s1; s1 -c2-n\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c1;c2-n\<rightarrow> s2"

| "\<lbrakk>  b s; s -c1-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2-n\<rightarrow> t"
| "\<lbrakk> \<not>b s; s -c2-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2-n\<rightarrow> t"

| (*<*)WhileFalse:(*>*)"\<not>b s \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> s"
| (*<*)WhileTrue:(*>*)"\<lbrakk>b s; s -c-n\<rightarrow> t; t -WHILE b DO c-n\<rightarrow> u\<rbrakk> \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> u"

| "s -body-n\<rightarrow> t \<Longrightarrow> s -CALL-Suc n\<rightarrow> t"

| "f s -c-n\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g-n\<rightarrow> g s t"

lemma [iff]: "(s -Do f-n\<rightarrow> t) = (t \<in> f s)"
by(auto elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -c1;c2-n\<rightarrow> u) = (\<exists>t. s -c1-n\<rightarrow> t \<and> t -c2-n\<rightarrow> u)"
by(best elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -IF b THEN c ELSE d-n\<rightarrow> t) =
              (s -if b s then c else d-n\<rightarrow> t)"
apply auto
apply(blast elim: execn.cases intro:execn.intros)+
done

lemma [iff]: "(s -CALL- 0\<rightarrow> t) = False"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -CALL-Suc n\<rightarrow> t) = (s -body-n\<rightarrow> t)"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -LOCAL f; c; g-n\<rightarrow> u) = (\<exists>t. f s -c-n\<rightarrow> t \<and> u = g s t)"
by(auto elim: execn.cases intro:execn.intros)

text\<open>\noindent By induction on @{prop"s -c-m\<rightarrow> t"} we show
monotonicity w.r.t.\ the call depth:\<close>

lemma exec_mono[rule_format]: "s -c-m\<rightarrow> t \<Longrightarrow> \<forall>n. m \<le> n \<longrightarrow> s -c-n\<rightarrow> t"
apply(erule execn.induct)
         apply(blast)
        apply(blast)
       apply(simp)
      apply(simp)
     apply(simp add:execn.intros)
    apply(blast intro:execn.intros)
   apply(clarify)
   apply(rename_tac m)
   apply(case_tac m)
    apply simp
   apply simp
  apply blast
done

text\<open>\noindent With the help of this lemma we prove the expected
relationship between the two semantics:\<close>

lemma exec_iff_execn: "(s -c\<rightarrow> t) = (\<exists>n. s -c-n\<rightarrow> t)"
apply(rule iffI)
apply(erule exec.induct)
           apply blast
          apply clarify
          apply(rename_tac m n)
          apply(rule_tac x = "max m n" in exI)
          apply(fastforce intro:exec.intros exec_mono simp add:max_def)
         apply fastforce
        apply fastforce
       apply(blast intro:execn.intros)
      apply clarify
      apply(rename_tac m n)
      apply(rule_tac x = "max m n" in exI)
      apply(fastforce elim:execn.WhileTrue exec_mono simp add:max_def)
     apply blast
    apply blast
apply(erule exE, erule execn.induct)
         apply blast
        apply blast
       apply fastforce
      apply fastforce
     apply(erule exec.WhileFalse)
    apply(blast intro: exec.intros)
   apply blast
  apply blast
done

lemma while_lemma[rule_format]:
"s -w-n\<rightarrow> t \<Longrightarrow> \<forall>b c. w = WHILE b DO c \<and> P s \<and>
                    (\<forall>s s'. P s \<and> b s \<and> s -c-n\<rightarrow> s' \<longrightarrow> P s') \<longrightarrow> P t \<and> \<not>b t"
apply(erule execn.induct)
apply clarify+
defer
apply clarify+
apply(subgoal_tac "P t")
apply blast
apply blast
done

lemma while_rule:
 "\<lbrakk>s -WHILE b DO c-n\<rightarrow> t; P s; \<And>s s'. \<lbrakk>P s; b s; s -c-n\<rightarrow> s' \<rbrakk> \<Longrightarrow> P s'\<rbrakk>
  \<Longrightarrow> P t \<and> \<not>b t"
apply(drule while_lemma)
prefer 2 apply assumption
apply blast
done

end


(*  Author:     Stefan Berghofer, TU Muenchen, 2005
*)

theory Basis
imports Main
begin

section \<open>General Utilities\<close>

text \<open>
This section introduces some general utilities that will be useful later on in
the formalization of System \fsub{}.

The following rewrite rules are useful for simplifying mutual induction rules.
\<close>

lemma True_simps:
  "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
  "(PROP P \<Longrightarrow> True) \<equiv> PROP Trueprop True"
  "(\<And>x. True) \<equiv> PROP Trueprop True"
  apply -
  apply rule
  apply (erule meta_mp)
  apply (rule TrueI)
  apply assumption
  apply rule
  apply (rule TrueI)
  apply assumption
  apply rule
  apply (rule TrueI)+
  done

text \<open>
Unfortunately, the standard introduction and elimination rules for bounded
universal and existential quantifier do not work properly for sets of pairs.
\<close>

lemma ballpI: "(\<And>x y. (x, y) \<in> A \<Longrightarrow> P x y) \<Longrightarrow> \<forall>(x, y) \<in> A. P x y"
  by blast

lemma bpspec: "\<forall>(x, y) \<in> A. P x y \<Longrightarrow> (x, y) \<in> A \<Longrightarrow> P x y"
  by blast

lemma ballpE: "\<forall>(x, y) \<in> A. P x y \<Longrightarrow> (P x y \<Longrightarrow> Q) \<Longrightarrow>
  ((x, y) \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
  by blast

lemma bexpI: "P x y \<Longrightarrow> (x, y) \<in> A \<Longrightarrow> \<exists>(x, y) \<in> A. P x y"
  by blast

lemma bexpE: "\<exists>(x, y) \<in> A. P x y \<Longrightarrow>
  (\<And>x y. (x, y) \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q) \<Longrightarrow> Q"
  by blast

lemma ball_eq_sym: "\<forall>(x, y) \<in> S. f x y = g x y \<Longrightarrow> \<forall>(x, y) \<in> S. g x y = f x y"
  by auto

lemma wf_measure_size: "wf (measure size)" by simp

notation
  Some ("\<lfloor>_\<rfloor>")

notation
  None ("\<bottom>")

notation
  length ("\<parallel>_\<parallel>")

notation
  Cons ("_ \<Colon>/ _" [66, 65] 65)

text \<open>
The following variant of the standard \<open>nth\<close> function returns
\<open>\<bottom>\<close> if the index is out of range.
\<close>

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = \<bottom>"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

lemma [simp]: "\<parallel>xs\<parallel> \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle> = ys\<langle>i - \<parallel>xs\<parallel>\<rangle>"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
  done

text \<open>Association lists\<close>

primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^sub>?" [90, 0] 91)
where
  "[]\<langle>a\<rangle>\<^sub>? = \<bottom>"
| "(x # xs)\<langle>a\<rangle>\<^sub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^sub>?)"

primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^sub>? = \<bottom> \<and> unique xs)"

lemma assoc_set: "ps\<langle>x\<rangle>\<^sub>? = \<lfloor>y\<rfloor> \<Longrightarrow> (x, y) \<in> set ps"
  by (induct ps) (auto split: if_split_asm)

lemma map_assoc_None [simp]:
  "ps\<langle>x\<rangle>\<^sub>? = \<bottom> \<Longrightarrow> map (\<lambda>(x, y). (x, f x y)) ps\<langle>x\<rangle>\<^sub>? = \<bottom>"
  by (induct ps) auto

no_syntax
  "_Map" :: "maplets => 'a \<rightharpoonup> 'b"  ("(1[_])")

end


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

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\"]"

typedecl Bool

consts
Not__X :: "bool => bool" ("(Not''/ _)" [56] 56)
X__XAmpXAmp__X :: "bool => bool => bool" ("(_/ &&/ _)" [54,54] 52)
X__XVBarXVBar__X :: "bool => bool => bool" ("(_/ ||/ _)" [54,54] 52)
otherwiseH :: "bool"

axioms
NotFalse [rule_format] : "Not' False"

NotTrue [rule_format] : "~ Not' True"

AndFalse [rule_format] : "ALL x. ~ False && x"

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

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

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

OtherwiseDef [rule_format] : "otherwiseH"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare OtherwiseDef [simp]

theorem NotFalse1 : "ALL x. Not' x = (~ x)"
by (auto)

ML "Header.record \"NotFalse1\""

theorem NotTrue1 : "ALL x. ~ Not' x = x"
by (auto)

ML "Header.record \"NotTrue1\""

theorem notNot1 : "ALL x. (~ x) = Not' x"
by (auto)

ML "Header.record \"notNot1\""

theorem notNot2 : "ALL x. (~ ~ x) = (~ Not' x)"
apply(auto)
apply(case_tac x)
apply(auto)
done

ML "Header.record \"notNot2\""

end


(*  Title:       Aodv_Predicates.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Invariant assumptions and properties"

theory Aodv_Predicates
imports Aodv
begin

text \<open>Definitions for expression assumptions on incoming messages and properties of
      outgoing messages.\<close>

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Rreq _ _ _ _ _ _ _ ipc \<Rightarrow> ipc
                              | Rrep _ _ _ _ ipc \<Rightarrow> ipc
                              | Rerr _ ipc \<Rightarrow> ipc
                              | Pkt _ _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                          msg_sender (Rreq hops rreqid dip dsn dsk oip osn sip) = sip"
  "\<And>hops dip dsn oip sip. msg_sender (Rrep hops dip dsn oip sip) = sip"
  "\<And>dests sip.            msg_sender (Rerr dests sip) = sip"
  "\<And>d dip sip.            msg_sender (Pkt d dip sip) = sip"
  unfolding msg_sender_def by simp_all

definition msg_zhops :: "msg \<Rightarrow> bool"
where "msg_zhops m \<equiv> case m of
                                 Rreq hopsc _ dipc _ _ oipc _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> oipc = sipc
                               | Rrep hopsc dipc _ _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> dipc = sipc
                               | _ \<Rightarrow> True"

lemma msg_zhops_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           msg_zhops (Rreq hops rreqid dip dsn dsk oip osn sip) = (hops = 0 \<longrightarrow> oip = sip)"
  "\<And>hops dip dsn oip sip. msg_zhops (Rrep hops dip dsn oip sip) = (hops = 0 \<longrightarrow> dip = sip)"
  "\<And>dests sip.            msg_zhops (Rerr dests sip)        = True"
  "\<And>d dip.                msg_zhops (Newpkt d dip)          = True"
  "\<And>d dip sip.            msg_zhops (Pkt d dip sip)         = True"
  unfolding msg_zhops_def by simp_all

definition rreq_rrep_sn :: "msg \<Rightarrow> bool"
where "rreq_rrep_sn m \<equiv> case m of Rreq _ _ _ _ _ _ osnc _ \<Rightarrow> osnc \<ge> 1
                                | Rrep _ _ dsnc _ _ \<Rightarrow> dsnc \<ge> 1
                                | _ \<Rightarrow> True"

lemma rreq_rrep_sn_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_sn (Rreq hops rreqid dip dsn dsk oip osn sip) = (osn \<ge> 1)"
  "\<And>hops dip dsn oip sip. rreq_rrep_sn (Rrep hops dip dsn oip sip) = (dsn \<ge> 1)"
  "\<And>dests sip.            rreq_rrep_sn (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_sn (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_sn (Pkt d dip sip)  = True"
  unfolding rreq_rrep_sn_def by simp_all

definition rreq_rrep_fresh :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rreq_rrep_fresh crt m \<equiv> case m of Rreq hopsc _ _ _ _ oipc osnc ipcc \<Rightarrow> (ipcc \<noteq> oipc \<longrightarrow>
                                                oipc\<in>kD(crt) \<and> (sqn crt oipc > osnc
                                                                \<or> (sqn crt oipc = osnc
                                                                   \<and> the (dhops crt oipc) \<le> hopsc
                                                                   \<and> the (flag crt oipc) = val)))
                                | Rrep hopsc dipc dsnc _ ipcc \<Rightarrow> (ipcc \<noteq> dipc \<longrightarrow>
                                                                    dipc\<in>kD(crt)
                                                                  \<and> sqn crt dipc = dsnc
                                                                  \<and> the (dhops crt dipc) = hopsc
                                                                  \<and> the (flag crt dipc) = val)
                                | _ \<Rightarrow> True"

lemma rreq_rrep_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           rreq_rrep_fresh crt (Rreq hops rreqid dip dsn dsk oip osn sip) =
                               (sip \<noteq> oip \<longrightarrow> oip\<in>kD(crt)
                                            \<and> (sqn crt oip > osn
                                               \<or> (sqn crt oip = osn
                                                  \<and> the (dhops crt oip) \<le> hops
                                                  \<and> the (flag crt oip) = val)))"
  "\<And>hops dip dsn oip sip. rreq_rrep_fresh crt (Rrep hops dip dsn oip sip) =
                               (sip \<noteq> dip \<longrightarrow> dip\<in>kD(crt)
                                              \<and> sqn crt dip = dsn
                                              \<and> the (dhops crt dip) = hops
                                              \<and> the (flag crt dip) = val)"
  "\<And>dests sip.            rreq_rrep_fresh crt (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_fresh crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_fresh crt (Pkt d dip sip)  = True"
  unfolding rreq_rrep_fresh_def by simp_all

definition rerr_invalid :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rerr_invalid crt m \<equiv> case m of Rerr destsc _ \<Rightarrow> (\<forall>ripc\<in>dom(destsc).
                                            (ripc\<in>iD(crt) \<and> the (destsc ripc) = sqn crt ripc))
                                | _ \<Rightarrow> True"

lemma rerr_invalid [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
                           rerr_invalid crt (Rreq hops rreqid dip dsn dsk oip osn sip) = True"
  "\<And>hops dip dsn oip sip. rerr_invalid crt (Rrep hops dip dsn oip sip) = True"
  "\<And>dests sip.            rerr_invalid crt (Rerr dests sip) = (\<forall>rip\<in>dom(dests).
                                                 rip\<in>iD(crt) \<and> the (dests rip) = sqn crt rip)"
  "\<And>d dip.                rerr_invalid crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rerr_invalid crt (Pkt d dip sip)  = True"
  unfolding rerr_invalid_def by simp_all

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> aodv_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = aodv_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

text \<open>We introduce a streamlined alternative to @{term initmissing} with @{term netgmap}
        to simplify invariant statements and thus facilitate their comprehension and
        presentation.\<close>

lemma fst_initmissing_netgmap_default_aodv_init_netlift:
  "fst (initmissing (netgmap fst s)) = default aodv_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default aodv_init (netlift fst s)))"

end


theory PartialityTest_Test_E1
imports "$HETS_ISABELLE_LIB/MainHC" "$HETS_LIB/Isabelle/RestrictOpProps"
uses "$HETS_ISABELLE_LIB/prelude"
begin

ML "Header.initialize [\"Ax1\", \"Ax1_2\"]"

typedecl a

consts
X_f :: "a => a => a partial" ("f/'(_,/ _')" [3,3] 999)

axioms
Ax1 [rule_format] :
"ALL (x :: a).
 ALL (y :: a).
 ALL (z :: a).
 defOp (f(x, y)) & defOp (f(y, z)) -->
 restrictOp (f(x, makeTotal (f(y, z)))) (defOp (f(y, z))) =
 restrictOp (f(makeTotal (f(x, y)), z)) (defOp (f(x, y)))"

lemma assoc_dom : "defOp (f(x, y)) & defOp (f(y, z)) ==>
  (defOp (f(x, makeTotal (f(y, z)))) & defOp (f(y, z))) =
  (defOp (f(makeTotal (f(x, y)), z)) & defOp (f(x, y)))"
apply (frule Ax1)
apply (simp)
done

lemma assoc_eq : "defOp (f(x, y)) & defOp (f(y, z)) ==>
  f(x, makeTotal (f(y, z))) = f(makeTotal (f(x, y)), z)"
apply (frule Ax1)
apply (simp)
done

theorem Ax1_2 :
"ALL (w :: a).
 ALL (x :: a).
 ALL (y :: a).
 ALL (z :: a).
 defOp (restrictOp (f(x, makeTotal (f(y, z)))) (defOp (f(y, z)))) &
 defOp
 (restrictOp (f(y, makeTotal (f(z, w)))) (defOp (f(z, w)))) -->
 restrictOp (f(makeTotal (f(x, makeTotal (f(y, z)))), w))
 (defOp (f(x, makeTotal (f(y, z)))) & defOp (f(y, z))) =
 restrictOp (f(x, makeTotal (f(y, makeTotal (f(z, w))))))
 (defOp (f(y, makeTotal (f(z, w)))) & defOp (f(z, w)))"
apply (auto)
apply (simp add: assoc_eq assoc_dom)
done

ML "Header.record \"Ax1_2\""

end


theory BALFI_logic
  imports BA_logic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3, timeout=60] (*default Nitpick settings*)

(**The LFIs are a family of paraconsistent logics featuring a paraconsistent negation \<^bold>\<not>
and a consistency operator \<^bold>\<circ> that can be used to recover some classical properties
of the negation \<^bold>\<not> (in particular 'explosion').
We axiomatize below extensions of Boolean algebras with additional LFI operators (BALFIs).*)

consts pneg:: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_" [57]58)
consts pcons::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circ>_" [57]58)

axiomatization where
          LEM:  "a \<^bold>\<or> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" and
          CONS: "a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<and> \<^bold>\<circ>a \<^bold>\<approx> \<^bold>\<bottom>"

(**The following axioms are commonly employed in the literature on LFIs to obtain stronger logics.
We explore under which conditions they can be assumed while keeping the logic boldly paraconsistent.*)
abbreviation ciw where "ciw \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<circ>a \<^bold>\<or> (a \<^bold>\<and> \<^bold>\<not>a)]"
abbreviation ci  where  "ci \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<circ>a \<^bold>\<rightarrow> (a \<^bold>\<and> \<^bold>\<not>a)]"
abbreviation cl  where  "cl \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<rightarrow> \<^bold>\<circ>a]"
abbreviation cf where "cf \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<not>a \<^bold>\<rightarrow> a]"
abbreviation ce where "ce \<equiv> \<forall>a. [\<^bold>\<turnstile> a \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>\<not>a]"
abbreviation ca_conj where "ca_conj \<equiv> \<forall>a b. [\<^bold>\<turnstile> (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<rightarrow> \<^bold>\<circ>(a \<^bold>\<and> b)]"
abbreviation ca_disj where "ca_disj \<equiv> \<forall>a b. [\<^bold>\<turnstile> (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<rightarrow> \<^bold>\<circ>(a \<^bold>\<or> b)]"
abbreviation ca_impl where "ca_impl \<equiv> \<forall>a b. [\<^bold>\<turnstile> (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<rightarrow> \<^bold>\<circ>(a \<^bold>\<rightarrow> b)]"
abbreviation ca where "ca \<equiv> ca_conj \<and> ca_disj \<and> ca_impl"

lemma "ciw \<longleftrightarrow> (\<forall>a. \<^bold>\<circ>a \<^bold>\<approx> \<^bold>\<sim>(a \<^bold>\<and> \<^bold>\<not>a))" by (metis CONS compl_def join_def meet_def)
lemma "ci \<longleftrightarrow> (\<forall>a. \<^bold>\<not>\<^bold>\<circ>a \<^bold>\<approx> a \<^bold>\<and> \<^bold>\<not>a)" by (metis CONS LEM impl_def join_def meet_def)
lemma "cl \<longleftrightarrow> (\<forall>a. \<^bold>\<circ>a \<^bold>\<approx> \<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>a))" by (metis CONS LEM impl_def join_def meet_def)
lemma "cf \<longleftrightarrow> (\<forall>a. a \<^bold>\<and> \<^bold>\<not>\<^bold>\<not>a \<^bold>\<approx> \<^bold>\<not>\<^bold>\<not>a)" by (metis impl_def meet_def)
lemma "ce \<longleftrightarrow> (\<forall>a. a \<^bold>\<and> \<^bold>\<not>\<^bold>\<not>a \<^bold>\<approx> a)" by (metis impl_def meet_def)
lemma "ca_conj \<longleftrightarrow> (\<forall>a b. (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<and> \<^bold>\<circ>(a \<^bold>\<and> b) \<^bold>\<approx> \<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b)" by (metis impl_def meet_def)
lemma "ca_disj \<longleftrightarrow> (\<forall>a b. (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<and> \<^bold>\<circ>(a \<^bold>\<or> b) \<^bold>\<approx> \<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b)" by (metis impl_def meet_def)
lemma "ca_impl \<longleftrightarrow> (\<forall>a b. (\<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b) \<^bold>\<and> \<^bold>\<circ>(a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<^bold>\<circ>a \<^bold>\<and> \<^bold>\<circ>b)" by (metis impl_def meet_def)

(**The principle of 'explosion' or ex contradictione (sequitur) quodlibet.*)
abbreviation "ECQ  \<equiv> \<forall>a b. [a, \<^bold>\<not>a \<^bold>\<turnstile> b]"
abbreviation "ECQg \<equiv> \<forall>a b. [a, \<^bold>\<not>a \<^bold>\<turnstile>\<^sub>g b]"
(**The property below is a weaker variant of 'explosion'.
Logics with a negation satisfying this property are sometimes called "boldly paraconsistent".*)
abbreviation "wECQ  \<equiv> \<forall>a b. [a, \<^bold>\<not>a \<^bold>\<turnstile> \<^bold>\<not>b]"
abbreviation "wECQg \<equiv> \<forall>a b. [a, \<^bold>\<not>a \<^bold>\<turnstile>\<^sub>g \<^bold>\<not>b]"

lemma "ECQ \<longrightarrow> ECQg" by (metis meet_def)
lemma "ECQg \<longrightarrow> ECQ" nitpick oops (*counterexample found*)
lemma "ECQ \<longrightarrow> wECQ" by auto
lemma "wECQ \<longrightarrow> ECQ" nitpick oops (*counterexample found*)
lemma "ECQg \<longrightarrow> wECQg" by auto
lemma "wECQg \<longrightarrow> ECQg" nitpick oops (*counterexample found*)

(**The LFI negation as defined above is (boldly) paraconsistent in all accounts.*)
lemma "ECQ" nitpick oops (*countermodel*)
lemma "ECQg" nitpick oops (*countermodel*)
lemma "wECQ" nitpick oops (*countermodel*)
lemma "wECQg" nitpick oops (*countermodel*)

(**We can recover explosion using \<^bold>\<circ> (cf. 'principle of gentle explosion')*)
lemma "[a, \<^bold>\<not>a, \<^bold>\<circ>a \<^bold>\<turnstile> b]" by (simp add: CONS bottom_def)

(**We can employ model finder Nitpick to generate models (option: satisfy) of a given cardinality
(option: card w=2, i.e. 4-valued powerset algebras).
We ask Nitpick to generate up to 100 models (Nitpick technical disclaimer: some models may be duplicated).*)
lemma True nitpick[satisfy, card w=2, max_genuine=100] oops

(**We can employ Nitpick to generate (boldly) paraconsistent models satisfying different conditions.
For instance, we can find models satisfying cf, cf & ci, and cl but not cf, respectively.*)
lemma "\<not>wECQ \<and> cf" nitpick[satisfy, card w=2, max_genuine=10] oops
lemma "\<not>wECQ \<and> cf \<and> ci" nitpick[satisfy, card w=4, max_genuine=10] oops
lemma "\<not>wECQ \<and> cl \<and> \<not>cf" nitpick[satisfy, card w=2, max_genuine=10] oops (*only 2 are returned!*)

(**Observe, that Nitpick cannot find models with smaller cardinalities than the ones shown above.
Also note that Nitpick might find different models each time it runs.*)

end


(* License: LGPL *)
(*
Author: Julian Parsert <julian.parsert@gmail.com>
Author: Cezary Kaliszyk
*)

section \<open> Arrow-Debreu model \<close>

theory Arrow_Debreu_Model
  imports
    "../Preferences"
    "../Preferences"
    "../Utility_Functions"
    "../Argmax"
    Consumers
    Common
begin

locale pre_arrow_debreu_model =
  fixes production_sets :: "'f \<Rightarrow> ('a::ordered_euclidean_space) set"
  fixes consumption_set :: "'a set"
  fixes agents :: "'i set"
  fixes firms :: "'f set"
  fixes \<E> :: "'i \<Rightarrow> 'a"  ("\<E>[_]")
  fixes Pref :: "'i \<Rightarrow> 'a relation" ("Pr[_]")
  fixes U :: "'i \<Rightarrow> 'a \<Rightarrow> real" ("U[_]")
  fixes \<Theta> :: "'i \<Rightarrow> 'f \<Rightarrow> real"  ("\<Theta>[_,_]")
  assumes cons_set_props: "arrow_debreu_consum_set consumption_set"
  assumes agent_props: "i \<in> agents \<Longrightarrow> eucl_ordinal_utility consumption_set (Pr[i]) (U[i])"
  assumes firms_comp_owned: "j \<in> firms \<Longrightarrow> (\<Sum>i\<in>agents. \<Theta>[i,j]) = 1"
  assumes finite_nonepty_agents: "finite agents" and "agents \<noteq> {}"

sublocale pre_arrow_debreu_model \<subseteq> pareto_ordering agents U
  .

(*sublocale pre_arrow_debreu_model \<subseteq> exchange_economy consumption_set agents \<E> Pref U Price
  by (metis exchange_economy.intro pre_arrow_debreu_model_axioms pre_arrow_debreu_model_def)
*)

context pre_arrow_debreu_model
begin

text \<open> Calculate wealth of individual i in context of Private Ownership economy. \<close>

context
begin

private abbreviation poe_wealth
  where
    "poe_wealth P i Y \<equiv> P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"

subsection \<open> Feasiblity \<close>
private abbreviation feasible
  where
    "feasible X Y \<equiv> feasible_private_ownership agents firms \<E> consumption_set production_sets X Y"

private abbreviation calculate_value
  where
    "calculate_value P x \<equiv> P \<bullet> x"

subsection \<open> Profit maximisation \<close>

text \<open> In a production economy (which this is) we need to specify profit maximisation. \<close>

definition profit_maximisation
  where
    "profit_maximisation P S = arg_max_set (\<lambda>x. P \<bullet> x) S"

subsection \<open> Competitive Equilibirium \<close>

text \<open> Competitive equilibrium in context of production economy with private ownership.
             This includes the profit maximisation condition. \<close>

definition competitive_equilibrium
  where
    "competitive_equilibrium P X Y \<longleftrightarrow> feasible X Y \<and>
    (\<forall>j \<in> firms. (Y j) \<in> profit_maximisation P (production_sets j)) \<and>
    (\<forall>i \<in> agents. (X i) \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)))"

lemma competitive_equilibriumD [dest]:
  assumes "competitive_equilibrium P X Y"
  shows "feasible X Y \<and>
         (\<forall>j \<in> firms. (Y j) \<in> profit_maximisation P (production_sets j)) \<and>
         (\<forall>i \<in> agents. (X i) \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)))"
  using assms by (simp add: competitive_equilibrium_def)

lemma compet_max_profit:
  assumes "j \<in> firms"
  assumes "competitive_equilibrium P X Y"
  shows "Y j \<in> profit_maximisation P (production_sets j)"
  using assms(1) assms(2) by blast

subsection \<open> Pareto Optimality \<close>

definition pareto_optimal
  where
    "pareto_optimal X Y \<longleftrightarrow>
              (feasible X Y \<and>
              (\<nexists>X' Y'. feasible X' Y' \<and> X' \<succ>Pareto X))"

lemma pareto_optimalI[intro]:
  assumes "feasible X Y"
    and "\<nexists>X' Y'. feasible X' Y' \<and> X' \<succ>Pareto X"
  shows "pareto_optimal X Y"
  using pareto_optimal_def assms(1) assms(2) by blast

lemma pareto_optimalD[dest]:
  assumes "pareto_optimal X Y"
  shows "feasible X Y" and "\<nexists>X' Y'. feasible X' Y' \<and> X' \<succ>Pareto X"
  using pareto_optimal_def assms by auto

lemma util_fun_def_holds:
  assumes "i \<in> agents"
    and "x \<in> consumption_set"
    and "y \<in> consumption_set"
  shows "x \<succeq>[Pr[i]] y \<longleftrightarrow> U[i] x \<ge> U[i] y"
proof
  assume "x \<succeq>[Pr[i]] y"
  show "U[i] x \<ge> U[i] y"
    by (meson \<open>x \<succeq>[Pr[i]] y\<close> agent_props assms eucl_ordinal_utility_def ordinal_utility_def)
next
  assume "U[i] x \<ge> U[i] y"
  have "eucl_ordinal_utility consumption_set (Pr[i]) (U[i])"
    by (simp add: agent_props assms)
  then show "x \<succeq>[Pr[i]] y"
    by (meson \<open>U[i] y \<le> U[i] x\<close> assms(2) assms(3) eucl_ordinal_utility_def ordinal_utility.util_def_conf)
qed

lemma base_pref_is_ord_eucl_rpr: "i \<in> agents \<Longrightarrow> rational_preference consumption_set Pr[i]"
  using agent_props ord_eucl_utility_imp_rpr real_vector_rpr.have_rpr by blast

lemma prof_max_ge_all_in_pset:
  assumes "j \<in> firms"
  assumes "Y j \<in> profit_maximisation P (production_sets j)"
  shows "\<forall>y \<in> production_sets j. P \<bullet> Y j \<ge> P \<bullet> y"
  using all_leq assms(2) profit_maximisation_def by fastforce

subsection \<open> Lemmas for final result \<close>

text \<open> Strictly preferred bundles are strictly more expensive. \<close>

lemma all_prefered_are_more_expensive:
  assumes i_agt: "i \<in> agents"
  assumes equil: "competitive_equilibrium P \<X> \<Y>"
  assumes "z \<in> consumption_set"
  assumes "(U i) z > (U i) (\<X> i)"
  shows "z \<bullet> P > P \<bullet> (\<X> i)"
proof (rule ccontr)
  assume neg_as :  "\<not>(z \<bullet> P > P \<bullet> (\<X> i))"
  have xp_leq : "z \<bullet> P \<le> P \<bullet>  (\<X> i)"
    using \<open>\<not>z \<bullet> P > P \<bullet> (\<X> i)\<close> by auto
  have x_in_argmax: "(\<X> i) \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>))"
    using equil i_agt by blast
  hence x_in: "\<X> i \<in> (budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>))"
    using argmax_sol_in_s [of "(\<X> i)" "U[i]" "budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>)"]
    by blast
  hence z_in_budget: "z \<in> (budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>))"
  proof -
    have z_leq_endow: "P \<bullet> z \<le> P \<bullet> (\<X> i)"
      by (metis xp_leq inner_commute)
    have z_in_cons: "z \<in> consumption_set"
      using assms by auto
    then show ?thesis
      using x_in budget_constraint_def z_leq_endow
    proof -
      have "\<forall>r.  P \<bullet> \<X> i \<le> r \<longrightarrow> P \<bullet> z \<le> r"
        using z_leq_endow by linarith
      then show ?thesis
        using budget_constraint_def x_in z_in_cons
        by (simp add: budget_constraint_def)
    qed
  qed
  have nex_prop: "\<nexists>e. e \<in>  (budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>)) \<and>
        U[i] e > U[i] (\<X> i)"
    using no_better_in_s[of "\<X> i" "U[i]"
        "budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>)"] x_in_argmax by blast
  have "z \<in> budget_constraint (calculate_value P) consumption_set (poe_wealth P i \<Y>) \<and> U[i] z > U[i] (\<X> i)"
    using assms z_in_budget by blast
  thus False using nex_prop
    by blast
qed

text \<open> Given local non-satiation, argmax will use the entire budget. \<close>

lemma am_utilises_entire_bgt:
  assumes i_agts: "i \<in> agents"
  assumes lns : "local_nonsatiation consumption_set Pr[i]"
  assumes argmax_sol : "X \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y))"
  shows "P \<bullet> X = P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"
proof -
  let ?wlt = "P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"
  let ?bc = "budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)"
  have xin: "X \<in> budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)"
    using argmax_sol_in_s [of "X" "U[i]" ?bc] argmax_sol by blast
  hence is_leq: "X \<bullet> P \<le> (poe_wealth P i Y)"
    by (metis (mono_tags, lifting) budget_constraint_def
        inner_commute mem_Collect_eq)
  have not_less: "\<not>X \<bullet> P < (poe_wealth P i Y)"
  proof
    assume neg: "X \<bullet> P < (poe_wealth P i Y)"
    have bgt_leq: "\<forall>x\<in> ?bc. U[i] X \<ge> U[i] x"
      using leq_all_in_sol [of "X" "U[i]" "?bc"]
        all_leq [of "X" "U[i]" "?bc"]
        argmax_sol by blast
    define s_low where
      "s_low = {x . P \<bullet> x < ?wlt}"
    have "\<exists>e > 0. ball X e \<subseteq> s_low"
    proof -
      have x_in_budget: "P \<bullet> X < ?wlt"
        by (metis inner_commute neg)
      have s_low_open: "open s_low"
        using open_halfspace_lt s_low_def by blast
      then show ?thesis
        using s_low_open open_contains_ball_eq
          s_low_def x_in_budget by blast
    qed
    obtain e where
      "e > 0" and e: "ball X e \<subseteq> s_low"
      using \<open>\<exists>e>0. ball X e \<subseteq> s_low\<close> by blast
    obtain y where
      y_props: "y \<in> ball X e" "y \<succ>[Pref i] X"
      using \<open>0 < e\<close> xin assms(2) budget_constraint_def
      by (metis (no_types, lifting) lns_alt_def2 mem_Collect_eq)
    have "y \<in> budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)"
    proof -
      have "y \<in> s_low"
        using \<open>y \<in> ball X e\<close> e by blast
      moreover have "y \<in> consumption_set"
        by (meson agent_props eucl_ordinal_utility_def i_agts ordinal_utility_def y_props(2))
      moreover have "P \<bullet> y \<le> poe_wealth P i Y"
        using calculation(1) s_low_def by auto
      ultimately show ?thesis
        by (simp add: budget_constraint_def)
    qed
    then show False
      using bgt_leq i_agts y_props(2) util_fun_def_holds xin budget_constraint_def
      by (metis (no_types, lifting) mem_Collect_eq)
  qed
  then show ?thesis
    by (metis inner_commute is_leq
        less_eq_real_def)
qed

corollary x_equil_x_ext_budget:
  assumes i_agt: "i \<in> agents"
  assumes lns : "local_nonsatiation consumption_set Pr[i]"
  assumes equilibrium : "competitive_equilibrium P X Y"
  shows "P \<bullet> X i = P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"
proof -
  have "X i \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y))"
    using equilibrium i_agt by blast
  then show ?thesis
    using am_utilises_entire_bgt i_agt lns by blast
qed

lemma same_price_in_argmax :
  assumes i_agt: "i \<in> agents"
  assumes lns : "local_nonsatiation consumption_set Pr[i]"
  assumes "x \<in> arg_max_set (U[i]) (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y))"
  assumes "y \<in> arg_max_set (U[i]) (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y))"
  shows "(P \<bullet> x) = (P \<bullet> y)"
  using am_utilises_entire_bgt assms lns
  by (metis (no_types) am_utilises_entire_bgt assms(3) assms(4) i_agt lns)

text \<open> Greater or equal utility implies greater or equal value. \<close>

lemma utility_ge_price_ge :
  assumes agts: "i \<in> agents"
  assumes lns : "local_nonsatiation consumption_set Pr[i]"
  assumes equil: "competitive_equilibrium P X Y"
  assumes geq: "U[i] z \<ge> U[i] (X i)"
    and "z \<in> consumption_set"
  shows "P \<bullet> z \<ge> P \<bullet> (X i)"
proof -
  let ?bc = "(budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y))"
  have not_in : "z \<notin> arg_max_set (U[i]) ?bc \<Longrightarrow>
    P \<bullet> z > (P \<bullet> \<E>[i]) + (\<Sum>j\<in>(firms). (\<Theta>[i,j] *\<^sub>R (P \<bullet> Y j)))"
  proof-
    assume "z \<notin> arg_max_set (U[i]) ?bc"
    moreover have "X i \<in> arg_max_set (U[i]) ?bc"
      using competitive_equilibriumD assms pareto_optimal_def
      by auto
    ultimately have "z \<notin> budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)"
      by (meson  geq leq_all_in_sol)
    then show ?thesis
      using budget_constraint_def assms
      by (simp add: budget_constraint_def)
  qed
  have x_in_argmax: "(X i) \<in> arg_max_set U[i] ?bc"
    using agts equil by blast
  hence x_in_budget: "(X i) \<in> ?bc"
    using argmax_sol_in_s [of "(X i)" "U[i]" "?bc"] by blast
  have "U[i] z = U[i] (X i) \<Longrightarrow> P \<bullet> z \<ge> P \<bullet> (X i)"
  proof(rule contrapos_pp)
    assume con_neg: "\<not> P \<bullet> z \<ge> P \<bullet> (X i)"
    then have "P \<bullet> z < P \<bullet> (X i)"
      by linarith
    then have z_in_argmax: "z \<in> arg_max_set U[i] ?bc"
    proof -
      have "P \<bullet>(X i) = P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"
        using agts am_utilises_entire_bgt lns x_in_argmax by blast
      then show ?thesis
        by (metis (no_types) con_neg less_eq_real_def not_in)
    qed
    have z_budget_utilisation: "P \<bullet> z = P \<bullet> (X i)"
      by (metis (no_types) agts am_utilises_entire_bgt lns x_in_argmax z_in_argmax)
    have "P \<bullet> (X i) = P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> Y j))"
      using agts am_utilises_entire_bgt lns x_in_argmax by blast
    show "\<not> U[i] z = U[i] (X i)"
      using z_budget_utilisation con_neg by linarith
  qed
  thus ?thesis
    by (metis (no_types) agts am_utilises_entire_bgt eq_iff eucl_less_le_not_le lns not_in x_in_argmax)
qed

lemma commutativity_sums_over_funs:
  fixes X :: "'x set"
  fixes Y :: "'y set"
  shows "(\<Sum>i\<in>X. \<Sum>j\<in>Y. (f i j *\<^sub>R C \<bullet> g j)) = (\<Sum>j\<in>Y.\<Sum>i\<in>X. (f i j *\<^sub>R C \<bullet> g j))"
  using Groups_Big.comm_monoid_add_class.sum.swap by auto

lemma assoc_fun_over_sum:
  fixes X :: "'x set"
  fixes Y :: "'y set"
  shows "(\<Sum>j\<in>Y. \<Sum>i\<in>X. f i j *\<^sub>R C \<bullet> g j) = (\<Sum>j\<in>Y. (\<Sum>i\<in>X. f i j) *\<^sub>R C \<bullet> g j)"
  by (simp add: inner_sum_left scaleR_left.sum)

text \<open> Walras' law in context of production economy with private ownership.
       That is, in an equilibrium demand equals supply. \<close>

lemma walras_law:
  assumes "\<And>i. i\<in>agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
  assumes "(\<forall>i \<in> agents. (X i) \<in> arg_max_set U[i] (budget_constraint (calculate_value P) consumption_set (poe_wealth P i Y)))"
  shows "P \<bullet> (\<Sum>i\<in>agents. (X i)) = P \<bullet> ((\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>j\<in>firms. Y j))"
proof -
  have value_equal: "P \<bullet> (\<Sum>i\<in>agents. (X i)) = P \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>i\<in>agents. \<Sum>f\<in>firms. \<Theta>[i,f] *\<^sub>R (P \<bullet> Y f))"
  proof -
    have all_exhaust_bgt: "\<forall>i\<in>agents. P \<bullet> (X i) = P \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (P \<bullet> (Y j)))"
      using assms am_utilises_entire_bgt by blast
    then show ?thesis
      by (simp add:all_exhaust_bgt inner_sum_right sum.distrib)
  qed
  have eq_1: "(\<Sum>i\<in>agents. \<Sum>j\<in>firms. (\<Theta>[i,j] *\<^sub>R P \<bullet> Y j)) = (\<Sum>j\<in>firms. \<Sum>i\<in>agents. (\<Theta>[i,j] *\<^sub>R P \<bullet> Y j))"
    using commutativity_sums_over_funs [of \<Theta> P Y firms agents] by blast
  hence eq_2: "P \<bullet> (\<Sum>i\<in>agents. X i) = P \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>j\<in>firms. \<Sum>i\<in>agents. \<Theta>[i,j] *\<^sub>R P \<bullet> Y j)"
    using value_equal by auto
  also  have eq_3: "...= P \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>j\<in>firms. (\<Sum>i\<in>agents. \<Theta>[i,j]) *\<^sub>R P \<bullet>  Y j)"
    using assoc_fun_over_sum[of "\<Theta>" P Y agents firms] by auto
  also have eq_4: "... = P \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>f\<in>firms. P \<bullet>  Y f)"
    using firms_comp_owned by auto
  have comp_wise_inner: "P \<bullet>  (\<Sum>i\<in>agents. X i) - (P \<bullet> (\<Sum>i\<in>agents. \<E>[i])) - (\<Sum>f\<in>firms. P \<bullet> Y f) = 0"
    using eq_1 eq_2 eq_3 eq_4 by linarith
  then show ?thesis
    by (simp add: inner_right_distrib inner_sum_right)
qed

lemma walras_law_in_compeq:
  assumes "\<And>i. i\<in>agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
  assumes "competitive_equilibrium P X Y"
  shows "P \<bullet> ((\<Sum>i\<in>agents. (X i)) - (\<Sum>i\<in>agents. \<E>[i]) - (\<Sum>j\<in>firms. Y j)) = 0"
proof-
  have "P \<bullet> (\<Sum>i\<in>agents. (X i)) = P \<bullet> ((\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>j\<in>firms. Y j))"
    using assms(1) assms(2) walras_law by auto
  then show ?thesis
    by (simp add: inner_diff_right inner_right_distrib)
qed

subsection \<open> First Welfare Theorem \<close>

text \<open> Proof of First Welfare Theorem in context of production economy with private ownership. \<close>

theorem first_welfare_theorem_priv_own:
  assumes "\<And>i. i \<in> agents \<Longrightarrow> local_nonsatiation consumption_set Pr[i]"
    and "Price > 0"
  assumes "competitive_equilibrium Price \<X> \<Y>"
  shows "pareto_optimal \<X> \<Y>"
proof (rule ccontr)
  assume neg_as: "\<not> pareto_optimal \<X> \<Y>"
  have equili_feasible : "feasible \<X> \<Y>"
    using  assms by (simp add: competitive_equilibrium_def)
  obtain X' Y' where
    xprime_pareto: "feasible X' Y' \<and>
      (\<forall>i \<in> agents. U[i] (X' i) \<ge> U[i] (\<X> i)) \<and>
      (\<exists>i \<in> agents. U[i] (X' i) > U[i] (\<X> i))"
    using equili_feasible pareto_optimal_def
      pareto_dominating_def neg_as by auto
  have is_feasible: "feasible X' Y'"
    using xprime_pareto by blast
  have xprime_leq_y: "\<forall>i \<in> agents. (Price \<bullet> (X' i) \<ge>
    (Price \<bullet> \<E>[i]) + (\<Sum>j\<in>(firms). \<Theta>[i,j] *\<^sub>R (Price \<bullet> \<Y> j)))"
  proof
    fix i
    assume as: "i \<in> agents"
    have xprime_cons: "X' i \<in> consumption_set"
      using feasible_private_ownershipD as is_feasible by blast
    have x_leq_xprime: "U[i] (X' i) \<ge> U[i] (\<X> i)"
      using \<open>i \<in> agents\<close> xprime_pareto by blast
    have lns_pref: "local_nonsatiation consumption_set Pr[i]"
      using as assms by blast
    hence xprime_ge_x: "Price \<bullet> (X' i) \<ge> Price \<bullet> (\<X> i)"
      using x_leq_xprime xprime_cons as assms utility_ge_price_ge by blast
    then show  "Price \<bullet> (X' i) \<ge> (Price \<bullet> \<E>[i]) + (\<Sum>j\<in>(firms). \<Theta>[i,j] *\<^sub>R (Price \<bullet> \<Y> j))"
      using xprime_ge_x \<open>i \<in> agents\<close> lns_pref assms x_equil_x_ext_budget by fastforce
  qed
  have ex_greater_value : "\<exists>i \<in> agents. Price \<bullet> (X' i) > Price \<bullet> (\<X> i)"
  proof(rule ccontr)
    assume cpos : "\<not>(\<exists>i \<in> agents. Price \<bullet> (X' i) > Price \<bullet> (\<X> i))"
    obtain i where
      obt_witness : "i \<in> agents" "(U[i]) (X' i) > U[i] (\<X> i)"
      using xprime_pareto by blast
    show False
      by (metis all_prefered_are_more_expensive assms(3) cpos
          feasible_private_ownershipD(2) inner_commute xprime_pareto)
  qed
  have dom_g : "Price \<bullet> (\<Sum>i\<in>agents. X' i) > Price \<bullet> (\<Sum>i\<in>agents. (\<X> i))" (is "_ > _ \<bullet> ?x_sum")
  proof-
    have "(\<Sum>i\<in>agents. Price \<bullet> X' i) > (\<Sum>i\<in>agents. Price \<bullet> (\<X> i))"
      by (metis (mono_tags, lifting) xprime_leq_y assms(1,3) ex_greater_value
          finite_nonepty_agents sum_strict_mono_ex1 x_equil_x_ext_budget)
    thus "Price \<bullet> (\<Sum>i\<in>agents. X' i) > Price \<bullet> ?x_sum"
      by (simp add: inner_sum_right)
  qed
  let ?y_sum = "(\<Sum>j\<in>firms. \<Y> j)"
  have equili_walras_law: "Price \<bullet> ?x_sum =
    (\<Sum>i\<in>agents. Price \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (Price \<bullet> \<Y> j)))" (is "_ = ?ws")
  proof-
    have "\<forall>i\<in>agents. Price \<bullet> \<X> i = Price \<bullet> \<E>[i] + (\<Sum>j\<in>firms. \<Theta>[i,j] *\<^sub>R (Price \<bullet> \<Y> j))"
      by (metis (no_types, lifting) assms(1,3) x_equil_x_ext_budget)
    then show ?thesis
      by (simp add: inner_sum_right)
  qed
  also have remove_firm_pct: "... = Price \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + (Price \<bullet> ?y_sum)"
  proof-
    have equals_inner_price:"0 = Price \<bullet> (?x_sum - ((\<Sum>i\<in>agents. \<E> i) + ?y_sum))"
      by (metis (no_types) diff_diff_add assms(1,3) walras_law_in_compeq)
    have "Price \<bullet> ?x_sum = Price \<bullet> ((\<Sum>i\<in>agents. \<E> i) + ?y_sum)"
      by (metis (no_types) equals_inner_price inner_diff_right right_minus_eq)
    then show ?thesis
      by (simp add: equili_walras_law inner_right_distrib)
  qed
  have xp_l_yp: "(\<Sum>i\<in>agents. X' i) \<le> (\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>f\<in>firms. Y' f)"
    using feasible_private_ownership_def is_feasible by blast
  hence yprime_sgr_y: "Price \<bullet> (\<Sum>i\<in>agents. \<E>[i]) + Price \<bullet> (\<Sum>f\<in>firms. Y' f) > ?ws"
  proof -
    have "Price \<bullet> (\<Sum>i\<in>agents. X' i) \<le> Price \<bullet> ((\<Sum>i\<in>agents. \<E>[i]) + (\<Sum>j\<in>firms. Y' j))"
      by (metis xp_l_yp atLeastAtMost_iff inner_commute
          interval_inner_leI(2) less_imp_le order_refl assms(2))
    hence "?ws < Price \<bullet> ((\<Sum>i\<in>agents. \<E> i) + (\<Sum>j\<in>firms. Y' j))"
      using dom_g equili_walras_law by linarith
    then show ?thesis
      by (simp add: inner_right_distrib)
  qed
  have Y_is_optimum: "\<forall>j\<in>firms. \<forall>y \<in> production_sets j. Price \<bullet> \<Y> j \<ge> Price \<bullet> y"
    using assms prof_max_ge_all_in_pset by blast
  have yprime_in_prod_set: "\<forall>j \<in> firms. Y' j \<in> production_sets j"
    using feasible_private_ownershipD xprime_pareto by fastforce
  hence "\<forall>j \<in> firms. \<forall>y \<in> production_sets j. Price \<bullet> \<Y> j \<ge> Price \<bullet> y"
    using Y_is_optimum by blast
  hence Y_ge_yprime: "\<forall>j \<in> firms. Price \<bullet> \<Y> j \<ge> Price \<bullet> Y' j"
    using yprime_in_prod_set by blast
  hence yprime_p_leq_Y: "Price \<bullet> (\<Sum>f\<in>firms. Y' f) \<le> Price \<bullet> ?y_sum"
    by (simp add: Y_ge_yprime inner_sum_right sum_mono)
  then show False
    using remove_firm_pct yprime_sgr_y by linarith
qed

text \<open> Equilibrium cannot be Pareto dominated. \<close>

text \<open> Using monotonicity instead of local non-satiation proves the First Welfare Theorem. \<close>

corollary first_welfare_thm_monotone:
  assumes "\<forall>M \<in> carrier. (\<forall>x > M. x \<in> carrier)"
  assumes "\<And>i. i \<in> agents \<Longrightarrow> monotone_preference consumption_set Pr[i]"
    and "Price > 0"
  assumes "competitive_equilibrium Price \<X> \<Y>"
  shows "pareto_optimal \<X> \<Y>"
  by (meson arrow_debreu_consum_set_def assms cons_set_props first_welfare_theorem_priv_own unbounded_above_mono_imp_lns)

end

end

end


section \<open>(Co)Inductive Predicates\<close>

text \<open>This subsection corresponds to Section 4 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

theory FixedPoint
  imports Distributivity Combinability
begin

type_synonym ('d, 'c, 'a) chain = "nat \<Rightarrow> ('d, 'c, 'a) interp"

context logic
begin

subsection Definitions

definition smaller_interp :: "('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> bool" where
  "smaller_interp \<Delta> \<Delta>' \<longleftrightarrow> (\<forall>s. \<Delta> s \<subseteq> \<Delta>' s)"

lemma smaller_interpI:
  assumes "\<And>s x. x \<in> \<Delta> s \<Longrightarrow> x \<in> \<Delta>' s"
  shows "smaller_interp \<Delta> \<Delta>'"
  by (simp add: assms smaller_interp_def subsetI)

definition indep_interp where
  "indep_interp A \<longleftrightarrow> (\<forall>x s \<Delta> \<Delta>'. x, s, \<Delta> \<Turnstile> A \<longleftrightarrow> x, s, \<Delta>' \<Turnstile> A)"

fun applies_eq :: "('a, 'b, 'c, 'd) assertion \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp" where
  "applies_eq A \<Delta> s = { a |a. a, s, \<Delta> \<Turnstile> A }"

definition monotonic :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> bool" where
  "monotonic f \<longleftrightarrow> (\<forall>\<Delta> \<Delta>'. smaller_interp \<Delta> \<Delta>' \<longrightarrow> smaller_interp (f \<Delta>) (f \<Delta>'))"

lemma monotonicI:
  assumes "\<And>\<Delta> \<Delta>'. smaller_interp \<Delta> \<Delta>' \<Longrightarrow> smaller_interp (f \<Delta>) (f \<Delta>')"
  shows "monotonic f"
  by (simp add: assms monotonic_def)

definition non_increasing :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> bool" where
  "non_increasing f \<longleftrightarrow> (\<forall>\<Delta> \<Delta>'. smaller_interp \<Delta> \<Delta>' \<longrightarrow> smaller_interp (f \<Delta>') (f \<Delta>))"

lemma non_increasingI:
  assumes "\<And>\<Delta> \<Delta>'. smaller_interp \<Delta> \<Delta>' \<Longrightarrow> smaller_interp (f \<Delta>') (f \<Delta>)"
  shows "non_increasing f"
  by (simp add: assms non_increasing_def)

lemma smaller_interp_refl:
  "smaller_interp \<Delta> \<Delta>"
  by (simp add: smaller_interp_def)

lemma smaller_interp_applies_cons:
  assumes "smaller_interp (applies_eq A \<Delta>) (applies_eq A \<Delta>')"
      and "a, s, \<Delta> \<Turnstile> A"
    shows "a, s, \<Delta>' \<Turnstile> A"
proof -
  have "a \<in> applies_eq A \<Delta> s"
    using assms(2) by force
  then have "a \<in> applies_eq A \<Delta>' s"
    by (metis assms(1) in_mono smaller_interp_def)
  then show ?thesis by auto
qed

definition empty_interp where
  "empty_interp s = {}"

definition full_interp :: "('d, 'c, 'a) interp" where
  "full_interp s = UNIV"

lemma smaller_interp_trans:
  assumes "smaller_interp a b"
      and "smaller_interp b c"
    shows "smaller_interp a c"
  by (metis assms(1) assms(2) dual_order.trans smaller_interp_def)

lemma smaller_empty:
  "smaller_interp empty_interp x"
  by (simp add: empty_interp_def smaller_interp_def)

text \<open>The definition of set-closure properties corresponds to Definition 8 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

definition set_closure_property :: "('a \<Rightarrow> 'a \<Rightarrow> 'a set) \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> bool" where
  "set_closure_property S \<Delta> \<longleftrightarrow> (\<forall>a b s. a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<longrightarrow> S a b \<subseteq> \<Delta> s)"

lemma set_closure_propertyI:
  assumes "\<And>a b s. a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<Longrightarrow> S a b \<subseteq> \<Delta> s"
  shows "set_closure_property S \<Delta>"
  by (simp add: assms set_closure_property_def)

lemma set_closure_property_instantiate:
  assumes "set_closure_property S \<Delta>"
      and "a \<in> \<Delta> s"
      and "b \<in> \<Delta> s"
      and "x \<in> S a b"
    shows "x \<in> \<Delta> s"
  using assms subsetD set_closure_property_def by metis

subsection \<open>Everything preserves monotonicity\<close>

lemma indep_implies_non_increasing:
  assumes "indep_interp A"
  shows "non_increasing (applies_eq A)"
  by (metis (no_types, lifting) applies_eq.simps assms indep_interp_def smaller_interp_def mem_Collect_eq non_increasingI subsetI)

subsubsection Monotonicity

lemma mono_instantiate:
  assumes "monotonic (applies_eq A)"
      and "x \<in> applies_eq A \<Delta> s"
      and "smaller_interp \<Delta> \<Delta>'"
    shows "x \<in> applies_eq A \<Delta>' s"
  using assms(1) assms(2) assms(3) monotonic_def smaller_interp_applies_cons by fastforce

lemma mono_star:
  assumes "monotonic (applies_eq A)"
      and "monotonic (applies_eq B)"
    shows "monotonic (applies_eq (Star A B))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Star A B) \<Delta>) (applies_eq (Star A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Star A B) \<Delta> s"
    then obtain a b where "Some x = a \<oplus> b" "a \<in> applies_eq A \<Delta> s" "b \<in> applies_eq B \<Delta> s"
      by auto
    then have "a \<in> applies_eq A \<Delta>' s \<and> b \<in> applies_eq B \<Delta>' s"
      by (meson asm0 assms(1) assms(2) mono_instantiate)
    then show "x \<in> applies_eq (Star A B) \<Delta>' s"
      using \<open>Some x = a \<oplus> b\<close> by force
  qed
qed

lemma mono_wand:
  assumes "non_increasing (applies_eq A)"
      and "monotonic (applies_eq B)"
    shows "monotonic (applies_eq (Wand A B))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Wand A B) \<Delta>) (applies_eq (Wand A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Wand A B) \<Delta> s"
    have "x, s, \<Delta>' \<Turnstile> Wand A B"
    proof (rule sat_wand)
      fix a b
      assume asm2: "a, s, \<Delta>' \<Turnstile> A \<and> Some b = x \<oplus> a"
      then have "a, s, \<Delta> \<Turnstile> A"
        by (meson asm0 assms(1) non_increasing_def smaller_interp_applies_cons)
      then have "b, s, \<Delta> \<Turnstile> B"
        using asm1 asm2 by auto
      then show "b, s, \<Delta>' \<Turnstile> B"
        by (meson asm0 assms(2) monotonic_def smaller_interp_applies_cons)
    qed
    then show "x \<in> applies_eq (Wand A B) \<Delta>' s"
      by simp
  qed
qed

lemma mono_and:
  assumes "monotonic (applies_eq A)"
      and "monotonic (applies_eq B)"
    shows "monotonic (applies_eq (And A B))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (And A B) \<Delta>) (applies_eq (And A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (And A B) \<Delta> s"
    then show "x \<in> applies_eq (And A B) \<Delta>' s"
      using asm0 assms(1) assms(2) monotonic_def logic_axioms mem_Collect_eq sat.simps(8) smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_or:
  assumes "monotonic (applies_eq A)"
      and "monotonic (applies_eq B)"
    shows "monotonic (applies_eq (Or A B))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Or A B) \<Delta>) (applies_eq (Or A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Or A B) \<Delta> s"
    then show "x \<in> applies_eq (Or A B) \<Delta>' s"
      using asm0 assms(1) assms(2) monotonic_def logic_axioms mem_Collect_eq sat.simps(8) smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_sem:
  "monotonic (applies_eq (Sem B))"
  using monotonic_def smaller_interp_def by fastforce

lemma mono_interp:
  "monotonic (applies_eq Pred)"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq Pred \<Delta>) (applies_eq Pred \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume "x \<in> applies_eq Pred \<Delta> s"
    then show "x \<in> applies_eq Pred \<Delta>' s"
      by (metis (mono_tags, lifting) \<open>smaller_interp \<Delta> \<Delta>'\<close> applies_eq.simps in_mono mem_Collect_eq sat.simps(10) smaller_interp_def)
  qed
qed

lemma mono_mult:
  assumes "monotonic (applies_eq A)"
  shows "monotonic (applies_eq (Mult \<pi> A))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Mult \<pi> A) \<Delta>) (applies_eq (Mult \<pi> A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Mult \<pi> A) \<Delta> s"
    then show "x \<in> applies_eq (Mult \<pi> A) \<Delta>' s"
      using asm0 assms monotonic_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_wild:
  assumes "monotonic (applies_eq A)"
  shows "monotonic (applies_eq (Wildcard A))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Wildcard A) \<Delta>) (applies_eq (Wildcard A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Wildcard A) \<Delta> s"
    then show "x \<in> applies_eq (Wildcard A) \<Delta>' s"
      using asm0 assms monotonic_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_imp:
  assumes "non_increasing (applies_eq A)"
      and "monotonic (applies_eq B)"
    shows "monotonic (applies_eq (Imp A B))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Imp A B) \<Delta>) (applies_eq (Imp A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Imp A B) \<Delta> s"
    have "x, s, \<Delta>' \<Turnstile> Imp A B"
    proof (cases "x, s, \<Delta>' \<Turnstile> A")
      case True
      then have "x, s, \<Delta> \<Turnstile> A"
        by (meson asm0 assms(1) non_increasing_def smaller_interp_applies_cons)
      then have "x, s, \<Delta> \<Turnstile> B"
        using asm1 by auto
      then show ?thesis
        by (metis asm0 assms(2) monotonic_def sat.simps(5) smaller_interp_applies_cons)
    next
      case False
      then show ?thesis by simp
    qed
    then show "x \<in> applies_eq (Imp A B) \<Delta>' s"
      by simp
  qed
qed

lemma mono_bounded:
  assumes "monotonic (applies_eq A)"
  shows "monotonic (applies_eq (Bounded A))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Bounded A) \<Delta>) (applies_eq (Bounded A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume "x \<in> applies_eq (Bounded A) \<Delta> s"
    then show "x \<in> applies_eq (Bounded A) \<Delta>' s"
      using asm assms monotonic_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_exists:
  assumes "monotonic (applies_eq A)"
    shows "monotonic (applies_eq (Exists v A))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Exists v A) \<Delta>) (applies_eq (Exists v A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Exists v A) \<Delta> s"
    then show "x \<in> applies_eq (Exists v A) \<Delta>' s"
      using asm0 assms monotonic_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma mono_forall:
  assumes "monotonic (applies_eq A)"
    shows "monotonic (applies_eq (Forall v A))"
proof (rule monotonicI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Forall v A) \<Delta>) (applies_eq (Forall v A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Forall v A) \<Delta> s"
    then show "x \<in> applies_eq (Forall v A) \<Delta>' s"
      using asm0 assms monotonic_def smaller_interp_applies_cons by fastforce
  qed
qed

subsubsection \<open>Non-increasing\<close>

lemma non_increasing_instantiate:
  assumes "non_increasing (applies_eq A)"
      and "x \<in> applies_eq A \<Delta>' s"
      and "smaller_interp \<Delta> \<Delta>'"
    shows "x \<in> applies_eq A \<Delta> s"
  using assms(1) assms(2) assms(3) non_increasing_def smaller_interp_applies_cons by fastforce

lemma non_inc_star:
  assumes "non_increasing (applies_eq A)"
      and "non_increasing (applies_eq B)"
    shows "non_increasing (applies_eq (Star A B))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Star A B) \<Delta>') (applies_eq (Star A B) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Star A B) \<Delta>' s"
    then obtain a b where "Some x = a \<oplus> b" "a \<in> applies_eq A \<Delta>' s" "b \<in> applies_eq B \<Delta>' s"
      by auto
    then have "a \<in> applies_eq A \<Delta> s \<and> b \<in> applies_eq B \<Delta> s"
      by (meson asm0 assms(1) assms(2) non_increasing_instantiate)
    then show "x \<in> applies_eq (Star A B) \<Delta> s"
      using \<open>Some x = a \<oplus> b\<close> by force
  qed
qed

lemma non_increasing_wand:
  assumes "monotonic (applies_eq A)"
      and "non_increasing (applies_eq B)"
    shows "non_increasing (applies_eq (Wand A B))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Wand A B) \<Delta>') (applies_eq (Wand A B) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Wand A B) \<Delta>' s"
    have "x, s, \<Delta> \<Turnstile> Wand A B"
    proof (rule sat_wand)
      fix a b
      assume asm2: "a, s, \<Delta> \<Turnstile> A \<and> Some b = x \<oplus> a"
      then have "a, s, \<Delta>' \<Turnstile> A"
        by (meson asm0 assms(1) monotonic_def smaller_interp_applies_cons)
      then have "b, s, \<Delta>' \<Turnstile> B"
        using asm1 asm2 by auto
      then show "b, s, \<Delta> \<Turnstile> B"
        by (meson asm0 assms(2) non_increasing_def smaller_interp_applies_cons)
    qed
    then show "x \<in> applies_eq (Wand A B) \<Delta> s"
      by simp
  qed
qed

lemma non_increasing_and:
  assumes "non_increasing (applies_eq A)"
      and "non_increasing (applies_eq B)"
    shows "non_increasing (applies_eq (And A B))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta>' \<Delta>"
  show "smaller_interp (applies_eq (And A B) \<Delta>) (applies_eq (And A B) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (And A B) \<Delta> s"
    then show "x \<in> applies_eq (And A B) \<Delta>' s"
      using asm0 assms(1) assms(2) non_increasing_def logic_axioms mem_Collect_eq sat.simps(8) smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_or:
  assumes "non_increasing (applies_eq A)"
      and "non_increasing (applies_eq B)"
    shows "non_increasing (applies_eq (Or A B))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Or A B) \<Delta>') (applies_eq (Or A B) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Or A B) \<Delta>' s"
    then show "x \<in> applies_eq (Or A B) \<Delta> s"
      using asm0 assms(1) assms(2) non_increasing_def logic_axioms mem_Collect_eq sat.simps(8) smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_sem:
  "non_increasing (applies_eq (Sem B))"
  using non_increasing_def smaller_interp_def by fastforce

lemma non_increasing_mult:
  assumes "non_increasing (applies_eq A)"
  shows "non_increasing (applies_eq (Mult \<pi> A))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Mult \<pi> A) \<Delta>') (applies_eq (Mult \<pi> A) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Mult \<pi> A) \<Delta>' s"
    then show "x \<in> applies_eq (Mult \<pi> A) \<Delta> s"
      using asm0 assms non_increasing_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_wild:
  assumes "non_increasing (applies_eq A)"
  shows "non_increasing (applies_eq (Wildcard A))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Wildcard A) \<Delta>') (applies_eq (Wildcard A) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Wildcard A) \<Delta>' s"
    then show "x \<in> applies_eq (Wildcard A) \<Delta> s"
      using asm0 assms non_increasing_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_imp:
  assumes "monotonic (applies_eq A)"
      and "non_increasing (applies_eq B)"
    shows "non_increasing (applies_eq (Imp A B))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta> \<Delta>'"
  show "smaller_interp (applies_eq (Imp A B) \<Delta>') (applies_eq (Imp A B) \<Delta>)"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Imp A B) \<Delta>' s"
    have "x, s, \<Delta> \<Turnstile> Imp A B"
    proof (cases "x, s, \<Delta> \<Turnstile> A")
      case True
      then have "x, s, \<Delta>' \<Turnstile> A"
        by (meson asm0 assms(1) monotonic_def smaller_interp_applies_cons)
      then have "x, s, \<Delta>' \<Turnstile> B"
        using asm1 by auto
      then show ?thesis
        by (metis asm0 assms(2) non_increasing_def sat.simps(5) smaller_interp_applies_cons)
    next
      case False
      then show ?thesis by simp
    qed
    then show "x \<in> applies_eq (Imp A B) \<Delta> s"
      by simp
  qed
qed

lemma non_increasing_bounded:
  assumes "non_increasing (applies_eq A)"
  shows "non_increasing (applies_eq (Bounded A))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm: "smaller_interp \<Delta>' \<Delta>"
  show "smaller_interp (applies_eq (Bounded A) \<Delta>) (applies_eq (Bounded A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume "x \<in> applies_eq (Bounded A) \<Delta> s"
    then show "x \<in> applies_eq (Bounded A) \<Delta>' s"
      using asm assms non_increasing_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_exists:
  assumes "non_increasing (applies_eq A)"
    shows "non_increasing (applies_eq (Exists v A))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta>' \<Delta>"
  show "smaller_interp (applies_eq (Exists v A) \<Delta>) (applies_eq (Exists v A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Exists v A) \<Delta> s"
    then show "x \<in> applies_eq (Exists v A) \<Delta>' s"
      using asm0 assms non_increasing_def smaller_interp_applies_cons by fastforce
  qed
qed

lemma non_increasing_forall:
  assumes "non_increasing (applies_eq A)"
    shows "non_increasing (applies_eq (Forall v A))"
proof (rule non_increasingI)
  fix \<Delta> \<Delta>' :: "('c, 'd, 'a) interp"
  assume asm0: "smaller_interp \<Delta>' \<Delta>"
  show "smaller_interp (applies_eq (Forall v A) \<Delta>) (applies_eq (Forall v A) \<Delta>')"
  proof (rule smaller_interpI)
    fix s x assume asm1: "x \<in> applies_eq (Forall v A) \<Delta> s"
    then show "x \<in> applies_eq (Forall v A) \<Delta>' s"
      using asm0 assms non_increasing_def smaller_interp_applies_cons by fastforce
  qed
qed

subsection \<open>Tarski's fixed points\<close>

subsubsection \<open>Greatest Fixed Point\<close>

definition D :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> ('d, 'c, 'a) interp set" where
  "D f = { \<Delta> |\<Delta>. smaller_interp \<Delta> (f \<Delta>) }"

fun GFP :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> ('d, 'c, 'a) interp" where
  "GFP f s = { \<sigma> |\<sigma>. \<exists>\<Delta> \<in> D f. \<sigma> \<in> \<Delta> s }"

lemma smaller_interp_D:
  assumes "x \<in> D f"
  shows "smaller_interp x (GFP f)"
  by (metis (mono_tags, lifting) CollectI GFP.elims assms smaller_interpI)

lemma GFP_lub:
  assumes "\<And>x. x \<in> D f \<Longrightarrow> smaller_interp x y"
  shows "smaller_interp (GFP f) y"
proof (rule smaller_interpI)
  fix s x
  assume "x \<in> GFP f s"
  then obtain \<Delta> where "\<Delta> \<in> D f" "x \<in> \<Delta> s"
    by auto
  then show "x \<in> y s"
    by (metis assms in_mono smaller_interp_def)
qed

lemma smaller_interp_antisym:
  assumes "smaller_interp a b"
      and "smaller_interp b a"
    shows "a = b"
proof (rule ext)
  fix x show "a x = b x"
    by (metis assms(1) assms(2) set_eq_subset smaller_interp_def)
qed

subsubsection \<open>Least Fixed Point\<close>

definition DD :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> ('d, 'c, 'a) interp set" where
  "DD f = { \<Delta> |\<Delta>. smaller_interp (f \<Delta>) \<Delta> }"

fun LFP :: "(('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp) \<Rightarrow> ('d, 'c, 'a) interp" where
  "LFP f s = { \<sigma> |\<sigma>. \<forall>\<Delta> \<in> DD f. \<sigma> \<in> \<Delta> s }"

lemma smaller_interp_DD:
  assumes "x \<in> DD f"
  shows "smaller_interp (LFP f) x"
  using assms smaller_interp_def by fastforce

lemma LFP_glb:
  assumes "\<And>x. x \<in> DD f \<Longrightarrow> smaller_interp y x"
  shows "smaller_interp y (LFP f)"
proof (rule smaller_interpI)
  fix s x
  assume "x \<in> y s"
  then have "\<And>\<Delta>. \<Delta> \<in> DD f \<Longrightarrow> x \<in> \<Delta> s"
    by (metis assms smaller_interp_def subsetD)
  then show "x \<in> LFP f s"
    by simp
qed

subsection \<open>Combinability and (an assertion being) intuitionistic are set-closure properties\<close>

subsubsection \<open>Intuitionistic assertions\<close>

definition sem_intui :: "('d, 'c, 'a) interp \<Rightarrow> bool" where
  "sem_intui \<Delta> \<longleftrightarrow> (\<forall>s \<sigma> \<sigma>'. \<sigma>' \<succeq> \<sigma> \<and> \<sigma> \<in> \<Delta> s \<longrightarrow> \<sigma>' \<in> \<Delta> s)"

lemma sem_intuiI:
  assumes "\<And>s \<sigma> \<sigma>'. \<sigma>' \<succeq> \<sigma> \<and> \<sigma> \<in> \<Delta> s \<Longrightarrow> \<sigma>' \<in> \<Delta> s"
  shows "sem_intui \<Delta>"
  using assms sem_intui_def by blast

lemma instantiate_intui_applies:
  assumes "intuitionistic s \<Delta> A"
      and "\<sigma>' \<succeq> \<sigma>"
      and "\<sigma> \<in> applies_eq A \<Delta> s"
    shows "\<sigma>' \<in> applies_eq A \<Delta> s"
  using assms(1) assms(2) assms(3) intuitionistic_def by fastforce

lemma sem_intui_intuitionistic:
  "sem_intui (applies_eq A \<Delta>) \<longleftrightarrow> (\<forall>s. intuitionistic s \<Delta> A)" (is "?A \<longleftrightarrow> ?B")
proof
  show "?B \<Longrightarrow> ?A"
  proof -
    assume ?B
    show ?A
    proof (rule sem_intuiI)
      fix s \<sigma> \<sigma>'
      assume "\<sigma>' \<succeq> \<sigma> \<and> \<sigma> \<in> applies_eq A \<Delta> s"
      then show "\<sigma>' \<in> applies_eq A \<Delta> s"
        using \<open>\<forall>s. intuitionistic s \<Delta> A\<close> instantiate_intui_applies by blast
    qed
  qed
  assume ?A
  show ?B
  proof
    fix s show "intuitionistic s \<Delta> A"
    proof (rule intuitionisticI)
      fix a b
      assume "a \<succeq> b \<and> b, s, \<Delta> \<Turnstile> A"
      then have "b \<in> applies_eq A \<Delta> s" by simp
      then show "a, s, \<Delta> \<Turnstile> A"
        by (metis CollectD \<open>a \<succeq> b \<and> b, s, \<Delta> \<Turnstile> A\<close> \<open>sem_intui (applies_eq A \<Delta>)\<close> applies_eq.simps sem_intui_def)
    qed
  qed
qed

lemma intuitionistic_set_closure:
  "sem_intui = set_closure_property (\<lambda>a b. { \<sigma> |\<sigma>. \<sigma> \<succeq> a})"
proof (rule ext)
  fix \<Delta> :: "('c, 'd, 'a) interp"
  show "sem_intui \<Delta> = set_closure_property (\<lambda>a b. {\<sigma> |\<sigma>. \<sigma> \<succeq> a}) \<Delta>" (is "?A \<longleftrightarrow> ?B")
  proof
    show "?A \<Longrightarrow> ?B"
      by (metis (no_types, lifting) CollectD set_closure_propertyI sem_intui_def subsetI)
    assume ?B
    show ?A
    proof (rule sem_intuiI)
      fix s \<sigma> \<sigma>'
      assume "\<sigma>' \<succeq> \<sigma> \<and> \<sigma> \<in> \<Delta> s"
      moreover have "(\<lambda>a b. {\<sigma> |\<sigma>. \<sigma> \<succeq> a}) \<sigma> \<sigma> = {\<sigma>' |\<sigma>'. \<sigma>' \<succeq> \<sigma>}" by simp
      ultimately have "{\<sigma>' |\<sigma>'. \<sigma>' \<succeq> \<sigma>} \<subseteq> \<Delta> s"
        by (metis \<open>set_closure_property (\<lambda>a b. {\<sigma> |\<sigma>. \<sigma> \<succeq> a}) \<Delta>\<close> set_closure_property_def)
      show "\<sigma>' \<in> \<Delta> s"
        using \<open>\<sigma>' \<succeq> \<sigma> \<and> \<sigma> \<in> \<Delta> s\<close> \<open>{\<sigma>' |\<sigma>'. \<sigma>' \<succeq> \<sigma>} \<subseteq> \<Delta> s\<close> by fastforce
    qed
  qed
qed

subsubsection \<open>Combinable assertions\<close>

definition sem_combinable :: "('d, 'c, 'a) interp \<Rightarrow> bool" where
  "sem_combinable \<Delta> \<longleftrightarrow> (\<forall>s p q a b x. sadd p q = one \<and> a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<longrightarrow> x \<in> \<Delta> s)"

lemma sem_combinableI:
  assumes "\<And>s p q a b x. sadd p q = one \<and> a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<Longrightarrow> x \<in> \<Delta> s"
  shows "sem_combinable \<Delta>"
  using assms sem_combinable_def by blast

lemma sem_combinableE:
  assumes "sem_combinable \<Delta>"
      and "a \<in> \<Delta> s"
      and "b \<in> \<Delta> s"
      and "Some x = p \<odot> a \<oplus> q \<odot> b"
      and "sadd p q = one"
    shows "x \<in> \<Delta> s"
  using assms(1) assms(2) assms(3) assms(4) assms(5) sem_combinable_def[of \<Delta>]
  by blast

lemma applies_eq_equiv:
  "x \<in> applies_eq A \<Delta> s \<longleftrightarrow> x, s, \<Delta> \<Turnstile> A"
  by simp

lemma sem_combinable_appliesE:
  assumes "sem_combinable (applies_eq A \<Delta>)"
      and "a, s, \<Delta> \<Turnstile> A"
      and "b, s, \<Delta> \<Turnstile> A"
      and "Some x = p \<odot> a \<oplus> q \<odot> b"
      and "sadd p q = one"
    shows "x, s, \<Delta> \<Turnstile> A"
    using sem_combinableE[of "applies_eq A \<Delta>" a s b x p q] assms by simp

lemma sem_combinable_equiv:
  "sem_combinable (applies_eq A \<Delta>) \<longleftrightarrow> (combinable \<Delta> A)" (is "?A \<longleftrightarrow> ?B")
proof
  show "?B \<Longrightarrow> ?A"
  proof -
    assume ?B
    show ?A
    proof (rule sem_combinableI)
      fix s p q a b x
      assume asm: "sadd p q = one \<and> a \<in> applies_eq A \<Delta> s \<and> b \<in> applies_eq A \<Delta> s \<and> Some x = p \<odot> a \<oplus> q \<odot> b"
      then show "x \<in> applies_eq A \<Delta> s"
        using \<open>combinable \<Delta> A\<close> applies_eq_equiv combinable_instantiate_one by blast
    qed
  qed
  assume ?A
  show ?B
  proof -
    fix s show "combinable \<Delta> A"
    proof (rule combinableI)
      fix a b p q x \<sigma> s
      assume "a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
      then show "x, s, \<Delta> \<Turnstile> A"
        using \<open>sem_combinable (applies_eq A \<Delta>)\<close> sem_combinable_appliesE by blast
    qed
  qed
qed

lemma combinable_set_closure:
  "sem_combinable = set_closure_property (\<lambda>a b. { \<sigma> |\<sigma> p q. sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b})"
proof (rule ext)
  fix \<Delta> :: "('c, 'd, 'a) interp"
  show "sem_combinable \<Delta> = set_closure_property (\<lambda>a b. { \<sigma> |\<sigma> p q. sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b}) \<Delta>" (is "?A \<longleftrightarrow> ?B")
  proof
    show "?A \<Longrightarrow> ?B"
    proof -
      assume ?A
      show ?B
      proof (rule set_closure_propertyI)
        fix a b s
        assume "a \<in> \<Delta> s \<and> b \<in> \<Delta> s"
        then show "{x. \<exists>\<sigma> p q. x = \<sigma> \<and> sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b} \<subseteq> \<Delta> s"
          using \<open>sem_combinable \<Delta>\<close> sem_combinableE by blast
      qed
    qed
    assume ?B
    show ?A
    proof (rule sem_combinableI)
      fix s p q a b x
      assume asm: "sadd p q = one \<and> a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<and> Some x = p \<odot> a \<oplus> q \<odot> b"

      then have "x \<in> (\<lambda>a b. { \<sigma> |\<sigma> p q. sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b}) a b"
        by blast
      moreover have "(\<lambda>a b. { \<sigma> |\<sigma> p q. sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b}) a b \<subseteq> \<Delta> s"
        using \<open>?B\<close> set_closure_property_def[of "(\<lambda>a b. { \<sigma> |\<sigma> p q. sadd p q = one \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b})" \<Delta>]
        asm by meson
      ultimately show "x \<in> \<Delta> s" by blast
    qed
  qed
qed

subsection \<open>Transfinite induction\<close>

definition Inf :: "('d, 'c, 'a) interp set \<Rightarrow> ('d, 'c, 'a) interp" where
  "Inf S s = { \<sigma> |\<sigma>. \<forall>\<Delta> \<in> S. \<sigma> \<in> \<Delta> s}"

definition Sup :: "('d, 'c, 'a) interp set \<Rightarrow> ('d, 'c, 'a) interp" where
  "Sup S s = { \<sigma> |\<sigma>. \<exists>\<Delta> \<in> S. \<sigma> \<in> \<Delta> s}"

definition inf :: "('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp" where
  "inf \<Delta> \<Delta>' s = \<Delta> s \<inter> \<Delta>' s"

definition less where
  "less a b \<longleftrightarrow> smaller_interp a b \<and> a \<noteq> b"

definition sup :: "('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp \<Rightarrow> ('d, 'c, 'a) interp" where
  "sup \<Delta> \<Delta>' s = \<Delta> s \<union> \<Delta>' s"

lemma smaller_full:
  "smaller_interp x full_interp"
  by (simp add: full_interp_def smaller_interpI)

lemma inf_empty:
  "local.Inf {} = full_interp"
proof (rule ext)
  fix s :: "'c \<Rightarrow> 'd" show "local.Inf {} s = full_interp s"
    by (simp add: Inf_def full_interp_def)
qed

lemma sup_empty:
  "local.Sup {} = empty_interp"
proof (rule ext)
  fix s :: "'c \<Rightarrow> 'd" show "local.Sup {} s = empty_interp s"
    by (simp add: Sup_def empty_interp_def)
qed

lemma test_axiom_inf:
  assumes "\<And>x. x \<in> A \<Longrightarrow> smaller_interp z x"
  shows "smaller_interp z (local.Inf A)"
proof (rule smaller_interpI)
  fix s x
  assume "x \<in> z s"
  then have "\<And>y. y \<in> A \<Longrightarrow> x \<in> y s"
    by (metis assms in_mono smaller_interp_def)
  then show "x \<in> local.Inf A s"
    by (simp add: Inf_def)
qed

lemma test_axiom_sup:
  assumes "\<And>x. x \<in> A \<Longrightarrow> smaller_interp x z"
  shows "smaller_interp (local.Sup A) z"
proof (rule smaller_interpI)
  fix s x
  assume "x \<in> local.Sup A s"
  then obtain y where "y \<in> A" "x \<in> y s"
    using Sup_def[of A s] mem_Collect_eq[of x]
    by auto
  then show "x \<in> z s"
    by (metis assms smaller_interp_def subsetD)
qed

interpretation complete_lattice Inf Sup inf smaller_interp less sup empty_interp full_interp
  apply standard
  apply (metis less_def smaller_interp_antisym)
  apply (simp add: smaller_interp_refl)
  using smaller_interp_trans apply blast
  using smaller_interp_antisym apply blast
  apply (simp add: inf_def smaller_interp_def)
  apply (simp add: inf_def smaller_interp_def)
  apply (simp add: inf_def smaller_interp_def)
  apply (simp add: smaller_interpI sup_def)
  apply (simp add: smaller_interpI sup_def)
  apply (simp add: smaller_interp_def sup_def)
  apply (metis (mono_tags, lifting) CollectD Inf_def smaller_interpI)
  using test_axiom_inf apply blast
  apply (metis (mono_tags, lifting) CollectI Sup_def smaller_interpI)
  using test_axiom_sup apply auto[1]
  apply (simp add: inf_empty)
  by (simp add: sup_empty)

lemma mono_same:
  "monotonic f \<longleftrightarrow> order_class.mono f"
  by (metis (no_types, opaque_lifting) le_funE le_funI monotonic_def order_class.mono_def smaller_interp_def)

lemma "smaller_interp a b \<longleftrightarrow> a \<le> b"
  by (simp add: le_fun_def smaller_interp_def)

lemma set_closure_property_admissible:
  "ccpo.admissible Sup_class.Sup (\<le>) (set_closure_property S)"
proof (rule ccpo.admissibleI)
  fix A :: "('c, 'd, 'a) interp set"
  assume asm0: "Complete_Partial_Order.chain (\<le>) A"
  "A \<noteq> {}" "\<forall>x\<in>A. set_closure_property S x"

  show "set_closure_property S (Sup_class.Sup A)"
  proof (rule set_closure_propertyI)
    fix a b s
    assume asm: "a \<in> Sup_class.Sup A s \<and> b \<in> Sup_class.Sup A s"
    then obtain \<Delta>a \<Delta>b where "\<Delta>a \<in> A" "\<Delta>b \<in> A" "a \<in> \<Delta>a s" "b \<in> \<Delta>b s"
      by auto
    then show "S a b \<subseteq> Sup_class.Sup A s"
    proof (cases "\<Delta>a s \<subseteq> \<Delta>b s")
      case True
      then have "S a b \<subseteq> \<Delta>b s"
        by (metis \<open>\<Delta>b \<in> A\<close> \<open>a \<in> \<Delta>a s\<close> \<open>b \<in> \<Delta>b s\<close> asm0(3) set_closure_property_def subsetD)
      then show ?thesis
        using \<open>\<Delta>b \<in> A\<close> by auto
    next
      case False
      then have "\<Delta>b s \<subseteq> \<Delta>a s"
        by (metis \<open>\<Delta>a \<in> A\<close> \<open>\<Delta>b \<in> A\<close> asm0(1) chainD le_funD)
      then have "S a b \<subseteq> \<Delta>a s"
        by (metis \<open>\<Delta>a \<in> A\<close> \<open>a \<in> \<Delta>a s\<close> \<open>b \<in> \<Delta>b s\<close> asm0(3) subsetD set_closure_property_def)
      then show ?thesis using \<open>\<Delta>a \<in> A\<close> by auto
    qed
  qed
qed

definition supp :: "('d, 'c, 'a) interp \<Rightarrow> bool" where
  "supp \<Delta> \<longleftrightarrow> (\<forall>a b s. a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<longrightarrow> (\<exists>x. a \<succeq> x \<and> b \<succeq> x \<and> x \<in> \<Delta> s))"

lemma suppI:
  assumes "\<And>a b s. a \<in> \<Delta> s \<and> b \<in> \<Delta> s \<Longrightarrow> (\<exists>x. a \<succeq> x \<and> b \<succeq> x \<and> x \<in> \<Delta> s)"
  shows "supp \<Delta>"
  by (simp add: assms supp_def)

lemma supp_admissible:
  "ccpo.admissible Sup_class.Sup (\<le>) supp"
proof (rule ccpo.admissibleI)
  fix A :: "('c, 'd, 'a) interp set"
  assume asm0: "Complete_Partial_Order.chain (\<le>) A"
  "A \<noteq> {}" "\<forall>x\<in>A. supp x"
  show "supp (Sup_class.Sup A)"
  proof (rule suppI)
    fix a b s
    assume asm: "a \<in> Sup_class.Sup A s \<and> b \<in> Sup_class.Sup A s"
    then obtain \<Delta>a \<Delta>b where "\<Delta>a \<in> A" "\<Delta>b \<in> A" "a \<in> \<Delta>a s" "b \<in> \<Delta>b s"
      by auto
    then show "\<exists>x. a \<succeq> x \<and> b \<succeq> x \<and> x \<in> Sup_class.Sup A s"
    proof (cases "\<Delta>a s \<subseteq> \<Delta>b s")
      case True
      then have "a \<in> \<Delta>b s"
        using \<open>a \<in> \<Delta>a s\<close> by blast
      then obtain x where "a \<succeq> x" "b \<succeq> x" "x \<in> \<Delta>b s"
        by (metis \<open>\<Delta>b \<in> A\<close> \<open>b \<in> \<Delta>b s\<close> asm0(3) supp_def)
      then show ?thesis
        using \<open>\<Delta>b \<in> A\<close> by auto
    next
      case False
      then have "b \<in> \<Delta>a s"
        by (metis \<open>\<Delta>a \<in> A\<close> \<open>\<Delta>b \<in> A\<close> \<open>b \<in> \<Delta>b s\<close> asm0(1) chainD le_funD subsetD)
      then obtain x where "a \<succeq> x" "b \<succeq> x" "x \<in> \<Delta>a s"
        using \<open>\<Delta>a \<in> A\<close> \<open>a \<in> \<Delta>a s\<close> asm0(3) supp_def by metis
      then show ?thesis using \<open>\<Delta>a \<in> A\<close> by auto
    qed
  qed
qed

lemma "Sup_class.Sup {} = empty_interp" using empty_interp_def
  by fastforce

lemma set_closure_prop_empty_all:
  shows "set_closure_property S empty_interp"
  and "set_closure_property S full_interp"
   apply (metis empty_interp_def equals0D set_closure_propertyI)
  by (simp add: full_interp_def set_closure_propertyI)

lemma LFP_preserves_set_closure_property_aux:
  assumes "monotonic f"
      and "set_closure_property S empty_interp"
      and "\<And>\<Delta>. set_closure_property S \<Delta> \<Longrightarrow> set_closure_property S (f \<Delta>)"
    shows "set_closure_property S (ccpo_class.fixp f)"
  using set_closure_property_admissible
proof (rule fixp_induct[of "set_closure_property S"])
  show "set_closure_property S (Sup_class.Sup {})"
    by (simp add: set_closure_property_def)
  show "monotone (\<le>) (\<le>) f"
    by (metis (full_types) assms(1) le_fun_def monotoneI monotonic_def smaller_interp_def)
  show "\<And>x. set_closure_property S x \<Longrightarrow> set_closure_property S (f x)"
    by (simp add: assms(3))
qed

lemma GFP_preserves_set_closure_property_aux:
  assumes "order_class.mono f"
      and "set_closure_property S full_interp"
      and "\<And>\<Delta>. set_closure_property S \<Delta> \<Longrightarrow> set_closure_property S (f \<Delta>)"
    shows "set_closure_property S (complete_lattice_class.gfp f)"
  using assms(1)
proof (rule gfp_ordinal_induct[of f "set_closure_property S"])
  show "\<And>Sa. set_closure_property S Sa \<Longrightarrow> complete_lattice_class.gfp f \<le> Sa \<Longrightarrow> set_closure_property S (f Sa)"
    using assms(3) by blast
  fix M :: "('c, 'd, 'a) interp set"
  assume "\<forall>Sa\<in>M. set_closure_property S Sa"
  show "set_closure_property S (Inf_class.Inf M)"
  proof (rule set_closure_propertyI)
    fix a b s
    assume "a \<in> Inf_class.Inf M s \<and> b \<in> Inf_class.Inf M s"
    then have "\<And>\<Delta>. \<Delta> \<in> M \<Longrightarrow> a \<in> \<Delta> s \<and> b \<in> \<Delta> s"
      by simp
    then have "\<And>\<Delta>. \<Delta> \<in> M \<Longrightarrow> S a b \<subseteq> \<Delta> s"
      by (metis \<open>\<forall>Sa\<in>M. set_closure_property S Sa\<close> set_closure_property_def)
    show "S a b \<subseteq> Inf_class.Inf M s"
      by (simp add: \<open>\<And>\<Delta>. \<Delta> \<in> M \<Longrightarrow> S a b \<subseteq> \<Delta> s\<close> complete_lattice_class.INF_greatest)
  qed
qed

subsection Theorems

subsubsection \<open>Greatest Fixed Point\<close>

theorem GFP_is_FP:
  assumes "monotonic f"
  shows "f (GFP f) = GFP f"
proof -
  let ?u = "GFP f"
  have "\<And>x. x \<in> D f \<Longrightarrow> smaller_interp x (f ?u)"
  proof -
    fix x
    assume "x \<in> D f"
    then have "smaller_interp (f x) (f ?u)"
      using assms monotonic_def smaller_interp_D by blast
    moreover have "smaller_interp x (f x)"
      using D_def \<open>x \<in> D f\<close> by fastforce
    ultimately show "smaller_interp x (f ?u)"
      using smaller_interp_trans by blast
  qed
  then have "?u \<in> D f"
    using D_def GFP_lub by blast
  then have "f ?u \<in> D f"
    by (metis CollectI D_def \<open>\<And>x. x \<in> D f \<Longrightarrow> smaller_interp x (f (GFP f))\<close> assms monotonic_def)
  then show ?thesis
    by (simp add: \<open>GFP f \<in> D f\<close> \<open>\<And>x. x \<in> D f \<Longrightarrow> smaller_interp x (f (GFP f))\<close> smaller_interp_D smaller_interp_antisym)
qed

theorem GFP_greatest:
  assumes "f u = u"
  shows "smaller_interp u (GFP f)"
  by (simp add: D_def assms smaller_interp_D smaller_interp_refl)

lemma same_GFP:
  assumes "monotonic f"
  shows "complete_lattice_class.gfp f = GFP f"
proof -
  have "f (GFP f) = GFP f"
    using GFP_is_FP assms by blast
  then have "smaller_interp (GFP f) (complete_lattice_class.gfp f)"
    by (metis complete_lattice_class.gfp_upperbound le_funD order_class.order.eq_iff smaller_interp_def)
  moreover have "f (complete_lattice_class.gfp f) = complete_lattice_class.gfp f"
    using assms gfp_fixpoint mono_same by blast
  then have "smaller_interp (complete_lattice_class.gfp f) (GFP f)"
    by (simp add: GFP_greatest)
  ultimately show ?thesis
    by simp
qed

subsubsection \<open>Least Fixed Point\<close>

theorem LFP_is_FP:
  assumes "monotonic f"
  shows "f (LFP f) = LFP f"
proof -
  let ?u = "LFP f"
  have "\<And>x. x \<in> DD f \<Longrightarrow> smaller_interp (f ?u) x"
  proof -
    fix x
    assume "x \<in> DD f"
    then have "smaller_interp (f ?u) (f x)"
      using assms monotonic_def smaller_interp_DD by blast
    moreover have "smaller_interp (f x) x"
      using DD_def \<open>x \<in> DD f\<close> by fastforce
    ultimately show "smaller_interp (f ?u) x"
      using smaller_interp_trans by blast
  qed
  then have "?u \<in> DD f"
    using DD_def LFP_glb by blast
  then have "f ?u \<in> DD f"
    by (metis (mono_tags, lifting) CollectI DD_def \<open>\<And>x. x \<in> DD f \<Longrightarrow> smaller_interp (f (LFP f)) x\<close> assms monotonic_def)
  then show ?thesis
    by (simp add: \<open>LFP f \<in> DD f\<close> \<open>\<And>x. x \<in> DD f \<Longrightarrow> smaller_interp (f (LFP f)) x\<close> smaller_interp_DD smaller_interp_antisym)
qed

theorem LFP_least:
  assumes "f u = u"
  shows "smaller_interp (LFP f) u"
  by (simp add: DD_def assms smaller_interp_DD smaller_interp_refl)

lemma same_LFP:
  assumes "monotonic f"
  shows "complete_lattice_class.lfp f = LFP f"
proof -
  have "f (LFP f) = LFP f"
    using LFP_is_FP assms by blast
  then have "smaller_interp (complete_lattice_class.lfp f) (LFP f)"
    by (metis complete_lattice_class.lfp_lowerbound le_funE preorder_class.order_refl smaller_interp_def)
  moreover have "f (complete_lattice_class.gfp f) = complete_lattice_class.gfp f"
    using assms gfp_fixpoint mono_same by blast
  then have "smaller_interp (LFP f) (complete_lattice_class.lfp f)"
    by (meson LFP_least assms lfp_fixpoint mono_same)
  ultimately show ?thesis
    by simp
qed

lemma LFP_same:
  assumes "monotonic f"
  shows "ccpo_class.fixp f = LFP f"
proof -
  have "f (ccpo_class.fixp f) = ccpo_class.fixp f"
    by (metis (mono_tags, lifting) assms fixp_unfold mono_same monotoneI order_class.mono_def)
  then have "smaller_interp (LFP f) (ccpo_class.fixp f)"
    by (simp add: LFP_least)
  moreover have "f (LFP f) = LFP f"
    using LFP_is_FP assms by blast
  then have "ccpo_class.fixp f \<le> LFP f"
    by (metis assms fixp_lowerbound mono_same monotoneI order_class.mono_def preorder_class.order_refl)
  ultimately show ?thesis
    by (metis assms lfp_eq_fixp mono_same same_LFP)
qed

text \<open>The following theorem corresponds to Theorem 5 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

theorem FP_preserves_set_closure_property:
  assumes "monotonic f"
      and "\<And>\<Delta>. set_closure_property S \<Delta> \<Longrightarrow> set_closure_property S (f \<Delta>)"
    shows "set_closure_property S (GFP f)"
      and "set_closure_property S (LFP f)"
  apply (metis GFP_preserves_set_closure_property_aux assms(1) assms(2) mono_same same_GFP set_closure_prop_empty_all(2))
  by (metis LFP_preserves_set_closure_property_aux LFP_same assms(1) assms(2) set_closure_prop_empty_all(1))

end

end