section \<open>Coercion Operator\<close>

theory Coerce
imports HOLCF
begin

subsection \<open>Coerce\<close>

text \<open>The \<open>domain\<close> type class, which is the default type class
in HOLCF, fixes two overloaded functions: \<open>emb::'a \<rightarrow> udom\<close> and
\<open>prj::udom \<rightarrow> 'a\<close>. By composing the \<open>prj\<close> and \<open>emb\<close>
functions together, we can coerce values between any two types in
class \<open>domain\<close>. \medskip\<close>

definition coerce :: "'a \<rightarrow> 'b"
  where "coerce \<equiv> prj oo emb"

text \<open>When working with proofs involving \<open>emb\<close>, \<open>prj\<close>,
and \<open>coerce\<close>, it is often difficult to tell at which types those
constants are being used. To alleviate this problem, we define special
input and output syntax to indicate the types. \medskip\<close>

syntax
  "_emb" :: "type \<Rightarrow> logic" ("(1EMB/(1'(_')))")
  "_prj" :: "type \<Rightarrow> logic" ("(1PRJ/(1'(_')))")
  "_coerce" :: "type \<Rightarrow> type \<Rightarrow> logic" ("(1COERCE/(1'(_,/ _')))")

translations
  "EMB('a)" \<rightharpoonup> "CONST emb :: 'a \<rightarrow> udom"
  "PRJ('a)" \<rightharpoonup> "CONST prj :: udom \<rightarrow> 'a"
  "COERCE('a,'b)" \<rightharpoonup> "CONST coerce :: 'a \<rightarrow> 'b"

typed_print_translation \<open>
let
  fun emb_tr' (ctxt : Proof.context) (Type(_, [T, _])) [] =
    Syntax.const @{syntax_const "_emb"} $ Syntax_Phases.term_of_typ ctxt T
  fun prj_tr' ctxt (Type(_, [_, T])) [] =
    Syntax.const @{syntax_const "_prj"} $ Syntax_Phases.term_of_typ ctxt T
  fun coerce_tr' ctxt (Type(_, [T, U])) [] =
    Syntax.const @{syntax_const "_coerce"} $
      Syntax_Phases.term_of_typ ctxt T $ Syntax_Phases.term_of_typ ctxt U
in
  [(@{const_syntax emb}, emb_tr'),
   (@{const_syntax prj}, prj_tr'),
   (@{const_syntax coerce}, coerce_tr')]
end
\<close>

lemma beta_coerce: "coerce\<cdot>x = prj\<cdot>(emb\<cdot>x)"
by (simp add: coerce_def)

lemma prj_emb: "prj\<cdot>(emb\<cdot>x) = coerce\<cdot>x"
by (simp add: coerce_def)

lemma coerce_strict [simp]: "coerce\<cdot>\<bottom> = \<bottom>"
by (simp add: coerce_def)

text \<open>Certain type instances of \<open>coerce\<close> may reduce to the
identity function, \<open>emb\<close>, or \<open>prj\<close>. \medskip\<close>

lemma coerce_eq_ID [simp]: "COERCE('a, 'a) = ID"
by (rule cfun_eqI, simp add: beta_coerce)

lemma coerce_eq_emb [simp]: "COERCE('a, udom) = EMB('a)"
by (rule cfun_eqI, simp add: beta_coerce)

lemma coerce_eq_prj [simp]: "COERCE(udom, 'a) = PRJ('a)"
by (rule cfun_eqI, simp add: beta_coerce)

text "Cancellation rules"

lemma emb_coerce:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> EMB('b)\<cdot>(COERCE('a,'b)\<cdot>x) = EMB('a)\<cdot>x"
by (simp add: beta_coerce emb_prj_emb)

lemma coerce_prj:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> COERCE('b,'a)\<cdot>(PRJ('b)\<cdot>x) = PRJ('a)\<cdot>x"
by (simp add: beta_coerce prj_emb_prj)

lemma coerce_idem [simp]:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> COERCE('b,'c)\<cdot>(COERCE('a,'b)\<cdot>x) = COERCE('a,'c)\<cdot>x"
by (simp add: beta_coerce emb_prj_emb)

subsection \<open>More lemmas about emb and prj\<close>

lemma prj_cast_DEFL [simp]: "PRJ('a)\<cdot>(cast\<cdot>DEFL('a)\<cdot>x) = PRJ('a)\<cdot>x"
by (simp add: cast_DEFL)

lemma cast_DEFL_emb [simp]: "cast\<cdot>DEFL('a)\<cdot>(EMB('a)\<cdot>x) = EMB('a)\<cdot>x"
by (simp add: cast_DEFL)

text \<open>@{term "DEFL(udom)"}\<close>

lemma below_DEFL_udom [simp]: "A \<sqsubseteq> DEFL(udom)"
apply (rule cast_below_imp_below)
apply (rule cast.belowI)
apply (simp add: cast_DEFL)
done

subsection \<open>Coercing various datatypes\<close>

text \<open>Coercing from the strict product type @{typ "'a \<otimes> 'b"} to
another strict product type @{typ "'c \<otimes> 'd"} is equivalent to mapping
the \<open>coerce\<close> function separately over each component using
\<open>sprod_map :: ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'b \<rightarrow> 'c \<otimes> 'd\<close>. Each
of the several type constructors defined in HOLCF satisfies a similar
property, with respect to its own map combinator. \medskip\<close>

lemma coerce_u: "coerce = u_map\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
apply (subst ep_pair.e_inverse [OF ep_pair_u])
apply (simp add: u_map_map cfcomp1)
done

lemma coerce_sfun: "coerce = sfun_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_sfun_def prj_sfun_def)
apply (subst ep_pair.e_inverse [OF ep_pair_sfun])
apply (simp add: sfun_map_map cfcomp1)
done

lemma coerce_cfun': "coerce = cfun_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: prj_emb [symmetric])
apply (simp add: emb_cfun_def prj_cfun_def)
apply (simp add: prj_emb coerce_sfun coerce_u)
apply (simp add: encode_cfun_map [symmetric])
done

lemma coerce_ssum: "coerce = ssum_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_ssum_def prj_ssum_def)
apply (subst ep_pair.e_inverse [OF ep_pair_ssum])
apply (simp add: ssum_map_map cfcomp1)
done

lemma coerce_sprod: "coerce = sprod_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_sprod_def prj_sprod_def)
apply (subst ep_pair.e_inverse [OF ep_pair_sprod])
apply (simp add: sprod_map_map cfcomp1)
done

lemma coerce_prod: "coerce = prod_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_prod_def prj_prod_def)
apply (subst ep_pair.e_inverse [OF ep_pair_prod])
apply (simp add: prod_map_map cfcomp1)
done

subsection \<open>Simplifying coercions\<close>

text \<open>When simplifying applications of the \<open>coerce\<close> function,
rewrite rules are always oriented to replace \<open>coerce\<close> at complex
types with other applications of \<open>coerce\<close> at simpler types.\<close>

text \<open>The safest rewrite rules for \<open>coerce\<close> are given the
\<open>[simp]\<close> attribute. For other rules that do not belong in the
global simpset, we use dynamic theorem list called \<open>coerce_simp\<close>,
which will collect additional rules for simplifying coercions. \medskip\<close>

named_theorems coerce_simp "rule for simplifying coercions"

text \<open>The \<open>coerce\<close> function commutes with data constructors
for various HOLCF datatypes. \medskip\<close>

lemma coerce_up [simp]: "coerce\<cdot>(up\<cdot>x) = up\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_u)

lemma coerce_sinl [simp]: "coerce\<cdot>(sinl\<cdot>x) = sinl\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_ssum ssum_map_sinl')

lemma coerce_sinr [simp]: "coerce\<cdot>(sinr\<cdot>x) = sinr\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_ssum ssum_map_sinr')

lemma coerce_spair [simp]: "coerce\<cdot>(:x, y:) = (:coerce\<cdot>x, coerce\<cdot>y:)"
by (simp add: coerce_sprod sprod_map_spair')

lemma coerce_Pair [simp]: "coerce\<cdot>(x, y) = (coerce\<cdot>x, coerce\<cdot>y)"
by (simp add: coerce_prod)

lemma beta_coerce_cfun [simp]: "coerce\<cdot>f\<cdot>x = coerce\<cdot>(f\<cdot>(coerce\<cdot>x))"
by (simp add: coerce_cfun')

lemma coerce_cfun: "coerce\<cdot>f = coerce oo f oo coerce"
by (simp add: cfun_eqI)

lemma coerce_cfun_app [coerce_simp]:
  "coerce\<cdot>f = (\<Lambda> x. coerce\<cdot>(f\<cdot>(coerce\<cdot>x)))"
by (simp add: cfun_eqI)

end


(*  File:       Result.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Electoral Result\<close>

theory Result
  imports Main
begin

text
\<open>An electoral result is the principal result type of the composable modules
voting framework, as it is a generalization of the set of winning alternatives
from social choice functions. Electoral results are selections of the received
(possibly empty) set of alternatives into the three disjoint groups of elected,
rejected and deferred alternatives.
Any of those sets, e.g., the set of winning (elected) alternatives, may also
be left empty, as long as they collectively still hold all the received
alternatives.\<close>

subsection \<open>Definition\<close>

(*
   A result contains three sets of alternatives:
   elected, rejected, and deferred alternatives.
*)
type_synonym 'a Result = "'a set * 'a set * 'a set"

subsection \<open>Auxiliary Functions\<close>

(*
   A partition of a set A are pairwise disjoint sets that set_equals_partition A.
   For this specific predicate, we have three disjoint sets in a three-tuple.
*)
fun disjoint3 :: "'a Result \<Rightarrow> bool" where
  "disjoint3 (e, r, d) =
    ((e \<inter> r = {}) \<and>
      (e \<inter> d = {}) \<and>
      (r \<inter> d = {}))"

fun set_equals_partition :: "'a set \<Rightarrow>'a Result \<Rightarrow> bool" where
  "set_equals_partition A (e, r, d) = (e \<union> r \<union> d = A)"

fun well_formed :: "'a set \<Rightarrow> 'a Result \<Rightarrow> bool" where
  "well_formed A result = (disjoint3 result \<and> set_equals_partition A result)"

(*These three functions return the elect, reject, or defer set of a result.*)
abbreviation elect_r :: "'a Result \<Rightarrow> 'a set" where
  "elect_r r \<equiv> fst r"

abbreviation reject_r :: "'a Result \<Rightarrow> 'a set" where
  "reject_r r \<equiv> fst (snd r)"

abbreviation defer_r :: "'a Result \<Rightarrow> 'a set" where
  "defer_r r \<equiv> snd (snd r)"

subsection \<open>Auxiliary Lemmata\<close>

lemma result_imp_rej:
  assumes "well_formed A (e, r, d)"
  shows "A - (e \<union> d) = r"
proof (safe)
  fix
    x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    x_not_rej:   "x \<notin> r" and
    x_not_def:   "x \<notin> d"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "x \<in> e"
    using x_in_A x_not_rej x_not_def
    by auto
next
  fix
    x :: "'a"
  assume
    x_rej:   "x \<in> r"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "x \<in> A"
    using x_rej
    by auto
next
  fix
    x :: "'a"
  assume
    x_rej:  "x \<in> r" and
    x_elec: "x \<in> e"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "False"
    using x_rej x_elec
    by auto
next
  fix
    x :: "'a"
  assume
    x_rej: "x \<in> r" and
    x_def: "x \<in> d"
  from assms have
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and>
    (r \<inter> d = {}) \<and> (e \<union> r \<union> d = A)"
    by simp
  thus "False"
    using x_rej x_def
    by auto
qed

lemma result_count:
  assumes
    "well_formed A (e, r, d)" and
    "finite A"
  shows "card A = card e + card r + card d"
proof -
  from assms(1) have disj:
    "(e \<inter> r = {}) \<and> (e \<inter> d = {}) \<and> (r \<inter> d = {})"
    by simp
  from assms(1) have set_partit:
    "e \<union> r \<union> d = A"
    by simp
  show ?thesis
    using assms disj set_partit Int_Un_distrib2 finite_Un
          card_Un_disjoint sup_bot.right_neutral
    by metis
qed

lemma defer_subset:
  assumes "well_formed A result"
  shows "defer_r result \<subseteq> A"
proof (safe)
  fix x :: "'a"
  assume assm0: "x \<in> defer_r result"
  obtain
    AA :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    pp :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    assm1: "A = AA result A \<and> result = pp result A \<and>
            disjoint3 (pp result A) \<and>
            set_equals_partition (AA result A) (pp result A)"
    using assms
    by simp
  hence
    "\<forall>p A. \<exists>Aa Ab Ac.
      (\<not> set_equals_partition (A::'a set) p \<or> (Aa, Ab, Ac) = p) \<and>
        (\<not> set_equals_partition A p \<or> Aa \<union> Ab \<union> Ac = A)"
    by auto
  thus "x \<in> A"
    using UnCI assm0 assm1 snd_conv
    by metis
qed

lemma elect_subset:
  assumes "well_formed A result"
  shows "elect_r result \<subseteq> A"
proof (safe)
  fix x :: "'a"
  assume assm0: "x \<in> elect_r result"
  obtain
    AA :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    pp :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    assm1: "A = AA result A \<and> result = pp result A \<and>
            disjoint3 (pp result A) \<and>
            set_equals_partition (AA result A) (pp result A)"
    using assms
    by simp
  hence
    "\<forall>p A. \<exists>Aa Ab Ac.
      (\<not> set_equals_partition (A::'a set) p \<or> (Aa, Ab, Ac) = p) \<and>
        (\<not> set_equals_partition A p \<or> Aa \<union> Ab \<union> Ac = A)"
    by auto
  thus "x \<in> A"
    using UnCI assm0 assm1 assms fst_conv
    by metis
qed

lemma reject_subset:
  assumes "well_formed A result"
  shows "reject_r result \<subseteq> A"
proof (safe)
  fix x :: "'a"
  assume assm0: "x \<in> reject_r result"
  obtain
    AA :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a set" and
    pp :: "'a Result \<Rightarrow> 'a set \<Rightarrow> 'a Result" where
    assm1: "A = AA result A \<and> result = pp result A \<and>
            disjoint3 (pp result A) \<and>
            set_equals_partition (AA result A) (pp result A)"
    using assms
    by simp
  hence
    "\<forall>p A. \<exists>Aa Ab Ac.
      (\<not> set_equals_partition (A::'a set) p \<or> (Aa, Ab, Ac) = p) \<and>
        (\<not> set_equals_partition A p \<or> Aa \<union> Ab \<union> Ac = A)"
    by auto
  thus "x \<in> A"
    using UnCI assms assm0 assm1 fst_conv snd_conv disjoint3.cases
    by metis
qed

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Robot
imports
  ClockView
  SPRViewSingle
  "~~/src/HOL/Library/Saturated"
begin

(*>*)
subsection{* The Robot *}

text{*
\label{sec:kbps-theory-robot}

\begin{figure}[tb]
 \includegraphics[width=\textwidth]{robot_clock}
 \caption{The implementation of the robot using the clock semantics.}
 \label{fig:kbps-theory-robot-clock}
\end{figure}

\begin{figure}[tb]
 \includegraphics[width=\textwidth]{robot_spr}
 \caption{The implementation of the robot using the SPR semantics.}
 \label{fig:kbps-theory-robot-spr}
\end{figure}

Recall the autonomous robot of \S\ref{sec:kbps-robot-intro}: we are
looking for an implementation of the KBP:
\begin{center}
  \begin{tabular}{lll}
    $\mathbf{do}$\\
     & $\gcalt$ $\mathbf{K}_{\mbox{robot}}$ \textsf{goal} & $\rightarrow$ \textsf{Halt}\\
     & $\gcalt$ $\lnot\mathbf{K}_{\mbox{robot}}$ \textsf{goal} & $\rightarrow$ \textsf{Nothing}\\
    $\mathbf{od}$\\
  \end{tabular}
\end{center}
in an environment where positions are identified with the natural
numbers, the robot's sensor is within one of the position, and the
proposition \textsf{goal} is true when the position is in
$\{2,3,4\}$. The robot is initially at position zero, and the effect
of its \textsf{Halt} action is to cause the robot to instantaneously
stop at its current position. A later \textsf{Nothing}
action may allow the environment to move the robot further to the
right.

To obtain a finite environment, we truncate the number line at 5,
which is intuitively sound for determinining the robot's behaviour due
to the synchronous view, and the fact that if it reaches this
rightmost position then it can never satisfy its objective.  Running
the Haskell code generated by Isabelle yields the automata shown in
Figure~\ref{fig:kbps-theory-robot-clock} and
Figure~\ref{fig:kbps-theory-robot-spr} for the clock and synchronous
perfect recall semantics respectively. These have been minimised using
Hopcroft's algorithm \citep{DBLP:journals/acta/Gries73}.

The (inessential) labels on the states are an upper bound on the set
of positions that the robot considers possible when it is in that
state. Transitions are annotated with the observations yielded by the
sensor. Double-circled states are those in which the robot performs
the \textsf{Halt} action, the others \textsf{Nothing}. We observe that
the synchronous perfect-recall view yields a ``ratchet'' protocol,
i.e. if the robot learns that it is in the goal region then it halts
for all time, and that it never overshoots the goal region. Conversely
the clock semantics allows the robot to infinitely alternate its
actions depending on the sensor reading. This is effectively the
behaviour of the intuitive implementation that halts iff the sensor
reads three or more.

We can also see that minimisation does not yield the smallest automata
we could hope for; in particular there are a lot of redundant states
where the prescribed behaviour is the same but the robot's state of
knowledge different. This is because our implementations do not
specify what happens on invalid observations, which we have modelled
as errors instead of don't-cares, and these extraneous distinctions
are preserved by bisimulation reduction. We discuss this further in
\S\ref{sec:kbps-alg-auto-min}.

*}(*<*)

(*

The environment protocol does nothing if the robot has signalled halt,
or chooses a new position and sensor reading if it hasn't.

We need a finite type to represent positions and observations. It is
sufficient to go to 5, for by then we are either halted in the goal
region or have gone past it.

*)

type_synonym digit = "5 sat"

datatype Agent = Robot
datatype EnvAct = Stay | MoveRight
datatype ObsError = Left | On | Right
datatype Proposition = Halted | InGoal
datatype RobotAct = NOP | Halt

type_synonym Halted = bool
type_synonym Pos = digit
type_synonym Obs = digit
type_synonym EnvState = "Pos \<times> Obs \<times> Halted"

definition
  envInit :: "EnvState list"
where
  "envInit \<equiv> [(0, 0, False), (0, 1, False)]"

definition
  envAction :: "EnvState \<Rightarrow> (EnvAct \<times> ObsError) list"
where
  "envAction \<equiv> \<lambda>_. [ (x, y) . x \<leftarrow> [Stay, MoveRight], y \<leftarrow> [Left, On, Right] ]"

definition
  newObs :: "digit \<Rightarrow> ObsError \<Rightarrow> digit"
where
  "newObs pos obserr \<equiv>
              case obserr of Left \<Rightarrow> pos - 1 | On \<Rightarrow> pos | Right \<Rightarrow> pos + 1"

definition
  envTrans :: "EnvAct \<times> ObsError \<Rightarrow> (Agent \<Rightarrow> RobotAct) \<Rightarrow> EnvState \<Rightarrow> EnvState"
where
  "envTrans \<equiv> \<lambda>(move, obserr) aact (pos, obs, halted).
    if halted
      then (pos, newObs pos obserr, halted)
      else
        case aact Robot of
           NOP \<Rightarrow> (case move of
                      Stay \<Rightarrow> (pos, newObs pos obserr, False)
                    | MoveRight \<Rightarrow> (pos + 1, newObs (pos + 1) obserr, False))
         | Halt \<Rightarrow> (pos, newObs pos obserr, True)"

definition
  envObs :: "EnvState \<Rightarrow> Obs"
where
  "envObs \<equiv> \<lambda>(pos, obs, halted). obs"

definition
  envVal :: "EnvState \<Rightarrow> Proposition \<Rightarrow> bool"
where
  "envVal \<equiv> \<lambda>(pos, obs, halted) p.
     case p of Halted \<Rightarrow> halted
             | InGoal \<Rightarrow> 2 \<le> pos \<and> pos \<le> (4 :: 5 sat)"

(* The KBP, clearly subjective. *)

definition
  kbp :: "(Agent, Proposition, RobotAct) KBP"
where
  "kbp \<equiv> [ \<lparr> guard = \<^bold>K\<^sub>Robot (Kprop InGoal),        action = Halt \<rparr>,
           \<lparr> guard = Knot (\<^bold>K\<^sub>Robot (Kprop InGoal)), action = NOP \<rparr> ]"

(*<*)

lemma Agent_univ: "(UNIV :: Agent set) = {Robot}"
  unfolding UNIV_def
  apply auto
  apply (case_tac x)
  apply auto
  done

instance Agent :: finite
  apply intro_classes
  apply (auto iff: Agent_univ)
  done

instantiation Agent :: linorder
begin

definition
  less_Agent_def: "(x::Agent) < y \<equiv> False"

definition
  less_eq_Agent_def: "(x::Agent) \<le> y \<equiv> x = y"

instance
  apply intro_classes
  unfolding less_Agent_def less_eq_Agent_def
  apply simp_all
  apply (case_tac x)
  apply (case_tac y)
  apply simp
  done
end

(*>*)

subsubsection{* Locale instantiations *}

interpretation Robot!:
  Environment "\<lambda>_. kbp" envInit envAction envTrans envVal "\<lambda>_. envObs"
  apply unfold_locales
  apply (auto simp: kbp_def)
  apply ((case_tac a, simp)+)
  done

subsubsection{* The Clock view implementation *}

interpretation Robot_Clock!:
  FiniteLinorderEnvironment "\<lambda>_. kbp" envInit envAction envTrans envVal "\<lambda>_. envObs" "fromList [Robot]"
  apply unfold_locales
  apply (simp add: Agent_univ)
  done

abbreviation "Agents \<equiv> ODList.fromList [Robot]"

definition
  robot_ClockDFS :: "((EnvState, RobotAct list) clock_acts_trie, (EnvState, digit) clock_trans_trie) AlgState"
where
  "robot_ClockDFS \<equiv> ClockAutoDFS Agents (\<lambda>_. kbp) envInit envAction envTrans envVal (\<lambda>_. envObs) Robot"

definition
  robot_ClockAlg :: "Agent \<Rightarrow> (digit, RobotAct, EnvState odlist \<times> EnvState odlist) Protocol"
where
  "robot_ClockAlg \<equiv> mkClockAuto Agents (\<lambda>_. kbp) envInit envAction envTrans envVal (\<lambda>_. envObs)"

lemma (in FiniteLinorderEnvironment)
  "Robot.Clock.implements robot_ClockAlg"
  unfolding robot_ClockAlg_def by (rule Robot_Clock.mkClockAuto_implements)

subsubsection{* The SPR view implementation *}

interpretation Robot_SPR!:
  FiniteSingleAgentEnvironment "\<lambda>_. kbp" envInit envAction envTrans envVal "\<lambda>_. envObs" "Robot"
  apply unfold_locales
  apply (case_tac a, simp)
  done

definition
  robot_SPRSingleDFS :: "(RobotAct, digit, EnvState) SPRSingleAutoDFS"
where
  "robot_SPRSingleDFS \<equiv> SPRSingleAutoDFS kbp envInit envAction envTrans envVal (\<lambda>_. envObs) Robot"

definition
  robot_SPRSingleAlg :: "Agent \<Rightarrow> (digit, RobotAct, EnvState odlist) Protocol"
where
  "robot_SPRSingleAlg \<equiv> mkSPRSingleAuto kbp envInit envAction envTrans envVal (\<lambda>_. envObs)"

lemma (in FiniteSingleAgentEnvironment)
  "Robot.Robot.SPR.implements robot_SPRSingleAlg"
  unfolding robot_SPRSingleAlg_def by (rule Robot.Robot_SPR.mkSPRSingleAuto_implements)

end
(*>*)


theory Master_Assn
  imports Cell Fold_Assn
begin

definition master_assn :: "('a cell ref * 'a::heap cell') list \<Rightarrow> assn" where
  "master_assn t = fold_assn (map (\<lambda>(p, c'). \<exists>\<^sub>A c. p \<mapsto>\<^sub>r c * cell_assn c' c) t)"

lemma open_master_assn_cons:
    "master_assn ((p, c') # t) = (\<exists>\<^sub>A c. p \<mapsto>\<^sub>r c * cell_assn c' c) * master_assn t"
  unfolding master_assn_def
  by auto

lemma open_master_assn':
  assumes "(p, c') \<in>\<^sub>L t"
  shows "master_assn t = (\<exists>\<^sub>A c. p \<mapsto>\<^sub>r c * cell_assn c' c) * master_assn (remove1 (p, c') t)"
proof-
  from assms have
    "(\<exists>\<^sub>A c. p \<mapsto>\<^sub>r c * cell_assn c' c) \<in>\<^sub>L (map (\<lambda>(p, c'). \<exists>\<^sub>Ac. p \<mapsto>\<^sub>r c * cell_assn c' c) t)"
    by auto

  with assms show ?thesis
    unfolding master_assn_def
    using
        fold_assn_remove1
        fold_assn_remove1_map[of "(p, c')" t "(\<lambda>(p, c'). \<exists>\<^sub>Ac. p \<mapsto>\<^sub>r c * cell_assn c' c)"]
    by auto
qed

lemma open_master_assn:
  assumes "(p, c') \<in>\<^sub>L t"
  shows "master_assn t \<Longrightarrow>\<^sub>A (\<exists>\<^sub>A c. p \<mapsto>\<^sub>r c * cell_assn c' c) * master_assn (remove1 (p, c') t)"
  using assms open_master_assn' by fastforce

lemma close_master_assn_array: "(a, Array' xs) \<in>\<^sub>L t
  \<Longrightarrow> a' \<mapsto>\<^sub>a xs * a \<mapsto>\<^sub>r cell.Array a' * master_assn (remove1 (a, Array' xs) t) \<Longrightarrow>\<^sub>A master_assn t"
  using open_master_assn'[of a "Array' xs" t]
  by sep_auto

lemma close_master_assn_upd: "(a, Upd' i x a') \<in>\<^sub>L t
     \<Longrightarrow> a \<mapsto>\<^sub>r Upd i x a' * master_assn (remove1 (a, Upd' i x a') t) \<Longrightarrow>\<^sub>A master_assn t"
  using open_master_assn'[of a "Upd' i x a'" t]
  by sep_auto

lemma close_master_assn_upd': "(a, Upd' i x a') \<in>\<^sub>L t
     \<Longrightarrow> a \<mapsto>\<^sub>r Upd i x a' * master_assn (remove1 (a, Upd' i x a') t) = master_assn t"
  using open_master_assn'[of a "Upd' i x a'" t]
  by(auto simp: ent_iffI entails_def)

lemma master_assn_distinct: "h \<Turnstile> master_assn t \<Longrightarrow> distinct (map fst t)"
  apply(rule ccontr)
  using not_distinct_decomp[of "map fst t"]
  by(auto simp: map_eq_append_conv master_assn_def)

lemma master_assn_distinct': "master_assn t \<Longrightarrow>\<^sub>A master_assn t * \<up>(distinct (map fst t))"
  by(sep_auto simp: master_assn_distinct)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_ref
imports CSP_T_law_basic
begin

(*****************************************************************

         1. rules for refinement

 *****************************************************************)

(*-------------------------------------------------------*
 |            refinement and equality                    |
 *-------------------------------------------------------*)

lemma cspT_ref_eq_iff: "(P <=T[M,M] Q) = (P =T[M,M] Q |~| P)"
apply (simp add: cspT_semantics)
apply (rule)

(* <= *)
 apply (rule order_antisym)
 apply (simp add: subdomT_iff)
 apply (simp add: in_traces)
 apply (simp add: subdomT_iff)
 apply (simp add: in_traces)

(* => *)
 apply (erule order_antisymE)
 apply (rule)
 apply (rotate_tac 1)
 apply (erule subdomTE_ALL)
 apply (drule_tac x="t" in spec)
 apply (simp add: in_traces)
done

(*-------------------------------------------------------*
 |             simp STOP [+]                             |
 *-------------------------------------------------------*)

lemma cspT_Ent_choice_left1_ref:"P [+] Q <=T[M,M] P"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
done

lemma cspT_Ent_choice_left2_ref:"P [+] Q <=T[M,M] Q"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
done

lemmas cspT_Ent_choice_left_ref =
       cspT_Ent_choice_left1_ref
       cspT_Ent_choice_left2_ref

(*-------------------------------------------------------*
 |              decompose Internal choice                |
 *-------------------------------------------------------*)

(*** or <= ***)                                         (* unsafe *)

lemma cspT_Int_choice_left1:
  "P1 <=T[M1,M2] Q ==> P1 |~| P2 <=T[M1,M2] Q"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

lemma cspT_Int_choice_left2:
  "P2 <=T[M1,M2] Q ==> P1 |~| P2 <=T[M1,M2] Q"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
by (simp add: cspT_Int_choice_left1)

(*** <= and ***)                                          (* safe *)

lemma cspT_Int_choice_right:
  "[| P <=T[M1,M2] Q1 ; P <=T[M1,M2] Q2 |]
      ==> P <=T[M1,M2] Q1 |~| Q2"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

(*-------------------------------------------------------*
 |        decompose Replicated internal choice           |
 *-------------------------------------------------------*)

(*** EX <= ***)                                           (* unsafe *)

lemma cspT_Rep_int_choice_sum_left:
  "(EX c. c:sumset C & Pf c <=T[M1,M2] Q)
      ==> !! :C .. Pf <=T[M1,M2] Q"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

lemma cspT_Rep_int_choice_sum_left_x:
  "[| c: sumset C ; Pf c <=T[M1,M2] Q |]
  ==> !! :C .. Pf <=T[M1,M2] Q"
by (rule cspT_Rep_int_choice_sum_left, fast)

lemma cspT_Rep_int_choice_nat_left:
  "(EX n. n:N & Pf n <=T[M1,M2] Q)
      ==> !nat :N .. Pf <=T[M1,M2] Q"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_left, force)

lemma cspT_Rep_int_choice_nat_left_x:
  "[| n:N ; Pf n <=T[M1,M2] Q |]
  ==> !nat :N .. Pf <=T[M1,M2] Q"
by (rule cspT_Rep_int_choice_nat_left, fast)

lemma cspT_Rep_int_choice_set_left:
  "(EX X. X:Xs & Pf X <=T[M1,M2] Q)
      ==> !set :Xs .. Pf <=T[M1,M2] Q"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_left, force)

lemma cspT_Rep_int_choice_set_left_x:
  "[| X:Xs ; Pf X <=T[M1,M2] Q |]
  ==> !set :Xs .. Pf <=T[M1,M2] Q"
by (rule cspT_Rep_int_choice_set_left, fast)

lemma cspT_Rep_int_choice_com_left:
  "(EX a. a:X & Pf a <=T[M1,M2] Q)
      ==> ! :X .. Pf <=T[M1,M2] Q"
apply (simp add: Rep_int_choice_com_def)
by (rule cspT_Rep_int_choice_set_left, force)

lemma cspT_Rep_int_choice_com_left_x:
  "[| a:X ; Pf a <=T[M1,M2] Q |]
  ==> ! :X .. Pf <=T[M1,M2] Q"
by (rule cspT_Rep_int_choice_com_left, fast)

lemma cspT_Rep_int_choice_f_left:
  "[| inj f ; (EX a. a:X & Pf a <=T[M1,M2] Q) |]
      ==> !<f> :X .. Pf <=T[M1,M2] Q"
apply (simp add: Rep_int_choice_f_def)
by (rule cspT_Rep_int_choice_com_left, force)

lemma cspT_Rep_int_choice_f_left_x:
  "[| inj f ; a:X ; Pf a <=T[M1,M2] Q |]
  ==> !<f> :X .. Pf <=T[M1,M2] Q"
by (rule cspT_Rep_int_choice_f_left, simp, fast)

lemmas cspT_Rep_int_choice_left = cspT_Rep_int_choice_sum_left
                                  cspT_Rep_int_choice_nat_left
                                  cspT_Rep_int_choice_set_left
                                  cspT_Rep_int_choice_com_left
                                  cspT_Rep_int_choice_f_left

lemmas cspT_Rep_int_choice_left_x = cspT_Rep_int_choice_sum_left_x
                                  cspT_Rep_int_choice_nat_left_x
                                  cspT_Rep_int_choice_set_left_x
                                  cspT_Rep_int_choice_com_left_x
                                  cspT_Rep_int_choice_f_left_x

(*** <= ALL ***)                                         (* safe *)

lemma cspT_Rep_int_choice_sum_right:
  "[| !!c. c:sumset C ==> P <=T[M1,M2] Qf c |]
               ==> P <=T[M1,M2] !! :C .. Qf"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

lemma cspT_Rep_int_choice_nat_right:
  "[| !!n. n:N ==> P <=T[M1,M2] Qf n |]
               ==> P <=T[M1,M2] !nat :N .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_right, force)

lemma cspT_Rep_int_choice_set_right:
  "[| !!X. X:Xs ==> P <=T[M1,M2] Qf X |]
               ==> P <=T[M1,M2] !set :Xs .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_right, force)

lemma cspT_Rep_int_choice_com_right:
  "[| !!a. a:X ==> P <=T[M1,M2] Qf a |]
               ==> P <=T[M1,M2] ! :X .. Qf"
apply (simp add: Rep_int_choice_com_def)
by (rule cspT_Rep_int_choice_set_right, force)

lemma cspT_Rep_int_choice_f_right:
  "[| inj f ; !!a. a:X ==> P <=T[M1,M2] Qf a |]
               ==> P <=T[M1,M2] !<f> :X .. Qf"
apply (simp add: Rep_int_choice_f_def)
by (rule cspT_Rep_int_choice_com_right, force)

lemmas cspT_Rep_int_choice_right
     = cspT_Rep_int_choice_sum_right
       cspT_Rep_int_choice_nat_right
       cspT_Rep_int_choice_set_right
       cspT_Rep_int_choice_com_right
       cspT_Rep_int_choice_f_right

(* 1,2,3,f E *)

lemma cspT_Rep_int_choice_sum_rightE:
  "[| P <=T[M1,M2] !! :C .. Qf ;
      ALL c:sumset C. P <=T[M1,M2] Qf c ==> R
   |] ==> R"
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (simp add: in_traces)
apply (force)
done

lemma cspT_Rep_int_choice_nat_rightE:
  "[| P <=T[M1,M2] !nat :N .. Qf ;
      ALL n:N. P <=T[M1,M2] Qf n ==> R
   |] ==> R"
apply (simp add: Rep_int_choice_ss_def)
by (erule cspT_Rep_int_choice_sum_rightE, force)

lemma cspT_Rep_int_choice_set_rightE:
  "[| P <=T[M1,M2] !set :Xs .. Qf ;
      ALL X:Xs. P <=T[M1,M2] Qf X ==> R
   |] ==> R"
apply (simp add: Rep_int_choice_ss_def)
by (erule cspT_Rep_int_choice_sum_rightE, force)

lemma cspT_Rep_int_choice_com_rightE:
  "[| P <=T[M1,M2] ! :X .. Qf ;
      ALL a:X. P <=T[M1,M2] Qf a ==> R
   |] ==> R"
apply (simp add: Rep_int_choice_com_def)
by (erule cspT_Rep_int_choice_set_rightE, force)

lemma cspT_Rep_int_choice_f_rightE:
  "[| P <=T[M1,M2] !<f> :X .. Qf ; inj f ;
      [| ALL a:X. P <=T[M1,M2] Qf a |] ==> R
   |] ==> R"
apply (simp add: Rep_int_choice_f_def)
by (erule cspT_Rep_int_choice_com_rightE, force)

lemmas cspT_Rep_int_choice_rightE =
       cspT_Rep_int_choice_sum_rightE
       cspT_Rep_int_choice_nat_rightE
       cspT_Rep_int_choice_set_rightE
       cspT_Rep_int_choice_com_rightE
       cspT_Rep_int_choice_f_rightE

(*-------------------------------------------------------*
 |             decomposition with subset                 |
 *-------------------------------------------------------*)

(*** Rep_int_choice ***)                                        (* unsafe *)

lemma cspT_Rep_int_choice_sum_subset:
  "[| sumset C2 <= sumset C1  ; !!c. c:sumset C2 ==> Pf c <=T[M1,M2] Qf c |]
                    ==> !! :C1 .. Pf <=T[M1,M2] !! :C2 .. Qf"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

lemma cspT_Rep_int_choice_nat_subset:
  "[| N2 <= N1  ; !!n. n:N2 ==> Pf n <=T[M1,M2] Qf n |]
                    ==> !nat :N1 .. Pf <=T[M1,M2] !nat :N2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_subset, auto)

lemma cspT_Rep_int_choice_set_subset:
  "[| Ys <= Xs  ; !!X. X:Ys ==> Pf X <=T[M1,M2] Qf X |]
                    ==> !set :Xs .. Pf <=T[M1,M2] !set :Ys .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspT_Rep_int_choice_sum_subset, auto)

lemma cspT_Rep_int_choice_com_subset:
  "[| Y <= X  ; !!a. a:Y ==> Pf a <=T[M1,M2] Qf a |]
                    ==> ! :X .. Pf <=T[M1,M2] ! :Y .. Qf"
apply (simp add: Rep_int_choice_com_def)
by (rule cspT_Rep_int_choice_set_subset, auto)

lemma cspT_Rep_int_choice_f_subset:
  "[| inj f ; Y <= X  ; !!a. a:Y ==> Pf a <=T[M1,M2] Qf a |]
                    ==> !<f> :X .. Pf <=T[M1,M2] !<f> :Y .. Qf"
apply (simp add: Rep_int_choice_f_def)
by (rule cspT_Rep_int_choice_com_subset, auto)

lemmas cspT_Rep_int_choice_subset
     = cspT_Rep_int_choice_sum_subset
       cspT_Rep_int_choice_nat_subset
       cspT_Rep_int_choice_set_subset
       cspT_Rep_int_choice_com_subset
       cspT_Rep_int_choice_f_subset

(*** ! x:X .. and ? -> ***)

lemma cspT_Int_Ext_pre_choice_subset:
  "[| Y ~={} ; Y <= X ; !!a. a:Y ==> Pf a <=T[M1,M2] Qf a |]
        ==> ! x:X .. (x -> Pf x) <=T[M1,M2]
            ? :Y -> Qf"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

lemmas cspT_decompo_subset = cspT_Rep_int_choice_subset
                             cspT_Int_Ext_pre_choice_subset

(*-------------------------------------------------------*
 |               decompose external choice               |
 *-------------------------------------------------------*)

lemma cspT_Ext_choice_right:
  "[| P <=T[M1,M2] Q1 ;
      P <=T[M1,M2] Q2 |]
      ==> P <=T[M1,M2] Q1 [+] Q2"
apply (simp add: cspT_semantics)
apply (rule, simp add: in_traces)
apply (force)
done

end


(*  File:       Sequential_Majority_Comparison.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Sequential Majority Comparison\<close>

theory Sequential_Majority_Comparison
  imports "Compositional_Structures/Basic_Modules/Plurality_Module"
          "Compositional_Structures/Drop_And_Pass_Compatibility"
          "Compositional_Structures/Revision_Composition"
          "Compositional_Structures/Maximum_Parallel_Composition"
          "Compositional_Structures/Defer_One_Loop_Composition"
begin

text \<open>
  Sequential majority comparison compares two alternatives by plurality voting.
  The loser gets rejected, and the winner is compared to the next alternative.
  This process is repeated until only a single alternative is left, which is
  then elected.
\<close>

subsection \<open>Definition\<close>

fun smc :: "'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "smc x A p =
      ((((((pass_module 2 x) \<triangleright> ((plurality\<down>) \<triangleright> (pass_module 1 x))) \<parallel>\<^sub>\<up>
      (drop_module 2 x)) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) \<triangleright> elect_module) A p)"

subsection \<open>Soundness\<close>

text \<open>
  As all base components are electoral modules (, aggregators, or termination
  conditions), and all used compositional structures create electoral modules,
  sequential majority comparison unsurprisingly is an electoral module.
\<close>

theorem smc_sound:
  assumes order: "linear_order x"
  shows "electoral_module (smc x)"
proof (unfold electoral_module_def, simp, safe, simp_all)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa: "xa \<in> reject (?smc) A p" and
    elect_xa: "xa \<in> elect (?smc) A p"
  show False
    using IntI drop_mod_sound elect_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa: "xa \<in> reject (?smc) A p" and
    defer_xa: "xa \<in> defer (?smc) A p"
  show False
    using IntI drop_mod_sound defer_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    elect_xa:
      "xa \<in> elect (?smc) A p"
  show "xa \<in> A"
    using drop_mod_sound elect_in_alts elect_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    defer_xa: "xa \<in> defer (?smc) A p"
  show "xa \<in> A"
    using drop_mod_sound defer_in_alts defer_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    reject_xa:
      "xa \<in> reject (?smc) A p"
  have plurality_rev_sound:
    "electoral_module
      (plurality::'a set \<Rightarrow> (_ \<times> _) set list \<Rightarrow> _ set \<times> _ set \<times> _ set\<down>)"
    by simp
  have par1_sound:
    "electoral_module (pass_module 2 x \<triangleright> ((plurality\<down>) \<triangleright> pass_module 1 x))"
    using order
    by simp
  also have par2_sound:
      "electoral_module (drop_module 2 x)"
    using order
    by simp
  show "xa \<in> A"
    using reject_in_alts reject_xa fin_A in_mono
          loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound prof_A
          seq_comp_sound pass_mod_sound par1_sound
          par2_sound plurality_rev_sound
    by (metis (no_types))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    xa_in_A: "xa \<in> A" and
    not_defer_xa:
      "xa \<notin> defer (?smc) A p" and
    not_reject_xa:
      "xa \<notin> reject (?smc) A p"
  show "xa \<in> elect (?smc) A p"
    using drop_mod_sound loop_comp_sound max_agg_sound
          order par_comp_sound pass_mod_sound xa_in_A
          plurality_sound rev_comp_sound seq_comp_sound
          electoral_mod_defer_elem fin_A not_defer_xa
          not_reject_xa prof_A
    by metis
qed

subsection \<open>Electing\<close>

text \<open>
  The sequential majority comparison electoral module is electing.
  This property is needed to convert electoral modules to a social choice
  function. Apart from the very last proof step, it is a part of the
  monotonicity proof below.
\<close>

theorem smc_electing:
  assumes "linear_order x"
  shows "electing (smc x)"
proof -
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00011: "non_electing (plurality\<down>)"
    by simp
  have 00012: "non_electing ?tie_breaker"
    using assms
    by simp
  have 00013: "defers 1 ?tie_breaker"
    using assms pass_one_mod_def_one
    by simp
  have 20000: "non_blocking (plurality\<down>)"
    by simp

  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using assms
    by simp (* disj_compat_comm *)
  have 1000: "non_electing ?pass2"
    using assms
    by simp
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp
  have 2000: "non_blocking ?pass2"
    using assms
    by simp
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using assms 0020
    by simp
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp
  have 101: "non_electing ?drop2"
    using assms
    by simp
  have 102: "agg_conservative max_aggregator"
    by simp
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using assms
    by simp

  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by metis

  have 2: "defers 1 ?loop"
    using 10 20
    by simp
  have 3: "electing elect_module"
    by simp

  show ?thesis
    using 2 3 assms seq_comp_electing smc_sound
    unfolding Defer_One_Loop_Composition.iter.simps
              smc.simps electing_def
    by metis
qed

subsection \<open>(Weak) Monotonicity Property\<close>

text \<open>
  The following proof is a fully modular proof for weak monotonicity of
  sequential majority comparison. It is composed of many small steps.
\<close>

theorem smc_monotone:
  assumes "linear_order x"
  shows "monotonicity (smc x)"
proof -
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00010: "defer_invariant_monotonicity (plurality\<down>)"
    by simp (* rev_comp_def_inv_mono plurality_strict_strong_mono *)
  have 00011: "non_electing (plurality\<down>)"
    by simp (* rev_comp_non_electing plurality_sound *)
  have 00012: "non_electing ?tie_breaker"
    using assms
    by simp (* pass_mod_non_electing *)
  have 00013: "defers 1 ?tie_breaker"
    using assms pass_one_mod_def_one
    by simp
  have 00014: "defer_monotonicity ?tie_breaker"
    using assms
    by simp (* dl_inv_imp_def_mono pass_mod_dl_inv *)
  have 20000: "non_blocking (plurality\<down>)"
    by simp (* rev_comp_non_blocking plurality_electing *)

  have 0000: "defer_lift_invariance ?pass2"
    using assms
    by simp (* pass_mod_dl_inv *)
  have 0001: "defer_lift_invariance ?plurality_defer"
    using 00010 00011 00012 00013 00014
    by simp (* def_inv_mono_imp_def_lift_inv *)
  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using assms
    by simp (* disj_compat_comm drop_pass_disj_compat *)
  have 1000: "non_electing ?pass2"
    using assms
    by simp (* pass_mod_non_electing *)
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp (* seq_comp_presv_non_electing *)
  have 2000: "non_blocking ?pass2"
    using assms
    by simp (* pass_mod_non_blocking *)
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 000: "defer_lift_invariance ?compare_two"
    using 0000 0001
    by simp (* seq_comp_presv_def_lift_inv *)
  have 001: "defer_lift_invariance ?drop2"
    using assms
    by simp (* drop_mod_def_lift_inv *)
  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using assms 0020
    by simp
      (* disj_compat_seq seq_comp_sound rev_comp_sound
         plurality_sound pass_mod_sound *)
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp (* seq_comp_presv_non_electing *)
  have 101: "non_electing ?drop2"
    using assms
    by simp (* drop_mod_non_electing *)
  have 102: "agg_conservative max_aggregator"
    by simp (* max_agg_conserv *)
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using assms
    by simp (* drop_two_mod_rej_two *)

  have 00: "defer_lift_invariance ?eliminator"
    using 000 001 002 par_comp_def_lift_inv
    by simp (* par_comp_def_lift_inv *)
  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp (* conserv_agg_presv_non_electing *)
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by simp

  have 0: "defer_lift_invariance ?loop"
    using 00
    by simp (* loop_comp_presv_def_lift_inv *)
  have 1: "non_electing ?loop"
    using 10
    by simp (* loop_comp_presv_non_electing *)
  have 2: "defers 1 ?loop"
    using 10 20
    by simp (* iter_elim_def_n *)
  have 3: "electing elect_module"
    by simp (* elect_mod_electing *)

  show ?thesis
    using 0 1 2 3 assms seq_comp_mono
    unfolding Electoral_Module.monotonicity_def
              Defer_One_Loop_Composition.iter.simps
              smc_sound smc.simps
    by (metis (full_types))
qed

end


section \<open>Nonempty Sets Strictly Bounded by an Infinite Cardinal\<close>

theory Nonempty_Bounded_Set
imports
  "HOL-Cardinals.Bounded_Set"
begin

typedef ('a, 'k) nebset ("_ set![_]" [22, 21] 21) =
  "{A :: 'a set. A \<noteq> {} \<and> |A| <o natLeq +c |UNIV :: 'k set|}"
  morphisms set_nebset Abs_nebset
  apply (rule exI[of _ "{undefined}"], simp)
  apply (rule Cfinite_ordLess_Cinfinite)
  apply (auto simp: cfinite_def cinfinite_csum natLeq_cinfinite Card_order_csum)
  done

setup_lifting type_definition_nebset

lift_definition map_nebset ::
  "('a \<Rightarrow> 'b) \<Rightarrow> 'a set!['k] \<Rightarrow> 'b set!['k]" is image
  using card_of_image ordLeq_ordLess_trans by blast

lift_definition rel_nebset ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a set!['k] \<Rightarrow> 'b set!['k] \<Rightarrow> bool" is rel_set .

lift_definition nebinsert :: "'a \<Rightarrow> 'a set!['k] \<Rightarrow> 'a set!['k]" is "insert"
  using infinite_card_of_insert ordIso_ordLess_trans Field_card_of Field_natLeq UNIV_Plus_UNIV
   csum_def finite_Plus_UNIV_iff finite_insert finite_ordLess_infinite2 infinite_UNIV_nat
   insert_not_empty by metis

lift_definition nebsingleton :: "'a \<Rightarrow> 'a set!['k]" is "\<lambda>a. {a}"
  apply simp
  apply (rule Cfinite_ordLess_Cinfinite)
  apply (auto simp: cfinite_def cinfinite_csum natLeq_cinfinite Card_order_csum)
  done

lemma set_nebset_to_set_nebset: "A \<noteq> {} \<Longrightarrow> |A| <o natLeq +c |UNIV :: 'k set| \<Longrightarrow>
  set_nebset (the_inv set_nebset A :: 'a set!['k]) = A"
  apply (rule f_the_inv_into_f[unfolded inj_on_def])
  apply (simp add: set_nebset_inject range_eqI Abs_nebset_inverse[symmetric])
  apply (rule range_eqI Abs_nebset_inverse[symmetric] CollectI)+
  apply blast
  done

lemma rel_nebset_aux_infinite:
  fixes a :: "'a set!['k]" and b :: "'b set!['k]"
  shows "(\<forall>t \<in> set_nebset a. \<exists>u \<in> set_nebset b. R t u) \<and> (\<forall>u \<in> set_nebset b. \<exists>t \<in> set_nebset a. R t u) \<longleftrightarrow>
   ((BNF_Def.Grp {a. set_nebset a \<subseteq> {(a, b). R a b}} (map_nebset fst))\<inverse>\<inverse> OO
    BNF_Def.Grp {a. set_nebset a \<subseteq> {(a, b). R a b}} (map_nebset snd)) a b" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  define R' :: "('a \<times> 'b) set!['k]"
    where "R' = the_inv set_nebset (Collect (case_prod R) \<inter> (set_nebset a \<times> set_nebset b))"
    (is "_ = the_inv set_nebset ?L'")
  from \<open>?L\<close> have "?L' \<noteq> {}" by transfer auto
  moreover
  have "|?L'| <o natLeq +c |UNIV :: 'k set|"
    unfolding csum_def Field_natLeq
    by (intro ordLeq_ordLess_trans[OF card_of_mono1[OF Int_lower2]]
      card_of_Times_ordLess_infinite)
      (simp, (transfer, simp add: csum_def Field_natLeq)+)
  ultimately have *: "set_nebset R' = ?L'" unfolding R'_def by (intro set_nebset_to_set_nebset)
  show ?R unfolding Grp_def relcompp.simps conversep.simps
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * show "a = map_nebset fst R'" using conjunct1[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
    from * show "b = map_nebset snd R'" using conjunct2[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
  qed (auto simp add: *)
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
    by transfer force
qed

bnf "'a set!['k]"
  map: map_nebset
  sets: set_nebset
  bd: "natLeq +c |UNIV :: 'k set|"
  rel: rel_nebset
proof -
  show "map_nebset id = id" by (rule ext, transfer) simp
next
  fix f g
  show "map_nebset (f o g) = map_nebset f o map_nebset g" by (rule ext, transfer) auto
next
  fix X f g
  assume "\<And>z. z \<in> set_nebset X \<Longrightarrow> f z = g z"
  then show "map_nebset f X = map_nebset g X" by transfer force
next
  fix f
  show "set_nebset \<circ> map_nebset f = (`) f \<circ> set_nebset" by (rule ext, transfer) auto
next
  fix X :: "'a set!['k]"
  show "|set_nebset X| \<le>o natLeq +c |UNIV :: 'k set|"
    by transfer (blast dest: ordLess_imp_ordLeq)
next
  fix R S
  show "rel_nebset R OO rel_nebset S \<le> rel_nebset (R OO S)"
    by (rule predicate2I, transfer) (auto simp: rel_set_OO[symmetric])
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "rel_nebset R = ((\<lambda>x y. \<exists>z. set_nebset z \<subseteq> {(x, y). R x y} \<and>
    map_nebset fst z = x \<and> map_nebset snd z = y) :: 'a set!['k] \<Rightarrow> 'b set!['k] \<Rightarrow> bool)"
    by (simp add: rel_nebset_def map_fun_def o_def rel_set_def
      rel_nebset_aux_infinite[unfolded OO_Grp_alt])
qed (simp_all add: card_order_csum natLeq_card_order cinfinite_csum natLeq_cinfinite)

lemma map_nebset_nebinsert[simp]: "map_nebset f (nebinsert x X) = nebinsert (f x) (map_nebset f X)"
  by transfer auto

lemma map_nebset_nebsingleton: "map_nebset f (nebsingleton x) = nebsingleton (f x)"
  by transfer auto

lemma nebsingleton_inj[simp]: "nebsingleton x = nebsingleton y \<longleftrightarrow> x = y"
  by transfer auto

lemma rel_nebsingleton[simp]:
  "rel_nebset R (nebsingleton x1) (nebsingleton x2) = R x1 x2"
  by transfer (auto simp: rel_set_def)

lemma rel_nebset_nebsingleton[simp]:
  "rel_nebset R (nebsingleton x1) X = (\<forall>x2\<in>set_nebset X. R x1 x2)"
  "rel_nebset R X (nebsingleton x2) = (\<forall>x1\<in>set_nebset X. R x1 x2)"
  by (transfer, force simp add: rel_set_def)+

lemma rel_nebset_False[simp]: "rel_nebset (\<lambda>x y. False) x y = False"
  by transfer (auto simp: rel_set_def)

lemmas set_nebset_nebsingleton[simp] = nebsingleton.rep_eq

lemma nebinsert_absorb[simp]: "nebinsert a (nebinsert a x) = nebinsert a x"
  by transfer simp

lift_definition bset_of_nebset :: "'a set!['k] \<Rightarrow> 'a set['k]" is "\<lambda>X. X" by (rule conjunct2)

lemma rel_bset_bset_of_nebset[simp]:
  "rel_bset R (bset_of_nebset X) (bset_of_nebset Y) = rel_nebset R X Y"
  by transfer (rule refl)

lemma rel_nebset_conj[simp]:
  "rel_nebset (\<lambda>x y. P \<and> Q x y) x y \<longleftrightarrow> P \<and> rel_nebset Q x y"
  "rel_nebset (\<lambda>x y. Q x y \<and> P) x y \<longleftrightarrow> P \<and> rel_nebset Q x y"
  by (transfer, auto simp: rel_set_def)+

lemma set_bset_empty[simp]: "set_bset X = {} \<longleftrightarrow> X = bempty"
  by transfer simp

(* FIXME for ONDRA*)
(*
declare nebset.rel_eq[relator_eq]
declare nebset.rel_mono[relator_mono]
declare nebset.rel_compp[symmetric, relator_distr]
declare nebset.rel_transfer[transfer_rule]

lemma nebset_quot_map[quot_map]: "Quotient R Abs Rep T \<Longrightarrow>
  Quotient (rel_nebset R) (map_nebset Abs) (map_nebset Rep) (rel_nebset T)"
  unfolding Quotient_alt_def5 nebset.rel_Grp[of UNIV, simplified, symmetric]
    nebset.rel_conversep[symmetric] nebset.rel_compp[symmetric]
    by (auto elim: nebset.rel_mono_strong)

lemma set_relator_eq_onp [relator_eq_onp]:
  "rel_nebset (eq_onp P) = eq_onp (\<lambda>A. Ball (set_nebset A) P)"
  unfolding fun_eq_iff eq_onp_def by transfer (auto simp: rel_set_def)
*)

end


(* Author: Fabian Immler, Alexander Maletzky *)

theory Code_Target_Rat
  imports Complex_Main "HOL-Library.Code_Target_Numeral"
begin

text \<open>Mapping type @{typ rat} to type "Rat.rat" in Isabelle/ML. Serialization for other target
  languages will be provided in the future.\<close>

(* For testing only. *)
(*
primrec logistic' :: "rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> rat" where "logistic' r x 0 = x"
  | "logistic' r x (Suc n) = logistic' r (r * x * (rat_of_int 1 - x)) n"
definition "logistic n = logistic' (3.6) (0.5) (nat_of_integer n)"
ML \<open>val logistic_int = @{code logistic}\<close>
ML \<open>
fun logistic' r x n = (if n = 0 then x else logistic' r (r * x * (Rat.of_int 1 - x)) (n - 1))
fun logistic_ml n = logistic' (Rat.make (36, 10)) (Rat.make (5, 10)) n
\<close>
*)

context includes integer.lifting begin

lift_definition rat_of_integer :: "integer \<Rightarrow> rat" is Rat.of_int .

lift_definition quotient_of' :: "rat \<Rightarrow> integer \<times> integer" is quotient_of .

lemma [code_unfold]: "quotient_of = (\<lambda>x. map_prod int_of_integer int_of_integer (quotient_of' x))"
  by transfer simp

end

code_printing
  type_constructor rat \<rightharpoonup>
    (SML) "Rat.rat" |
  constant "plus :: rat \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.add" |
  constant "minus :: rat \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.add ((_)) (Rat.neg ((_)))" |
  constant "times :: rat \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.mult" |
  constant "inverse :: rat \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.inv" |
  constant "divide :: rat \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.mult ((_)) (Rat.inv ((_)))" |
  constant "rat_of_integer :: integer \<Rightarrow> rat" \<rightharpoonup>
    (SML) "Rat.of'_int" |
  constant "abs :: rat \<Rightarrow> _" \<rightharpoonup>
    (SML) "Rat.abs" |
  constant "0 :: rat" \<rightharpoonup>
    (SML) "!(Rat.make (0, 1))" |
  constant "1 :: rat" \<rightharpoonup>
    (SML) "!(Rat.make (1, 1))" |
  constant "uminus :: rat \<Rightarrow> rat" \<rightharpoonup>
    (SML) "Rat.neg" |
  constant "HOL.equal :: rat \<Rightarrow> _" \<rightharpoonup>
    (SML) "!((_ : Rat.rat) = _)" |
  constant "quotient_of'" \<rightharpoonup>
    (SML) "Rat.dest"

(* For testing only. *)
(*
ML \<open>val logistic_rat = @{code logistic}\<close>
ML \<open>timeap (fn n => let val r = logistic_int n in r end) 16\<close> (* 2.534s cpu time *)
ML \<open>timeap (fn n => let val r = logistic_ml n in r end) 16\<close> (* 0.021s cpu time *)
ML \<open>timeap (fn n => let val r = logistic_rat n in r end) 16\<close> (* 0.021s cpu time *)
*)

end (* theory *)


header {* Proper Iterators *}
theory Proper_Iterator
imports
  "SetIteratorOperations"
  "../../Automatic_Refinement/Lib/Refine_Lib"
begin
  text {*
    Proper iterators provide a way to obtain polymorphic iterators even
    inside locale contexts.

    For this purpose, an iterator that converts the set to a list is fixed
    inside the locale, and polymorphic iterators are described by folding
    over the generated list.

    In order to ensure efficiency, it is shown that folding over the generated
    list is equivalent to directly iterating over the set, and this equivalence
    is set up as a code preprocessing rule.
    *}

  subsection {* Proper Iterators *}

  text {* A proper iterator can be expressed as a fold over a list, where
    the list does only depend on the set. In particular, it does not depend
    on the type of the state. We express this by the following definition,
    using two iterators with different types: *}

  definition proper_it
    :: "('x,'\<sigma>1) set_iterator \<Rightarrow> ('x,'\<sigma>2) set_iterator \<Rightarrow> bool"
    where "proper_it it it' \<equiv> (\<exists>l. it=foldli l \<and> it'=foldli l)"

  lemma proper_itI[intro?]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "it=foldli l \<and> it'=foldli l"
    shows "proper_it it it'"
    using assms unfolding proper_it_def by auto

  lemma proper_itE:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    assumes "proper_it it it'"
    obtains l where "it=foldli l" and "it'=foldli l"
    using assms unfolding proper_it_def by auto

  lemma proper_it_parE:
    fixes it :: "'a \<Rightarrow> ('x,'\<sigma>1) set_iterator"
    and it' :: "'a \<Rightarrow> ('x,'\<sigma>2) set_iterator"
    assumes "\<forall>x. proper_it (it x) (it' x)"
    obtains f where "it = (\<lambda>x. foldli (f x))" and "it' = (\<lambda>x. foldli (f x))"
    using assms unfolding proper_it_def
    by metis

  definition
    proper_it'
    where "proper_it' it it' \<equiv> \<forall>s. proper_it (it s) (it' s)"

  lemma proper_it'I:
    "\<lbrakk>\<And>s. proper_it (it s) (it' s)\<rbrakk> \<Longrightarrow> proper_it' it it'"
    unfolding proper_it'_def by blast

  lemma proper_it'D:
    "proper_it' it it' \<Longrightarrow> proper_it (it s) (it' s)"
    unfolding proper_it'_def by blast

  subsubsection {* Properness Preservation *}
  ML {*
    structure Icf_Proper_Iterator = struct

      structure icf_proper_iteratorI = Named_Thms
        ( val name = @{binding icf_proper_iteratorI_raw}
          val description = "ICF (internal): Rules to show properness of iterators" )

      val get = icf_proper_iteratorI.get

      fun add_thm thm = icf_proper_iteratorI.add_thm thm

      val add = Thm.declaration_attribute add_thm

      fun del_thm thm = icf_proper_iteratorI.del_thm thm

      val del = Thm.declaration_attribute del_thm

      val setup = I
        #> icf_proper_iteratorI.setup
        #> Attrib.setup @{binding icf_proper_iteratorI}
          (Attrib.add_del add del)
          ("ICF: Rules to show properness of iterators")
        #> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI},
             get o Context.proof_of
            )

    end
    *}
  setup {* Icf_Proper_Iterator.setup *}

  lemma proper_iterator_trigger:
    "proper_it it it' \<Longrightarrow> proper_it it it'"
    "proper_it' itf itf' \<Longrightarrow> proper_it' itf itf'" .

  declaration {*
    Tagged_Solver.declare_solver @{thms proper_iterator_trigger}
      @{binding proper_iterator} "Proper iterator solver"
      (fn ctxt => REPEAT_ALL_NEW (resolve_tac (Icf_Proper_Iterator.get ctxt)))
    *}

  lemma pi_foldli[icf_proper_iteratorI]:
    "proper_it (foldli l :: ('a,'\<sigma>) set_iterator) (foldli l)"
    unfolding proper_it_def
    by auto

  lemma pi_foldri[icf_proper_iteratorI]:
    "proper_it (foldri l :: ('a,'\<sigma>) set_iterator) (foldri l)"
    unfolding proper_it_def foldri_def by auto

  lemma pi'_foldli[icf_proper_iteratorI]:
    "proper_it' (foldli o tsl) (foldli o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  lemma pi'_foldri[icf_proper_iteratorI]:
    "proper_it' (foldri o tsl) (foldri o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  text {* Iterator combinators preserve properness *}
  lemma pi_emp[icf_proper_iteratorI]:
    "proper_it set_iterator_emp set_iterator_emp"
    unfolding proper_it_def set_iterator_emp_def[abs_def]
    by (auto intro!: ext exI[where x="[]"])

  lemma pi_sng[icf_proper_iteratorI]:
    "proper_it (set_iterator_sng x) (set_iterator_sng x)"
    unfolding proper_it_def set_iterator_sng_def[abs_def]
    by (auto intro!: ext exI[where x="[x]"])

  lemma pi_union[icf_proper_iteratorI]:
    assumes PA: "proper_it it_a it_a'"
    assumes PB: "proper_it it_b it_b'"
    shows "proper_it (set_iterator_union it_a it_b)
      (set_iterator_union it_a' it_b')"
    unfolding set_iterator_union_def
    apply (rule proper_itE[OF PA])
    apply (rule proper_itE[OF PB])
    apply (rule_tac l="l@la" in proper_itI)
    apply simp
    apply (intro conjI ext)
    apply (simp_all add: foldli_append)
    done

  lemma pi_product[icf_proper_iteratorI]:
    fixes it_a :: "('a,'\<sigma>a) set_iterator"
    fixes it_b :: "'a \<Rightarrow> ('b,'\<sigma>a) set_iterator"
    assumes PA: "proper_it it_a it_a'"
    and PB: "\<And>x. proper_it (it_b x) (it_b' x)"
    shows "proper_it (set_iterator_product it_a it_b)
      (set_iterator_product it_a' it_b')"
  proof -
    from PB have PB': "\<forall>x. proper_it (it_b x) (it_b' x)" ..
    show ?thesis
      unfolding proper_it_def
      apply (rule proper_itE[OF PA])
      apply (rule proper_it_parE[OF PB'])
      apply (auto simp add: set_iterator_product_foldli_conv)
      done
  qed

  lemma pi_image_filter[icf_proper_iteratorI]:
    fixes it :: "('x,'\<sigma>1) set_iterator"
    and it' :: "('x,'\<sigma>2) set_iterator"
    and g :: "'x \<Rightarrow> 'y option"
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image_filter g it)
      (set_iterator_image_filter g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    apply (auto simp: set_iterator_image_filter_foldli_conv)
    done

  lemma pi_filter[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_filter P it)
      (set_iterator_filter P it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_filter_foldli_conv)

  lemma pi_image[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image g it)
      (set_iterator_image g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_image_foldli_conv)

  lemma pi_dom[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (map_iterator_dom it)
      (map_iterator_dom it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: map_iterator_dom_foldli_conv)

  lemma set_iterator_product_eq2:
    assumes "\<forall>a\<in>set la. itb a = itb' a"
    shows "set_iterator_product (foldli la) itb
    = set_iterator_product (foldli la) itb'"
  proof (intro ext)
    fix c f \<sigma>
    show "set_iterator_product (foldli la) itb c f \<sigma>
      = set_iterator_product (foldli la) itb' c f \<sigma>"
      using assms
      unfolding set_iterator_product_def
      apply (induct la arbitrary: \<sigma>)
      apply (auto)
      done
  qed

subsubsection {* Optimizing Folds *}
  text {*
    Using an iterator to create a list. The optimizations will
    match the pattern @{text "foldli (it_to_list it s)"}
    *}
  definition "it_to_list it s \<equiv> (it s) (\<lambda>_. True) (\<lambda>x l. l@[x]) []"

  lemma map_it_to_list_genord_correct:
    assumes A: "map_iterator_genord (it s) m (\<lambda>(k,_) (k',_). R k k')"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted_by_rel R ((map fst (it_to_list it s)))"
    unfolding it_to_list_def
    apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
      \<lambda>it l. map_of l = m |` it
        \<and> distinct (map fst l)
        \<and> sorted_by_rel R ((map fst l))
      "])
    apply auto
    apply (auto intro!: ext simp: restrict_map_def) []
    apply (metis Some_eq_map_of_iff restrict_map_eq(2))
    apply (auto simp add: sorted_by_rel_append)
    by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)

  lemma (in linorder) map_it_to_list_linord_correct:
    assumes A: "map_iterator_linord (it s) m"
    shows "map_of (it_to_list it s) = m
      \<and> distinct (map fst (it_to_list it s))
      \<and> sorted ((map fst (it_to_list it s)))"
    using map_it_to_list_genord_correct[where it=it,
      OF A[unfolded set_iterator_map_linord_def]]
    by simp

end


(*  Title:      HOL/Library/Quotient_Product.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section \<open>Quotient infrastructure for the product type\<close>

theory Quotient_Product
imports Quotient_Syntax
begin

subsection \<open>Rules for the Quotient package\<close>

lemma map_prod_id [id_simps]:
  shows "map_prod id id = id"
  by (simp add: fun_eq_iff)

lemma rel_prod_eq [id_simps]:
  shows "rel_prod (op =) (op =) = (op =)"
  by (simp add: fun_eq_iff)

lemma prod_equivp [quot_equiv]:
  assumes "equivp R1"
  assumes "equivp R2"
  shows "equivp (rel_prod R1 R2)"
  using assms by (auto intro!: equivpI reflpI sympI transpI elim!: equivpE elim: reflpE sympE transpE)

lemma prod_quotient [quot_thm]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "Quotient3 (rel_prod R1 R2) (map_prod Abs1 Abs2) (map_prod Rep1 Rep2)"
  apply (rule Quotient3I)
  apply (simp add: map_prod.compositionality comp_def map_prod.identity
     Quotient3_abs_rep [OF assms(1)] Quotient3_abs_rep [OF assms(2)])
  apply (simp add: split_paired_all Quotient3_rel_rep [OF assms(1)] Quotient3_rel_rep [OF assms(2)])
  using Quotient3_rel [OF assms(1)] Quotient3_rel [OF assms(2)]
  apply (auto simp add: split_paired_all)
  done

declare [[mapQ3 prod = (rel_prod, prod_quotient)]]

lemma Pair_rsp [quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(R1 ===> R2 ===> rel_prod R1 R2) Pair Pair"
  by (rule Pair_transfer)

lemma Pair_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(Rep1 ---> Rep2 ---> (map_prod Abs1 Abs2)) Pair = Pair"
  apply(simp add: fun_eq_iff)
  apply(simp add: Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
  done

lemma fst_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R1) fst fst"
  by auto

lemma fst_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs1) fst = fst"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1])

lemma snd_rsp [quot_respect]:
  assumes "Quotient3 R1 Abs1 Rep1"
  assumes "Quotient3 R2 Abs2 Rep2"
  shows "(rel_prod R1 R2 ===> R2) snd snd"
  by auto

lemma snd_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  assumes q2: "Quotient3 R2 Abs2 Rep2"
  shows "(map_prod Rep1 Rep2 ---> Abs2) snd = snd"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q2])

lemma case_prod_rsp [quot_respect]:
  shows "((R1 ===> R2 ===> (op =)) ===> (rel_prod R1 R2) ===> (op =)) case_prod case_prod"
  by (rule case_prod_transfer)

lemma split_prs [quot_preserve]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "(((Abs1 ---> Abs2 ---> id) ---> map_prod Rep1 Rep2 ---> id) case_prod) = case_prod"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_respect]:
  shows "((R2 ===> R2 ===> op =) ===> (R1 ===> R1 ===> op =) ===>
  rel_prod R2 R1 ===> rel_prod R2 R1 ===> op =) rel_prod rel_prod"
  by (rule prod.rel_transfer)

lemma [quot_preserve]:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> abs1 ---> id) ---> (abs2 ---> abs2 ---> id) --->
  map_prod rep1 rep2 ---> map_prod rep1 rep2 ---> id) rel_prod = rel_prod"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [quot_preserve]:
  shows"(rel_prod ((rep1 ---> rep1 ---> id) R1) ((rep2 ---> rep2 ---> id) R2)
  (l1, l2) (r1, r2)) = (R1 (rep1 l1) (rep1 r1) \<and> R2 (rep2 l2) (rep2 r2))"
  by simp

declare prod.inject[quot_preserve]

end


theory ND_Compl_Truthtable_Compact
imports ND_Compl_Truthtable Compactness
begin

theorem
  fixes \<Gamma> :: "'a :: countable formula set"
  shows "\<Gamma> \<TTurnstile> F \<Longrightarrow> \<Gamma> \<turnstile> F"
proof -
  assume \<open>\<Gamma> \<TTurnstile> F\<close>
  with compact_to_formula guess G .
  from ND_complete \<open>\<Turnstile> \<^bold>\<And>G \<^bold>\<rightarrow> F\<close> have \<open>{} \<turnstile> \<^bold>\<And>G \<^bold>\<rightarrow> F\<close> .
  with AssmBigAnd have \<open>set G \<turnstile> F\<close> ..
  with Weaken show ?thesis using \<open>set G \<subseteq> \<Gamma>\<close> .
qed

end


theory week09B_demo_monad
imports "~~/src/HOL/Library/Monad_Syntax"
begin

text {* The nondeterministic state monad with failure *}

type_synonym ('s,'a) nondet_monad = "'s \<Rightarrow> (('a \<times> 's) set \<times> bool)"

definition
  return :: "'a \<Rightarrow> ('s,'a) nondet_monad"
where
  "return x \<equiv> \<lambda>s. ({(x,s)},False)"

definition
  bind :: "('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> ('s,'b) nondet_monad"
where
  "bind a b \<equiv> \<lambda>s. ({(r'',s''). \<exists> (r',s') \<in> fst (a s). (r'',s'') \<in> fst (b r' s')},
                     snd (a s) \<or> (\<exists>(r', s') \<in> fst (a s). snd (b r' s')))"

(* Use standard monad syntax for our new "bind" *)
adhoc_overloading
  Monad_Syntax.bind bind

(* Always use do-notation *)
translations
  "CONST bind_do" == "CONST Monad_Syntax.bind"

lemma
  "return x >>= f = f x"
  apply(unfold bind_def return_def)
  apply simp
  done

lemma
  "m >>= return = m"
  apply(rule ext)
  apply(simp add: bind_def return_def)
  apply(rule prod_eqI)
  apply auto
  done

lemma
  "(a >>= b) >>= c = (a >>= (\<lambda>s. b s >>= c) :: ('s,'a) nondet_monad)"
  apply(rule ext)
  apply(fastforce simp: bind_def split: prod.splits)
  done

definition
  get :: "('s,'s) nondet_monad"
where
  "get \<equiv> \<lambda>s. ({(s,s)},False)"

definition
  put :: "'s \<Rightarrow> ('s,unit) nondet_monad"
where
  "put s \<equiv> \<lambda>_. ({((),s)},False)"

definition
  gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s,'a) nondet_monad"
where
  "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

definition
  modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s,unit) nondet_monad"
where
  "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

definition
  fail :: "('s,'a) nondet_monad"
where
  "fail \<equiv> \<lambda>_. ({},True)"

definition
  assert :: "bool \<Rightarrow> ('s,unit) nondet_monad"
where
  "assert P \<equiv> if P then return () else fail"

definition
  guard :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,unit) nondet_monad"
where
  "guard P \<equiv> get >>= (\<lambda>s. assert (P s))"

definition
  select :: "'a set \<Rightarrow> ('s,'a) nondet_monad"
where
  "select A \<equiv> \<lambda>s. ((A \<times> {s}),False)"

definition
  alternative :: "('s,'a) nondet_monad \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('s,'a) nondet_monad"
  (infixl "OR" 20)
where
  "alternative a b \<equiv> (\<lambda>s. (fst (a s) \<union> (fst (b s)),snd (a s) \<or> snd (b s)))"

text {*
  We use an abstract type for pointers.
  Later we talk more about how to faithfully model pointers.
*}
typedecl ptr

record state =
  hp :: "ptr \<Rightarrow> int"
  pvalid :: "ptr \<Rightarrow> bool"

definition
  func :: "ptr \<Rightarrow> (state,unit) nondet_monad"
where
  "func p \<equiv> do {
     y \<leftarrow> guard (\<lambda>s. pvalid s p);
     x \<leftarrow> gets (\<lambda>s. hp s p);
     if x < 10 then
       modify (hp_update (\<lambda>h. (h(p := x + 1))))
     else
       return ()
   }"

inductive_set
  whileLoop_results :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> ((('r \<times> 's) option) \<times> (('r \<times> 's) option)) set"
  for C B
where
    "\<lbrakk> \<not> C r s \<rbrakk> \<Longrightarrow> (Some (r, s), Some (r, s)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; snd (B r s) \<rbrakk> \<Longrightarrow> (Some (r, s), None) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (r', s') \<in> fst (B r s); (Some (r', s'), z) \<in> whileLoop_results C B  \<rbrakk>
       \<Longrightarrow> (Some (r, s), z) \<in> whileLoop_results C B"

inductive_cases whileLoop_results_cases_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_fail: "(Some x, None) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps: "(Some x, y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_start_fail [simp]: "(None, x) \<in> whileLoop_results C B"

inductive
  whileLoop_terminates :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
  for C B
where
    "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
  | "\<lbrakk> C r s; \<forall>(r', s') \<in> fst (B r s). whileLoop_terminates C B r' s' \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r s"

inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"

definition
  "whileLoop C B \<equiv> (\<lambda>r s.
     ({(r',s'). (Some (r, s), Some (r', s')) \<in> whileLoop_results C B},
        (Some (r, s), None) \<in> whileLoop_results C B \<or> (\<not> whileLoop_terminates C B r s)))"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

consts
  ptrAdd :: "ptr \<Rightarrow> nat \<Rightarrow> ptr"

term "whileLoop (\<lambda>p s. hp s p = 0) (\<lambda>p. return (ptrAdd p 1)) p"

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> fst (f s). Q r s')"

lemma return_wp:
  "\<lbrace>P x\<rbrace> return x \<lbrace>P\<rbrace>"
  by(simp add: valid_def return_def)

lemma get_wp:
  "\<lbrace>\<lambda>s. P s s\<rbrace> get \<lbrace>P\<rbrace>"
  by(simp add: valid_def get_def)

lemma gets_wp:
  "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>"
  apply(simp add:valid_def split_def gets_def return_def get_def bind_def)
  done

lemma modify_wp:
  "\<lbrace>\<lambda>s. P () (f s)\<rbrace> modify f \<lbrace>P\<rbrace>"
  apply(simp add:valid_def split_def modify_def get_def put_def bind_def)
  done

lemma put_wp:
  "\<lbrace>\<lambda>s. P () x\<rbrace> put x \<lbrace>P\<rbrace>"
  apply(simp add:valid_def put_def)
  done

lemma hoare_weaken_pre:
  "\<lbrakk>\<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>; \<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  apply(auto simp: valid_def)
  done

lemma fail_wp:  "\<lbrace>\<lambda>_. True\<rbrace> fail \<lbrace>Q\<rbrace>"
  apply(simp add: fail_def valid_def)
  done

lemma if_wp:
 "\<lbrakk> P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>S\<rbrace>; \<not>P \<Longrightarrow> \<lbrace>R\<rbrace> g \<lbrace>S\<rbrace> \<rbrakk> \<Longrightarrow>
  \<lbrace>\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not>P \<longrightarrow> R s)\<rbrace> if P then f else g \<lbrace>S\<rbrace>"
  by simp

(* do this proof using wp rules above *)
lemma assert_wp: "\<lbrace>\<lambda>s. P \<longrightarrow> Q () s\<rbrace> assert P \<lbrace>Q\<rbrace>"
  apply(unfold assert_def)
  apply (rule hoare_weaken_pre)
   apply (rule if_wp)
    apply (rule return_wp)
   apply (rule fail_wp)
  apply simp
  done

lemma bind_wp:
  "\<lbrakk> \<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>; \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> do { x \<leftarrow> f; g x } \<lbrace>C\<rbrace>"
  apply(force simp: valid_def bind_def split: prod.splits)
  done

lemma select_wp: "\<lbrace>\<lambda>s. \<forall>x \<in> S. Q x s\<rbrace> select S \<lbrace>Q\<rbrace>"
  by (simp add: select_def valid_def)

lemma guard_wp:
  "\<lbrace>\<lambda>s. P s \<longrightarrow> Q () s\<rbrace> guard P \<lbrace>Q\<rbrace>"
  apply (unfold guard_def)
  apply (rule bind_wp)
   apply (rule assert_wp)
  apply (rule get_wp)
  done

lemma func_lemma:
  "\<lbrace>\<lambda>s. hp s p \<ge> 10 \<and> Q () s\<rbrace> func p \<lbrace>Q\<rbrace>"
  apply (unfold func_def)
  apply (rule bind_wp)+
    apply (rule if_wp)
     apply (rule modify_wp)
    apply (rule return_wp)
   apply (rule gets_wp)
  apply (rule hoare_weaken_pre)
   apply (rule guard_wp)
  apply simp
  done

end


section \<open> Dwarf Signal \<close>

theory DwarfSignal
  imports "ITree_Simulation.ITree_Simulation" "Interaction_Trees.ITree_Eval"
begin

subsection \<open> State Space \<close>

enumtype LampId = L1 | L2 | L3

type_synonym Signal = "LampId set"

enumtype ProperState = dark | stop | warning | drive

definition "ProperState = {dark, stop, warning, drive}"

fun signalLamps :: "ProperState \<Rightarrow> LampId set" where
"signalLamps dark = {}" |
"signalLamps stop = {L1, L2}" |
"signalLamps warning = {L1, L3}" |
"signalLamps drive = {L2, L3}"

text \<open> Could we have separate processes for the actual lamp and its controller? We would then
  try to verify that the controller preserves the lamp-based safety properties. The current
  set up doesn't preserve them. \<close>

schema Dwarf =
  last_proper_state :: "ProperState"
  turn_off :: "LampId set"
  turn_on  :: "LampId set"
  last_state :: "Signal"
  current_state :: "Signal"
  desired_proper_state :: "ProperState"
  where
    "(current_state - turn_off) \<union> turn_on = signalLamps desired_proper_state"
    "turn_on \<inter> turn_off = {}"

record_default Dwarf

definition "NeverShowAll = (@Dwarf \<and> current_state \<noteq> {L1, L2, L3})\<^sub>e"

definition "MaxOneLampChange =
  (@Dwarf \<and>
  (\<exists> l. current_state - last_state = {l} \<or> last_state - current_state = {l} \<or> last_state = current_state))\<^sub>e"

definition "ForbidStopToDrive =
  (@Dwarf \<and> (last_proper_state = stop \<longrightarrow> desired_proper_state \<noteq> drive))\<^sub>e"

definition "DarkOnlyToStop =
  (@Dwarf \<and> (last_proper_state = dark \<longrightarrow> desired_proper_state = stop))\<^sub>e"

definition "DarkOnlyFromStop =
  (@Dwarf \<and> (desired_proper_state = dark \<longrightarrow> last_proper_state = stop))\<^sub>e"

definition "DwarfReq =
  (@NeverShowAll
  \<and> @MaxOneLampChange
  \<and> @ForbidStopToDrive
  \<and> @DarkOnlyToStop
  \<and> @DarkOnlyFromStop)\<^sub>e"

chantype chan =
  shine :: "LampId set"
  setNewProperState :: ProperState
  turnOff :: "LampId"
  turnOn :: "LampId"
  violation :: String.literal

definition Init :: "Dwarf subst" where
  "Init =
  [ last_proper_state \<leadsto> stop
  , turn_off \<leadsto> {}
  , turn_on \<leadsto> {}
  , last_state \<leadsto> signalLamps stop
  , current_state \<leadsto> signalLamps stop
  , desired_proper_state \<leadsto> stop ]"

lemma Init_establishes_inv: "Init \<dagger> Dwarf_inv = (True)\<^sub>e"
  by (simp add: Dwarf_inv_def Init_def usubst_eval)

definition "CheckReq =
  (\<questiondown>\<not> @NeverShowAll? \<Zcomp> violation!(STR ''NeverShowAll'') \<rightarrow> Skip) \<box>
  (\<questiondown>\<not> @MaxOneLampChange? \<Zcomp> violation!(STR ''MaxOneLampChange'') \<rightarrow> Skip) \<box>
  (\<questiondown>\<not> @ForbidStopToDrive? \<Zcomp> violation!(STR ''ForbidStopToDrive'') \<rightarrow> Skip) \<box>
  (\<questiondown>\<not> @DarkOnlyToStop? \<Zcomp> violation!(STR ''DarkOnlyToStop'') \<rightarrow> Skip) \<box>
  (\<questiondown>\<not> @DarkOnlyFromStop? \<Zcomp> violation!(STR ''DarkOnlyFromStop'') \<rightarrow> Skip)"

term "setNewProperState?(st):(ProperState - {desired_proper_state}) \<rightarrow>
      (last_proper_state := desired_proper_state \<Zcomp>
       turn_off := current_state - signalLamps st \<Zcomp>
       turn_on := signalLamps st - current_state \<Zcomp>
       last_state := current_state \<Zcomp>
       desired_proper_state := st)"

definition
  "SetNewProperState =
    \<questiondown>current_state = signalLamps desired_proper_state? \<Zcomp>
    setNewProperState?(st):(ProperState - {desired_proper_state}) \<rightarrow>
      (last_proper_state := desired_proper_state \<Zcomp>
       turn_off := current_state - signalLamps st \<Zcomp>
       turn_on := signalLamps st - current_state \<Zcomp>
       last_state := current_state \<Zcomp>
       desired_proper_state := st)"

definition
  "TurnOff =
   turnOff?(l):turn_off \<rightarrow>
    (turn_off := turn_off - {l} \<Zcomp>
     turn_on := turn_on - {l} \<Zcomp>
     last_state := current_state \<Zcomp>
     current_state := current_state - {l})"

definition
  "TurnOn =
   turnOn?(l):turn_on \<rightarrow>
    (turn_off := turn_off - {l} \<Zcomp>
     turn_on := turn_on - {l} \<Zcomp>
     last_state := current_state \<Zcomp>
     current_state := current_state \<union> {l})"

definition "Shine = shine!(current_state) \<rightarrow> Skip"

definition "DwarfSignal
  = process Init (loop (CheckReq \<box> SetNewProperState \<box> TurnOn \<box> TurnOff \<box> Shine))"

simulate DwarfSignal

text \<open> Testing SML lazy code evaluation \<close>

code_lazy_type itree

lemma "trres \<langle>setNewProperState warning, turnOff L2, turnOn L3, shine {L1, L3}\<rangle> 20 DwarfSignal = VisR {shine_C {L1, L3}, setNewProperState_C dark, setNewProperState_C stop, setNewProperState_C drive}"
  by eval

end