section \<open> Designs parallel-by-merge \<close>

theory utp_des_parallel
  imports utp_des_prog
begin

subsection \<open> Definitions \<close>

text \<open> We introduce the parametric design merge, which handles merging of the $ok$ variables, and
  leaves the other variables to the parametrised "inner" merge predicate. As expected, a parallel
  composition of designs can diverge whenever one of its arguments can. \<close>

definition des_merge :: "(('\<alpha>, '\<beta>, '\<gamma>) mrg, '\<delta>) urel \<Rightarrow> (('\<alpha> des, '\<beta> des, '\<gamma> des) mrg, '\<delta> des) urel" ("\<^bold>D\<^bold>M'(_')") where
[upred_defs]: "\<^bold>D\<^bold>M(M) \<equiv> (($0:ok \<and> $1:ok \<Rightarrow> $ok\<acute> \<and> $\<^bold>v\<^sub>D:0\<acute> =\<^sub>u $0:\<^bold>v\<^sub>D \<and> $\<^bold>v\<^sub>D:1\<acute> =\<^sub>u $1:\<^bold>v\<^sub>D \<and> $\<^bold>v\<^sub>D:<\<acute> =\<^sub>u $<:\<^bold>v\<^sub>D) ;; (true \<turnstile>\<^sub>n M))"

text \<open> Parallel composition is then defined via the above merge predicate and the standard UTP
  parallel-by-merge operator. \<close>

abbreviation
  dpar_by_merge :: "('\<alpha>, '\<beta>) rel_des \<Rightarrow> (('\<alpha>, '\<beta>, '\<gamma>) mrg, '\<delta>) urel \<Rightarrow> ('\<alpha>, '\<gamma>) rel_des \<Rightarrow> ('\<alpha>, '\<delta>) rel_des"
  ("_ \<parallel>\<^sup>D\<^bsub>_\<^esub> _" [85,0,86] 85)
  where "P \<parallel>\<^sup>D\<^bsub>M\<^esub> Q \<equiv> P \<parallel>\<^bsub>\<^bold>D\<^bold>M(M)\<^esub> Q"

subsection \<open> Theorems \<close>

text \<open> The design merge predicate is symmetric up to the inner merge predicate. \<close>

lemma swap_des_merge: "swap\<^sub>m ;; \<^bold>D\<^bold>M(M) = \<^bold>D\<^bold>M(swap\<^sub>m ;; M)"
  by (rel_auto)

text \<open> The following laws explain the meaning of a merge of two normal (@{term H3}) designs.
  The postcondition is straightforward: we simply distribute the inner merge. However, the
  precondition is more complex. We'd be forgiven for thinking it would simply be $p \wedge q$, but
  this does not account for the possibility of miraculous behaviour in either argument. When this
  occurs, divergence is effectively overshadowed by miraculous behaviour, and so the precondition
  needs to involve the relational preconditions of both the design commitments ($P$ and $Q$). \<close>

lemma ndes_par_aux:
  "(p \<turnstile>\<^sub>n P) \<parallel>\<^sup>D\<^bsub>M\<^esub> (q \<turnstile>\<^sub>n Q) =(\<not> Pre(\<not> p\<^sup>< \<and> (q\<^sup>< \<Rightarrow> Q)) \<and> \<not> Pre(\<not> q\<^sup>< \<and> (p\<^sup>< \<Rightarrow> P))) \<turnstile>\<^sub>n (P \<parallel>\<^bsub>M\<^esub> Q)"
proof -
  have p2: "(\<lceil>p \<turnstile>\<^sub>n P\<rceil>\<^sub>0 \<and> \<lceil>q \<turnstile>\<^sub>n Q\<rceil>\<^sub>1 \<and> $<\<acute> =\<^sub>u $\<^bold>v) ;;
            ($0:ok \<and> $1:ok \<Rightarrow> $ok\<acute> \<and> $\<^bold>v\<^sub>D:0\<acute> =\<^sub>u $0:\<^bold>v\<^sub>D \<and> $\<^bold>v\<^sub>D:1\<acute> =\<^sub>u $1:\<^bold>v\<^sub>D \<and> $\<^bold>v\<^sub>D:<\<acute> =\<^sub>u $<:\<^bold>v\<^sub>D)
            = (\<not> Pre(\<not> p\<^sup>< \<and> (q\<^sup>< \<Rightarrow> Q)) \<and> \<not> Pre(\<not> q\<^sup>< \<and> (p\<^sup>< \<Rightarrow> P))) \<turnstile>\<^sub>n (\<lceil>P\<rceil>\<^sub>0 \<and> \<lceil>Q\<rceil>\<^sub>1 \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"
    by (rel_auto, metis+)
  show ?thesis
    by (simp add: des_merge_def par_by_merge_alt_def seqr_assoc[THEN sym] ndesign_composition_wp wp p2)
qed

lemma ndes_par [ndes_simp]:
  "(p \<turnstile>\<^sub>n P) \<parallel>\<^sup>D\<^bsub>M\<^esub> (q \<turnstile>\<^sub>n Q) =((p \<or> q \<and> \<not>Pre(Q)) \<and> (q \<or> p \<and> \<not>Pre(P))) \<turnstile>\<^sub>n (P \<parallel>\<^bsub>M\<^esub> Q)"
  by (simp add: ndes_par_aux, rel_auto)

lemma ndes_par_wlp:
  "(p \<turnstile>\<^sub>n P) \<parallel>\<^sup>D\<^bsub>M\<^esub> (q \<turnstile>\<^sub>n Q) =((p \<or> q \<and> Q wlp false) \<and> (q \<or> p \<and> P wlp false)) \<turnstile>\<^sub>n (P \<parallel>\<^bsub>M\<^esub> Q)"
  by (simp add: ndes_par_aux, rel_auto)

text \<open> If the commitments are both total relations, then we do indeed get a precondition of simply
  $p \wedge q$. \<close>

lemma ndes_par_total:
  assumes "Pre(P) = true" "Pre(Q) = true"
  shows "(p \<turnstile>\<^sub>n P) \<parallel>\<^sup>D\<^bsub>M\<^esub> (q \<turnstile>\<^sub>n Q) =(p \<and> q) \<turnstile>\<^sub>n (P \<parallel>\<^bsub>M\<^esub> Q)"
  by (simp add: ndes_par assms)

lemma ndes_par_assigns: "(p\<^sub>1 \<turnstile>\<^sub>n \<langle>\<sigma>\<rangle>\<^sub>a) \<parallel>\<^sup>D\<^bsub>M\<^esub> (q\<^sub>1 \<turnstile>\<^sub>n \<langle>\<rho>\<rangle>\<^sub>a) = (p\<^sub>1 \<and> q\<^sub>1) \<turnstile>\<^sub>n (\<langle>\<sigma>\<rangle>\<^sub>a \<parallel>\<^bsub>M\<^esub> \<langle>\<rho>\<rangle>\<^sub>a)" (is "?lhs = ?rhs")
  by (rule ndes_par_total, simp_all add: Pre_assigns)

lemma ndes_par_H1_H3_closed [closure]:
  assumes "P is \<^bold>N" "Q is \<^bold>N"
  shows "P \<parallel>\<^sup>D\<^bsub>M\<^esub> Q is \<^bold>N"
  by (metis assms ndes_par ndesign_H1_H3 ndesign_form)

lemma ndes_par_commute:
  "P \<parallel>\<^sup>D\<^bsub>swap\<^sub>m ;; M\<^esub> Q = Q \<parallel>\<^sup>D\<^bsub>M\<^esub> P"
  by (metis par_by_merge_commute_swap swap_des_merge)

lemma ndes_merge_miracle:
  assumes "P is \<^bold>N"
  shows "P \<parallel>\<^sup>D\<^bsub>M\<^esub> \<top>\<^sub>D = \<top>\<^sub>D"
  by (ndes_simp cls: assms, simp add: prepost)

lemma ndes_merge_chaos:
  assumes "P is \<^bold>N" "Pre(post\<^sub>D(P)) = true"
  shows "P \<parallel>\<^sup>D\<^bsub>M\<^esub> \<bottom>\<^sub>D = \<bottom>\<^sub>D"
proof -
  obtain p\<^sub>1 P\<^sub>2 where "P = p\<^sub>1 \<turnstile>\<^sub>n P\<^sub>2"
    by (metis assms(1) ndesign_form)
  with assms(2) show ?thesis
    by (simp add: ndes_simp, rel_auto)
qed

end


(*  Title:      JinjaThreads/JVM/JVMExceptions.thy
    Author:     Gerwin Klein, Martin Strecker, Andreas Lochbihler
*)

section \<open>Exception handling in the JVM\<close>

theory JVMExceptions
imports
  JVMInstructions
begin

abbreviation Any :: "cname option"
where "Any \<equiv> None"

definition matches_ex_entry :: "'m prog \<Rightarrow> cname \<Rightarrow> pc \<Rightarrow> ex_entry \<Rightarrow> bool"
where
 "matches_ex_entry P C pc xcp \<equiv>
                 let (s, e, C', h, d) = xcp in
                 s \<le> pc \<and> pc < e \<and> (case C' of None \<Rightarrow> True | \<lfloor>C''\<rfloor> \<Rightarrow> P \<turnstile> C \<preceq>\<^sup>* C'')"

primrec
  match_ex_table :: "'m prog \<Rightarrow> cname \<Rightarrow> pc \<Rightarrow> ex_table \<Rightarrow> (pc \<times> nat) option"
where
  "match_ex_table P C pc []     = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
                                   then Some (snd(snd(snd e)))
                                   else match_ex_table P C pc es)"

abbreviation ex_table_of :: "'addr jvm_prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ex_table"
where "ex_table_of P C M == snd (snd (snd (the (snd (snd (snd(method P C M)))))))"

lemma match_ex_table_SomeD:
  "match_ex_table P C pc xt = Some (pc',d') \<Longrightarrow>
  \<exists>(f,t,D,h,d) \<in> set xt. matches_ex_entry P C pc (f,t,D,h,d) \<and> h = pc' \<and> d=d'"
  by (induct xt) (auto split: if_split_asm)

end


theory IMP_Minus_To_SAT
  imports "IMP_Minus_To_SAS_Plus" "Verified_SAT_Based_AI_Planning.SAT_Solve_SAS_Plus"
    "../Complexity_classes/Cook_Levin" "IMP_Minus.Max_Constant"
begin

section \<open>Translation from IMP- to SAT\<close>

text \<open>In this theory the translations `from IMP- to SAS+`
      and `SAS+ to SAT` are composed and the `main_lemma` for
      the Cook_Levin theorem is proven correct.\<close>

subsection \<open>The partial steps:\<close>

text \<open>theorems about the translation from IMP- to SAS+\<close>
thm SAS_Plus_to_IMP_Minus_correctness

thm IMP_Minus_to_SAS_Plus_correctness

text \<open>theorem about the translation from SAS+ to SAT\<close>
thm sas_plus_problem_has_serial_solution_iff

(* TODO: use that *)
term Sema.sat

subsection \<open>Putting things together\<close>

text \<open>Putting things together works in three steps:
  \<^item> first we put together the transformations on the HOL level
  \<^item> then we synthesize a IMP- program that refines the HOL algorithm
  \<^item> then we instantiate the Cook_Levin locale\<close>

subsubsection \<open>Putting things together on the HOL level\<close>

definition encode_sat :: "_ \<Rightarrow> nat"  where
  "encode_sat F = undefined"

lemma valid_problem: "is_valid_problem_sas_plus (IMP_Minus_to_SAS_Plus c I r G t)"
  using SAS_Plus_Plus_To_SAS_Plus_valid[OF imp_minus_minus_to_sas_plus_valid]
  by (auto simp: IMP_Minus_to_SAS_Plus_def Let_def)

lemma while_program_has_model:
  assumes
    "I \<subseteq>\<^sub>m Some \<circ> s1"
    "finite (range s1)"
    (*Mohammad: The next assumption has to be fixed in IMP_Minus_to_SAS_Plus_correctness*)
    "Max (range s1) < r"
    "G \<subseteq>\<^sub>m Some \<circ> s2"
    "(c, s1) \<Rightarrow>\<^bsup> t \<^esup> s2"
    "t \<le> t'"
  shows
  (*Mohammad: there is still a problem with this theorem, namely, the generated formula is still
              parameterised by the specific running time 't'.
              This can only be fixed by generalising IMP_Minus_to_SAS_Plus_correctness *)
  "\<exists>\<A>. \<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> prob_with_noop (IMP_Minus_to_SAS_Plus c I r G t'))
                100 * (max_input_bits c I r + t' + 1) * (t' - 1) +
                   (max_input_bits c I r + t' + 2) *
                      (num_variables c + 2) + 52"
  (is "\<exists>_. _ \<Turnstile> \<Phi>\<^sub>\<forall> _ (?b::nat)")
proof-
  obtain plan where plan:
    "length plan \<le> ?b"
    "SAS_Plus_Semantics.is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t') plan"
    using assms(6) le_trans IMP_Minus_to_SAS_Plus_correctness[OF assms(1-5)]
    by (smt group_cancel.add1 one_add_one)
  thus ?thesis
    using sas_plus_problem_has_serial_solution_iff_ii'[OF valid_problem plan(2,1)]
    by auto
qed

lemma if_there_is_model_then_program_terminates:
  assumes
    "dom I \<subseteq> set (Max_Constant.all_variables c)"
    "dom G \<subseteq> set (Max_Constant.all_variables c)"
    "Max (ran G) < 2 ^ (t + max_input_bits c I r)"
    (* Mohammad: The following assumption cannot be true for many verifiers. s1 has to depend on I
                 , otherwise the assumption is vacuous.*)
    "\<And>s1. I \<subseteq>\<^sub>m Some \<circ> s1 \<Longrightarrow> \<exists>s2. \<exists>t' \<le> t. (c, s1) \<Rightarrow>\<^bsup>t'\<^esup> s2"
    "\<A> \<Turnstile> \<Phi>\<^sub>\<forall> (\<phi> prob_with_noop (IMP_Minus_to_SAS_Plus c I r G t))
            100 * (max_input_bits c I r + t + 1) * (t - 1) +
               (max_input_bits c I r + t + 2) *
                  (num_variables c + 2) + 52"
  shows "\<exists>s1 s2 t'. t' \<le> t \<and> I \<subseteq>\<^sub>m Some \<circ> s1 \<and> G \<subseteq>\<^sub>m Some \<circ> s2 \<and> (c, s1)  \<Rightarrow>\<^bsup>t'\<^esup> s2"
proof-
  obtain plan
    where "SAS_Plus_Semantics.is_serial_solution_for_problem (IMP_Minus_to_SAS_Plus c I r G t) plan"
    using sas_plus_problem_has_serial_solution_iff_i'[OF valid_problem assms(5)]
    by rule
  thus ?thesis
    using assms
    by(auto intro: SAS_Plus_to_IMP_Minus_correctness)
qed

definition t' ::"(nat \<Rightarrow> nat) \<Rightarrow> (nat\<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
  where "t' pt p_cer x = (make_mono pt) (bit_length x + (make_mono p_cer) (bit_length x)) + 1"

 definition imp_to_sat :: "Com.com \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat\<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> sat_plan_formula" where
    "imp_to_sat c pt p_cer x =
      (let I = (Map.empty)(''input'' \<mapsto> x);
          G = (Map.empty)(''input'' \<mapsto> 0);
          guess_range = x + 1 + 2 * 2 ^ (p_cer (bit_length x));
          max_bits = max_input_bits c I guess_range
      in
        \<Phi>\<^sub>\<forall> (\<phi> prob_with_noop (IMP_Minus_to_SAS_Plus c I guess_range G (t' pt p_cer x)))
           100 * (max_bits + (t' pt p_cer x) + 1) * ((t' pt p_cer  x) - 1) +
             (max_bits + (t' pt p_cer x) + 2) * (num_variables c + 2) + 52)"

lemma main_lemma_hol:
  fixes c pt p_cer in_lang
  assumes "poly pt"
  assumes "poly p_cer"
  assumes verifier_tbounded:
  (*Mohammad: I don't think we need the time to bounded by the cert length since the cert length
              is bounded by input length.*)
    "\<And>s. \<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                   t \<le> pt (bit_length (s ''input''))"
  assumes verifier_terminates:
          (*"\<And>x z. \<forall>s. s ''input'' = x \<and> s ''certificate'' = z \<longrightarrow>
                         (\<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> s' ''input'' = in_lang x)"*)
          (*Mohammad: The TM needs no access to the certificate since it is non-deterministic, i.e. it can
            assume it is guessed.*)
          (*Mohammad: The computation output should depend on the state, otherwise the theorem
                      statement does not hold*)
          (*Mohammad: We need to specify what it means for c to be a verifier for the certificates*)
          "\<And>x s. \<lbrakk>in_lang x = 0 ; s ''input'' = x\<rbrakk> \<Longrightarrow>
                    (\<exists>z t s'. bit_length z \<le> p_cer (bit_length x) \<and>
                              (c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                              s' ''input'' = in_lang x)"
          "\<And>x s s' t. \<lbrakk>in_lang x \<noteq> 0; s ''input'' = x; (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<rbrakk> \<Longrightarrow>
                         s' ''input'' = in_lang x"
  assumes verifier_has_registers:
    "''input'' \<in> set (Max_Constant.all_variables c)"
  shows "\<exists>t_red s_red.
         poly t_red
       \<and> poly s_red
       \<and> (\<forall>x. \<exists>f.  bit_length (encode_sat f) \<le> s_red ( bit_length x ) \<and> imp_to_sat c pt p_cer x = f
                   \<and> (Sema.sat {f}  \<longleftrightarrow> in_lang x = 0))"
proof -
  define t''::"(char list \<Rightarrow> nat) \<Rightarrow> nat" where
    "t'' s = (make_mono pt) (bit_length (s ''input''))" for s

  have t_bound: "\<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> t \<le> t'' s" for s
    using verifier_tbounded[of s] order.trans
    by (auto 5 1 simp: t''_def)

  text\<open>Upper bound on the time\<close>

  have t_bound_2: "\<exists>s' t. t \<le> t' pt p_cer  x \<and> (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'"
    if "s ''input'' = x"
    for s x
  proof-
    obtain t s' where
      "(c, s) \<Rightarrow>\<^bsup> t \<^esup> s'"
      "t \<le> pt (bit_length (s ''input''))"
      using verifier_tbounded
      by blast+
    have "t'' s \<le> t' pt p_cer (s ''input'')"
      by (auto simp: t'_def t''_def le_make_mono order_trans
               intro!: le_SucI monoD[OF mono_make_mono])
    hence "t \<le> t' pt p_cer (s ''input'')"
      using t_bound \<open>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<close>
      by (smt bigstepT_the_cost less_le_trans not_le)
    thus ?thesis
      using \<open>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<close> that
      by auto
  qed

  have "Sema.sat {imp_to_sat c pt p_cer x}"
    if init: "in_lang x = 0"
    for x
  proof-
    define s where "s \<equiv> (\<lambda>_. 0) (''input'' := x)"
    have "s ''input'' = x"
      by (auto simp add: s_def)
    then obtain z t s'
      where "bit_length z \<le> p_cer (bit_length x)"
            "(c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s'"
            "s' ''input'' = in_lang x"
      using verifier_terminates(1)[of x s, OF init]
      by auto
    moreover hence "t'' (s(''certificate'' := z)) \<le> t' pt p_cer x"
      by (auto simp: \<open>s ''input'' = x\<close> t'_def t''_def bit_length_def le_make_mono order_trans
               intro!: le_SucI monoD[OF mono_make_mono])
    hence "t \<le> t' pt p_cer x"
      using t_bound \<open>(c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s'\<close>
      by (smt bigstepT_the_cost less_le_trans not_le)
    moreover have "[''input'' \<mapsto> x] \<subseteq>\<^sub>m Some \<circ> s(''certificate'' := z)"
      by (auto simp: s_def map_le_def)
    moreover have "finite (range (s(''certificate'' := z)))"
      by (auto simp: image_def s_def)
    moreover have "z \<le> 2 * 2 ^ p_cer (Discrete.log x)"
      using \<open>bit_length z \<le> p_cer (bit_length x)\<close>
      apply(simp add: bit_length_def)
      by (metis le_iff_add log_exp2_ge mult.commute not_less power_of_two_increase_exponent_le)
    ultimately have "\<exists>\<A>. \<A> \<Turnstile> imp_to_sat c pt p_cer x"
      unfolding Sema.sat_def imp_to_sat_def Let_def
      by (fastforce simp add: s_def bit_length_def map_le_def init
                    intro!: while_program_has_model[of _ "s(''certificate'' := z)" _ _ s' _ t])
    thus ?thesis
      by (auto simp: Sema.sat_def)
  qed

  moreover have "in_lang x = 0"
    if "Sema.sat {imp_to_sat c pt p_cer x}"
    for x
  proof-
    obtain \<A> where "\<A> \<Turnstile> imp_to_sat c pt p_cer x"
      using \<open>Sema.sat {imp_to_sat c pt p_cer x}\<close>
      by (auto simp: Sema.sat_def)
    hence "\<exists>s1 s2 t''. t'' \<le> t' pt p_cer  x \<and> [''input'' \<mapsto> x] \<subseteq>\<^sub>m Some \<circ> s1 \<and>
                       [''input'' \<mapsto> 0] \<subseteq>\<^sub>m Some \<circ> s2 \<and> (c, s1) \<Rightarrow>\<^bsup> t'' \<^esup> s2"
      apply(intro if_there_is_model_then_program_terminates
                    [where \<A> = \<A> and r = "x + 1 + 2 * 2 ^ (p_cer (bit_length x))"])
      using verifier_has_registers
      by (auto simp: map_le_def imp_to_sat_def Let_def intro: t_bound_2 )
    then obtain s1 s2 t''
      where "t'' \<le> t' pt p_cer x" "[''input'' \<mapsto> x] \<subseteq>\<^sub>m Some \<circ> s1"
            "[''input'' \<mapsto> 0] \<subseteq>\<^sub>m Some \<circ> s2" "(c, s1) \<Rightarrow>\<^bsup> t'' \<^esup> s2"
      by auto
    moreover hence "s2 ''input'' = 0" "s1 ''input'' = x"
      by (auto simp: map_le_def)
    ultimately show "in_lang x = 0"
      using verifier_terminates(2)
      by fastforce
  qed

  ultimately show ?thesis
    sorry
qed

definition decode_sat :: "nat \<Rightarrow> nat three_sat" where
  "decode_sat n = undefined"

interpretation encode_decode_sat encode_sat decode_sat
  sorry

subsubsection \<open>Synthesizing the IMP- Program\<close>

lemma main_lemma_synth :
  fixes c pt p_cer
  assumes "poly pt"
  assumes "poly p_cer"
  assumes "\<forall>s. \<exists>t. Ex (big_step_t (c, s) t) \<and> t \<le>
                      pt (bit_length (s ''input'') + bit_length (s ''certificate''))"
  assumes "\<forall>x z. \<exists>r. \<forall>s. s ''input'' = x \<and> s ''certificate'' = z \<longrightarrow>
                         (\<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> s' ''input'' = r)"
  shows "\<exists>imp_to_sat t_red s_red.
         poly t_red
       \<and> poly s_red
       \<and> (\<forall>s t s'. (imp_to_sat,s) \<Rightarrow>\<^bsup> t \<^esup> s' \<longrightarrow> s ''certificate'' = s' ''certificate'')
       \<and> (\<forall>x. \<exists>f.    bit_length f \<le> s_red ( bit_length x )
                   \<and> (\<forall>s. s ''input'' = x \<longrightarrow> (\<exists>t s'. (imp_to_sat,s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                                          s' ''input'' = f \<and> t \<le> t_red(bit_length x)))
                   \<and> ( f \<in> IMP_SAT \<longleftrightarrow>
                                        (\<exists>z. bit_length z \<le> p_cer (bit_length x) \<and>
                                                      (\<forall>s t s'. s ''input'' = x
                                                      \<and> s ''certificate'' = z
                                                      \<and>(c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<longrightarrow> s' ''input'' = 0))
                                        )
                      )"
  sorry

subsubsection \<open>Instantiating the Cook_Levin locale\<close>

(*interpretation Cook_Levin_assumes_Main_lemma encode_sat decode_sat
  apply standard
  by (fact main_lemma_synth)

term strict_sorted*)

end


section {* Simulink Blocks Examples *}

theory simu_contract_real_example
  imports
    simu_contract_real
begin

subsection {* inps and outps *}
lemma
  fixes ok and inouts
  shows "\<lbrakk>(true \<turnstile>\<^sub>r II)\<rbrakk>\<^sub>e
   (\<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>, \<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>)"
  apply (rel_auto)
done

lemma
  fixes ok and inouts
  assumes "\<lbrakk>(true \<turnstile>\<^sub>r II)\<rbrakk>\<^sub>e
   (\<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>, \<lparr>ok\<^sub>v = ok1, inouts\<^sub>v = inouts\<rparr>)"
  shows "(ok1 = ok) \<or> \<not>ok"
  using assms apply (simp add: urel_defs)
  apply (rel_simp)
done

lemma
  fixes ok and inouts
  assumes "\<lbrakk>(true \<turnstile>\<^sub>r II)\<rbrakk>\<^sub>e
   (\<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>, \<lparr>ok\<^sub>v = ok1, inouts\<^sub>v = inouts\<rparr>)"
  shows "ok1 = ok"
  using assms apply (simp add: urel_defs)
  apply (rel_simp)
  (*
    "e": The prover derived "False" from "SimBlock_def", "impl_mp1", "inps_outps", "rdesign_post", "rdesign_pre", and "utp_pred_laws.inf_top_left", which could be due to a bug in Sledgehammer or to inconsistent axioms (including "sorry"s)
    "z3": Timed out
    "cvc4": Timed out
    "spass": Timed out
  *)
sorry

declare [[show_types]]
lemma
  fixes ok and inouts
  assumes "\<forall>x . length(inouts x) = Suc 0"
  shows "\<lbrakk>Id\<rbrakk>\<^sub>e
   (\<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>, \<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>)"
  apply (simp add: sim_blocks)
  apply (rel_simp)
  by (simp add: assms)

lemma
  fixes ok and inouts
  assumes "\<forall>x . length(inouts x) = 2"
  shows "\<lbrakk>takem 2 1\<rbrakk>\<^sub>e
   (\<lparr>ok\<^sub>v = ok, inouts\<^sub>v = inouts\<rparr>, \<lparr>ok\<^sub>v = ok, inouts\<^sub>v = \<lambda>na . [hd(inouts na)]\<rparr>)"
  apply (simp add: sim_blocks)
  apply (rel_simp)
  by (metis assms length_0_conv take_0 take_Suc zero_not_eq_two)

lemma
  fixes ok\<^sub>v0 and inouts\<^sub>v0
  assumes "\<forall>x . length(inouts\<^sub>v0 x) = (m1 + m2 + m3)"
  shows "\<lbrakk>takem (m1 + m2 + m3) (m1 + m2)\<rbrakk>\<^sub>e
          (\<lparr>ok\<^sub>v = ok\<^sub>v0, inouts\<^sub>v = inouts\<^sub>v0\<rparr>, \<lparr>ok\<^sub>v = ok\<^sub>v0, inouts\<^sub>v = \<lambda>na . take (m1+m2) (inouts\<^sub>v0 na)\<rparr>)"
  apply (simp add: sim_blocks)
  apply (rel_simp)
  using assms by auto

lemma
  fixes m and n
  assumes a2: "n \<le> m"
  assumes a1: "\<lbrakk>takem m n\<rbrakk>\<^sub>e
          (\<lparr>ok\<^sub>v = ok\<^sub>v0, inouts\<^sub>v = inouts\<^sub>v0\<rparr>, \<lparr>ok\<^sub>v = ok\<^sub>v1, inouts\<^sub>v = inouts\<^sub>v1\<rparr>)"
  (* shows "(ok\<^sub>v0 \<longrightarrow> ok\<^sub>v1)"*)
  (* shows "(ok\<^sub>v1 = ok\<^sub>v0) \<or> ok\<^sub>v1)" *)
  shows "ok\<^sub>v0 \<longrightarrow> (\<forall>x . length(inouts\<^sub>v0 x) = (m))"
  proof -
    show ?thesis
      using a1 a2 apply (simp add: sim_blocks)
      apply (rel_simp)
    done
  qed

lemma
  fixes m and n
  assumes a2: "n \<le> m"
  assumes a1: "\<lbrakk>takem m n\<rbrakk>\<^sub>e
          (\<lparr>ok\<^sub>v = ok\<^sub>v0, inouts\<^sub>v = inouts\<^sub>v0\<rparr>, \<lparr>ok\<^sub>v = ok\<^sub>v1, inouts\<^sub>v = inouts\<^sub>v1\<rparr>)"
  (* shows "(ok\<^sub>v0 \<longrightarrow> ok\<^sub>v1)"*)
  (* shows "(ok\<^sub>v1 = ok\<^sub>v0) \<or> ok\<^sub>v1)" *)
  shows "ok\<^sub>v0 \<and> n \<noteq> 0 \<longrightarrow> (inouts\<^sub>v1 = (\<lambda>na. (take n (inouts\<^sub>v0 na))))"
  proof -
    show ?thesis
      using a1 a2 apply (simp add: sim_blocks)
      apply (rel_simp)
      proof -
        fix x
        assume "\<forall>x::nat.
          length(inouts\<^sub>v0 x) = m \<and>
          length(inouts\<^sub>v1 x) = n \<and>
          \<lbrakk>bop op = (\<guillemotleft>take n\<guillemotright>($inouts(\<guillemotleft>x\<guillemotright>)\<^sub>a)\<^sub>a) ($inouts\<acute>(\<guillemotleft>x\<guillemotright>)\<^sub>a)\<rbrakk>\<^sub>e
           (get\<^bsub>\<Sigma>\<^sub>D \<times> \<Sigma>\<^sub>D\<^esub> (\<lparr>ok\<^sub>v = True, inouts\<^sub>v = inouts\<^sub>v0\<rparr>, \<lparr>ok\<^sub>v = True, inouts\<^sub>v = inouts\<^sub>v1\<rparr>))"
        show "inouts\<^sub>v1 x = take n (inouts\<^sub>v0 x)"
    done
  qed

lemma
  fixes m and n
  assumes a2: "n \<le> m"
  assumes a1: "\<lbrakk>takem m n\<rbrakk>\<^sub>e
          (\<lparr>ok\<^sub>v = ok\<^sub>v0, inouts\<^sub>v = inouts\<^sub>v0\<rparr>, \<lparr>ok\<^sub>v = ok\<^sub>v1, inouts\<^sub>v = inouts\<^sub>v1\<rparr>)"
  (* shows "(ok\<^sub>v0 \<longrightarrow> ok\<^sub>v1)"*)
  (* shows "(ok\<^sub>v1 = ok\<^sub>v0) \<or> ok\<^sub>v1)" *)
  shows "ok\<^sub>v0 \<longrightarrow> (\<forall>x . length(inouts\<^sub>v1 x) = (n))"
  proof -
    show ?thesis
      using a1 a2 apply (simp add: sim_blocks)
      apply (rel_simp)
    done
  qed

subsubsection {* SimBlock *}
paragraph {* Illustration *}

lemma "(pre\<^sub>D(Id) \<and> post\<^sub>D(Id)) =
  (\<^bold>\<forall> n \<bullet> #\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u 1 \<and> #\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u 1 \<and>
         head\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a))"
apply (simp add: sim_blocks)
done

lemma Dom_Id: "Dom(pre\<^sub>D(Id) \<and> post\<^sub>D(Id)) = (\<^bold>\<forall> n \<bullet> #\<^sub>u(&inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u 1)"
apply (simp add: sim_blocks Dom_def)
apply (rel_auto)
done

lemma Ran_Id: "Ran(pre\<^sub>D(Id) \<and> post\<^sub>D(Id)) = (\<^bold>\<forall> n \<bullet> #\<^sub>u(&inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u 1)"
apply (simp add: sim_blocks Ran_def)
apply (rel_auto)
done

lemma "(\<^bold>\<forall> n \<bullet> #\<^sub>u(&inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u 1) \<sqsubseteq> Dom(pre\<^sub>D(Id) \<and> post\<^sub>D(Id))"
apply (simp add: Dom_Id)
done

subsubsection {* inps and outps *}

subsection {* Experiments *}

paragraph {* Example *}
lemma takem_simp2:
"(takem (Suc (Suc 0)) (Suc 0)) ;; Id =
 true \<turnstile>\<^sub>r (\<^bold>\<forall> n \<bullet> #\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u \<guillemotleft>2\<guillemotright> \<and>
               #\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u \<guillemotleft>1\<guillemotright> \<and>
               head\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a))"
apply (simp add: sim_blocks)
apply (rel_auto)
apply (metis list.sel(1) list.size(3) numeral_2_eq_2 take_Suc zero_not_eq_two)
by (metis Cons_nth_drop_Suc Suc_1 Suc_leI append.simps(1) drop_0 drop_all hd_drop_conv_nth take_0 take_hd_drop zero_less_Suc)

lemma dropm_simp2:
"(dropm (Suc (Suc 0)) (Suc 0)) ;; Id =
 true \<turnstile>\<^sub>r (\<^bold>\<forall> n \<bullet> #\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u \<guillemotleft>2\<guillemotright> \<and>
               #\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u \<guillemotleft>1\<guillemotright> \<and>
               last\<^sub>u($inouts(\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts\<acute>(\<guillemotleft>n\<guillemotright>)\<^sub>a))"
apply (simp add: sim_blocks)
apply (rel_auto)
apply (metis One_nat_def add_Suc_right cancel_ab_semigroup_add_class.add_diff_cancel_left' hd_drop_conv_nth last_conv_nth lessI list.size(3) numeral_2_eq_2 of_nat_1 of_nat_Suc semiring_1_class.of_nat_0 zero_not_eq_two)
by (smt Cons_nth_drop_Suc One_nat_def Suc_less_eq add_2_eq_Suc add_Suc cancel_ab_semigroup_add_class.add_diff_cancel_left' drop_0 drop_all hd_drop_conv_nth last_conv_nth neq0_conv neq_Nil_conv not_less_zero numeral_2_eq_2 order_refl)

lemma lem_parallel_1 : "\<And>(ok\<^sub>v::bool) inouts\<^sub>v more (ok\<^sub>v'::bool) inouts\<^sub>v'.
       \<not> ok\<^sub>v \<Longrightarrow>
       \<exists>ok\<^sub>v inouts\<^sub>v'' morea ok\<^sub>v'' inouts\<^sub>v'''.
          (\<exists>inouts\<^sub>v. \<forall>x. inouts\<^sub>v''' x = inouts\<^sub>v x) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v'' x = inouts\<^sub>v x) \<and>
              morea = more \<and> ok\<^sub>v' = (ok\<^sub>v'' \<and> ok\<^sub>v''') \<and> (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v''' x @ inouts\<^sub>v'''' x))"
proof -
  -- {* use fix to fix variables in \<And> *}
  fix ok\<^sub>v :: "bool" and
      inouts\<^sub>v and
      more and
      ok\<^sub>v':: "bool" and
      inouts\<^sub>v'
  assume "\<not> ok\<^sub>v"
  show "\<exists>ok1\<^sub>v inouts\<^sub>v'' morea ok\<^sub>v'' inouts\<^sub>v'''.
          (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v''' x = inouts1\<^sub>v x) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok1\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v'' x = inouts\<^sub>v x) \<and>
              morea = more \<and>
              ok\<^sub>v' = (ok\<^sub>v'' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v''' x @ inouts\<^sub>v'''' x))"
  proof -
    -- {* use obtain to fix local variables in \<exists> *}
    obtain ok1\<^sub>v and inouts\<^sub>v'' and morea and ok\<^sub>v'' and inouts\<^sub>v'''
    where p: "ok1\<^sub>v = ok\<^sub>v" and "inouts\<^sub>v'' = inouts\<^sub>v" and "morea = more" and "ok\<^sub>v''= ok\<^sub>v'" and
      "inouts\<^sub>v''' = inouts\<^sub>v'"
      apply blast
    done
    (* P(x) *)
    have 1: "(\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v' x = inouts1\<^sub>v x) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ inouts\<^sub>v'''' x))"
      proof -
        have c1: "(\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v' x = inouts1\<^sub>v x)"
          by blast
        have c2: "(\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ inouts\<^sub>v'''' x))"
          proof -
            obtain ok\<^sub>v''' and inouts\<^sub>v'''' where "ok\<^sub>v''' = ok\<^sub>v'" and "inouts\<^sub>v'''' = (\<lambda>x.[])"
              by auto
            have c3: "(\<exists>inouts1\<^sub>v. \<forall>x. [] = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ [])"
              using \<open>\<not> ok\<^sub>v\<close> by fastforce
            from c3 show ?thesis
              by metis
          qed
        from c1 and c2 show ?thesis
          by auto
      qed
    (* \<exists>x. P(x) *)
    then show ?thesis
      by metis
  qed
qed

text {* Parallel of two @{term "Id"}s equal to a @{term "Idm"} with two inputs and ouptuts. *}
lemma parallel_id_equal_idm2: "sim_parallel Id Id = Idm 2"
apply (simp add: sim_parallel_def inps_id mergeB_def par_by_merge_def)
apply (simp add: takem_simp2)
apply (simp add: dropm_simp2)
apply (simp add: Idm_def)
apply (simp add: U0_def U1_def)
apply (rel_auto+)
apply (metis Cons_nth_drop_Suc One_nat_def Suc_1 add.right_neutral add_Suc_right append.simps(1) append_Cons cancel_ab_semigroup_add_class.add_diff_cancel_left' drop_0 drop_all hd_drop_conv_nth last_conv_nth lessI neq0_conv neq_Nil_conv order_refl zero_neq_numeral)
-- {* Subgoal 2: *}
apply (simp add: lem_parallel_1)
proof -
  (*
  -- {* use fix to fix variables in \<And> *}
  fix ok\<^sub>v :: "bool" and
      inouts\<^sub>v and
      more and
      ok\<^sub>v':: "bool" and
      inouts\<^sub>v'
  assume "\<not> ok\<^sub>v"
  show "\<exists>ok1\<^sub>v inouts\<^sub>v'' morea ok\<^sub>v'' inouts\<^sub>v'''.
          (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v''' x = inouts1\<^sub>v x) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok1\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v'' x = inouts\<^sub>v x) \<and>
              morea = more \<and>
              ok\<^sub>v' = (ok\<^sub>v'' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v''' x @ inouts\<^sub>v'''' x))"
  proof -
    -- {* use obtain to fix local variables in \<exists> *}
    obtain ok1\<^sub>v and inouts\<^sub>v'' and morea and ok\<^sub>v'' and inouts\<^sub>v'''
    where p: "ok1\<^sub>v = ok\<^sub>v" and "inouts\<^sub>v'' = inouts\<^sub>v" and "morea = more" and "ok\<^sub>v''= ok\<^sub>v'" and
      "inouts\<^sub>v''' = inouts\<^sub>v'"
      apply blast
    done
    (* P(x) *)
    have 1: "(\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v' x = inouts1\<^sub>v x) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ inouts\<^sub>v'''' x))"
      proof -
        have c1: "(\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v' x = inouts1\<^sub>v x)"
          by blast
        have c2: "(\<exists>ok\<^sub>v''' inouts\<^sub>v''''.
              (\<exists>inouts1\<^sub>v. \<forall>x. inouts\<^sub>v'''' x = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v''') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ inouts\<^sub>v'''' x))"
          proof -
            obtain ok\<^sub>v''' and inouts\<^sub>v'''' where "ok\<^sub>v''' = ok\<^sub>v'" and "inouts\<^sub>v'''' = (\<lambda>x.[])"
              by auto
            have c3: "(\<exists>inouts1\<^sub>v. \<forall>x. [] = inouts1\<^sub>v x) \<and>
              \<not> ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v x = inouts\<^sub>v x) \<and>
              more = more \<and>
              ok\<^sub>v' = (ok\<^sub>v' \<and> ok\<^sub>v') \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x @ [])"
              using \<open>\<not> ok\<^sub>v\<close> by fastforce
            from c3 show ?thesis
              by metis
          qed
        from c1 and c2 show ?thesis
          by auto
      qed
    (* \<exists>x. P(x) *)
    then show ?thesis
      by metis
  qed
next
*)
  fix ok\<^sub>v :: "bool" and
      inouts\<^sub>v and
      more and
      ok\<^sub>v':: "bool" and
      inouts\<^sub>v'
  assume s1: " ok\<^sub>v'"
  assume s2: "\<forall>x. length(inouts\<^sub>v x) = 2 \<and> length(inouts\<^sub>v' x) = 2 \<and> inouts\<^sub>v x = inouts\<^sub>v' x"
  show "\<exists>ok0\<^sub>v' inouts0\<^sub>v morea ok\<^sub>v'' inouts\<^sub>v''.
          (\<exists>inouts1\<^sub>v.
              (ok\<^sub>v \<longrightarrow> ok\<^sub>v'' \<and> (\<forall>x. length(inouts1\<^sub>v x) = Suc 0 \<and> hd (inouts\<^sub>v' x) = hd (inouts1\<^sub>v x))) \<and>
              (\<forall>x. inouts\<^sub>v'' x = inouts1\<^sub>v x)) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v'''.
              (\<exists>inouts\<^sub>v.
                  (ok\<^sub>v \<longrightarrow> ok\<^sub>v''' \<and> (\<forall>x. length(inouts\<^sub>v x) = Suc 0 \<and> last (inouts\<^sub>v' x) = hd (inouts\<^sub>v x))) \<and>
                  (\<forall>x. inouts\<^sub>v''' x = inouts\<^sub>v x)) \<and>
              ok0\<^sub>v' = ok\<^sub>v \<and>
              (\<forall>x. inouts0\<^sub>v x = inouts\<^sub>v' x) \<and>
              morea = more \<and> ok\<^sub>v'' \<and> ok\<^sub>v''' \<and> (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v'' x @ inouts\<^sub>v''' x))"
    proof -
      obtain ok0\<^sub>v' and inouts0\<^sub>v and morea and ok\<^sub>v'' and inouts\<^sub>v''
      where p: "ok0\<^sub>v' = ok\<^sub>v" and "inouts0\<^sub>v = inouts\<^sub>v'" and "morea = more" and "ok\<^sub>v''= True" and
        "inouts\<^sub>v'' = (\<lambda>x. [hd(inouts\<^sub>v' x)])"
        apply auto
      done
      have Px: "(\<exists>inouts1\<^sub>v.
              (ok\<^sub>v \<longrightarrow> True \<and> (\<forall>x. length(inouts1\<^sub>v x) = Suc 0 \<and> hd (inouts\<^sub>v' x) = hd (inouts1\<^sub>v x))) \<and>
              (\<forall>x. [hd(inouts\<^sub>v' x)] = inouts1\<^sub>v x)) \<and>
          (\<exists>ok\<^sub>v''' inouts\<^sub>v'''.
              (\<exists>inouts\<^sub>v.
                  (ok\<^sub>v \<longrightarrow> ok\<^sub>v''' \<and> (\<forall>x. length(inouts\<^sub>v x) = Suc 0 \<and> last (inouts\<^sub>v' x) = hd (inouts\<^sub>v x))) \<and>
                  (\<forall>x. inouts\<^sub>v''' x = inouts\<^sub>v x)) \<and>
              ok\<^sub>v = ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x) \<and>
              more = more \<and> True \<and> ok\<^sub>v''' \<and> (\<forall>x. inouts\<^sub>v' x = [hd(inouts\<^sub>v' x)] @ inouts\<^sub>v''' x))"
        proof -
          have c1: "(\<exists>inouts1\<^sub>v.
              (ok\<^sub>v \<longrightarrow> True \<and> (\<forall>x. length(inouts1\<^sub>v x) = Suc 0 \<and> hd (inouts\<^sub>v' x) = hd (inouts1\<^sub>v x))) \<and>
              (\<forall>x. [hd(inouts\<^sub>v' x)] = inouts1\<^sub>v x))"
            by (metis \<open>inouts\<^sub>v'' = (\<lambda>x. [hd (inouts\<^sub>v' x)])\<close> length_Cons list.sel(1) list.size(3))
          have c2: "(\<exists>ok\<^sub>v''' inouts\<^sub>v'''.
              (\<exists>inouts\<^sub>v.
                  (ok\<^sub>v \<longrightarrow> ok\<^sub>v''' \<and> (\<forall>x. length(inouts\<^sub>v x) = Suc 0 \<and> last (inouts\<^sub>v' x) = hd (inouts\<^sub>v x))) \<and>
                  (\<forall>x. inouts\<^sub>v''' x = inouts\<^sub>v x)) \<and>
              ok\<^sub>v = ok\<^sub>v \<and>
              (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x) \<and>
              more = more \<and> True \<and> ok\<^sub>v''' \<and> (\<forall>x. inouts\<^sub>v' x = [hd(inouts\<^sub>v' x)] @ inouts\<^sub>v''' x))"
            proof -
              obtain ok\<^sub>v''' and inouts\<^sub>v''' where
                "ok\<^sub>v''' = True" and "inouts\<^sub>v''' =  (\<lambda>x. [last(inouts\<^sub>v' x)])"
                by auto
              have Px: "(\<exists>inouts\<^sub>v.
                  (ok\<^sub>v \<longrightarrow> True \<and> (\<forall>x. length(inouts\<^sub>v x) = Suc 0 \<and> last (inouts\<^sub>v' x) = hd (inouts\<^sub>v x))) \<and>
                  (\<forall>x. [last(inouts\<^sub>v' x)] = inouts\<^sub>v x)) \<and>
                ok\<^sub>v = ok\<^sub>v \<and>
                (\<forall>x. inouts\<^sub>v' x = inouts\<^sub>v' x) \<and>
                more = more \<and> True \<and> True \<and> (\<forall>x. inouts\<^sub>v' x = [hd(inouts\<^sub>v' x)] @ [last(inouts\<^sub>v' x)])"
                proof -
                  have c1: "(\<exists>inouts\<^sub>v.
                    (ok\<^sub>v \<longrightarrow> True \<and> (\<forall>x. length(inouts\<^sub>v x) = Suc 0 \<and> last (inouts\<^sub>v' x) = hd (inouts\<^sub>v x))) \<and>
                    (\<forall>x. [last(inouts\<^sub>v' x)] = inouts\<^sub>v x))"
                    by force
                  have c2: "(\<forall>x. inouts\<^sub>v' x = [hd(inouts\<^sub>v' x)] @ [last(inouts\<^sub>v' x)])"
                    using list_equal_size2 s2 by blast
                  from c1 and c2 show ?thesis
                    by auto
                qed
              then show ?thesis
                by metis
            qed
          from c1 and c2 show ?thesis by auto
        qed
      then show ?thesis
        by metis
    qed
qed

paragraph {* Example *}
text {* For example, *}
definition IntegratorWOFeedback :: "(dummyT sim_state_scheme, dummyT sim_state_scheme) rel_des" where
"IntegratorWOFeedback = (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 2) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 2) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a) +
                (if n = 0 then 0 else head\<^sub>u(tail\<^sub>u($inouts (\<guillemotleft>n-1\<guillemotright>)\<^sub>a)))) \<and>
          head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u(tail\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)))
        ))"

definition PreFD1 :: "(nat \<Rightarrow> real) \<Rightarrow> (dummyT sim_state_scheme, dummyT sim_state_scheme) rel_des" where
"PreFD1 x = (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 2) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) \<and>
          (head\<^sub>u(tail\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u (\<guillemotleft>x n\<guillemotright>))) ))"

definition PostFD1 :: "(nat \<Rightarrow> real) \<Rightarrow> (dummyT sim_state_scheme, dummyT sim_state_scheme) rel_des" where
"PostFD1 x = (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 2) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) \<and>
          (head\<^sub>u(tail\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u (\<guillemotleft>x n\<guillemotright>))) ))"

definition Integrator :: "(dummyT sim_state_scheme, dummyT sim_state_scheme) rel_des" where
"Integrator = (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a) +
                (if n = 0 then 0 else head\<^sub>u($inouts\<acute> (\<guillemotleft>n-1\<guillemotright>)\<^sub>a))))
        ))"

definition IntegratorWCFeedback :: "(dummyT sim_state_scheme, dummyT sim_state_scheme) rel_des" where
"IntegratorWCFeedback = (\<^bold>\<exists> (x) \<bullet> ((PreFD1 x) ;; IntegratorWOFeedback ;; (PostFD1 x)))"

(*
lemma "IntegratorWCFeedback = Integrator"
apply (simp add: IntegratorWCFeedback_def Integrator_def)
apply (simp add: PreFD1_def PostFD1_def IntegratorWOFeedback_def)
apply (rel_auto)
apply (metis not_gr0)
-- {* Goal 2: *}
proof - (* 2 *)
  fix inouts\<^sub>v :: "nat \<Rightarrow> real list" and inouts\<^sub>v':: "nat \<Rightarrow> real list" and ok\<^sub>v and ok\<^sub>v'
  assume s1: "ok\<^sub>v" and "ok\<^sub>v'"
  assume s2: "\<forall>x. (x = 0 \<longrightarrow> length(inouts\<^sub>v 0) = Suc 0 \<and> length(inouts\<^sub>v' 0) = Suc 0 \<and>
                  hd (inouts\<^sub>v' 0) = hd (inouts\<^sub>v 0)) \<and>
           (0 < x \<longrightarrow>  length(inouts\<^sub>v x) = Suc 0 \<and> length(inouts\<^sub>v' x) = Suc 0 \<and>
                  hd (inouts\<^sub>v' x) = hd (inouts\<^sub>v x) + hd (inouts\<^sub>v' (x - Suc 0)))"
  show "\<exists>x inouts\<^sub>v''.
          (\<forall>xa. length(inouts\<^sub>v xa) = Suc 0 \<and> length(inouts\<^sub>v'' xa) = 2 \<and>
              hd (inouts\<^sub>v'' xa) = hd (inouts\<^sub>v xa) \<and> hd (tl (inouts\<^sub>v'' xa)) = x xa) \<and>
          (\<exists>inouts\<^sub>v.
              (\<forall>x. (x = 0 \<longrightarrow> length(inouts\<^sub>v'' 0) = 2 \<and> length(inouts\<^sub>v 0) = 2 \<and>
                        hd (inouts\<^sub>v 0) = hd (inouts\<^sub>v'' 0) \<and> hd (inouts\<^sub>v 0) = hd (tl (inouts\<^sub>v 0))) \<and>
                   (0 < x \<longrightarrow> length(inouts\<^sub>v'' x) = 2 \<and> length(inouts\<^sub>v x) = 2 \<and>
                      hd (inouts\<^sub>v x) = hd (inouts\<^sub>v'' x) + hd (tl (inouts\<^sub>v'' (x - Suc 0))) \<and>
                      hd (inouts\<^sub>v x) = hd (tl (inouts\<^sub>v x)))) \<and>
              (\<forall>xa. length(inouts\<^sub>v xa) = 2 \<and> length(inouts\<^sub>v' xa) = Suc 0 \<and>
                  hd (inouts\<^sub>v' xa) = hd (inouts\<^sub>v xa) \<and> hd (tl (inouts\<^sub>v xa)) = x xa))"
  -- {* Goal 2.1: unroll forall*}
  proof - (* 2.1 *)
    let ?x = "(\<lambda>n. (if n = 0 then hd (inouts\<^sub>v n) else hd (inouts\<^sub>v n) + hd (inouts\<^sub>v' (n - Suc 0))))"
    obtain x and inouts\<^sub>v'' where
      p: "x = ?x"  and "inouts\<^sub>v'' = (\<lambda>n.[hd (inouts\<^sub>v n), ?x n])"
        by auto
    (* P(x) *)
    let ?P = "\<lambda>u v . (\<forall>xa. length(inouts\<^sub>v xa) = Suc 0 \<and> length(u xa) = 2 \<and>
            hd (u xa) = hd (inouts\<^sub>v xa) \<and> hd (tl (u xa)) = v xa) \<and>
        (\<exists>inouts\<^sub>v.
            (\<forall>x. (x = 0 \<longrightarrow> length(u 0) = 2 \<and> length(inouts\<^sub>v 0) = 2 \<and>
                      hd (inouts\<^sub>v 0) = hd (u 0) \<and> hd (inouts\<^sub>v 0) = hd (tl (inouts\<^sub>v 0))) \<and>
                 (0 < x \<longrightarrow> length(u x) = 2 \<and> length(inouts\<^sub>v x) = 2 \<and>
                    hd (inouts\<^sub>v x) = hd (u x) + hd (tl (u (x - Suc 0))) \<and>
                    hd (inouts\<^sub>v x) = hd (tl (inouts\<^sub>v x)))) \<and>
            (\<forall>xa. length(inouts\<^sub>v xa) = 2 \<and> length(inouts\<^sub>v' xa) = Suc 0 \<and>
                hd (inouts\<^sub>v' xa) = hd (inouts\<^sub>v xa) \<and> hd (tl (inouts\<^sub>v xa)) = v xa))"
    -- {* Goal 2.1.1 : unroll exists *}
    have Px: "?P (\<lambda>n.[hd (inouts\<^sub>v n), ?x n]) (?x)"
      proof - (* 2.1.1 *)
        have 0: "\<forall>xa. length(inouts\<^sub>v xa) = Suc 0"
          using neq0_conv s2 by blast
        -- {* Goal 2.1.1.1 : 1st conjunction *}
        then have 1: "(\<forall>xa. length(inouts\<^sub>v xa) = Suc 0 \<and>
          length([hd (inouts\<^sub>v xa), ?x xa]) = 2 \<and> hd [hd (inouts\<^sub>v xa), ?x xa] =
          hd (inouts\<^sub>v xa) \<and>
          hd (tl [hd (inouts\<^sub>v xa), ?x xa]) = ?x xa)"
          by simp
        -- {* Goal 2.1.1.2 : 2nd conjunction *}
        let ?P2 = "(\<lambda>inouts\<^sub>v'' :: nat\<Rightarrow>real list.
          (\<forall>x. (x = 0 \<longrightarrow>
            length([hd (inouts\<^sub>v 0), ?x 0]) = 2 \<and>
            length(inouts\<^sub>v'' 0) = 2 \<and>
            hd (inouts\<^sub>v'' 0) = hd [hd (inouts\<^sub>v 0), ?x 0] \<and>
            hd (inouts\<^sub>v'' 0) = hd (tl (inouts\<^sub>v'' 0))) \<and>
           (0 < x \<longrightarrow>
            length([hd (inouts\<^sub>v x), ?x x]) = 2 \<and>
            length(inouts\<^sub>v'' x) = 2 \<and>
            hd (inouts\<^sub>v'' x) = hd [hd (inouts\<^sub>v x), ?x x] +
            hd (tl [hd (inouts\<^sub>v (x - Suc 0)),
                    if x - Suc 0 = 0 then hd (inouts\<^sub>v (x - Suc 0))
                    else hd (inouts\<^sub>v (x - Suc 0)) + hd (inouts\<^sub>v' (x - Suc 0 - Suc 0))]) \<and>
            hd (inouts\<^sub>v'' x) = hd (tl (inouts\<^sub>v'' x)))) \<and>
          (\<forall>xa. length(inouts\<^sub>v'' xa) = 2 \<and>
            length(inouts\<^sub>v' xa) = Suc 0 \<and>
            hd (inouts\<^sub>v' xa) = hd (inouts\<^sub>v'' xa) \<and>
            hd (tl (inouts\<^sub>v'' xa)) =
            (if xa = 0 then hd (inouts\<^sub>v xa) else hd (inouts\<^sub>v xa) + hd (inouts\<^sub>v' (xa - Suc 0)))))"
        -- {* Goal 2.1.1.2 : 2nd conjunction *}
        have 2: "(\<exists>inouts\<^sub>v''. (?P2 inouts\<^sub>v''))"
          proof - (* 2.1.1 *)
            -- {* Goal 2.1.1.2.1 : unroll exists *}
            let ?t = "\<lambda>n.(hd (inouts\<^sub>v n) + (
                  if n = 0 then 0 else
                    if n = 1 then hd (inouts\<^sub>v (n-1)) else
                      hd (inouts\<^sub>v (n-1)) + hd (inouts\<^sub>v' (n - 2))))"
            obtain inouts\<^sub>v'' where p: "inouts\<^sub>v''= (\<lambda>n.[?t n,?t n])"
              by auto
            have P2x: "?P2 (\<lambda>n.[?t n,?t n])"
              proof - (* 2.1.1.1 *)
                -- {* Goal 2.1.1.2.1.1 : 1st conjunction *}
                have 11: "\<forall>x. (x = 0 \<longrightarrow>
                  length([hd (inouts\<^sub>v 0), ?x 0]) = 2 \<and>
                  length([?t 0, ?t 0]) = 2 \<and>
                  hd [?t 0, ?t 0] = hd [hd (inouts\<^sub>v 0), ?x 0] \<and>
                  hd [?t 0, ?t 0] = hd (tl [?t 0, ?t 0]))"
                  by simp
                -- {* Goal 2.1.1.2.1.2 : 2st conjunction *}
                have 12: "(\<forall>x.(0 < x \<longrightarrow>
                  length([hd (inouts\<^sub>v x), ?x 0]) = 2 \<and>
                  length([?t x, ?t x]) = 2 \<and>
                  hd [?t x, ?t x] = hd [hd (inouts\<^sub>v x), ?x x] +
                      hd (tl [hd (inouts\<^sub>v (x - Suc 0)),
                          if x - Suc 0 = 0 then hd (inouts\<^sub>v (x - Suc 0))
                          else hd (inouts\<^sub>v (x - Suc 0)) + hd (inouts\<^sub>v' (x - Suc 0 - Suc 0))]) \<and>
                  hd [?t x, ?t x] = hd (tl [?t x, ?t x])))"
                  by (smt Suc_1 Suc_diff_eq_diff_pred diff_Suc_1 length_Cons less_imp_Suc_add list.sel(1) list.sel(3) list.size(3) neq0_conv numeral_1_eq_Suc_0 numeral_One pos2)
                -- {* Goal 2.1.1.2.1.3 : 3rd conjunction *}
                have 13: "(\<forall>xa. length([?t xa, ?t xa]) =  2 \<and>
                    length(inouts\<^sub>v' xa) = Suc 0 \<and>
                    hd (inouts\<^sub>v' xa) = hd [?t xa, ?t xa] \<and>
                    hd (tl [?t xa, ?t xa]) = (?x xa))"
                  using "12" s2 by auto
                show ?thesis using 11 12 13
                  by simp
              qed -- {* Goal 2.1.1.2.1 : 1st conjunction *} (* 2.1.1.1 *)
            show ?thesis using P2x
              sorry (* proof found but slow *)
          qed -- {* Goal 2.1.1.2 *} (* 2.1.1 *)
        then show ?thesis using 1 2
          by blast
      qed  -- {* Goal 2.1.1 *} (* 2.1 *)
    then show ?thesis using Px
      by (metis \<open>\<And>thesis. (\<And>x inouts\<^sub>v''. \<lbrakk>x = (\<lambda>n. if n = 0 then hd (inouts\<^sub>v n) else hd (inouts\<^sub>v n) + hd (inouts\<^sub>v' (n - Suc 0))); inouts\<^sub>v'' = (\<lambda>n. [hd (inouts\<^sub>v n), if n = 0 then hd (inouts\<^sub>v n) else hd (inouts\<^sub>v n) + hd (inouts\<^sub>v' (n - Suc 0))])\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>)
  qed (* 2 *)
qed
*)

(*
lemma "(inps IntegratorWOFeedback) = 2"
proof -
  have 1: "IntegratorWOFeedback is HDim 2"
    apply (simp add: IntegratorWOFeedback_def Healthy_def sim_blocks)
    apply (ndes_simp)
    sorry
  then show ?thesis
    apply (simp add: inps_dim)
  done
qed
*)
(*
lemma "IntegratorWOFeedback f\<^sub>D [(1,1)] = Integrator"
apply (simp add: sim_blocks IntegratorWOFeedback_def Integrator_def)
apply (rel_auto)
  apply blast
  apply blast
  apply blast
(*  apply blast
  apply blast
  apply blast *)
sorry

lemma "IntegratorWCFeedback = IntegratorWOFeedback f\<^sub>D [(1,1)]"
apply (simp add: sim_blocks IntegratorWCFeedback_def PreFD1_def PostFD1_def IntegratorWOFeedback_def)
apply (rel_auto)
  apply blast
  apply blast
  apply blast
(*  apply blast
  apply blast
  apply blast *)
sorry
*)

subsection {* Examples *}

subsubsection {* PID Integrator *}
fun listsum :: "real list \<Rightarrow> real" where
  "listsum [] = 0" |
  "listsum (x # xs) = x + listsum xs"

term "(map nat [0..n])"
term "head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a)"
term "(\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))"
term "(\<guillemotleft>map\<guillemotright> (\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))\<^sub>a (\<guillemotleft>(map nat [0..n])\<guillemotright>)\<^sub>a)"
term "(\<guillemotleft>list_sum\<guillemotright> (\<guillemotleft>map\<guillemotright> (\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))\<^sub>a (\<guillemotleft>(map nat [0..n])\<guillemotright>)\<^sub>a)\<^sub>a) + 0"
term "head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)"
term "head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a)"
(*
term "(head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u
  ((\<guillemotleft>list_sum\<guillemotright> (\<guillemotleft>map\<guillemotright> (\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))\<^sub>a (\<guillemotleft>(map nat [0..n])\<guillemotright>)\<^sub>a)\<^sub>a) + 0))"
*)

lemma sum_1:
  fixes n :: "nat" and x :: "nat \<Rightarrow> real" and y :: "nat \<Rightarrow> real"
  assumes "\<forall>n. (x(n) = y(n) + (if (n = 0) then 1 else x(n-1)))"
  shows "(x(n) = list_sum (map (\<lambda>x. y(x)) (map nat [0..n])) + 1)"
proof (induction n)
  case 0
  then show ?case
    proof -
      from assms have 0: "x(0) = y(0) + 1"
        by simp
      have 1: "list_sum (map (\<lambda>x. y(x)) (map nat [0..0])) = y(0)"
        by (simp add: upto.simps)
      from 0 1 show ?thesis
        by auto
    qed
next
  case (Suc n)
  then show ?case
    proof -
      have 00: "(map y (map nat [0..int (Suc n)])) = (map y (map nat [0..int n])) @ [y(Suc n)]"
        by (smt list.simps(8) list.simps(9) map_append nat_int of_nat_0_le_iff of_nat_Suc upto_rec2)
      then have 01: "(foldr op + (map y (map nat [0..int (Suc n)])) 0) =
                     (foldr op + (map y (map nat [0..int (n)])) 0) + y(Suc n)"
        sorry
      from assms have 0: "x (Suc n) = y(Suc n) + x(n)"
        by simp
      then have 1: "... = y(Suc n) + (foldr op + (map y (map nat [0..int n])) 0 + 1)"
        by (simp add: Suc.IH)
      then have 2: "... = (foldr op + (map y (map nat [0..int (Suc n)])) 0 + 1)"
        using "01" by auto
      show ?thesis
       using "0" "2" Suc.IH by linarith
    qed
qed

(*
lemma pid_int_l1:
  shows "
  (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a) +
                (if n = 0 then 0 else head\<^sub>u($inouts\<acute> (\<guillemotleft>n-1\<guillemotright>)\<^sub>a))))
        )
  )
   =
  (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u ((\<guillemotleft>list_sum\<guillemotright> (\<guillemotleft>map\<guillemotright> (\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))\<^sub>a (\<guillemotleft>(map nat [0..n])\<guillemotright>)\<^sub>a)\<^sub>a) + 0)))
        )
      )"
sorry

(* (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u ((\<guillemotleft>sum_list\<guillemotright> (\<guillemotleft>map\<guillemotright> (\<lambda>x \<bullet> head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))\<^sub>a (\<guillemotleft>[0..n]\<guillemotright>)\<^sub>a)) + 0) *)

lemma pid_int:
  shows "((Id \<parallel>\<^sub>D (UnitDelay 0)) ;; Sum) =
      (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 2) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a) +
                (if n = 0 then 0 else (\<guillemotleft>nth\<guillemotright> ($inouts (\<guillemotleft>n-1\<guillemotright>)\<^sub>a)\<^sub>a (1)\<^sub>a))))
        )
      )"
sorry

term " (\<lambda>x. head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a))"
term "map (\<lambda>x. head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a)) (map nat [0..n])"

lemma pid_int_feed:
  shows "(true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u head\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a) +
                (if n = 0 then 1 else head\<^sub>u($inouts\<acute> (\<guillemotleft>n-1\<guillemotright>)\<^sub>a))))
        )
      ) = (true \<turnstile>\<^sub>r
        (\<^bold>\<forall> n::nat \<bullet>
          (((#\<^sub>u($inouts (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and> ((#\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a)) =\<^sub>u 1) \<and>
          (head\<^sub>u($inouts\<acute> (\<guillemotleft>n\<guillemotright>)\<^sub>a) =\<^sub>u (\<guillemotleft>list_sum\<guillemotright> (map (\<lambda>x. head\<^sub>u($inouts (\<guillemotleft>x\<guillemotright>)\<^sub>a)) (map (nat) ([0..n])))\<^sub>a) + 1))
        )
      )"
apply (rel_auto)
*)

end


theory Tools
imports "HOL.HOL"
keywords "close" :: "prf_script" % "proof"
begin

subsection {* "close" keyword *}

txt \<open>See @{file "tools.ML"}\<close>

subsection {* Simplifier modulo equivalence relation *}

txt {* See also @{url "http://stackoverflow.com/q/30573837/2646248"} *}

definition fun_equiv :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where "fun_equiv f x y == f x = f y"
lemma fun_equiv_refl: "fun_equiv f x x" by(simp add: fun_equiv_def)

ML_file "tools.ML"

end


theory Monitor_Code
  imports "HOL-Library.Code_Target_Nat" "Containers.Containers" Monitor Preliminaries
begin

derive (eq) ceq enat

instantiation enat :: ccompare begin

definition ccompare_enat :: "enat comparator option" where
  "ccompare_enat = Some (\<lambda>x y. if x = y then order.Eq else if x < y then order.Lt else order.Gt)"

instance by intro_classes
    (auto simp: ccompare_enat_def split: if_splits intro!: comparator.intro)

end

code_printing
  code_module "IArray" \<rightharpoonup> (OCaml)
\<open>module IArray : sig
  val length' : 'a array -> Z.t
  val sub' : 'a array * Z.t -> 'a
end = struct

let length' xs = Z.of_int (Array.length xs);;

let sub' (xs, i) = Array.get xs (Z.to_int i);;

end\<close> for type_constructor iarray constant IArray.length' IArray.sub'

code_reserved OCaml IArray

code_printing
  type_constructor iarray \<rightharpoonup> (OCaml) "_ array"
| constant iarray_of_list \<rightharpoonup> (OCaml) "Array.of'_list"
| constant IArray.list_of \<rightharpoonup> (OCaml) "Array.to'_list"
| constant IArray.length' \<rightharpoonup> (OCaml) "IArray.length'"
| constant IArray.sub' \<rightharpoonup> (OCaml) "IArray.sub'"

lemma iarray_list_of_inj: "IArray.list_of xs = IArray.list_of ys \<Longrightarrow> xs = ys"
  by (cases xs; cases ys) auto

instantiation iarray :: (ccompare) ccompare
begin

definition ccompare_iarray :: "('a iarray \<Rightarrow> 'a iarray \<Rightarrow> order) option" where
  "ccompare_iarray = (case ID CCOMPARE('a list) of None \<Rightarrow> None
  | Some c \<Rightarrow> Some (\<lambda>xs ys. c (IArray.list_of xs) (IArray.list_of ys)))"

instance
  apply standard
  apply unfold_locales
  using comparator.sym[OF ID_ccompare'] comparator.weak_eq[OF ID_ccompare']
    comparator.comp_trans[OF ID_ccompare'] iarray_list_of_inj
    apply (auto simp: ccompare_iarray_def split: option.splits)
   apply blast+
  done

end

derive (rbt) mapping_impl iarray

definition mk_db :: "String.literal list \<Rightarrow> String.literal set" where "mk_db = set"

definition init_vydra_string_enat :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (String.literal, enat, 'e) vydra" where
  "init_vydra_string_enat = init_vydra"
definition run_vydra_string_enat :: " _  \<Rightarrow> (String.literal, enat, 'e) vydra \<Rightarrow> _" where
  "run_vydra_string_enat = run_vydra"
definition progress_enat :: "(String.literal, enat) formula \<Rightarrow> enat list \<Rightarrow> nat" where
  "progress_enat = progress"
definition bounded_future_fmla_enat :: "(String.literal, enat) formula \<Rightarrow> bool" where
  "bounded_future_fmla_enat = bounded_future_fmla"
definition wf_fmla_enat :: "(String.literal, enat) formula \<Rightarrow> bool" where
  "wf_fmla_enat = wf_fmla"
definition mdl2mdl'_enat :: "(String.literal, enat) formula \<Rightarrow> (String.literal, enat) Preliminaries.formula" where
  "mdl2mdl'_enat = mdl2mdl'"
definition interval_enat :: "enat \<Rightarrow> enat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> enat \<I>" where
  "interval_enat = interval"
definition rep_interval_enat :: "enat \<I> \<Rightarrow> enat \<times> enat \<times> bool \<times> bool" where
  "rep_interval_enat = Rep_\<I>"

definition init_vydra_string_ereal :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (String.literal, ereal, 'e) vydra" where
  "init_vydra_string_ereal = init_vydra"
definition run_vydra_string_ereal :: " _  \<Rightarrow> (String.literal, ereal, 'e) vydra \<Rightarrow> _" where
  "run_vydra_string_ereal = run_vydra"
definition progress_ereal :: "(String.literal, ereal) formula \<Rightarrow> ereal list \<Rightarrow> real" where
  "progress_ereal = progress"
definition bounded_future_fmla_ereal :: "(String.literal, ereal) formula \<Rightarrow> bool" where
  "bounded_future_fmla_ereal = bounded_future_fmla"
definition wf_fmla_ereal :: "(String.literal, ereal) formula \<Rightarrow> bool" where
  "wf_fmla_ereal = wf_fmla"
definition mdl2mdl'_ereal :: "(String.literal, ereal) formula \<Rightarrow> (String.literal, ereal) Preliminaries.formula" where
  "mdl2mdl'_ereal = mdl2mdl'"
definition interval_ereal :: "ereal \<Rightarrow> ereal \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ereal \<I>" where
  "interval_ereal = interval"
definition rep_interval_ereal :: "ereal \<I> \<Rightarrow> ereal \<times> ereal \<times> bool \<times> bool" where
  "rep_interval_ereal = Rep_\<I>"

lemma tfin_enat_code[code]: "(tfin :: enat set) = Collect_set (\<lambda>x. x \<noteq> \<infinity>)"
  by (auto simp: tfin_enat_def)

lemma tfin_ereal_code[code]: "(tfin :: ereal set) = Collect_set (\<lambda>x. x \<noteq> -\<infinity> \<and> x \<noteq> \<infinity>)"
  by (auto simp: tfin_ereal_def)

lemma Ball_atms[code_unfold]: "Ball (atms r) P = list_all P (collect_subfmlas r [])"
  using collect_subfmlas_atms[where ?phis="[]"]
  by (auto simp: list_all_def)

lemma MIN_fold: "(MIN x\<in>set (z # zs). f x) = fold min (map f zs) (f z)"
  by (metis Min.set_eq_fold list.set_map list.simps(9))

declare progress.simps(1-8)[code]

lemma progress_matchP_code[code]:
  "progress (MatchP I r) ts = (case collect_subfmlas r [] of x # xs \<Rightarrow> fold min (map (\<lambda>f. progress f ts) xs) (progress x ts))"
  using collect_subfmlas_atms[where ?r=r and ?phis="[]"] atms_nonempty[of r]
  by (auto split: list.splits) (smt (z3) MIN_fold[where ?f="\<lambda>f. progress f ts"] list.simps(15))

lemma progress_matchF_code[code]:
  "progress (MatchF I r) ts = (if length ts = 0 then 0 else
  (let k = min (length ts - 1) (case collect_subfmlas r [] of x # xs \<Rightarrow> fold min (map (\<lambda>f. progress f ts) xs) (progress x ts)) in
   Min {j \<in> {..k}. memR (ts ! j) (ts ! k) I}))"
  by (auto simp: progress_matchP_code[unfolded progress.simps])

export_code init_vydra_string_enat run_vydra_string_enat progress_enat bounded_future_fmla_enat wf_fmla_enat mdl2mdl'_enat
  Bool Preliminaries.Bool enat interval_enat rep_interval_enat nat_of_integer integer_of_nat mk_db
  in OCaml module_name VYDRA file_prefix "verified"

end