chapter \<open>Operational Semantics\<close>
text\<open>\label{chap:operational_semantics}\<close>

theory Operational
imports
  SymbolicPrimitive

begin

text\<open>
  The operational semantics defines rules to build symbolic runs from a TESL
  specification (a set of TESL formulae).
  Symbolic runs are described using the symbolic primitives presented in the
  previous chapter.
  Therefore, the operational semantics compiles a set of constraints on runs,
  as defined by the denotational semantics, into a set of symbolic constraints
  on the instants of the runs. Concrete runs can then be obtained by solving the
  constraints at each instant.
\<close>

section\<open>Operational steps\<close>

text \<open>
  We introduce a notation to describe configurations:
  \<^item> @{term \<open>\<Gamma>\<close>} is the context, the set of symbolic constraints on past instants of the run;
  \<^item> @{term \<open>n\<close>} is the index of the current instant, the present;
  \<^item> @{term \<open>\<Psi>\<close>} is the TESL formula that must be satisfied at the current instant (present);
  \<^item> @{term \<open>\<Phi>\<close>} is the TESL formula that must be satisfied for the following instants (the future).
\<close>
abbreviation uncurry_conf
  ::\<open>('\<tau>::linordered_field) system \<Rightarrow> instant_index \<Rightarrow> '\<tau> TESL_formula \<Rightarrow> '\<tau> TESL_formula
      \<Rightarrow> '\<tau> config\<close>                                                  (\<open>_, _ \<turnstile> _ \<triangleright> _\<close> 80)
where
  \<open>\<Gamma>, n \<turnstile> \<Psi> \<triangleright> \<Phi> \<equiv> (\<Gamma>, n, \<Psi>, \<Phi>)\<close>

text \<open>
  The only introduction rule allows us to progress to the next instant
  when there are no more constraints to satisfy for the present instant.
\<close>
inductive operational_semantics_intro
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sub>i _\<close> 70)
where
  instant_i:
  \<open>(\<Gamma>, n \<turnstile> [] \<triangleright> \<Phi>) \<hookrightarrow>\<^sub>i  (\<Gamma>, Suc n \<turnstile> \<Phi> \<triangleright> [])\<close>

text \<open>
  The elimination rules describe how TESL formulae for the present are transformed
  into constraints on the past and on the future.
\<close>
inductive operational_semantics_elim
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sub>e _\<close> 70)
where
  sporadic_on_e1:
\<comment> \<open>A sporadic constraint can be ignored in the present and rejected into the future.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 sporadic \<tau> on K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (\<Gamma>, n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 sporadic \<tau> on K\<^sub>2) # \<Phi>))\<close>
| sporadic_on_e2:
\<comment> \<open>It can also be handled in the present by making the clock tick and have
  the expected time. Once it has been handled, it is no longer a constraint
  to satisfy, so it disappears from the future.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 sporadic \<tau> on K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<Down> n @ \<tau>) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> \<Phi>)\<close>
| tagrel_e:
\<comment> \<open>A relation between time scales has to be obeyed at every instant.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((time-relation \<lfloor>K\<^sub>1, K\<^sub>2\<rfloor> \<in> R) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((\<lfloor>\<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>1, n), \<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>2, n)\<rfloor> \<in> R) # \<Gamma>), n
              \<turnstile> \<Psi> \<triangleright> ((time-relation \<lfloor>K\<^sub>1, K\<^sub>2\<rfloor> \<in> R) # \<Phi>))\<close>
| implies_e1:
\<comment> \<open>An implication can be handled in the present by forbidding a tick of the master
  clock. The implication is copied back into the future because it holds for
  the whole run.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 implies K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies K\<^sub>2) # \<Phi>))\<close>
| implies_e2:
\<comment> \<open>It can also be handled in the present by making both the master and the slave
    clocks tick.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 implies K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies K\<^sub>2) # \<Phi>))\<close>
| implies_not_e1:
\<comment> \<open>A negative implication can be handled in the present by forbidding a tick of
  the master clock. The implication is copied back into the future because
  it holds for the whole run.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 implies not K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies not K\<^sub>2) # \<Phi>))\<close>
| implies_not_e2:
\<comment> \<open>It can also be handled in the present by making the master clock ticks and
    forbidding a tick on the slave clock.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 implies not K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies not K\<^sub>2) # \<Phi>))\<close>
| timedelayed_e1:
\<comment> \<open>A timed delayed implication can be handled by forbidding a tick on
    the master clock.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Phi>))\<close>
| timedelayed_e2:
\<comment> \<open>It can also be handled by making the master clock tick and adding a constraint
    that makes the slave clock tick when the delay has elapsed on the measuring clock.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<Up> n) # (K\<^sub>2 @ n \<oplus> \<delta>\<tau> \<Rightarrow> K\<^sub>3) # \<Gamma>), n
            \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Phi>))\<close>
| weakly_precedes_e:
\<comment> \<open>A weak precedence relation has to hold at every instant.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 weakly precedes K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((\<lceil>#\<^sup>\<le> K\<^sub>2 n, #\<^sup>\<le> K\<^sub>1 n\<rceil> \<in> (\<lambda>(x,y). x\<le>y)) # \<Gamma>), n
            \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 weakly precedes K\<^sub>2) # \<Phi>))\<close>
| strictly_precedes_e:
\<comment> \<open>A strict precedence relation has to hold at every instant.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 strictly precedes K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((\<lceil>#\<^sup>\<le> K\<^sub>2 n, #\<^sup>< K\<^sub>1 n\<rceil> \<in> (\<lambda>(x,y). x\<le>y)) # \<Gamma>), n
            \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 strictly precedes K\<^sub>2) # \<Phi>))\<close>
| kills_e1:
\<comment> \<open>A kill can be handled by forbidding a tick of the triggering clock.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 kills K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 kills K\<^sub>2) # \<Phi>))\<close>
| kills_e2:
\<comment> \<open>It can also be handled by making the triggering clock tick and by forbidding
    any further tick of the killed clock.\<close>
  \<open>(\<Gamma>, n \<turnstile> ((K\<^sub>1 kills K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>)
     \<hookrightarrow>\<^sub>e  (((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<not>\<Up> \<ge> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 kills K\<^sub>2) # \<Phi>))\<close>

text \<open>
  A step of the operational semantics is either the application of the introduction
  rule or the application of an elimination rule.
\<close>
inductive operational_semantics_step
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow> _\<close> 70)
where
  intro_part:
  \<open>(\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)  \<hookrightarrow>\<^sub>i  (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)
    \<Longrightarrow> (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)  \<hookrightarrow>  (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)\<close>
| elims_part:
  \<open>(\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)  \<hookrightarrow>\<^sub>e  (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)
    \<Longrightarrow> (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)  \<hookrightarrow>  (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)\<close>

text \<open>
  We introduce notations for the reflexive transitive closure of the operational
  semantic step, its transitive closure and its reflexive closure.
\<close>
abbreviation operational_semantics_step_rtranclp
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sup>*\<^sup>* _\<close> 70)
where
  \<open>\<C>\<^sub>1 \<hookrightarrow>\<^sup>*\<^sup>* \<C>\<^sub>2 \<equiv> operational_semantics_step\<^sup>*\<^sup>* \<C>\<^sub>1 \<C>\<^sub>2\<close>

abbreviation operational_semantics_step_tranclp
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sup>+\<^sup>+ _\<close> 70)
where
  \<open>\<C>\<^sub>1 \<hookrightarrow>\<^sup>+\<^sup>+ \<C>\<^sub>2 \<equiv> operational_semantics_step\<^sup>+\<^sup>+ \<C>\<^sub>1 \<C>\<^sub>2\<close>

abbreviation operational_semantics_step_reflclp
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sup>=\<^sup>= _\<close> 70)
where
  \<open>\<C>\<^sub>1 \<hookrightarrow>\<^sup>=\<^sup>= \<C>\<^sub>2 \<equiv> operational_semantics_step\<^sup>=\<^sup>= \<C>\<^sub>1 \<C>\<^sub>2\<close>

abbreviation operational_semantics_step_relpowp
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> nat \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>       (\<open>_ \<hookrightarrow>\<^bsup>_\<^esup> _\<close> 70)
where
  \<open>\<C>\<^sub>1 \<hookrightarrow>\<^bsup>n\<^esup> \<C>\<^sub>2 \<equiv> (operational_semantics_step ^^ n) \<C>\<^sub>1 \<C>\<^sub>2\<close>

definition operational_semantics_elim_inv
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config \<Rightarrow> bool\<close>              (\<open>_ \<hookrightarrow>\<^sub>e\<^sup>\<leftarrow> _\<close> 70)
where
  \<open>\<C>\<^sub>1 \<hookrightarrow>\<^sub>e\<^sup>\<leftarrow> \<C>\<^sub>2 \<equiv> \<C>\<^sub>2 \<hookrightarrow>\<^sub>e \<C>\<^sub>1\<close>

section\<open>Basic Lemmas\<close>

text \<open>
  If a configuration can be reached in @{term \<open>m\<close>} steps from a configuration that
  can be reached in @{term \<open>n\<close>} steps from an original configuration, then it can be
  reached in @{term \<open>n+m\<close>} steps from the original configuration.
\<close>
lemma operational_semantics_trans_generalized:
  assumes \<open>\<C>\<^sub>1 \<hookrightarrow>\<^bsup>n\<^esup> \<C>\<^sub>2\<close>
  assumes \<open>\<C>\<^sub>2 \<hookrightarrow>\<^bsup>m\<^esup> \<C>\<^sub>3\<close>
    shows \<open>\<C>\<^sub>1 \<hookrightarrow>\<^bsup>n + m\<^esup> \<C>\<^sub>3\<close>
using relcompp.relcompI[of  \<open>operational_semantics_step ^^ n\<close> _ _
                            \<open>operational_semantics_step ^^ m\<close>, OF assms]
by (simp add: relpowp_add)

text \<open>
  We consider the set of configurations that can be reached in one operational
  step from a given configuration.
\<close>
abbreviation Cnext_solve
  ::\<open>('\<tau>::linordered_field) config \<Rightarrow> '\<tau> config set\<close> (\<open>\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t _\<close>)
where
  \<open>\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t \<S> \<equiv> { \<S>'. \<S> \<hookrightarrow> \<S>' }\<close>

text \<open>
  Advancing to the next instant is possible when there are no more constraints
  on the current instant.
\<close>
lemma Cnext_solve_instant:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> [] \<triangleright> \<Phi>)) \<supseteq> { \<Gamma>, Suc n \<turnstile> \<Phi> \<triangleright> [] }\<close>
by (simp add: operational_semantics_step.simps operational_semantics_intro.instant_i)

text \<open>
  The following lemmas state that the configurations produced by the elimination
  rules of the operational semantics belong to the configurations that can be
  reached in one step.
\<close>
lemma Cnext_solve_sporadicon:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 sporadic \<tau> on K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { \<Gamma>, n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 sporadic \<tau> on K\<^sub>2) # \<Phi>),
        ((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<Down> n @ \<tau>) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> \<Phi> }\<close>
by (simp add: operational_semantics_step.simps
              operational_semantics_elim.sporadic_on_e1
              operational_semantics_elim.sporadic_on_e2)

lemma Cnext_solve_tagrel:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((time-relation \<lfloor>K\<^sub>1, K\<^sub>2\<rfloor> \<in> R) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((\<lfloor>\<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>1, n), \<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>2, n)\<rfloor> \<in> R) # \<Gamma>),n
          \<turnstile> \<Psi> \<triangleright> ((time-relation \<lfloor>K\<^sub>1, K\<^sub>2\<rfloor> \<in> R) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps operational_semantics_elim.tagrel_e)

lemma Cnext_solve_implies:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 implies K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies K\<^sub>2) # \<Phi>),
         ((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies K\<^sub>2) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps operational_semantics_elim.implies_e1
              operational_semantics_elim.implies_e2)

lemma Cnext_solve_implies_not:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 implies not K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies not K\<^sub>2) # \<Phi>),
        ((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 implies not K\<^sub>2) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps
              operational_semantics_elim.implies_not_e1
              operational_semantics_elim.implies_not_e2)

lemma Cnext_solve_timedelayed:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Phi>),
        ((K\<^sub>1 \<Up> n) # (K\<^sub>2 @ n \<oplus> \<delta>\<tau> \<Rightarrow> K\<^sub>3) # \<Gamma>), n
          \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 time-delayed by \<delta>\<tau> on K\<^sub>2 implies K\<^sub>3) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps
              operational_semantics_elim.timedelayed_e1
              operational_semantics_elim.timedelayed_e2)

lemma Cnext_solve_weakly_precedes:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 weakly precedes K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((\<lceil>#\<^sup>\<le> K\<^sub>2 n, #\<^sup>\<le> K\<^sub>1 n\<rceil> \<in> (\<lambda>(x,y). x\<le>y)) # \<Gamma>), n
          \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 weakly precedes K\<^sub>2) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps
              operational_semantics_elim.weakly_precedes_e)

lemma Cnext_solve_strictly_precedes:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 strictly precedes K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((\<lceil>#\<^sup>\<le> K\<^sub>2 n, #\<^sup>< K\<^sub>1 n\<rceil> \<in> (\<lambda>(x,y). x\<le>y)) # \<Gamma>), n
          \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 strictly precedes K\<^sub>2) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps
              operational_semantics_elim.strictly_precedes_e)

lemma Cnext_solve_kills:
  \<open>(\<C>\<^sub>n\<^sub>e\<^sub>x\<^sub>t (\<Gamma>, n \<turnstile> ((K\<^sub>1 kills K\<^sub>2) # \<Psi>) \<triangleright> \<Phi>))
    \<supseteq> { ((K\<^sub>1 \<not>\<Up> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 kills K\<^sub>2) # \<Phi>),
        ((K\<^sub>1 \<Up> n) # (K\<^sub>2 \<not>\<Up> \<ge> n) # \<Gamma>), n \<turnstile> \<Psi> \<triangleright> ((K\<^sub>1 kills K\<^sub>2) # \<Phi>) }\<close>
by (simp add: operational_semantics_step.simps operational_semantics_elim.kills_e1
              operational_semantics_elim.kills_e2)

text \<open>
  An empty specification can be reduced to an empty specification for
  an arbitrary number of steps.
\<close>
lemma empty_spec_reductions:
  \<open>([], 0 \<turnstile> [] \<triangleright> []) \<hookrightarrow>\<^bsup>k\<^esup> ([], k \<turnstile> [] \<triangleright> [])\<close>
proof (induct k)
  case 0 thus ?case by simp
next
  case Suc thus ?case
    using instant_i operational_semantics_step.simps by fastforce
qed

end


subsection \<open>IMO 2006 SL - A5\<close>

theory IMO_2006_SL_A5
  imports Complex_Main
begin

theorem IMO_2006_SL_A5:
  fixes a b c :: nat
  assumes "a > 0" "b > 0" "c > 0" "a + b > c" "b + c > a" "c + a > b"
  shows "sqrt (b + c - a) / (sqrt b + sqrt c - sqrt a) +
         sqrt (c + a - b) / (sqrt c + sqrt a - sqrt b) +
         sqrt (a + b - c) / (sqrt a + sqrt b - sqrt c) \<le> 3"
  sorry

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
  Adds positivity law to separation algebra, as well as defining
  the septraction and sep-coimplication operators, providing lemmas
  for each.
*)

theory Extended_Separation_Algebra
imports
  Lib.Lib
  "Sep_Tactics"
begin

no_notation pred_and (infixr "and" 35)
no_notation pred_or (infixr "or" 30)
no_notation pred_not ("not _" [40] 40)
no_notation pred_imp (infixr "imp" 25)

lemma sep_conj_exists_left[simp]: "((\<lambda>s. \<exists>x. (P x) s) \<and>* R) \<equiv> (EXS x. (P x \<and>* R)) "
  apply (rule eq_reflection)
  by (clarsimp simp: sep_conj_def, fastforce)

instantiation "bool" :: stronger_sep_algebra
begin
 definition "zero_bool \<equiv> True"
 definition "plus_bool \<equiv> \<lambda>(x :: bool) (y :: bool). x \<and> y"
 definition "sep_disj_bool \<equiv> \<lambda>(x :: bool) (y :: bool). x \<or> y"
instance
  by (intro_classes; fastforce simp: zero_bool_def plus_bool_def sep_disj_bool_def)
end

instantiation "prod" :: (stronger_sep_algebra, stronger_sep_algebra) stronger_sep_algebra
begin
definition "zero_prod \<equiv> (0,0)"
definition "plus_prod p p' \<equiv> (fst p + fst p', snd p + snd p')"
definition "sep_disj_prod p p' \<equiv> fst p ## fst p' \<and> snd p ## snd p'"
instance
  apply (intro_classes; simp add: zero_prod_def plus_prod_def sep_disj_prod_def)
     apply (simp add: sep_add_assoc | fastforce simp: sep_disj_commute sep_add_commute)+
  done
end

instantiation "fun" :: (type, pre_sep_algebra) pre_sep_algebra
begin
definition "zero_fun = (\<lambda>x. 0)"
definition "plus_fun f f'  \<equiv> (\<lambda>x. (f x) + (f' x) )"
definition "sep_disj_fun   \<equiv> (\<lambda>f f'.  \<forall>x. f x ## f' x ) :: ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool "
instance
  apply (intro_classes)
      apply (clarsimp simp:  comp_def sep_disj_fun_def )
      apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def )
     apply (clarsimp simp: zero_fun_def comp_def sep_disj_fun_def plus_fun_def )
     apply (simp add: sep_disj_commute)
    apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def)
   apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def sep_add_commute)
  apply (clarsimp simp: zero_fun_def sep_disj_commuteI sep_disj_fun_def plus_fun_def sep_add_commute sep_add_assoc)
  done
end

instantiation "fun" :: (type, sep_algebra) sep_algebra
begin

instance
  apply (intro_classes)
   apply (clarsimp simp: zero_fun_def sep_disj_fun_def plus_fun_def )
  using sep_disj_addD apply blast
  apply (clarsimp simp: zero_fun_def comp_def sep_disj_fun_def plus_fun_def )
  by (simp add: sep_disj_addI1)
end

instantiation option :: (type) sep_algebra begin
definition "sep_disj_option (h :: 'a option) (h' :: 'a option) =
             (case h of (Some x) \<Rightarrow> h' = None | _ \<Rightarrow> h = None)"
definition "plus_option (h :: 'a option) (h' :: 'a option) =
           (case h of (Some x) \<Rightarrow> h | _ \<Rightarrow> h')"
definition "zero_option = None"
instance
  apply (intro_classes)
        by (clarsimp simp: sep_disj_option_def zero_option_def plus_option_def split: option.splits)+
end

instantiation option :: (type) cancellative_sep_algebra begin
instance
  apply (intro_classes)
    apply (simp add: option.case_eq_if plus_option_def sep_disj_option_def)
   apply (clarsimp simp: zero_option_def option.case_eq_if plus_option_def sep_disj_option_def split: if_split_asm  option.splits)
   apply (clarsimp simp: zero_option_def option.case_eq_if plus_option_def sep_disj_option_def split: if_split_asm option.splits)
  done
end

instantiation "fun" :: (type, cancellative_sep_algebra) cancellative_sep_algebra begin
instance
  apply (intro_classes)
    apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
    apply (safe; fastforce)
   apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
    apply (rule ext)
    apply (meson sep_disj_positive)
   apply (rule ext)
  apply (clarsimp simp: plus_fun_def sep_disj_fun_def zero_fun_def)
  by (meson sep_add_cancel)
end

lemma sep_substate_antisym:
  "x \<preceq> y \<Longrightarrow> y \<preceq> x \<Longrightarrow> x = (y :: 'a ::cancellative_sep_algebra)"
  apply (clarsimp simp: sep_substate_def)
  apply (rename_tac h' h)
  apply (subgoal_tac "h' = 0")
   apply (clarsimp)
  apply (drule_tac trans[where s=x and t="x+0"])
   apply (clarsimp)
  apply (subgoal_tac "(x + h' + h = x + 0) \<longrightarrow> ((0 + x) = (h' + h) + x)")
   apply (drule mp, clarsimp)
   apply (metis sep_add_cancelD sep_add_disj_eq sep_disj_commuteI sep_disj_positive_zero sep_disj_zero)
  by (metis sep_add_assoc sep_add_commute sep_add_zero sep_add_zero_sym sep_disj_commuteI)

context sep_algebra begin

definition
  septraction :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "-*" 25)
where
  "septraction P Q = (not (P \<longrightarrow>* not Q))"

lemma septraction_impl1:
  "(P -* Q) s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> (P' -* Q) s "
  apply (clarsimp simp: septraction_def pred_neg_def)
  using sep_impl_def by auto

lemma septraction_impl2:
  "(P -* Q) s \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P -* Q') s "
  apply (clarsimp simp: septraction_def pred_neg_def)
  using sep_impl_def by auto

definition
  sep_coimpl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infix "\<leadsto>*" 24)
where
  "sep_coimpl P Q \<equiv> \<lambda>s. \<not> (P \<and>* not Q) s"

lemma sep_septraction_snake:
  "(P -* Q) s \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> (P \<leadsto>* Q') s) \<Longrightarrow>  Q' s"
  apply (clarsimp simp: sep_coimpl_def septraction_def pred_neg_def sep_conj_def sep_impl_def)
  using sep_add_commute sep_disj_commute by auto

lemma sep_snake_septraction:
  "Q s \<Longrightarrow> (\<And>s. (P -* Q) s \<Longrightarrow> Q' s) \<Longrightarrow> (P \<leadsto>* Q') s  "
  apply (clarsimp simp: sep_coimpl_def septraction_def pred_neg_def sep_conj_def sep_impl_def)
  using sep_add_commute sep_disj_commute by fastforce

lemma septraction_snake_trivial:
  "(P -* (P \<leadsto>* R)) s \<Longrightarrow> R s" by (erule sep_septraction_snake)

end

lemma sep_impl_impl:
  "(P \<longrightarrow>* Q) s\<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P \<longrightarrow>* Q') s"
  by (metis sep_implD sep_implI)

lemma disjointness_equiv:
  "(\<forall>P (s :: 'a :: sep_algebra). strictly_exact P \<longrightarrow> \<not>P 0 \<longrightarrow> (P \<leadsto>* (P \<leadsto>* sep_false)) s) =
   (\<forall>h :: 'a. h ## h \<longrightarrow> h = 0)"
  apply (rule iffI)
   apply (clarsimp)
   apply (erule_tac x="(=) h" in allE)
   apply (drule mp)
    apply (clarsimp simp: strictly_exact_def)
   apply (rule ccontr)
   apply (drule mp)
    apply (clarsimp)
   apply (erule_tac x="h + h" in allE)
   apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
   apply (erule_tac x=h in allE, clarsimp)
   apply (erule_tac x=0 in allE, clarsimp)
  apply (clarsimp)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def strictly_exact_def)
  apply (erule_tac x=x in allE, erule_tac x=xa in allE, clarsimp simp: sep_empty_def)
  apply (erule_tac x=x in allE, clarsimp)
  using sep_disj_addD1 by blast

definition
  sep_min :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_min P \<equiv> P and (P \<leadsto>* \<box>)"

definition
  sep_subtract :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_subtract P Q \<equiv> P and (Q \<leadsto>* \<box>)"

lemma sep_min_subtract_subtract:
  "sep_min P = sep_subtract P P"
  apply (clarsimp simp: sep_subtract_def sep_min_def)
  done

lemma sep_subtract_distrib_disj:
  "sep_subtract (P or Q) R = ((sep_subtract P R) or (sep_subtract Q R))"
  apply (rule ext, rule iffI)
   apply (clarsimp simp: pred_disj_def pred_conj_def sep_subtract_def)
  apply (clarsimp simp: pred_disj_def pred_conj_def sep_subtract_def)
  apply (safe)
  done

lemma sep_snake_sep_impl:
  "(P \<longrightarrow>* R) s \<Longrightarrow> (\<And> s. R s \<Longrightarrow> (P \<leadsto>* sep_false) s) \<Longrightarrow> (not P \<and>* (not (P -* R))) s"
  apply (drule sep_impl_impl[where Q'="(P \<leadsto>* sep_false)"])
   apply (atomize)
   apply (erule allE, drule mp, assumption)
   apply (assumption)
  apply (erule contrapos_pp)
  apply (clarsimp simp: sep_impl_def sep_coimpl_def sep_conj_def pred_neg_def septraction_def)
  apply (erule_tac x=0 in allE)
  apply (erule_tac x=s in allE)
  apply (clarsimp)
  apply (rule_tac x=0 in exI)
  apply (clarsimp)
  by (metis (full_types) disjoint_zero_sym sep_add_commute sep_add_zero_sym sep_disj_commuteI)

lemma sep_snake_mp:
  "(P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* sep_true) s \<Longrightarrow>  (P \<and>* Q) s  "
  apply (clarsimp simp: sep_coimpl_def)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_coimpl_contrapos:
  "(P \<leadsto>* Q) = ((not Q) \<leadsto>* (not P))"
  by (rule ext, rule iffI; simp add: sep_coimpl_def pred_neg_def sep_conj_commute)

lemma sep_coimpl_def':
  "(\<not> (P \<and>* Q) s) = ((P \<leadsto>* (not Q)) s)"
  by (simp add: pred_neg_def sep_coimpl_def)

lemma rewrite_sp:
  "(\<forall>R s. (P \<leadsto>* R) s \<longrightarrow> (Q \<and>* R) (f s))  \<longleftrightarrow> (\<forall>R s. R s \<longrightarrow> (Q \<and>* (P -* R)) (f s) )"
  apply (rule iffI)
   apply (clarsimp)
   apply (erule_tac x="P -* R" in allE)
   apply (erule_tac x=s in allE)
   apply (drule mp)
    apply (erule (1) sep_snake_septraction)
   apply (assumption)
  apply (clarsimp)
  apply (erule_tac x="P \<leadsto>* R" in allE)
  apply (erule_tac x=s in allE)
  apply (clarsimp)
  apply (sep_cancel)
  apply (erule (1) sep_septraction_snake)
  done

lemma sep_coimpl_weaken:
  "(P \<leadsto>* Q) s \<Longrightarrow> (\<And>s. P' s \<Longrightarrow> P s) \<Longrightarrow> (P' \<leadsto>* Q) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_curry':
  "R s \<Longrightarrow> (P \<longrightarrow>* (P \<and>* R)) s"
  by (simp add: sep_wand_trivial)

lemma sep_coimpl_mp_gen:
  "(P \<and>* Q) s \<Longrightarrow> (P' \<leadsto>* Q') s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> ((P and P') \<and>* (Q and Q')) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_conj_def pred_neg_def)
  by (fastforce simp: sep_disj_commute sep_add_commute)

lemma ex_pull:
  "\<exists>h s. P h s \<and> Q h \<Longrightarrow> \<exists>h. Q h \<and> (\<exists>s. P h s)"
  apply (fastforce)
  done

lemma sep_mp_snake_mp:
  "(P \<and>* (P \<longrightarrow>* (P \<leadsto>* Q))) s \<Longrightarrow> (P \<and>* Q) s"
  apply (clarsimp simp: sep_conj_def)
  apply (rename_tac x y)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=y in exI)
  apply (clarsimp)
  apply (clarsimp simp: sep_impl_def)
  apply (erule_tac x=x in allE)
  apply (clarsimp simp: sep_disj_commute)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  by (fastforce simp: sep_disj_commute sep_add_commute)

lemma septract_cancel:
  "(P -* Q) s \<Longrightarrow> (\<And>s. P s \<Longrightarrow> P' s) \<Longrightarrow> (\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> (P' -* Q') s"
  apply (clarsimp simp: septraction_def sep_impl_def pred_neg_def)
  apply (fastforce)
  done

lemma sep_coimpl_mp_zero:
  "(P \<leadsto>* Q) s \<Longrightarrow> P s   \<Longrightarrow> Q (0)"
  by (clarsimp simp: sep_coimpl_def sep_conj_def)

lemma sep_neg_not:
  "(P \<leadsto>* sep_false) s \<Longrightarrow> \<not>P s"
  apply (cases "P s")
   apply (drule(1) sep_coimpl_mp_zero)
   apply (clarsimp)
  apply (simp)
  done

lemma sep_antimp':
  "P s \<Longrightarrow> (Q \<leadsto>* (Q -* P)) s \<and> P s"
  apply (clarsimp)
  apply (erule sep_snake_septraction, assumption)
  done

definition
  sep_precise_conj :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
  "sep_precise_conj P \<equiv> P and (ALLS R. (sep_true \<longrightarrow>* (P \<leadsto>* R)))"

notation sep_precise_conj (infix "\<and>@" 50)

definition
  coprecise ::  "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow>  bool" where
  "coprecise P = (\<forall>s h h'. P h \<longrightarrow> P h' \<longrightarrow> s \<preceq> h \<longrightarrow> s \<preceq> h' \<longrightarrow> s \<noteq> 0 \<longrightarrow> h = h')"

definition
  cointuitionistic :: "(('a :: sep_algebra) \<Rightarrow> bool) \<Rightarrow> bool" where
  "cointuitionistic P = (\<forall>h h'. P h \<and> h' \<preceq> h \<longrightarrow> P h')"

lemma intuitionistic_def':
  "intuitionistic P = (\<forall>s R. (P \<and>* R) s \<longrightarrow> P s)"
  apply (rule iffI)
   apply (clarsimp simp: intuitionistic_def)
   apply (clarsimp simp: sep_conj_def)
  using sep_substate_disj_add apply blast
  apply (clarsimp simp: intuitionistic_def)
  apply (erule_tac x=h' in allE)
  apply (drule mp)
   apply (rule_tac x=sep_true in exI)
   apply (clarsimp simp:sep_conj_def sep_substate_def, fastforce)
  apply (assumption)
  done

lemma cointuitionistic_def':
  "cointuitionistic P = (\<forall>s R. P s \<longrightarrow> (R \<leadsto>* P) s)"
  apply (rule iffI)
   apply (clarsimp)
   apply (clarsimp simp: sep_coimpl_def)
   apply (clarsimp simp: sep_conj_def pred_neg_def cointuitionistic_def)
   apply (rename_tac R x y)
   apply (erule_tac x="x + y" in allE)
   apply (erule_tac x=y in allE)
   apply (clarsimp)
  using sep_disj_commuteI sep_substate_disj_add' apply blast
  apply (clarsimp simp: cointuitionistic_def)
  apply (erule_tac x=h in allE)
  apply (clarsimp)
  apply (clarsimp simp: sep_substate_def)
  apply (erule_tac x="\<lambda>s. s = z" in allE)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma saturated_split:
  "cointuitionistic P \<Longrightarrow> P s \<Longrightarrow> (Q \<and>* R) s \<Longrightarrow> ((P and Q) \<and>* (P and R)) s"
  apply (clarsimp simp: cointuitionistic_def sep_conj_def pred_conj_def)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=y in exI)
  apply (clarsimp)
  using sep_disj_commuteI sep_substate_disj_add sep_substate_disj_add' by blast

lemma sep_wand_dne:
  "((P \<longrightarrow>* sep_false) \<longrightarrow>* sep_false) s \<Longrightarrow> \<exists>s. P s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def)
  apply (erule_tac x=0 in allE)
  apply (clarsimp)
  done

lemma sep_snake_dne:
  "(sep_true \<leadsto>* P) s \<Longrightarrow> ((P \<leadsto>* sep_false) \<leadsto>* sep_false) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def)
  apply (rename_tac x y)
  apply (erule_tac x=y in allE)
  apply (erule_tac x=x in allE)
  apply (rule_tac x=x in exI)
  apply (rule_tac x=0 in exI)
  apply (clarsimp)
  apply (fastforce simp: sep_disj_commute sep_add_commute)
  done

lemma strictly_exactI:
  "(\<And>P s. ((P -* R) -* R) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)) \<Longrightarrow> strictly_exact R"
  apply (atomize)
  apply (clarsimp simp: strictly_exact_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def strictly_exact_def)
  apply (rename_tac h h')
  apply (erule_tac x="\<lambda>s. s = h" in allE)
  by (metis disjoint_zero_sym sep_add_commute sep_add_zero sep_disj_zero)

lemma strictly_exact_septractD:
  "strictly_exact R \<Longrightarrow> ((P -* R) -* R) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_conj_def sep_coimpl_def
                        strictly_exact_def)
  by (metis sep_add_cancel sep_add_commute sep_disj_commuteI)

lemma strictly_exact_def':
  "(\<forall>P s. ((P -* R) -* R) s \<longrightarrow> P (s :: 'a :: cancellative_sep_algebra)) = strictly_exact R"
  using strictly_exactI strictly_exact_septractD by auto

lemma copreciseI:
  "(\<forall>(s ) R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s) \<Longrightarrow> coprecise P"
  apply (clarsimp simp: coprecise_def)
  apply (clarsimp simp: sep_substate_def)
  apply (erule_tac x="0" in allE)
  apply (rename_tac s h h')
  apply (erule_tac x="\<lambda>s'. s' = s + h" in allE)
  apply (drule mp)
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  done

lemma sep_implI':
  "strictly_exact P \<Longrightarrow> (P -* R) s \<Longrightarrow> (P \<longrightarrow>* R) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def coprecise_def strictly_exact_def)
  apply (fastforce)
  done

lemma
  "\<forall>s P. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s \<Longrightarrow> \<exists>s. R s \<Longrightarrow> R s"
  apply (clarsimp simp: coprecise_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  by (metis disjoint_zero_sym sep_add_zero_sym)

lemma strictly_exactI':
  "\<forall>s R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s \<Longrightarrow> strictly_exact P"
  apply (clarsimp simp: strictly_exact_def)
  apply (erule_tac x="0" in allE)
  apply (rename_tac h h')
  apply (erule_tac x="\<lambda>h. h = h'" in allE)
  apply (drule mp)
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  done

lemma strictly_exact_def'':
  "(\<forall>s R. (P -* R) s \<longrightarrow> (P \<longrightarrow>* R) s) = strictly_exact P"
  using sep_implI' strictly_exactI' by blast

lemma conj_coimpl_precise:
  "(\<forall>s R. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s) \<Longrightarrow> precise P"
  apply (clarsimp simp: precise_def)
  apply (clarsimp simp: sep_substate_def)
  apply (rename_tac h h' z z')
  apply (erule_tac x="h + z" in allE)
  apply (erule_tac x="\<lambda>s. s= z" in allE)
  apply (drule mp)
   apply (clarsimp simp: sep_conj_def)
   apply (fastforce)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  using sep_add_cancel by fastforce

lemma precise_conj_coimpl:
  "precise P \<Longrightarrow> (\<forall>s R. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s)"
  apply (clarsimp simp: precise_def)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  by (metis cancellative_sep_algebra_class.sep_add_cancelD sep_add_commute
             sep_disj_commuteI sep_substate_disj_add)

lemma septract_cancel_eq_precise:
  "(\<forall>s. ((P -* (P \<and>* R)) s \<longrightarrow> R s)) = (\<forall>s. (P \<and>* R) s \<longrightarrow> (P \<leadsto>* R) s)"
  apply (rule iffI)
   apply (clarsimp)
   apply (clarsimp simp: sep_conj_def sep_impl_def septraction_def pred_neg_def sep_coimpl_def)
   apply (rule ccontr)
   apply (rename_tac x y h h')
   apply (erule_tac x=h' in allE)
   apply (clarsimp)
   apply (erule_tac x=h in allE)
   apply (clarsimp simp: sep_disj_commute)
   apply (erule_tac x=x in allE)
   apply (clarsimp)
   apply (erule_tac x=y in allE)
   apply (clarsimp)
   apply (fastforce simp: sep_disj_commute sep_add_commute)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  by (metis pred_neg_def sep_coimpl_def sep_conjI sep_conj_commuteI)

lemma sep_coimpl_cancel:
  "(P \<leadsto>* Q) s \<Longrightarrow> ((P \<and>* Q) s \<Longrightarrow> (P \<leadsto>* Q') s) \<Longrightarrow> (P \<leadsto>* Q') s"
  apply (clarsimp simp: sep_coimpl_def pred_neg_def)
  apply (clarsimp simp: sep_conj_def)
  by blast

lemma sep_cases:
  "R s \<Longrightarrow> (P \<and>* (P -* R)) s \<or> (P \<leadsto>* (sep_false)) s"
  apply (safe)
  apply (clarsimp simp: sep_coimpl_def)
  apply (rule ccontr)
  by (meson sep_antimp' sep_conj_sep_true_right sep_snake_mp)

lemma contra:
  "(\<forall>s. P s \<longrightarrow> Q s) \<Longrightarrow> (\<forall>s. \<not> Q s \<longrightarrow> \<not> P s )"
  apply (safe)
  by (fastforce)

lemma
  "(\<forall>R s. (P \<and>* R) (s) \<longrightarrow> (Q \<and>* R) (f s) ) = (\<forall>R s. (Q \<leadsto>* R) (f s) \<longrightarrow> (P \<leadsto>* R) ( s))"
  apply (clarsimp simp: sep_coimpl_def)
  apply (rule iffI)
   apply (clarsimp)
  apply (clarsimp)
  by (meson sep_coimpl_def sep_coimpl_def')

lemma
  "R s \<Longrightarrow> strictly_exact R \<Longrightarrow> (P \<longrightarrow>* R) s' \<Longrightarrow> (P -* R) s' \<Longrightarrow> s' \<preceq> s \<Longrightarrow> (P \<and>* sep_true) s"
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def septraction_def sep_impl_def)
  by (metis sep_add_commute sep_disj_commuteI strictly_exact_def)

lemma sep_coimpl_comb:
  " (R \<leadsto>* P) s \<Longrightarrow> (R \<leadsto>* Q) s \<Longrightarrow> (R \<leadsto>* (P and Q)) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def pred_conj_def)
  done

lemma sep_coimpl_contra:
  "(R \<leadsto>* (not Q)) s \<Longrightarrow> (R \<leadsto>* Q) s \<Longrightarrow> (R \<leadsto>* sep_false) s"
  apply (drule sep_coimpl_comb, assumption)
  apply (clarsimp simp: pred_neg_def pred_conj_def)
  done

lemma sep_comb':
  "((not Q) \<leadsto>* P) s \<Longrightarrow> (Q \<leadsto>* R) s \<Longrightarrow> ((R or P) \<and>* sep_true) s"
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def)
  by (metis (full_types) disjoint_zero_sym pred_disj_def sep_add_zero sep_add_zero_sym sep_disj_zero)

lemma sep_coimpl_dne:
  "((R \<leadsto>* sep_false) \<leadsto>* sep_false) s \<Longrightarrow> (R \<and>* sep_true) s"
  by (metis sep_coimpl_def sep_conj_sep_true_right sep_neg_not)

lemma sep_antimp_contrapos:
  " (R) s \<Longrightarrow> ((P \<longrightarrow>* not R) \<leadsto>* (not P)) s "
  by (metis pred_neg_def sep_coimpl_def' sep_mp_gen)

lemma sep_snake_trivial:
  "(sep_true \<leadsto>* Q) s \<Longrightarrow> Q s"
  by (metis pred_neg_def sep_coimpl_def sep_conj_sep_true')

lemma min_predD:
  "(R \<leadsto>* \<box>) s \<Longrightarrow> (R \<and>* sep_true) s  \<Longrightarrow> R s"
  using Sep_Cancel_Set.sep_conj_empty' sep_coimpl_dne sep_snake_mp by blast

lemma septract_sep_wand:
  "(P -* R) s \<Longrightarrow> (P \<longrightarrow>* Q) s \<Longrightarrow> (P -* (Q and R)) s"
  apply (clarsimp simp: sep_impl_def septraction_def pred_neg_def)
  by (fastforce simp: pred_conj_def)

lemma
  "(P -* (P \<and>* R)) s \<Longrightarrow> (P \<longrightarrow>* Q) s \<Longrightarrow> (\<And>s. (Q and (P \<and>* R)) s \<Longrightarrow> (P \<leadsto>* R) s) \<Longrightarrow> R s"
  using sep_septraction_snake septract_sep_wand by blast

lemma sep_elsewhereD:
  "(P -* sep_true) s \<Longrightarrow> (P \<longrightarrow>* (P \<leadsto>* R)) s \<Longrightarrow> R s"
  apply (drule (1) septract_sep_wand, simp add: pred_conj_def)
  using sep_septraction_snake  by blast

lemma sep_conj_coimplI:
  "(Q \<leadsto>* R) s \<Longrightarrow>  ((P \<and>* Q) \<leadsto>* (P -* R)) s  "
  by (metis sep_coimpl_def sep_coimpl_def' sep_conj_commuteI sep_mp_frame septraction_def)

lemma sep_conj_septract_curry:
  "((P \<and>* Q) -* R) s \<Longrightarrow>  (P -* (Q -* R)) s"
  by (smt sep_antimp' sep_conj_coimplI sep_septraction_snake)

lemma sep_snake_boxI:
  "Q s \<Longrightarrow> (\<box> \<leadsto>* Q) s"
  by (simp add: pred_neg_def sep_coimpl_def)

lemma sep_snake_boxD:
  "(Q \<leadsto>* \<box>) s \<Longrightarrow> ((Q \<leadsto>* sep_false) or Q) s"
  apply (simp only: pred_disj_def)
  apply (safe)
  using Sep_Cancel_Set.sep_conj_empty' sep_coimpl_cancel by blast

lemma septract_wandD:
  "(( R \<longrightarrow>* (not Q)) -* Q) s \<Longrightarrow> (not R) s"
  apply (erule sep_septraction_snake)
  using sep_antimp_contrapos by blast

lemma sep_impl_septractD:
  "(P \<longrightarrow>* Q) s \<Longrightarrow> (R -* (not Q)) s \<Longrightarrow> ((R and not P) -* (not Q)) s"
  apply (clarsimp simp: sep_impl_def pred_neg_def septraction_def)
  apply (erule_tac x=h' in allE)
  apply (clarsimp simp: pred_conj_def)
  apply (fastforce)
  done

lemma sep_neg_impl:
  "(not (R \<longrightarrow>* Q)) = (R -* (not Q)) "
  apply (clarsimp simp: pred_neg_def septraction_def)
  done

lemma
  "P s \<Longrightarrow> (R -* Q) s \<Longrightarrow> ((R and (P -* Q)) -* Q) s"
  apply (clarsimp simp: septraction_def sep_impl_def pred_neg_def pred_conj_def)
  by (fastforce simp: sep_add_commute sep_disj_commute)

lemma sep_coimpl_notempty:
  "(Q \<leadsto>* (not \<box>)) s \<Longrightarrow> (not Q) s"
  apply (clarsimp simp: sep_coimpl_def pred_neg_def)
  done

method sep_subst uses add = (sep_frule (direct) add)

lemma septract_empty_empty:
  "(P -* \<box>) s \<Longrightarrow> \<box> (s :: 'a :: cancellative_sep_algebra)"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_empty_def)
  done

lemma septract_trivial:
  "P s \<Longrightarrow> (sep_true -* P) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def sep_empty_def)
  using sep_disj_zero by fastforce

lemma sep_empty_and_conj:
  "\<box> s \<Longrightarrow> (P \<and>* Q) s \<Longrightarrow> P (s :: 'a :: cancellative_sep_algebra)"
  by (metis sep_conj_def sep_disj_positive_zero sep_empty_def)

lemma sep_conj_coimpl_mp:
  "(P \<and>* R) s \<Longrightarrow> (P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* (Q and R)) s"
  apply (drule (2) sep_coimpl_mp_gen, clarsimp simp: pred_conj_def conj_commute)
  done

lemma sep_conj_coimpl_contrapos_mp:
  "(P \<and>* Q) s \<Longrightarrow> (R \<leadsto>* (not Q)) s \<Longrightarrow> (Q \<and>* (P and (not R))) s"
  apply (subst (asm) sep_coimpl_contrapos)
  apply (clarsimp simp: pred_neg_def)
  apply (sep_drule (direct) sep_conj_coimpl_mp[where P=Q], assumption)
  apply (clarsimp simp: pred_conj_def conj_commute)
  done

end


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

(* Mendelson Variant (Church) *)

theory System_M0 imports System_L1 begin

inductive M0 (\<open>\<MM>\<^sub>0\<close>) where
  M0_MP: \<open>\<MM>\<^sub>0 q\<close> if \<open>\<MM>\<^sub>0 p\<close> and \<open>\<MM>\<^sub>0 (p \<rightarrow> q)\<close> |
  M0_1:  \<open>\<MM>\<^sub>0 (p \<rightarrow> (q \<rightarrow> p))\<close> |
  M0_2:  \<open>\<MM>\<^sub>0 ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> |
  M0_3:  \<open>\<MM>\<^sub>0 (((\<sim> p) \<rightarrow> q) \<rightarrow> (((\<sim> p) \<rightarrow> (\<sim> q)) \<rightarrow> p))\<close>

lemma M0_4: \<open>\<MM>\<^sub>0 ((\<sim> p) \<rightarrow> (((\<sim> q) \<rightarrow> (\<sim> p)) \<rightarrow> (p \<rightarrow> q)))\<close>
  using M0_1 M0_2 M0_3 M0_MP by metis

lemma M0_5: \<open>\<MM>\<^sub>0 ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close>
  using M0_1 M0_2 M0_4 M0_MP by metis

lemma M0_6: \<open>\<MM>\<^sub>0 (((\<sim> q) \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> p))\<close>
  using M0_2 M0_5 M0_MP by metis

lemma M0_7: \<open>\<MM>\<^sub>0 (q \<rightarrow> (((\<sim> q) \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> p)))\<close>
  using M0_1 M0_6 M0_MP by metis

lemma M0_8: \<open>\<MM>\<^sub>0 (q \<rightarrow> ((\<sim> q) \<rightarrow> p))\<close>
  using M0_1 M0_2 M0_7 M0_MP by metis

lemma M0_10: \<open>\<MM>\<^sub>0 ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r))))\<close>
  using M0_1 M0_2 M0_MP by metis

lemma M0_11: \<open>\<MM>\<^sub>0 ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_1 M0_2 M0_10 M0_MP by metis

lemma M0_12: \<open>\<MM>\<^sub>0 (((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q)) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_2 M0_11 M0_MP by metis

lemma M0_13: \<open>\<MM>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q)) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r))))\<close>
  using M0_1 M0_12 M0_MP by metis

lemma M0_14: \<open>\<MM>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_1 M0_2 M0_13 M0_MP by metis

lemma M0_15: \<open>\<MM>\<^sub>0 (((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (p \<rightarrow> q)) \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_2 M0_MP by metis

lemma M0_16: \<open>\<MM>\<^sub>0 ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> p))\<close>
  using M0_1 M0_2 M0_MP by metis

lemma M0_17: \<open>\<MM>\<^sub>0 (p \<rightarrow> p)\<close>
  using M0_1 M0_16 M0_MP by metis

lemma M0_19: \<open>\<MM>\<^sub>0 ((p \<rightarrow> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> q))\<close>
  using M0_15 M0_16 M0_MP by metis

lemma M0_21: \<open>\<MM>\<^sub>0 (((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> q)))\<close>
  using M0_1 M0_MP by metis

lemma M0_22: \<open>\<MM>\<^sub>0 (((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_1 M0_14 M0_MP by blast

lemma M0_23: \<open>\<MM>\<^sub>0 ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using M0_2 M0_11 M0_22 M0_MP by metis

lemma M0_26: \<open>\<MM>\<^sub>0 (((\<sim> q) \<rightarrow> q) \<rightarrow> (((\<sim> q) \<rightarrow> q) \<rightarrow> q))\<close>
  using M0_17 M0_23 M0_MP by (metis M0_1 M0_3)

lemma M0_27: \<open>\<MM>\<^sub>0 (((\<sim> p) \<rightarrow> p) \<rightarrow> p)\<close>
  using M0_19 M0_26 M0_MP by metis

theorem M0_iff_L1: \<open>\<MM>\<^sub>0 p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_M0_1: \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> for p q
    using L1_completeness by simp
  have L1_M0_2: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close> for p q r
    using L1_completeness by simp
  have L1_M0_3: \<open>\<turnstile> (((\<sim> p) \<rightarrow> q) \<rightarrow> (((\<sim> p) \<rightarrow> (\<sim> q)) \<rightarrow> p))\<close> for p q
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<MM>\<^sub>0 p\<close>
    using that by (induct) (metis MP, metis L1_M0_1, metis L1_M0_2, metis L1_M0_3)
  show \<open>\<MM>\<^sub>0 p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis M0_MP, metis M0_14, metis M0_27, metis M0_8)
qed

theorem M0_soundness: \<open>\<MM>\<^sub>0 p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: M0.induct) auto

theorem M0_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<MM>\<^sub>0 p\<close>
  using M0_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<MM>\<^sub>0 p\<close>
  unfolding valid_def using M0_soundness M0_completeness by blast

lemmas M0 = M0.intros main

end


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

chapter \<open>More bit operations on integers\<close>

theory More_Bits_Int
imports
  "HOL-Word.Bits_Int"
  "HOL-Word.Bit_Comprehension"
begin

text \<open>Preliminaries\<close>

lemma last_rev' [simp]: "last (rev xs) = hd xs" \<comment> \<open>TODO define \<open>last []\<close> as \<open>hd []\<close>?\<close>
  by (cases xs) (simp add: last_def hd_def, simp)

lemma nat_LEAST_True: "(LEAST _ :: nat. True) = 0"
  by (rule Least_equality) simp_all

text \<open>
  Use this function to convert numeral @{typ integer}s quickly into @{typ int}s.
  By default, it works only for symbolic evaluation; normally generated code raises
  an exception at run-time. If theory \<open>Code_Target_Bits_Int\<close> is imported,
  it works again, because then @{typ int} is implemented in terms of @{typ integer}
  even for symbolic evaluation.
\<close>

definition int_of_integer_symbolic :: "integer \<Rightarrow> int"
  where "int_of_integer_symbolic = int_of_integer"

lemma int_of_integer_symbolic_aux_code [code nbe]:
  "int_of_integer_symbolic 0 = 0"
  "int_of_integer_symbolic (Code_Numeral.Pos n) = Int.Pos n"
  "int_of_integer_symbolic (Code_Numeral.Neg n) = Int.Neg n"
  by (simp_all add: int_of_integer_symbolic_def)

code_identifier
  code_module Bits_Int \<rightharpoonup>
  (SML) Bits_Int and (OCaml) Bits_Int and (Haskell) Bits_Int and (Scala) Bits_Int
| code_module More_Bits_Int \<rightharpoonup>
  (SML) Bits_Int and (OCaml) Bits_Int and (Haskell) Bits_Int and (Scala) Bits_Int
| code_module Bit_Representation \<rightharpoonup>
  (SML) Bits_Int and (OCaml) Bits_Int and (Haskell) Bits_Int and (Scala) Bits_Int

section \<open>Symbolic bit operations on numerals and @{typ int}s\<close>

fun bitOR_num :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "bitOR_num num.One num.One = num.One"
| "bitOR_num num.One (num.Bit0 n) = num.Bit1 n"
| "bitOR_num num.One (num.Bit1 n) = num.Bit1 n"
| "bitOR_num (num.Bit0 m) num.One = num.Bit1 m"
| "bitOR_num (num.Bit0 m) (num.Bit0 n) = num.Bit0 (bitOR_num m n)"
| "bitOR_num (num.Bit0 m) (num.Bit1 n) = num.Bit1 (bitOR_num m n)"
| "bitOR_num (num.Bit1 m) num.One = num.Bit1 m"
| "bitOR_num (num.Bit1 m) (num.Bit0 n) = num.Bit1 (bitOR_num m n)"
| "bitOR_num (num.Bit1 m) (num.Bit1 n) = num.Bit1 (bitOR_num m n)"

fun bitAND_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitAND_num num.One num.One = Some num.One"
| "bitAND_num num.One (num.Bit0 n) = None"
| "bitAND_num num.One (num.Bit1 n) = Some num.One"
| "bitAND_num (num.Bit0 m) num.One = None"
| "bitAND_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit0 m) (num.Bit1 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit1 m) num.One = Some num.One"
| "bitAND_num (num.Bit1 m) (num.Bit0 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit1 m) (num.Bit1 n) = (case bitAND_num m n of None \<Rightarrow> Some num.One | Some n' \<Rightarrow> Some (num.Bit1 n'))"

fun bitXOR_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitXOR_num num.One num.One = None"
| "bitXOR_num num.One (num.Bit0 n) = Some (num.Bit1 n)"
| "bitXOR_num num.One (num.Bit1 n) = Some (num.Bit0 n)"
| "bitXOR_num (num.Bit0 m) num.One = Some (num.Bit1 m)"
| "bitXOR_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitXOR_num m n)"
| "bitXOR_num (num.Bit0 m) (num.Bit1 n) = Some (case bitXOR_num m n of None \<Rightarrow> num.One | Some n' \<Rightarrow> num.Bit1 n')"
| "bitXOR_num (num.Bit1 m) num.One = Some (num.Bit0 m)"
| "bitXOR_num (num.Bit1 m) (num.Bit0 n) = Some (case bitXOR_num m n of None \<Rightarrow> num.One | Some n' \<Rightarrow> num.Bit1 n')"
| "bitXOR_num (num.Bit1 m) (num.Bit1 n) = map_option num.Bit0 (bitXOR_num m n)"

fun bitORN_num :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "bitORN_num num.One num.One = num.One"
| "bitORN_num num.One (num.Bit0 m) = num.Bit1 m"
| "bitORN_num num.One (num.Bit1 m) = num.Bit1 m"
| "bitORN_num (num.Bit0 n) num.One = num.Bit0 num.One"
| "bitORN_num (num.Bit0 n) (num.Bit0 m) = Num.BitM (bitORN_num n m)"
| "bitORN_num (num.Bit0 n) (num.Bit1 m) = num.Bit0 (bitORN_num n m)"
| "bitORN_num (num.Bit1 n) num.One = num.One"
| "bitORN_num (num.Bit1 n) (num.Bit0 m) = Num.BitM (bitORN_num n m)"
| "bitORN_num (num.Bit1 n) (num.Bit1 m) = Num.BitM (bitORN_num n m)"

fun bitANDN_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitANDN_num num.One num.One = None"
| "bitANDN_num num.One (num.Bit0 n) = Some num.One"
| "bitANDN_num num.One (num.Bit1 n) = None"
| "bitANDN_num (num.Bit0 m) num.One = Some (num.Bit0 m)"
| "bitANDN_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitANDN_num m n)"
| "bitANDN_num (num.Bit0 m) (num.Bit1 n) = map_option num.Bit0 (bitANDN_num m n)"
| "bitANDN_num (num.Bit1 m) num.One = Some (num.Bit0 m)"
| "bitANDN_num (num.Bit1 m) (num.Bit0 n) = (case bitANDN_num m n of None \<Rightarrow> Some num.One | Some n' \<Rightarrow> Some (num.Bit1 n'))"
| "bitANDN_num (num.Bit1 m) (num.Bit1 n) = map_option num.Bit0 (bitANDN_num m n)"

lemma int_numeral_bitOR_num: "numeral n OR numeral m = (numeral (bitOR_num n m) :: int)"
by(induct n m rule: bitOR_num.induct) simp_all

lemma int_numeral_bitAND_num: "numeral n AND numeral m = (case bitAND_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct n m rule: bitAND_num.induct)(simp_all split: option.split)

lemma int_numeral_bitXOR_num:
  "numeral m XOR numeral n = (case bitXOR_num m n of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct m n rule: bitXOR_num.induct)(simp_all split: option.split)

lemma int_or_not_bitORN_num:
  "numeral n OR NOT (numeral m) = (- numeral (bitORN_num n m) :: int)"
by(induct n m rule: bitORN_num.induct)(simp_all add: Num.add_One BitM_inc)

lemma int_and_not_bitANDN_num:
  "numeral n AND NOT (numeral m) = (case bitANDN_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct n m rule: bitANDN_num.induct)(simp_all add: Num.add_One BitM_inc split: option.split)

lemma int_not_and_bitANDN_num:
  "NOT (numeral m) AND numeral n = (case bitANDN_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(simp add: int_and_not_bitANDN_num[symmetric] int_and_comm)

section \<open>Bit masks of type \<^typ>\<open>int\<close>\<close>

primrec bin_mask :: "nat \<Rightarrow> int"
where
  "bin_mask 0 = 0"
| "bin_mask (Suc n) = bin_mask n BIT True"

lemma bin_mask_conv_pow2:
  "bin_mask n = 2 ^ n - 1"
by(induct n)(simp_all add: Bit_def)

lemma bin_mask_ge0: "bin_mask n \<ge> 0"
by(induct n) simp_all

lemma and_bin_mask_conv_mod: "x AND bin_mask n = x mod 2 ^ n"
proof(induction n arbitrary: x)
  case 0 thus ?case by simp
next
  case (Suc n)
  obtain x' b where "x = x' BIT b" by(cases x rule: bin_exhaust)
  with Suc show ?case by (cases b)
    (simp_all, simp_all add: Bit_def pos_zmod_mult_2 add.commute)
qed

lemma bin_mask_numeral:
  "bin_mask (numeral n) = bin_mask (pred_numeral n) BIT True"
by(simp add: numeral_eq_Suc)

lemma bin_nth_mask [simp]: "bin_nth (bin_mask n) i \<longleftrightarrow> i < n"
proof(induction n arbitrary: i)
  case (Suc n)
  thus ?case by(cases i) simp_all
qed simp

lemma bin_mask_p1_conv_shift: "bin_mask n + 1 = 1 << n"
by(induct n) simp_all

section \<open>More on bit comprehension\<close>

inductive wf_set_bits_int :: "(nat \<Rightarrow> bool) \<Rightarrow> bool"
  for f :: "nat \<Rightarrow> bool"
where
  zeros: "\<forall>n' \<ge> n. \<not> f n' \<Longrightarrow> wf_set_bits_int f"
| ones: "\<forall>n' \<ge> n. f n' \<Longrightarrow> wf_set_bits_int f"

lemma wf_set_bits_int_simps: "wf_set_bits_int f \<longleftrightarrow> (\<exists>n. (\<forall>n'\<ge>n. \<not> f n') \<or> (\<forall>n'\<ge>n. f n'))"
by(auto simp add: wf_set_bits_int.simps)

lemma wf_set_bits_int_const [simp]: "wf_set_bits_int (\<lambda>_. b)"
by(cases b)(auto intro: wf_set_bits_int.intros)

lemma wf_set_bits_int_fun_upd [simp]:
  "wf_set_bits_int (f(n := b)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain n'
    where "(\<forall>n''\<ge>n'. \<not> (f(n := b)) n'') \<or> (\<forall>n''\<ge>n'. (f(n := b)) n'')"
    by(auto simp add: wf_set_bits_int_simps)
  hence "(\<forall>n''\<ge>max (Suc n) n'. \<not> f n'') \<or> (\<forall>n''\<ge>max (Suc n) n'. f n'')" by auto
  thus ?rhs by(auto simp only: wf_set_bits_int_simps)
next
  assume ?rhs
  then obtain n' where "(\<forall>n''\<ge>n'. \<not> f n'') \<or> (\<forall>n''\<ge>n'. f n'')" (is "?wf f n'")
    by(auto simp add: wf_set_bits_int_simps)
  hence "?wf (f(n := b)) (max (Suc n) n')" by auto
  thus ?lhs by(auto simp only: wf_set_bits_int_simps)
qed

lemma wf_set_bits_int_Suc [simp]:
  "wf_set_bits_int (\<lambda>n. f (Suc n)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
by(auto simp add: wf_set_bits_int_simps intro: le_SucI dest: Suc_le_D)

context
  fixes f
  assumes wff: "wf_set_bits_int f"
begin

lemma int_set_bits_unfold_BIT:
  "set_bits f = set_bits (f \<circ> Suc) BIT f 0"
using wff proof cases
  case (zeros n)
  show ?thesis
  proof(cases "\<forall>n. \<not> f n")
    case True
    hence "f = (\<lambda>_. False)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "f n'" by blast
    with zeros have "(LEAST n. \<forall>n'\<ge>n. \<not> f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. \<not> f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. \<not> f n') = (\<lambda>n. \<forall>n'\<ge>n. \<not> f (Suc n'))" by(auto dest: Suc_le_D)
    also from zeros have "\<forall>n'\<ge>n. \<not> f (Suc n')" by auto
    ultimately show ?thesis using zeros
      by(simp (no_asm_simp) add: set_bits_int_def exI split del: if_split)(rule bin_rl_eqI, auto simp add: bin_last_bl_to_bin hd_map bin_rest_bl_to_bin map_tl[symmetric] map_map[symmetric] map_Suc_upt simp del: map_map)
  qed
next
  case (ones n)
  show ?thesis
  proof(cases "\<forall>n. f n")
    case True
    hence "f = (\<lambda>_. True)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "\<not> f n'" by blast
    with ones have "(LEAST n. \<forall>n'\<ge>n. f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. f n') = (\<lambda>n. \<forall>n'\<ge>n. f (Suc n'))" by(auto dest: Suc_le_D)
    also from ones have "\<forall>n'\<ge>n. f (Suc n')" by auto
    moreover from ones have "(\<exists>n. \<forall>n'\<ge>n. \<not> f n') = False"
      by(auto intro!: exI[where x="max n m" for n m] simp add: max_def split: if_split_asm)
    moreover hence "(\<exists>n. \<forall>n'\<ge>n. \<not> f (Suc n')) = False"
      by(auto elim: allE[where x="Suc n" for n] dest: Suc_le_D)
    ultimately show ?thesis using ones
      by(simp (no_asm_simp) add: set_bits_int_def exI split del: if_split)(auto simp add: Let_def bin_last_bl_to_bin hd_map bin_rest_bl_to_bin map_tl[symmetric] map_map[symmetric] map_Suc_upt simp del: map_map)
  qed
qed

lemma bin_last_set_bits [simp]:
  "bin_last (set_bits f) = f 0"
  by (subst int_set_bits_unfold_BIT) simp_all

lemma bin_rest_set_bits [simp]:
  "bin_rest (set_bits f) = set_bits (f \<circ> Suc)"
  by (subst int_set_bits_unfold_BIT) simp_all

lemma bin_nth_set_bits [simp]:
  "bin_nth (set_bits f) m = f m"
using wff proof (induction m arbitrary: f)
  case 0
  then show ?case
    by (simp add: More_Bits_Int.bin_last_set_bits)
next
  case Suc
  from Suc.IH [of "f \<circ> Suc"] Suc.prems show ?case
    by (simp add: More_Bits_Int.bin_rest_set_bits comp_def)
qed

end

end


theory Modules
imports Lang_Typed TermX_Antiquot Procedures
begin

lemma well_typed_lift_same:
  assumes "i\<ge>length E"
  shows "well_typed'' E pg \<Longrightarrow> lift_proc_in_prog pg i = pg"
    and "well_typed_proc'' E p T \<Longrightarrow> lift_proc p i = p"
proof -
  show r1: "well_typed'' E pg \<Longrightarrow> i\<ge>length E \<Longrightarrow> lift_proc_in_prog pg i = pg"
    and r2: "well_typed_proc'' E p T \<Longrightarrow> i\<ge>length E \<Longrightarrow> lift_proc p i = p"
  by (induct arbitrary: i and i rule:well_typed''_well_typed_proc''.inducts, auto)
qed (auto simp: assms)

lemma well_typed_lift:
  assumes "well_typed_proc'' (F@E) q T"
  shows "well_typed_proc'' (F@U#E) (lift_proc q (length F)) T"
proof -
  have "\<And>T F. well_typed'' (F@E) pg \<Longrightarrow> well_typed'' (F@T#E) (lift_proc_in_prog pg (length F))"
   and res:"\<And>T U F. well_typed_proc'' (F@E) q U \<Longrightarrow> well_typed_proc'' (F@T#E) (lift_proc q (length F)) U"
  proof (induct pg and q)
  case Assign thus ?case by (auto simp: wt_Assign_iff[symmetric])
  next case Sample thus ?case by (auto simp: wt_Sample_iff[symmetric])
  next case (Proc body args ret) thus ?case by (auto simp: wt_Proc_iff[symmetric])
  next case (CallProc v p a U) thus ?case by (auto simp: wt_CallProc_iff[symmetric])
  next case Seq thus ?case by (auto simp: wt_Seq_iff[symmetric])
  next case Skip thus ?case by (auto simp: wt_Skip)
  next case IfTE thus ?case by (auto simp: wt_IfTE_iff[symmetric])
  next case While thus ?case by (auto simp: wt_While_iff[symmetric])
  next case (ProcRef n)
    from ProcRef show ?case by (auto simp: wt_ProcRef_iff[symmetric] nth_append)
  next case (ProcAbs p T U)
    from ProcAbs.prems obtain U1 U2 where U:"U=ProcFun U1 U2"
      and wt: "well_typed_proc'' (U1#F@E) p U2"
      unfolding wt_ProcAbs_iff[symmetric] by auto
    show ?case apply (simp add: wt_ProcAbs_iff[symmetric])
      apply (rule exI[of _ U1], rule exI[of _ U2], simp add: U)
      apply (rule ProcAbs.hyps[where F="U1#F" and T=T and U=U2, simplified])
      by (fact wt)
  next case (ProcAppl p1 p2 ) thus ?case by (auto simp: wt_ProcAppl_iff[symmetric], metis)
  qed
  from res assms show ?thesis .
qed

lemma well_typed_subst':
  assumes "well_typed_proc'' (F@E) q T"
  shows "well_typed'' (F@T#E) pg \<Longrightarrow> well_typed'' (F@E) (subst_proc_in_prog (length F) q pg)"
  and "well_typed_proc'' (F@T#E) p U \<Longrightarrow> well_typed_proc'' (F@E) (subst_proc (length F) q p) U"
proof -
  have res:"\<And>T E F q.
    well_typed'' (F@T#E) pg \<Longrightarrow>
    well_typed_proc'' (F@E) q T \<Longrightarrow>
    well_typed'' (F@E) (subst_proc_in_prog (length F) q pg)"
   and  "\<And>T U E F q.
    well_typed_proc'' (F@T#E) p U \<Longrightarrow>
    well_typed_proc'' (F@E) q T \<Longrightarrow>
    well_typed_proc'' (F@E) (subst_proc (length F) q p) U"
  proof (induct pg and p)
    case Assign thus ?case by (auto simp: wt_Assign_iff[symmetric])
    next case Sample thus ?case by (auto simp: wt_Sample_iff[symmetric])
    next case Proc thus ?case by (auto simp: wt_Proc_iff[symmetric])
    next case (ProcRef n)
      from ProcRef show ?case by (auto simp: wt_ProcRef_iff[symmetric] nth_append)
    next case (ProcAppl p1 p2)
      from ProcAppl.prems(1) obtain T' where
        wt1: "well_typed_proc'' (F@T#E) p1 (ProcFun T' U)" and wt2: "well_typed_proc'' (F@T#E) p2 T'"
        unfolding wt_ProcAppl_iff[symmetric] by auto
      have wt1': "well_typed_proc'' (F@E) (subst_proc (length F) q p1) (ProcFun T' U)"
        by (rule ProcAppl, rule wt1, rule ProcAppl)
      have wt2': "well_typed_proc'' (F@E) (subst_proc (length F) q p2) T'"
        by (rule ProcAppl, rule wt2, rule ProcAppl)
      show ?case apply simp
        unfolding wt_ProcAppl_iff[symmetric] apply (rule exI[of _ T']) using wt1' wt2' by auto
    next case Seq thus ?case by (auto simp: wt_Seq_iff[symmetric])
    next case Skip show ?case by (simp, rule wt_Skip)
    next case IfTE thus ?case by (auto simp: wt_IfTE_iff[symmetric])
    next case While thus ?case by (auto simp: wt_While_iff[symmetric])
    next case CallProc thus ?case by (auto simp: wt_CallProc_iff[symmetric])
    next case (ProcAbs p)
      from ProcAbs.prems obtain T' U' where U: "U = ProcFun T' U'" and wt: "well_typed_proc'' (T' # F @ T # E) p U'"
        unfolding wt_ProcAbs_iff[symmetric] by auto
      show ?case apply simp
        unfolding wt_ProcAbs_iff[symmetric]
        apply (rule exI[of _ T'], rule exI[of _ U'], auto simp: U wt)
        apply (rule ProcAbs.hyps[of "T'#F", simplified])
        apply (fact wt)
        apply (rule well_typed_lift[where F="[]", simplified])
        by (fact ProcAbs.prems)
    qed
  with assms
  show "well_typed'' (F@T#E) pg \<Longrightarrow> well_typed'' (F@E) (subst_proc_in_prog (length F) q pg)"
  and "well_typed_proc'' (F@T#E) p U \<Longrightarrow> well_typed_proc'' (F@E) (subst_proc (length F) q p) U"
    by auto
qed

lemma well_typed_subst:
  assumes "well_typed_proc'' (F@E) q T"
  assumes "well_typed'' (F@T#E) pg"
  shows "well_typed'' (F@E) (subst_proc_in_prog (length F) q pg)"
using assms by (rule well_typed_subst')

lemma well_typed_proc_subst:
  assumes "well_typed_proc'' (F@E) q T"
  assumes "well_typed_proc'' (F@T#E) p U"
  shows "well_typed_proc'' (F@E) (subst_proc (length F) q p) U"
using assms by (rule well_typed_subst')

definition "module_type_rep_set envT proctypes \<equiv> {procs. list_all2 (\<lambda>T p. well_typed_proc'' [] p (foldr ProcFun envT (ProcSimple T))) proctypes procs}"
lemma module_type_rep_set_inhabited: "\<exists>x. x \<in> module_type_rep_set env procT"
  SORRY

class module_type =
  fixes "module_type_procs" :: "'a \<Rightarrow> procedure_rep list"
  fixes "module_type_construct" :: "procedure_rep list \<Rightarrow> 'a"
  fixes "module_type_proc_names" :: "'a itself \<Rightarrow> id list"
  fixes "module_type_proc_types" :: "'a itself \<Rightarrow> procedure_type list"
  fixes "module_type_environment" :: "'a itself \<Rightarrow> procedure_type_open list"
  assumes module_type_proc_names_distict: "distinct (module_type_proc_names TYPE('a))"
  assumes module_type_procs_length: "length (module_type_procs a) = length (module_type_proc_names TYPE('a))"
  assumes module_type_procs_welltyped: "list_all2
          (\<lambda>T p. well_typed_proc'' [] p (foldr ProcFun (module_type_environment TYPE('a)) (ProcSimple T)))
          (module_type_proc_types TYPE('a)) (module_type_procs m)"
  assumes module_type_construct_inverse:
      "list_all2
          (\<lambda>T p. well_typed_proc'' [] p (foldr ProcFun (module_type_environment TYPE('a)) (ProcSimple T)))
          (module_type_proc_types TYPE('a)) procs
      \<Longrightarrow> module_type_procs (module_type_construct procs) = procs"
  assumes module_type_procs_inverse: "module_type_construct (module_type_procs m) = m"

class module_type_closed = module_type +
  assumes closed_module_type_empty: "module_type_environment TYPE('a) = []"

definition "module_type_proc_types_open (_::'a::module_type itself) \<equiv>
  map (\<lambda>T. foldr ProcFun (module_type_environment TYPE('a)) (ProcSimple T)) (module_type_proc_types TYPE('a))"

lemma module_type_procs_welltyped': "list_all2
          (\<lambda>T p. well_typed_proc'' [] p T) (module_type_proc_types_open TYPE('a::module_type)) (module_type_procs (m::'a))"
  unfolding module_type_proc_types_open_def apply (subst list_all2_map1)
  by (fact module_type_procs_welltyped)

definition "module_type_instantiation (_::'mt::module_type itself) (_::'mtc::module_type_closed itself)
  == module_type_proc_names TYPE('mt) = module_type_proc_names TYPE('mtc)
   \<and> module_type_proc_types TYPE('mt) = module_type_proc_types TYPE('mtc)"

definition "instantiate_procedure args p = fold (\<lambda>a p. apply_procedure p a) args p"

(* We need to remove const constraints for the next lemma. Is there a cleaner way? *)
ML {*
  val consts_to_unconstrain = [@{const_name module_type_procs},
                               @{const_name module_type_construct},
                               @{const_name module_type_proc_names},
                               @{const_name module_type_proc_types},
                               @{const_name module_type_environment}];
  val consts_orig_constraints = map (Sign.the_const_constraint @{theory}) consts_to_unconstrain
*}
setup {*
  fold (fn c => fn thy => Sign.add_const_constraint (c,NONE) thy) consts_to_unconstrain
*}

declare[[show_types=false]]
lemma OFCLASS_module_type:
  fixes procs construct proc_names proc_types environment

  (* These are directly instantiated with the various theorems generated by
     the definitional tools used for defining the module type *)
  assumes module_type_procs: "module_type_procs::'a\<Rightarrow>_ == procs"
  assumes module_type_construct: "module_type_construct::_\<Rightarrow>'a == construct"
  assumes module_type_proc_names: "module_type_proc_names == \<lambda>_\<Colon>'a itself. proc_names"
  assumes module_type_proc_types: "module_type_proc_types == \<lambda>_\<Colon>'a itself. proc_types"
  assumes module_type_environment: "module_type_environment == \<lambda>_\<Colon>'a itself. environment"
  assumes Rep: "\<And>m. procs (m\<Colon>'a) \<in> module_type_rep_set environment proc_types"
  assumes Rep_inverse: "\<And>m. construct (procs m) = m"
  assumes Abs_inverse: "\<And>m. m \<in> module_type_rep_set environment proc_types \<Longrightarrow> procs (construct m) = m"

  (* These need to be proven. "simp" should solve all of them once automatically. *)
  assumes distinct: "distinct proc_names"
  assumes length: "length proc_names = length proc_types"
  shows "OFCLASS('a, module_type_class)"
proof intro_classes
  show "distinct (module_type_proc_names TYPE('a))"
    unfolding module_type_proc_names using distinct by simp
  fix m::'a
  have "length (module_type_procs m) = length (module_type_proc_types TYPE('a))"
    unfolding module_type_procs module_type_proc_types
    using Rep unfolding module_type_rep_set_def apply auto
    by (metis list_all2_conv_all_nth)
  thus "length (module_type_procs m) = length (module_type_proc_names TYPE('a))"
    unfolding module_type_proc_types module_type_proc_names
    using length by auto
  show "list_all2 (\<lambda>T p. well_typed_proc'' [] p (foldr ProcFun (module_type_environment TYPE('a)) (ProcSimple T)))
          (module_type_proc_types TYPE('a)) (module_type_procs m)"
    unfolding module_type_environment module_type_proc_types module_type_procs
    using Rep unfolding module_type_rep_set_def by auto
  show "module_type_construct (module_type_procs m) = m"
    unfolding module_type_construct module_type_procs
    by (fact Rep_inverse)
  fix ps
  assume in_rep_set: "list_all2 (\<lambda>T p. well_typed_proc'' [] p (foldr ProcFun (module_type_environment TYPE('a)) (ProcSimple T)))
              (module_type_proc_types TYPE('a)) ps"
  show "module_type_procs (module_type_construct ps :: 'a) = ps"
    unfolding module_type_procs module_type_construct
    apply (rule Abs_inverse) using in_rep_set
    unfolding module_type_rep_set_def module_type_environment module_type_proc_types
    by simp
qed

declare[[show_types=false]]
lemma OFCLASS_module_type_closed:
  fixes environment
  assumes module_type_environment: "module_type_environment == \<lambda>_\<Colon>'a itself. []"
  assumes module_type: "OFCLASS('a, module_type_class)"
  shows "OFCLASS('a, module_type_closed_class)"
unfolding module_type_closed_class_def
  unfolding class.module_type_closed_axioms_def unfolding assms using assms
  by simp_all

(* Recover stored type constraints *)
setup {*
  fold2 (fn c => fn T => fn thy => Sign.add_const_constraint (c,SOME (Logic.unvarifyT_global T)) thy)
      consts_to_unconstrain consts_orig_constraints
*}

ML_file "modules.ML"

setup {*
fn thy => thy |> snd o
Modules.define_module_type {
  name = @{binding MT},
  arguments = [],
  procs = [{name = @{binding a}, typ = @{typ "(unit,int)procedure"}},
           {name = @{binding b}, typ = @{typ "(int*unit,int)procedure"}}]
}*}

(* TODO: move *)
lemma mk_expression_untyped_inverse: "mk_expression_typed (mk_expression_untyped e) = e"
  unfolding mk_expression_typed_def mk_expression_untyped_fun
            mk_expression_untyped_type embedding_inv' e_fun_def
  apply simp unfolding e_vars_def
  by (metis (full_types) Rep_expression_inverse expression_rep.surjective old.unit.exhaust)

(* TODO: move *)
lemma mk_procedure_untyped_inverse: "mk_procedure_typed (mk_procedure_untyped p) = p"
  unfolding mk_procedure_untyped_def apply simp
  unfolding Rep_program_inverse Rep_procargvars_inverse  mk_expression_untyped_inverse
  by auto

(* TODO: automate this proof *)
lemma "MT.b (MT.MAKE a b) = b"
unfolding MT.b_def MT.MAKE_def
apply (subst module_type_construct_inverse)
unfolding module_type_proc_types_MT_def module_type_environment_MT_def apply auto
using procedure_functor_welltyped[of a]
unfolding procedure_functor_type_procfun_def procedure_functor_type_procedure_ext_def
apply simp
using procedure_functor_welltyped[of b]
unfolding procedure_functor_type_procfun_def procedure_functor_type_procedure_ext_def
apply simp
unfolding instantiate_procedure_def procedure_functor_mk_untyped_procedure_ext_def
apply simp
by (rule mk_procedure_untyped_inverse)

setup {* fn thy => thy |>
Modules.define_module_type {
  name = @{binding MT2},
  procs = [{name = @{binding b}, typ = @{typ "(bool*unit,bool)procedure"}}],
  arguments = [{name = @{binding M}, typ = @{typ "MT"}},{name = @{binding MX}, typ = @{typ "MT"}}]
} |> snd*}
print_theorems

lemma instantiate_procedure_nil: "instantiate_procedure [] x = x" unfolding instantiate_procedure_def by simp

lemma beta_reduce_preserves_type: "well_typed_proc'' E p T \<Longrightarrow> well_typed_proc'' E (beta_reduce p) T" sorry

lemma tmp:
  assumes "well_typed_proc'' [] p (foldr ProcFun Ts T)"
  assumes "list_all2 (\<lambda>T p. well_typed_proc'' [] p T) Ts ps"
  shows "well_typed_proc'' [] (instantiate_procedure ps p) T"
proof -
  {fix p p' T T'
   assume a:"well_typed_proc'' [] p' T'" and b:"well_typed_proc'' [] p (ProcFun T' T)"
   have "well_typed_proc'' [] (apply_procedure p p') T"
    unfolding apply_procedure_def
    apply (rule beta_reduce_preserves_type)
    apply (rule wt_ProcAppl) using a b by auto}
  note tmp = this
  show ?thesis
    using assms(2) assms(1) unfolding instantiate_procedure_def
    apply (induction Ts ps arbitrary: p rule:list_all2_induct, auto)
    by (metis tmp)
qed

lemma tmp1:
  fixes p::"('a::procedure_functor,'b::procedure_functor)procfun" and q::'a
  shows "well_typed_proc'' [] (apply_procedure (procedure_functor_mk_untyped p) (procedure_functor_mk_untyped q))
    (procedure_functor_type TYPE('b))"
sorry
lemma tmp2:
  fixes p::"('a::procedure_functor,'b::procedure_functor)procfun" and q::'a
  shows "beta_reduced (apply_procedure (procedure_functor_mk_untyped p) (procedure_functor_mk_untyped q))"
sorry

lemma "MT2.b (MT2.MAKE b) M1 M2 = procfun_apply (procfun_apply (procfun_apply (procfun_apply b (MT.a M1)) (MT.b M1)) (MT.a M2)) (MT.b M2)"
proof -
  show ?thesis
  unfolding procfun_apply_def
  apply (subst procedure_functor_mk_typed_inverse, fact tmp1, fact tmp2)
  apply (subst procedure_functor_mk_typed_inverse, fact tmp1, fact tmp2)
  apply (subst procedure_functor_mk_typed_inverse, fact tmp1, fact tmp2)
  unfolding MT2.b_def procedure_functor_mk_typed_procedure_ext_def
  apply (tactic "cong_tac 1", simp)
find_theorems "module_type_procs (?M1::MT)"
  unfolding module_type_procs_

lemma "MT2_instantiated.b (MT2.INST MT2 MT MTX) = MT2.b MT2 MT MTX"
  unfolding MT2.INST_def MT2_instantiated.b_def MT2.b_def
  unfolding instantiate_procedure_nil
  apply (subst module_type_construct_inverse)
  defer
  apply (subst List.nth_map) unfolding module_type_procs_length module_type_proc_names_MT2_def apply simp_all
  unfolding module_type_environment_MT2_instantiated_def apply simp
  unfolding module_type_proc_types_MT2_instantiated_def list_all2_map2

  using module_type_procs_welltyped[where m=MT2] unfolding module_type_proc_types_MT2_def
  apply (rule list_all2_mono) unfolding module_type_environment_MT2_def
  apply (rule_tac Ts="module_type_proc_types_open TYPE(MT) @ module_type_proc_types_open TYPE(MT)" in tmp, simp)
  apply (rule list_all2_appendI[OF module_type_procs_welltyped'])
  by (rule module_type_procs_welltyped')

setup {*
fn thy => thy |> snd o
Modules.define_module_type {
  name = @{binding MT3},
  procs = [{name = @{binding x}, typ = @{typ "(bool*unit,string)procedure"}},
           {name = @{binding y}, typ = @{typ "(string*unit,string)procedure"}}],
  arguments = [{name = @{binding M}, typ = @{typ "MT"}},
               {name = @{binding M2}, typ = @{typ "MT2"}}]
  };
*}

term MT3.MAKE term MT3.UNMAKE