theory ASC_Hoare
  imports ASC_Sufficiency "HOL-Hoare.Hoare_Logic"
begin

section \<open> Correctness of the Adaptive State Counting Algorithm in Hoare-Logic \<close>

text \<open>
In this section we give an example implementation of the adaptive state counting algorithm in a
simple WHILE-language and prove that this implementation produces a certain output if and only if
input FSM @{verbatim M1} is a reduction of input FSM @{verbatim M2}.
\<close>

lemma atc_io_reduction_on_sets_from_obs :
  assumes "L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 T"
  and "(\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>) \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
shows "atc_io_reduction_on_sets M1 T \<Omega> M2"
  unfolding atc_io_reduction_on_sets.simps atc_io_reduction_on.simps
proof
  fix iseq assume "iseq \<in> T"
  have "L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}"
    by (metis \<open>iseq \<in> T\<close> assms(1) bot.extremum insert_mono io_reduction_on_subset
        mk_disjoint_insert)
  moreover have "\<forall>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega> \<subseteq> B M2 io \<Omega>"
  proof
    fix io assume "io \<in> L\<^sub>i\<^sub>n M1 {iseq}"
    then have "io \<in> L\<^sub>i\<^sub>n M2 {iseq}"
      using calculation by blast
    show "B M1 io \<Omega> \<subseteq> B M2 io \<Omega> "
    proof
      fix x assume "x \<in> B M1 io \<Omega>"

      have "io \<in> L\<^sub>i\<^sub>n M1 T"
        using \<open>io \<in> L\<^sub>i\<^sub>n M1 {iseq}\<close> \<open>iseq \<in> T\<close> by auto
      moreover have "(io,x) \<in> {io} \<times> B M1 io \<Omega>"
        using \<open>x \<in> B M1 io \<Omega>\<close> by blast
      ultimately have "(io,x) \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>)"
        by blast

      then have "(io,x) \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
        using assms(2) by blast
      then have "(io,x) \<in> {io} \<times> B M2 io \<Omega>"
        by blast
      then show "x \<in> B M2 io \<Omega>"
        by blast
    qed
  qed
  ultimately show "L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}
                    \<and> (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega> \<subseteq> B M2 io \<Omega>)"
    by linarith
qed

lemma atc_io_reduction_on_sets_to_obs :
  assumes "atc_io_reduction_on_sets M1 T \<Omega> M2"
shows "L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 T"
  and "(\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>) \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
proof
  fix x assume "x \<in> L\<^sub>i\<^sub>n M1 T"
  show "x \<in> L\<^sub>i\<^sub>n M2 T"
    using assms unfolding atc_io_reduction_on_sets.simps atc_io_reduction_on.simps
  proof -
    assume a1: "\<forall>iseq\<in>T. L\<^sub>i\<^sub>n M1 {iseq} \<subseteq> L\<^sub>i\<^sub>n M2 {iseq}
                  \<and> (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {iseq}. B M1 io \<Omega> \<subseteq> B M2 io \<Omega>)"
    have f2: "x \<in> UNION T (language_state_for_input M1 (initial M1))"
      by (metis (no_types) \<open>x \<in> L\<^sub>i\<^sub>n M1 T\<close> language_state_for_inputs_alt_def)
    obtain aas :: "'a list set \<Rightarrow> ('a list \<Rightarrow> ('a \<times> 'b) list set) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'a list"
      where
      "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x0 \<and> x2 \<in> x1 v3) = (aas x0 x1 x2 \<in> x0 \<and> x2 \<in> x1 (aas x0 x1 x2))"
      by moura
    then have "\<forall>ps f A. (ps \<notin> UNION A f \<or> aas A f ps \<in> A \<and> ps \<in> f (aas A f ps))
                          \<and> (ps \<in> UNION A f \<or> (\<forall>as. as \<notin> A \<or> ps \<notin> f as))"
      by blast
    then show ?thesis
      using f2 a1 by (metis (no_types) contra_subsetD language_state_for_input_alt_def
                      language_state_for_inputs_alt_def)
  qed
next
  show "(\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>) \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
  proof
    fix iox assume "iox \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>)"
    then obtain io x where "iox = (io,x)"
      by blast

    have "io \<in> L\<^sub>i\<^sub>n M1 T"
      using \<open>iox = (io, x)\<close> \<open>iox \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>)\<close> by blast
    have "(io,x) \<in> {io} \<times> B M1 io \<Omega>"
      using \<open>iox = (io, x)\<close> \<open>iox \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>)\<close> by blast
    then have "x \<in> B M1 io \<Omega>"
      by blast

    then have "x \<in> B M2 io \<Omega>"
      using assms unfolding atc_io_reduction_on_sets.simps atc_io_reduction_on.simps
      by (metis (no_types, lifting) UN_E \<open>io \<in> L\<^sub>i\<^sub>n M1 T\<close> language_state_for_input_alt_def
          language_state_for_inputs_alt_def subsetCE)
    then have "(io,x) \<in> {io} \<times>B M2 io \<Omega>"
      by blast
    then have "(io,x) \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
      using \<open>io \<in> L\<^sub>i\<^sub>n M1 T\<close> by auto
    then show "iox \<in> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>)"
      using \<open>iox = (io, x)\<close> by auto
  qed
qed

lemma atc_io_reduction_on_sets_alt_def :
  shows "atc_io_reduction_on_sets M1 T \<Omega> M2 =
           (L\<^sub>i\<^sub>n M1 T \<subseteq> L\<^sub>i\<^sub>n M2 T
            \<and> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 T. {io} \<times> B M1 io \<Omega>)
                \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 T. {io} \<times> B M2 io \<Omega>))"
  using atc_io_reduction_on_sets_to_obs[of M1 T \<Omega> M2]
  and   atc_io_reduction_on_sets_from_obs[of M1 T M2 \<Omega>]
  by blast

lemma asc_algorithm_correctness:
"VARS tsN cN rmN obs obsI obs\<^sub>\<Omega> obsI\<^sub>\<Omega> iter isReduction
  {
    OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>
  }
  tsN := {};
  cN  := V;
  rmN := {};
  obs := L\<^sub>i\<^sub>n M2 cN;
  obsI := L\<^sub>i\<^sub>n M1 cN;
  obs\<^sub>\<Omega> := (\<Union>io\<in>L\<^sub>i\<^sub>n M2 cN. {io} \<times> B M2 io \<Omega>);
  obsI\<^sub>\<Omega> := (\<Union>io\<in>L\<^sub>i\<^sub>n M1 cN. {io} \<times> B M1 io \<Omega>);
  iter := 1;
  WHILE (cN \<noteq> {} \<and> obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>)
  INV {
    0 < iter
    \<and> tsN = TS M2 M1 \<Omega> V m (iter-1)
    \<and> cN = C M2 M1 \<Omega> V m iter
    \<and> rmN = RM M2 M1 \<Omega> V m (iter-1)
    \<and> obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN)
    \<and> obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN)
    \<and> obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)
    \<and> obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)
    \<and> OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>
  }
  DO
    iter := iter + 1;
    rmN := {xs' \<in> cN .
      (\<not> (L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}))
      \<or> (\<forall> io \<in> L\<^sub>i\<^sub>n M1 {xs'} .
          (\<exists> V'' \<in> N io M1 V .
            (\<exists> S1 .
              (\<exists> vs xs .
                io = (vs@xs)
                \<and> mcp (vs@xs) V'' vs
                \<and> S1 \<subseteq> nodes M2
                \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                  s1 \<noteq> s2 \<longrightarrow>
                    (\<forall> io1 \<in> RP M2 s1 vs xs V'' .
                       \<forall> io2 \<in> RP M2 s2 vs xs V'' .
                         B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))
                \<and> m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'' ))))};
    tsN := tsN \<union> cN;
    cN := append_set (cN - rmN) (inputs M2) - tsN;
    obs := obs \<union> L\<^sub>i\<^sub>n M2 cN;
    obsI := obsI \<union> L\<^sub>i\<^sub>n M1 cN;
    obs\<^sub>\<Omega> := obs\<^sub>\<Omega> \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 cN. {io} \<times> B M2 io \<Omega>);
    obsI\<^sub>\<Omega> := obsI\<^sub>\<Omega> \<union> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 cN. {io} \<times> B M1 io \<Omega>)
  OD;
  isReduction := ((obsI \<subseteq> obs) \<and> (obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>))
  {
    isReduction = M1 \<preceq> M2   \<comment>\<open>variable isReduction is used only as a return value,
                               it is true if and only if M1 is a reduction of M2\<close>
  }"
proof (vcg)
  assume precond : "OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>"
  have "{} = TS M2 M1 \<Omega> V m (1-1)"
       "V = C M2 M1 \<Omega> V m 1"
       "{} = RM M2 M1 \<Omega> V m (1-1)"
       "L\<^sub>i\<^sub>n M2 V = L\<^sub>i\<^sub>n M2 ({} \<union> V)"
       "L\<^sub>i\<^sub>n M1 V = L\<^sub>i\<^sub>n M1 ({} \<union> V)"
       "(\<Union>io\<in>L\<^sub>i\<^sub>n M2 V. {io} \<times> B M2 io \<Omega>)
          = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 ({} \<union> V). {io} \<times> B M2 io \<Omega>)"
       "(\<Union>io\<in>L\<^sub>i\<^sub>n M1 V. {io} \<times> B M1 io \<Omega>)
          = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 ({} \<union> V). {io} \<times> B M1 io \<Omega>)"
    using precond by auto
  moreover have "OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega> "
    using precond by assumption
  ultimately show "0 < (1::nat) \<and>
                   {} = TS M2 M1 \<Omega> V m (1 - 1) \<and>
                   V = C M2 M1 \<Omega> V m 1 \<and>
                   {} = RM M2 M1 \<Omega> V m (1 - 1) \<and>
                   L\<^sub>i\<^sub>n M2 V = L\<^sub>i\<^sub>n M2 ({} \<union> V) \<and>
                   L\<^sub>i\<^sub>n M1 V = L\<^sub>i\<^sub>n M1 ({} \<union> V) \<and>
                   (\<Union>io\<in>L\<^sub>i\<^sub>n M2 V. {io} \<times> B M2 io \<Omega>)
                      = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 ({} \<union> V). {io} \<times> B M2 io \<Omega>) \<and>
                   (\<Union>io\<in>L\<^sub>i\<^sub>n M1 V. {io} \<times> B M1 io \<Omega>)
                      = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 ({} \<union> V). {io} \<times> B M1 io \<Omega>) \<and>
                   OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>"
    by linarith+
next
  fix tsN cN rmN obs obsI obs\<^sub>\<Omega> obsI\<^sub>\<Omega> iter isReduction
  assume precond : "(0 < iter \<and>
                      tsN = TS M2 M1 \<Omega> V m (iter - 1) \<and>
                      cN = C M2 M1 \<Omega> V m iter \<and>
                      rmN = RM M2 M1 \<Omega> V m (iter - 1) \<and>
                      obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN) \<and>
                      obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN) \<and>
                      obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>) \<and>
                      obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>) \<and>
                      OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>)
                    \<and> cN \<noteq> {} \<and> obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>"
  then have "0 < iter"
            "OFSM M1"
            "OFSM M2"
            "asc_fault_domain M2 M1 m"
            "test_tools M2 M1 FAIL PM V \<Omega>"
            "cN \<noteq> {}"
            "obsI \<subseteq> obs"
            "tsN = TS M2 M1 \<Omega> V m (iter-1)"
            "cN = C M2 M1 \<Omega> V m iter"
            "rmN = RM M2 M1 \<Omega> V m (iter-1)"
            "obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN)"
            "obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN)"
            "obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)"
            "obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)"
    by linarith+

  obtain k where "iter = Suc k"
    using gr0_implies_Suc[OF \<open>0 < iter\<close>] by blast
  then have "cN = C M2 M1 \<Omega> V m (Suc k)"
            "tsN = TS M2 M1 \<Omega> V m k"
    using \<open>cN = C M2 M1 \<Omega> V m iter\<close> \<open>tsN = TS M2 M1 \<Omega> V m (iter-1)\<close> by auto
  have "TS M2 M1 \<Omega> V m iter = TS M2 M1 \<Omega> V m (Suc k)"
           "C M2 M1 \<Omega> V m iter = C M2 M1 \<Omega> V m (Suc k)"
           "RM M2 M1 \<Omega> V m iter = RM M2 M1 \<Omega> V m (Suc k)"
    using \<open>iter = Suc k\<close> by presburger+

  have rmN_calc[simp] : "{xs' \<in> cN.
        \<not> io_reduction_on M1 {xs'} M2 \<or>
        (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
            \<exists>V''\<in>N io M1 V.
               \<exists>S1 vs xs.
                  io = vs @ xs \<and>
                  mcp (vs @ xs) V'' vs \<and>
                  S1 \<subseteq> nodes M2 \<and>
                  (\<forall>s1\<in>S1.
                      \<forall>s2\<in>S1.
                         s1 \<noteq> s2 \<longrightarrow>
                         (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                            B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                  m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')} =
       RM M2 M1 \<Omega> V m iter"
  proof -

    have "{xs' \<in> cN.
          \<not> io_reduction_on M1 {xs'} M2 \<or>
          (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
              \<exists>V''\<in>N io M1 V.
                 \<exists>S1 vs xs.
                    io = vs @ xs \<and>
                    mcp (vs @ xs) V'' vs \<and>
                    S1 \<subseteq> nodes M2 \<and>
                    (\<forall>s1\<in>S1.
                        \<forall>s2\<in>S1.
                           s1 \<noteq> s2 \<longrightarrow>
                           (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                              B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                    m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')} =
          {xs' \<in> C M2 M1 \<Omega> V m (Suc k).
          \<not> io_reduction_on M1 {xs'} M2 \<or>
          (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
              \<exists>V''\<in>N io M1 V.
                 \<exists>S1 vs xs.
                    io = vs @ xs \<and>
                    mcp (vs @ xs) V'' vs \<and>
                    S1 \<subseteq> nodes M2 \<and>
                    (\<forall>s1\<in>S1.
                        \<forall>s2\<in>S1.
                           s1 \<noteq> s2 \<longrightarrow>
                           (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                              B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                    m < LB M2 M1 vs xs ((TS M2 M1 \<Omega> V m k) \<union> V) S1 \<Omega> V'')}"
      using \<open>cN = C M2 M1 \<Omega> V m (Suc k)\<close> \<open>tsN = TS M2 M1 \<Omega> V m k\<close> by blast

    moreover have "{xs' \<in> C M2 M1 \<Omega> V m (Suc k).
                    \<not> io_reduction_on M1 {xs'} M2 \<or>
                    (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                        \<exists>V''\<in>N io M1 V.
                           \<exists>S1 vs xs.
                              io = vs @ xs \<and>
                              mcp (vs @ xs) V'' vs \<and>
                              S1 \<subseteq> nodes M2 \<and>
                              (\<forall>s1\<in>S1.
                                  \<forall>s2\<in>S1.
                                     s1 \<noteq> s2 \<longrightarrow>
                                     (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                                        B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                              m < LB M2 M1 vs xs ((TS M2 M1 \<Omega> V m k) \<union> V) S1 \<Omega> V'')} =
                    RM M2 M1 \<Omega> V m (Suc k)"
      using RM.simps(2)[of M2 M1 \<Omega> V m k] by blast
    ultimately have "{xs' \<in> cN.
                      \<not> io_reduction_on M1 {xs'} M2 \<or>
                      (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                          \<exists>V''\<in>N io M1 V.
                             \<exists>S1 vs xs.
                                io = vs @ xs \<and>
                                mcp (vs @ xs) V'' vs \<and>
                                S1 \<subseteq> nodes M2 \<and>
                                (\<forall>s1\<in>S1.
                                    \<forall>s2\<in>S1.
                                       s1 \<noteq> s2 \<longrightarrow>
                                       (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                                          B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                                m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')} =
                      RM M2 M1 \<Omega> V m (Suc k)"
      by presburger
    then show ?thesis
      using \<open>iter = Suc k\<close> by presburger
  qed
  moreover have "RM M2 M1 \<Omega> V m iter = RM M2 M1 \<Omega> V m (iter + 1 - 1)" by simp
  ultimately have rmN_calc' : "{xs' \<in> cN.
        \<not> io_reduction_on M1 {xs'} M2 \<or>
        (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
            \<exists>V''\<in>N io M1 V.
               \<exists>S1 vs xs.
                  io = vs @ xs \<and>
                  mcp (vs @ xs) V'' vs \<and>
                  S1 \<subseteq> nodes M2 \<and>
                  (\<forall>s1\<in>S1.
                      \<forall>s2\<in>S1.
                         s1 \<noteq> s2 \<longrightarrow>
                         (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                            B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                  m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')} =
       RM M2 M1 \<Omega> V m (iter + 1 - 1)" by presburger

  have "tsN \<union> cN = TS M2 M1 \<Omega> V m (Suc k)"
  proof (cases k)
    case 0
    then show ?thesis
      using \<open>tsN = TS M2 M1 \<Omega> V m k\<close> \<open>cN = C M2 M1 \<Omega> V m (Suc k)\<close> by auto
  next
    case (Suc nat)
    then have "TS M2 M1 \<Omega> V m (Suc k) = TS M2 M1 \<Omega> V m k \<union> C M2 M1 \<Omega> V m (Suc k)"
      using TS.simps(3) by blast
    moreover have "tsN \<union> cN = TS M2 M1 \<Omega> V m k \<union> C M2 M1 \<Omega> V m (Suc k)"
      using \<open>tsN = TS M2 M1 \<Omega> V m k\<close> \<open>cN = C M2 M1 \<Omega> V m (Suc k)\<close> by auto
    ultimately show ?thesis
      by auto
  qed
  then have tsN_calc : "tsN \<union> cN = TS M2 M1 \<Omega> V m iter"
    using \<open>iter = Suc k\<close> by presburger

  have cN_calc : "append_set
        (cN -
         {xs' \<in> cN.
          \<not> io_reduction_on M1 {xs'} M2 \<or>
          (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
              \<exists>V''\<in>N io M1 V.
                 \<exists>S1 vs xs.
                    io = vs @ xs \<and>
                    mcp (vs @ xs) V'' vs \<and>
                    S1 \<subseteq> nodes M2 \<and>
                    (\<forall>s1\<in>S1.
                        \<forall>s2\<in>S1.
                           s1 \<noteq> s2 \<longrightarrow>
                           (\<forall>io1\<in>RP M2 s1 vs xs V''.
                               \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                    m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
        (inputs M2) -
       (tsN \<union> cN) =
       C M2 M1 \<Omega> V m (iter + 1)"
  proof -
    have "append_set
          (cN -
           {xs' \<in> cN.
            \<not> io_reduction_on M1 {xs'} M2 \<or>
            (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                \<exists>V''\<in>N io M1 V.
                   \<exists>S1 vs xs.
                      io = vs @ xs \<and>
                      mcp (vs @ xs) V'' vs \<and>
                      S1 \<subseteq> nodes M2 \<and>
                      (\<forall>s1\<in>S1.
                          \<forall>s2\<in>S1.
                             s1 \<noteq> s2 \<longrightarrow>
                             (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                 \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                      m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
          (inputs M2) -
         (tsN \<union> cN) =
         append_set
          ((C M2 M1 \<Omega> V m iter) -
           (RM M2 M1 \<Omega> V m iter))
          (inputs M2) -
         (TS M2 M1 \<Omega> V m iter) "
      using \<open>cN = C M2 M1 \<Omega> V m iter\<close> \<open>tsN \<union> cN = TS M2 M1 \<Omega> V m iter\<close> rmN_calc by presburger
    moreover have "append_set
          ((C M2 M1 \<Omega> V m iter) -
           (RM M2 M1 \<Omega> V m iter))
          (inputs M2) -
         (TS M2 M1 \<Omega> V m iter) = C M2 M1 \<Omega> V m (iter + 1)"
    proof -
      have "C M2 M1 \<Omega> V m (iter + 1) = C M2 M1 \<Omega> V m ((Suc k) + 1)"
        using \<open>iter = Suc k\<close> by presburger+
      moreover have "(Suc k) + 1 = Suc (Suc k)"
        by simp
      ultimately have "C M2 M1 \<Omega> V m (iter + 1) = C M2 M1 \<Omega> V m (Suc (Suc k))"
        by presburger

      have "C M2 M1 \<Omega> V m (Suc (Suc k))
              = append_set (C M2 M1 \<Omega> V m (Suc k) - RM M2 M1 \<Omega> V m (Suc k)) (inputs M2)
                - TS M2 M1 \<Omega> V m (Suc k)"
        using C.simps(3)[of M2 M1 \<Omega> V m k] by linarith
      show ?thesis
        using Suc_eq_plus1
              \<open>C M2 M1 \<Omega> V m (Suc (Suc k))
                = append_set (C M2 M1 \<Omega> V m (Suc k) - RM M2 M1 \<Omega> V m (Suc k)) (inputs M2)
                  - TS M2 M1 \<Omega> V m (Suc k)\<close>
              \<open>iter = Suc k\<close>
        by presburger
    qed

    ultimately show ?thesis
      by presburger
  qed

  have obs_calc : "obs \<union>
       L\<^sub>i\<^sub>n M2
        (append_set
          (cN -
           {xs' \<in> cN.
            \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
            (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                \<exists>V''\<in>N io M1 V.
                   \<exists>S1 vs xs.
                      io = vs @ xs \<and>
                      mcp (vs @ xs) V'' vs \<and>
                      S1 \<subseteq> nodes M2 \<and>
                      (\<forall>s1\<in>S1.
                          \<forall>s2\<in>S1.
                             s1 \<noteq> s2 \<longrightarrow>
                             (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                 \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                      m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
          (inputs M2) -
         (tsN \<union> cN)) =
       L\<^sub>i\<^sub>n M2
        (tsN \<union> cN \<union>
         (append_set
           (cN -
            {xs' \<in> cN.
             \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
             (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                 \<exists>V''\<in>N io M1 V.
                    \<exists>S1 vs xs.
                       io = vs @ xs \<and>
                       mcp (vs @ xs) V'' vs \<and>
                       S1 \<subseteq> nodes M2 \<and>
                       (\<forall>s1\<in>S1.
                           \<forall>s2\<in>S1.
                              s1 \<noteq> s2 \<longrightarrow>
                              (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                  \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                       m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
           (inputs M2) -
          (tsN \<union> cN)))"
  proof -
    have "\<And>A. L\<^sub>i\<^sub>n M2 (tsN \<union> cN \<union> A) = obs \<union> L\<^sub>i\<^sub>n M2 A"
      by (metis (no_types) language_state_for_inputs_union precond)
    then show ?thesis
      by blast
  qed

  have obsI_calc : "obsI \<union>
       L\<^sub>i\<^sub>n M1
        (append_set
          (cN -
           {xs' \<in> cN.
            \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
            (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                \<exists>V''\<in>N io M1 V.
                   \<exists>S1 vs xs.
                      io = vs @ xs \<and>
                      mcp (vs @ xs) V'' vs \<and>
                      S1 \<subseteq> nodes M2 \<and>
                      (\<forall>s1\<in>S1.
                          \<forall>s2\<in>S1.
                             s1 \<noteq> s2 \<longrightarrow>
                             (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                 \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                      m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
          (inputs M2) -
         (tsN \<union> cN)) =
       L\<^sub>i\<^sub>n M1
        (tsN \<union> cN \<union>
         (append_set
           (cN -
            {xs' \<in> cN.
             \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
             (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                 \<exists>V''\<in>N io M1 V.
                    \<exists>S1 vs xs.
                       io = vs @ xs \<and>
                       mcp (vs @ xs) V'' vs \<and>
                       S1 \<subseteq> nodes M2 \<and>
                       (\<forall>s1\<in>S1.
                           \<forall>s2\<in>S1.
                              s1 \<noteq> s2 \<longrightarrow>
                              (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                  \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                       m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
           (inputs M2) -
          (tsN \<union> cN)))"
  proof -
    have "\<And>A. L\<^sub>i\<^sub>n M1 (tsN \<union> cN \<union> A) = obsI \<union> L\<^sub>i\<^sub>n M1 A"
      by (metis (no_types) language_state_for_inputs_union precond)
    then show ?thesis
      by blast
  qed

  have obs\<^sub>\<Omega>_calc : "obs\<^sub>\<Omega> \<union>
       (\<Union>io\<in>L\<^sub>i\<^sub>n M2
              (append_set
                (cN -
                 {xs' \<in> cN.
                  \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                  (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                      \<exists>V''\<in>N io M1 V.
                         \<exists>S1 vs xs.
                            io = vs @ xs \<and>
                            mcp (vs @ xs) V'' vs \<and>
                            S1 \<subseteq> nodes M2 \<and>
                            (\<forall>s1\<in>S1.
                                \<forall>s2\<in>S1.
                                   s1 \<noteq> s2 \<longrightarrow>
                                   (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                       \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                            m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                (inputs M2) -
               (tsN \<union> cN)).
           {io} \<times> B M2 io \<Omega>) =
       (\<Union>io\<in>L\<^sub>i\<^sub>n M2
              (tsN \<union> cN \<union>
               (append_set
                 (cN -
                  {xs' \<in> cN.
                   \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                   (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                       \<exists>V''\<in>N io M1 V.
                          \<exists>S1 vs xs.
                             io = vs @ xs \<and>
                             mcp (vs @ xs) V'' vs \<and>
                             S1 \<subseteq> nodes M2 \<and>
                             (\<forall>s1\<in>S1.
                                 \<forall>s2\<in>S1.
                                    s1 \<noteq> s2 \<longrightarrow>
                                    (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                        \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                             m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                 (inputs M2) -
                (tsN \<union> cN))).
           {io} \<times> B M2 io \<Omega>)"
    using \<open>obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN)\<close>
          \<open>obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)\<close>
          obs_calc
    by blast

  have obsI\<^sub>\<Omega>_calc : "obsI\<^sub>\<Omega> \<union>
       (\<Union>io\<in>L\<^sub>i\<^sub>n M1
              (append_set
                (cN -
                 {xs' \<in> cN.
                  \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                  (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                      \<exists>V''\<in>N io M1 V.
                         \<exists>S1 vs xs.
                            io = vs @ xs \<and>
                            mcp (vs @ xs) V'' vs \<and>
                            S1 \<subseteq> nodes M2 \<and>
                            (\<forall>s1\<in>S1.
                                \<forall>s2\<in>S1.
                                   s1 \<noteq> s2 \<longrightarrow>
                                   (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                       \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                            m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                (inputs M2) -
               (tsN \<union> cN)).
           {io} \<times> B M1 io \<Omega>) =
       (\<Union>io\<in>L\<^sub>i\<^sub>n M1
              (tsN \<union> cN \<union>
               (append_set
                 (cN -
                  {xs' \<in> cN.
                   \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                   (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                       \<exists>V''\<in>N io M1 V.
                          \<exists>S1 vs xs.
                             io = vs @ xs \<and>
                             mcp (vs @ xs) V'' vs \<and>
                             S1 \<subseteq> nodes M2 \<and>
                             (\<forall>s1\<in>S1.
                                 \<forall>s2\<in>S1.
                                    s1 \<noteq> s2 \<longrightarrow>
                                    (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                        \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                             m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                 (inputs M2) -
                (tsN \<union> cN))).
           {io} \<times> B M1 io \<Omega>)"
    using \<open>obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN)\<close>
          \<open>obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)\<close>
          obsI_calc
    by blast

  have "0 < iter + 1"
    using \<open>0 < iter\<close> by simp
  have "tsN \<union> cN = TS M2 M1 \<Omega> V m (iter + 1 - 1)"
    using tsN_calc by simp

  from \<open>0 < iter + 1\<close>
       \<open>tsN \<union> cN = TS M2 M1 \<Omega> V m (iter + 1 - 1)\<close>
       cN_calc
       rmN_calc'
       obs_calc
       obsI_calc
       obs\<^sub>\<Omega>_calc
       obsI\<^sub>\<Omega>_calc
       \<open>OFSM M1\<close>
       \<open>OFSM M2\<close>
       \<open>asc_fault_domain M2 M1 m\<close>
       \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close>
  show "0 < iter + 1 \<and>
       tsN \<union> cN = TS M2 M1 \<Omega> V m (iter + 1 - 1) \<and>
       append_set
        (cN -
         {xs' \<in> cN.
          \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
          (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
              \<exists>V''\<in>N io M1 V.
                 \<exists>S1 vs xs.
                    io = vs @ xs \<and>
                    mcp (vs @ xs) V'' vs \<and>
                    S1 \<subseteq> nodes M2 \<and>
                    (\<forall>s1\<in>S1.
                        \<forall>s2\<in>S1.
                           s1 \<noteq> s2 \<longrightarrow>
                           (\<forall>io1\<in>RP M2 s1 vs xs V''.
                               \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                    m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
        (inputs M2) -
       (tsN \<union> cN) =
       C M2 M1 \<Omega> V m (iter + 1) \<and>
       {xs' \<in> cN.
        \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
        (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
            \<exists>V''\<in>N io M1 V.
               \<exists>S1 vs xs.
                  io = vs @ xs \<and>
                  mcp (vs @ xs) V'' vs \<and>
                  S1 \<subseteq> nodes M2 \<and>
                  (\<forall>s1\<in>S1.
                      \<forall>s2\<in>S1.
                         s1 \<noteq> s2 \<longrightarrow>
                         (\<forall>io1\<in>RP M2 s1 vs xs V''. \<forall>io2\<in>RP M2 s2 vs xs V''.
                            B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                  m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')} =
       RM M2 M1 \<Omega> V m (iter + 1 - 1) \<and>
       obs \<union>
       L\<^sub>i\<^sub>n M2
        (append_set
          (cN -
           {xs' \<in> cN.
            \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
            (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                \<exists>V''\<in>N io M1 V.
                   \<exists>S1 vs xs.
                      io = vs @ xs \<and>
                      mcp (vs @ xs) V'' vs \<and>
                      S1 \<subseteq> nodes M2 \<and>
                      (\<forall>s1\<in>S1.
                          \<forall>s2\<in>S1.
                             s1 \<noteq> s2 \<longrightarrow>
                             (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                 \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                      m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
          (inputs M2) -
         (tsN \<union> cN)) =
       L\<^sub>i\<^sub>n M2
        (tsN \<union> cN \<union>
         (append_set
           (cN -
            {xs' \<in> cN.
             \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
             (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                 \<exists>V''\<in>N io M1 V.
                    \<exists>S1 vs xs.
                       io = vs @ xs \<and>
                       mcp (vs @ xs) V'' vs \<and>
                       S1 \<subseteq> nodes M2 \<and>
                       (\<forall>s1\<in>S1.
                           \<forall>s2\<in>S1.
                              s1 \<noteq> s2 \<longrightarrow>
                              (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                  \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                       m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
           (inputs M2) -
          (tsN \<union> cN))) \<and>
       obsI \<union>
       L\<^sub>i\<^sub>n M1
        (append_set
          (cN -
           {xs' \<in> cN.
            \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
            (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                \<exists>V''\<in>N io M1 V.
                   \<exists>S1 vs xs.
                      io = vs @ xs \<and>
                      mcp (vs @ xs) V'' vs \<and>
                      S1 \<subseteq> nodes M2 \<and>
                      (\<forall>s1\<in>S1.
                          \<forall>s2\<in>S1.
                             s1 \<noteq> s2 \<longrightarrow>
                             (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                 \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                      m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
          (inputs M2) -
         (tsN \<union> cN)) =
       L\<^sub>i\<^sub>n M1
        (tsN \<union> cN \<union>
         (append_set
           (cN -
            {xs' \<in> cN.
             \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
             (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                 \<exists>V''\<in>N io M1 V.
                    \<exists>S1 vs xs.
                       io = vs @ xs \<and>
                       mcp (vs @ xs) V'' vs \<and>
                       S1 \<subseteq> nodes M2 \<and>
                       (\<forall>s1\<in>S1.
                           \<forall>s2\<in>S1.
                              s1 \<noteq> s2 \<longrightarrow>
                              (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                  \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                       m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
           (inputs M2) -
          (tsN \<union> cN))) \<and>
       obs\<^sub>\<Omega> \<union>
       (\<Union>io\<in>L\<^sub>i\<^sub>n M2
              (append_set
                (cN -
                 {xs' \<in> cN.
                  \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                  (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                      \<exists>V''\<in>N io M1 V.
                         \<exists>S1 vs xs.
                            io = vs @ xs \<and>
                            mcp (vs @ xs) V'' vs \<and>
                            S1 \<subseteq> nodes M2 \<and>
                            (\<forall>s1\<in>S1.
                                \<forall>s2\<in>S1.
                                   s1 \<noteq> s2 \<longrightarrow>
                                   (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                       \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                            m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                (inputs M2) -
               (tsN \<union> cN)).
           {io} \<times> B M2 io \<Omega>) =
       (\<Union>io\<in>L\<^sub>i\<^sub>n M2
              (tsN \<union> cN \<union>
               (append_set
                 (cN -
                  {xs' \<in> cN.
                   \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                   (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                       \<exists>V''\<in>N io M1 V.
                          \<exists>S1 vs xs.
                             io = vs @ xs \<and>
                             mcp (vs @ xs) V'' vs \<and>
                             S1 \<subseteq> nodes M2 \<and>
                             (\<forall>s1\<in>S1.
                                 \<forall>s2\<in>S1.
                                    s1 \<noteq> s2 \<longrightarrow>
                                    (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                        \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                             m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                 (inputs M2) -
                (tsN \<union> cN))).
           {io} \<times> B M2 io \<Omega>) \<and>
       obsI\<^sub>\<Omega> \<union>
       (\<Union>io\<in>L\<^sub>i\<^sub>n M1
              (append_set
                (cN -
                 {xs' \<in> cN.
                  \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                  (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                      \<exists>V''\<in>N io M1 V.
                         \<exists>S1 vs xs.
                            io = vs @ xs \<and>
                            mcp (vs @ xs) V'' vs \<and>
                            S1 \<subseteq> nodes M2 \<and>
                            (\<forall>s1\<in>S1.
                                \<forall>s2\<in>S1.
                                   s1 \<noteq> s2 \<longrightarrow>
                                   (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                       \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                            m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                (inputs M2) -
               (tsN \<union> cN)).
           {io} \<times> B M1 io \<Omega>) =
       (\<Union>io\<in>L\<^sub>i\<^sub>n M1
              (tsN \<union> cN \<union>
               (append_set
                 (cN -
                  {xs' \<in> cN.
                   \<not> L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'} \<or>
                   (\<forall>io\<in>L\<^sub>i\<^sub>n M1 {xs'}.
                       \<exists>V''\<in>N io M1 V.
                          \<exists>S1 vs xs.
                             io = vs @ xs \<and>
                             mcp (vs @ xs) V'' vs \<and>
                             S1 \<subseteq> nodes M2 \<and>
                             (\<forall>s1\<in>S1.
                                 \<forall>s2\<in>S1.
                                    s1 \<noteq> s2 \<longrightarrow>
                                    (\<forall>io1\<in>RP M2 s1 vs xs V''.
                                        \<forall>io2\<in>RP M2 s2 vs xs V''. B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega>)) \<and>
                             m < LB M2 M1 vs xs (tsN \<union> V) S1 \<Omega> V'')})
                 (inputs M2) -
                (tsN \<union> cN))).
           {io} \<times> B M1 io \<Omega>) \<and>
       OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>"
    by linarith
next
  fix tsN cN rmN obs obsI obs\<^sub>\<Omega> obsI\<^sub>\<Omega> iter isReduction
  assume precond : "(0 < iter \<and>
                    tsN = TS M2 M1 \<Omega> V m (iter - 1) \<and>
                    cN = C M2 M1 \<Omega> V m iter \<and>
                    rmN = RM M2 M1 \<Omega> V m (iter - 1) \<and>
                    obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN) \<and>
                    obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN) \<and>
                    obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>) \<and>
                    obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>) \<and>
                    OFSM M1 \<and> OFSM M2 \<and> asc_fault_domain M2 M1 m \<and> test_tools M2 M1 FAIL PM V \<Omega>) \<and>
                   \<not> (cN \<noteq> {} \<and> obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>)"
  then have "0 < iter"
            "OFSM M1"
            "OFSM M2"
            "asc_fault_domain M2 M1 m"
            "test_tools M2 M1 FAIL PM V \<Omega>"
            "cN = {} \<or> \<not> obsI \<subseteq> obs \<or> \<not> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>"
            "tsN = TS M2 M1 \<Omega> V m (iter-1)"
            "cN = C M2 M1 \<Omega> V m iter"
            "rmN = RM M2 M1 \<Omega> V m (iter-1)"
            "obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN)"
            "obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN)"
            "obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)"
            "obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)"
    by linarith+

  show "(obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>) = M1 \<preceq> M2"
  proof (cases "cN = {}")
    case True
    then have "C M2 M1 \<Omega> V m iter = {}"
      using \<open>cN = C M2 M1 \<Omega> V m iter\<close> by auto

    have "is_det_state_cover M2 V"
      using \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> by auto
    then have "[] \<in> V"
      using det_state_cover_initial[of M2 V] by simp
    then have "V \<noteq> {}"
      by blast
    have "Suc 0 < iter"
    proof (rule ccontr)
      assume "\<not> Suc 0 < iter"
      then have "iter = Suc 0"
        using \<open>0 < iter\<close> by auto
      then have "C M2 M1 \<Omega> V m (Suc 0) = {}"
        using \<open>C M2 M1 \<Omega> V m iter = {}\<close> by auto
      moreover have "C M2 M1 \<Omega> V m (Suc 0) = V"
        by auto
      ultimately show"False"
        using \<open>V \<noteq> {}\<close> by blast
    qed

    obtain k where "iter = Suc k"
      using gr0_implies_Suc[OF \<open>0 < iter\<close>] by blast
    then have "Suc 0 < Suc k"
      using \<open>Suc 0 < iter\<close> by auto
    then have "0 < k"
      by simp
    then obtain k' where "k = Suc k'"
      using gr0_implies_Suc by blast
    have "iter = Suc (Suc k')"
      using \<open>iter = Suc k\<close> \<open>k = Suc k'\<close> by simp

    have "TS M2 M1 \<Omega> V m (Suc (Suc k')) = TS M2 M1 \<Omega> V m (Suc k') \<union> C M2 M1 \<Omega> V m (Suc (Suc k'))"
      using TS.simps(3)[of M2 M1 \<Omega> V m k'] by blast
    then have "TS M2 M1 \<Omega> V m iter = TS M2 M1 \<Omega> V m (Suc k')"
      using True \<open>cN = C M2 M1 \<Omega> V m iter\<close> \<open>iter = Suc (Suc k')\<close> by blast
    moreover have "Suc k' = iter - 1"
      using \<open>iter = Suc (Suc k')\<close> by presburger
    ultimately have "TS M2 M1 \<Omega> V m iter = TS M2 M1 \<Omega> V m (iter - 1)"
      by auto
    then have "tsN = TS M2 M1 \<Omega> V m iter"
      using \<open>tsN = TS M2 M1 \<Omega> V m (iter-1)\<close> by simp

    then  have "TS M2 M1 \<Omega> V m iter = TS M2 M1 \<Omega> V m (iter - 1)"
      using \<open>tsN = TS M2 M1 \<Omega> V m (iter - 1)\<close> by auto
    then have "final_iteration M2 M1 \<Omega> V m (iter-1)"
      using \<open>0 < iter\<close> by auto

    have "M1 \<preceq> M2 = atc_io_reduction_on_sets M1 tsN \<Omega> M2"
      using asc_main_theorem[OF \<open>OFSM M1\<close> \<open>OFSM M2\<close>
                                \<open>asc_fault_domain M2 M1 m\<close>
                                \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close>
                                \<open>final_iteration M2 M1 \<Omega> V m (iter-1)\<close>]
      using \<open>tsN = TS M2 M1 \<Omega> V m (iter - 1)\<close>
      by blast
    moreover have "tsN \<union> cN = tsN"
      using \<open>cN = {}\<close> by blast
    ultimately have "M1 \<preceq> M2 = atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
      by presburger

    have "obsI \<subseteq> obs \<equiv> L\<^sub>i\<^sub>n M1 (tsN \<union> cN) \<subseteq> L\<^sub>i\<^sub>n M2 (tsN \<union> cN)"
      by (simp add: \<open>obs = L\<^sub>i\<^sub>n M2 (tsN \<union> cN)\<close> \<open>obsI = L\<^sub>i\<^sub>n M1 (tsN \<union> cN)\<close>)

    have "obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega> \<equiv> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)
                            \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)"
      by (simp add: \<open>obsI\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)\<close>
                    \<open>obs\<^sub>\<Omega> = (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)\<close>)

    have "(obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>) = atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
    proof
      assume "obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>"
      show "atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
        using atc_io_reduction_on_sets_from_obs[of M1 "tsN \<union> cN" M2 \<Omega>]
        using \<open>obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>\<close> \<open>obsI \<subseteq> obs \<equiv> L\<^sub>i\<^sub>n M1 (tsN \<union> cN) \<subseteq> L\<^sub>i\<^sub>n M2 (tsN \<union> cN)\<close>
              \<open>obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega> \<equiv> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)
                                \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)\<close>
        by linarith
    next
      assume "atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
      show "obsI \<subseteq> obs \<and> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>"
        using atc_io_reduction_on_sets_to_obs[of M1 \<open>tsN \<union> cN\<close> \<Omega> M2]
              \<open>atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2\<close>
              \<open>obsI \<subseteq> obs \<equiv> L\<^sub>i\<^sub>n M1 (tsN \<union> cN) \<subseteq> L\<^sub>i\<^sub>n M2 (tsN \<union> cN)\<close>
              \<open>obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega> \<equiv> (\<Union>io\<in>L\<^sub>i\<^sub>n M1 (tsN \<union> cN). {io} \<times> B M1 io \<Omega>)
                                \<subseteq> (\<Union>io\<in>L\<^sub>i\<^sub>n M2 (tsN \<union> cN). {io} \<times> B M2 io \<Omega>)\<close>
        by blast
    qed
    then show ?thesis
      using \<open>M1 \<preceq> M2 = atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2\<close> by linarith
next
    case False

    then have "\<not> obsI \<subseteq> obs \<or> \<not> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>"
      using \<open>cN = {} \<or> \<not> obsI \<subseteq> obs \<or> \<not> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>\<close> by auto

    have "\<not> atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
      using atc_io_reduction_on_sets_to_obs[of M1 "tsN \<union> cN" \<Omega> M2]
            \<open>\<not> obsI \<subseteq> obs \<or> \<not> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>\<close> precond
      by fastforce

    have "\<not> M1 \<preceq> M2"
    proof
      assume "M1 \<preceq> M2"
      have "atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2"
        using asc_soundness[OF \<open>OFSM M1\<close> \<open>OFSM M2\<close>] \<open>M1 \<preceq> M2\<close> by blast
      then show "False"
        using \<open>\<not> atc_io_reduction_on_sets M1 (tsN \<union> cN) \<Omega> M2\<close> by blast
    qed

    then show ?thesis
      using \<open>\<not> obsI \<subseteq> obs \<or> \<not> obsI\<^sub>\<Omega> \<subseteq> obs\<^sub>\<Omega>\<close> by blast

  qed
qed

end


(*  Title:      HOL/Hoare/Separation.thy
    Author:     Tobias Nipkow
    Copyright   2003 TUM

A first attempt at a nice syntactic embedding of separation logic.
Already builds on the theory for list abstractions.

If we suppress the H parameter for "List", we have to hardwired this
into parser and pretty printer, which is not very modular.
Alternative: some syntax like <P> which stands for P H. No more
compact, but avoids the funny H.

*)

theory Separation imports Hoare_Logic_Abort SepLogHeap begin

text\<open>The semantic definition of a few connectives:\<close>

definition ortho :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<longleftrightarrow> dom h1 \<inter> dom h2 = {}"

definition is_empty :: "heap \<Rightarrow> bool"
  where "is_empty h \<longleftrightarrow> h = empty"

definition singl:: "heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "singl h x y \<longleftrightarrow> dom h = {x} & h x = Some y"

definition star:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "star P Q = (\<lambda>h. \<exists>h1 h2. h = h1++h2 \<and> h1 \<bottom> h2 \<and> P h1 \<and> Q h2)"

definition wand:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "wand P Q = (\<lambda>h. \<forall>h'. h' \<bottom> h \<and> P h' \<longrightarrow> Q(h++h'))"

text\<open>This is what assertions look like without any syntactic sugar:\<close>

lemma "VARS x y z w h
 {star (%h. singl h x y) (%h. singl h z w) h}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

text\<open>Now we add nice input syntax.  To suppress the heap parameter
of the connectives, we assume it is always called H and add/remove it
upon parsing/printing. Thus every pointer program needs to have a
program variable H, and assertions should not contain any locally
bound Hs - otherwise they may bind the implicit H.\<close>

syntax
 "_emp" :: "bool" ("emp")
 "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
 "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
 "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)

(* FIXME does not handle "_idtdummy" *)
ML\<open>
(* free_tr takes care of free vars in the scope of sep. logic connectives:
   they are implicitly applied to the heap *)
fun free_tr(t as Free _) = t $ Syntax.free "H"
(*
  | free_tr((list as Free("List",_))$ p $ ps) = list $ Syntax.free "H" $ p $ ps
*)
  | free_tr t = t

fun emp_tr [] = Syntax.const @{const_syntax is_empty} $ Syntax.free "H"
  | emp_tr ts = raise TERM ("emp_tr", ts);
fun singl_tr [p, q] = Syntax.const @{const_syntax singl} $ Syntax.free "H" $ p $ q
  | singl_tr ts = raise TERM ("singl_tr", ts);
fun star_tr [P,Q] = Syntax.const @{const_syntax star} $
      absfree ("H", dummyT) (free_tr P) $ absfree ("H", dummyT) (free_tr Q) $
      Syntax.free "H"
  | star_tr ts = raise TERM ("star_tr", ts);
fun wand_tr [P, Q] = Syntax.const @{const_syntax wand} $
      absfree ("H", dummyT) P $ absfree ("H", dummyT) Q $ Syntax.free "H"
  | wand_tr ts = raise TERM ("wand_tr", ts);
\<close>

parse_translation \<open>
 [(@{syntax_const "_emp"}, K emp_tr),
  (@{syntax_const "_singl"}, K singl_tr),
  (@{syntax_const "_star"}, K star_tr),
  (@{syntax_const "_wand"}, K wand_tr)]
\<close>

text\<open>Now it looks much better:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>But the output is still unreadable. Thus we also strip the heap
parameters upon output:\<close>

ML \<open>
local

fun strip (Abs(_,_,(t as Const("_free",_) $ Free _) $ Bound 0)) = t
  | strip (Abs(_,_,(t as Free _) $ Bound 0)) = t
(*
  | strip (Abs(_,_,((list as Const("List",_))$ Bound 0 $ p $ ps))) = list$p$ps
*)
  | strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
  | strip (Abs(_,_,P)) = P
  | strip (Const(@{const_syntax is_empty},_)) = Syntax.const @{syntax_const "_emp"}
  | strip t = t;

in

fun is_empty_tr' [_] = Syntax.const @{syntax_const "_emp"}
fun singl_tr' [_,p,q] = Syntax.const @{syntax_const "_singl"} $ p $ q
fun star_tr' [P,Q,_] = Syntax.const @{syntax_const "_star"} $ strip P $ strip Q
fun wand_tr' [P,Q,_] = Syntax.const @{syntax_const "_wand"} $ strip P $ strip Q

end
\<close>

print_translation \<open>
 [(@{const_syntax is_empty}, K is_empty_tr'),
  (@{const_syntax singl}, K singl_tr'),
  (@{const_syntax star}, K star_tr'),
  (@{const_syntax wand}, K wand_tr')]
\<close>

text\<open>Now the intermediate proof states are also readable:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 y := w
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>So far we have unfolded the separation logic connectives in
proofs. Here comes a simple example of a program proof that uses a law
of separation logic instead.\<close>

(* a law of separation logic *)
lemma star_comm: "P ** Q = Q ** P"
  by(auto simp add:star_def ortho_def dest: map_add_comm)

lemma "VARS H x y z w
 {P ** Q}
 SKIP
 {Q ** P}"
apply vcg
apply(simp add: star_comm)
done

lemma "VARS H
 {p\<noteq>0 \<and> [p \<mapsto> x] ** List H q qs}
 H := H(p \<mapsto> q)
 {List H p (p#qs)}"
apply vcg
apply(simp add: star_def ortho_def singl_def)
apply clarify
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply simp
done

lemma "VARS H p q r
  {List H p Ps ** List H q Qs}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (List H p ps ** List H q qs) \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {List H q (rev Ps @ Qs)}"
apply vcg
apply(simp_all add: star_def ortho_def singl_def)

apply fastforce

apply (clarsimp simp add:List_non_null)
apply(rename_tac ps')
apply(rule_tac x = ps' in exI)
apply(rule_tac x = "p#qs" in exI)
apply simp
apply(rule_tac x = "h1(p:=None)" in exI)
apply(rule_tac x = "h2(p\<mapsto>q)" in exI)
apply simp
apply(rule conjI)
 apply(rule ext)
 apply(simp add:map_add_def split:option.split)
apply(rule conjI)
 apply blast
apply(simp add:map_add_def split:option.split)
apply(rule conjI)
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply(simp)
apply fast

apply(fastforce)
done

end


(*  Title:      HOL/Isar_Examples/Hoare.thy
    Author:     Markus Wenzel, TU Muenchen

A formulation of Hoare logic suitable for Isar.
*)

section \<open>Hoare Logic\<close>

theory Hoare
imports Main
begin

subsection \<open>Abstract syntax and semantics\<close>

text \<open>The following abstract syntax and semantics of Hoare Logic
  over \texttt{WHILE} programs closely follows the existing tradition
  in Isabelle/HOL of formalizing the presentation given in
  @{cite \<open>\S6\<close> "Winskel:1993"}.  See also @{file "~~/src/HOL/Hoare"} and
  @{cite "Nipkow:1998:Winskel"}.\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
    Basic "'a \<Rightarrow> 'a"
  | Seq "'a com" "'a com"    ("(_;/ _)" [60, 61] 60)
  | Cond "'a bexp" "'a com" "'a com"
  | While "'a bexp" "'a assn" "'a com"

abbreviation Skip  ("SKIP")
  where "SKIP \<equiv> Basic id"

type_synonym 'a sem = "'a \<Rightarrow> 'a \<Rightarrow> bool"

primrec iter :: "nat \<Rightarrow> 'a bexp \<Rightarrow> 'a sem \<Rightarrow> 'a sem"
where
  "iter 0 b S s s' \<longleftrightarrow> s \<notin> b \<and> s = s'"
| "iter (Suc n) b S s s' \<longleftrightarrow> s \<in> b \<and> (\<exists>s''. S s s'' \<and> iter n b S s'' s')"

primrec Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s s' \<longleftrightarrow> s' = f s"
| "Sem (c1; c2) s s' \<longleftrightarrow> (\<exists>s''. Sem c1 s s'' \<and> Sem c2 s'' s')"
| "Sem (Cond b c1 c2) s s' \<longleftrightarrow>
    (if s \<in> b then Sem c1 s s' else Sem c2 s s')"
| "Sem (While b x c) s s' \<longleftrightarrow> (\<exists>n. iter n b (Sem c) s s')"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
    ("(3\<turnstile> _/ (2_)/ _)" [100, 55, 100] 50)
  where "\<turnstile> P c Q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> P \<longrightarrow> s' \<in> Q)"

lemma ValidI [intro?]:
    "(\<And>s s'. Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q) \<Longrightarrow> \<turnstile> P c Q"
  by (simp add: Valid_def)

lemma ValidD [dest?]:
    "\<turnstile> P c Q \<Longrightarrow> Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q"
  by (simp add: Valid_def)

subsection \<open>Primitive Hoare rules\<close>

text \<open>From the semantics defined above, we derive the standard set
  of primitive Hoare rules; e.g.\ see @{cite \<open>\S6\<close> "Winskel:1993"}.
  Usually, variant forms of these rules are applied in actual proof,
  see also \S\ref{sec:hoare-isar} and \S\ref{sec:hoare-vcg}.

  \medskip The \name{basic} rule represents any kind of atomic access
  to the state space.  This subsumes the common rules of \name{skip}
  and \name{assign}, as formulated in \S\ref{sec:hoare-isar}.\<close>

theorem basic: "\<turnstile> {s. f s \<in> P} (Basic f) P"
proof
  fix s s'
  assume s: "s \<in> {s. f s \<in> P}"
  assume "Sem (Basic f) s s'"
  then have "s' = f s" by simp
  with s show "s' \<in> P" by simp
qed

text \<open>The rules for sequential commands and semantic consequences are
 established in a straight forward manner as follows.\<close>

theorem seq: "\<turnstile> P c1 Q \<Longrightarrow> \<turnstile> Q c2 R \<Longrightarrow> \<turnstile> P (c1; c2) R"
proof
  assume cmd1: "\<turnstile> P c1 Q" and cmd2: "\<turnstile> Q c2 R"
  fix s s'
  assume s: "s \<in> P"
  assume "Sem (c1; c2) s s'"
  then obtain s'' where sem1: "Sem c1 s s''" and sem2: "Sem c2 s'' s'"
    by auto
  from cmd1 sem1 s have "s'' \<in> Q" ..
  with cmd2 sem2 show "s' \<in> R" ..
qed

theorem conseq: "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P' c Q'"
proof
  assume P'P: "P' \<subseteq> P" and QQ': "Q \<subseteq> Q'"
  assume cmd: "\<turnstile> P c Q"
  fix s s' :: 'a
  assume sem: "Sem c s s'"
  assume "s : P'" with P'P have "s \<in> P" ..
  with cmd sem have "s' \<in> Q" ..
  with QQ' show "s' \<in> Q'" ..
qed

text \<open>The rule for conditional commands is directly reflected by the
  corresponding semantics; in the proof we just have to look closely
  which cases apply.\<close>

theorem cond:
  assumes case_b: "\<turnstile> (P \<inter> b) c1 Q"
    and case_nb: "\<turnstile> (P \<inter> -b) c2 Q"
  shows "\<turnstile> P (Cond b c1 c2) Q"
proof
  fix s s'
  assume s: "s \<in> P"
  assume sem: "Sem (Cond b c1 c2) s s'"
  show "s' \<in> Q"
  proof cases
    assume b: "s \<in> b"
    from case_b show ?thesis
    proof
      from sem b show "Sem c1 s s'" by simp
      from s b show "s \<in> P \<inter> b" by simp
    qed
  next
    assume nb: "s \<notin> b"
    from case_nb show ?thesis
    proof
      from sem nb show "Sem c2 s s'" by simp
      from s nb show "s : P \<inter> -b" by simp
    qed
  qed
qed

text \<open>The @{text while} rule is slightly less trivial --- it is the
  only one based on recursion, which is expressed in the semantics by
  a Kleene-style least fixed-point construction.  The auxiliary
  statement below, which is by induction on the number of iterations
  is the main point to be proven; the rest is by routine application
  of the semantics of \texttt{WHILE}.\<close>

theorem while:
  assumes body: "\<turnstile> (P \<inter> b) c P"
  shows "\<turnstile> P (While b X c) (P \<inter> -b)"
proof
  fix s s' assume s: "s \<in> P"
  assume "Sem (While b X c) s s'"
  then obtain n where "iter n b (Sem c) s s'" by auto
  from this and s show "s' \<in> P \<inter> -b"
  proof (induct n arbitrary: s)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then obtain s'' where b: "s \<in> b" and sem: "Sem c s s''"
      and iter: "iter n b (Sem c) s'' s'" by auto
    from Suc and b have "s \<in> P \<inter> b" by simp
    with body sem have "s'' \<in> P" ..
    with iter show ?case by (rule Suc)
  qed
qed

subsection \<open>Concrete syntax for assertions\<close>

text \<open>We now introduce concrete syntax for describing commands (with
  embedded expressions) and assertions. The basic technique is that of
  semantic ``quote-antiquote''.  A \emph{quotation} is a syntactic
  entity delimited by an implicit abstraction, say over the state
  space.  An \emph{antiquotation} is a marked expression within a
  quotation that refers the implicit argument; a typical antiquotation
  would select (or even update) components from the state.

  We will see some examples later in the concrete rules and
  applications.\<close>

text \<open>The following specification of syntax and translations is for
  Isabelle experts only; feel free to ignore it.

  While the first part is still a somewhat intelligible specification
  of the concrete syntactic representation of our Hoare language, the
  actual ``ML drivers'' is quite involved.  Just note that the we
  re-use the basic quote/antiquote translations as already defined in
  Isabelle/Pure (see @{ML Syntax_Trans.quote_tr}, and
  @{ML Syntax_Trans.quote_tr'},).\<close>

syntax
  "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"  ("\<acute>_" [1000] 1000)
  "_Subst" :: "'a bexp \<Rightarrow> 'b \<Rightarrow> idt \<Rightarrow> 'a bexp"  ("_[_'/\<acute>_]" [1000] 999)
  "_Assert" :: "'a \<Rightarrow> 'a set"  ("(\<lbrace>_\<rbrace>)" [0] 1000)
  "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com"  ("(\<acute>_ :=/ _)" [70, 65] 61)
  "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
  "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0WHILE _/ INV _ //DO _ /OD)"  [0, 0, 0] 61)
  "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(0WHILE _ //DO _ /OD)"  [0, 0] 61)

translations
  "\<lbrace>b\<rbrace>" \<rightharpoonup> "CONST Collect (_quote b)"
  "B [a/\<acute>x]" \<rightharpoonup> "\<lbrace>\<acute>(_update_name x (\<lambda>_. a)) \<in> B\<rbrace>"
  "\<acute>x := a" \<rightharpoonup> "CONST Basic (_quote (\<acute>(_update_name x (\<lambda>_. a))))"
  "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond \<lbrace>b\<rbrace> c1 c2"
  "WHILE b INV i DO c OD" \<rightharpoonup> "CONST While \<lbrace>b\<rbrace> i c"
  "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr @{syntax_const "_antiquote"} t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(@{syntax_const "_quote"}, K quote_tr)] end
\<close>

text \<open>As usual in Isabelle syntax translations, the part for
  printing is more complicated --- we cannot express parts as macro
  rules as above.  Don't look here, unless you have to do similar
  things for yourself.\<close>

print_translation \<open>
  let
    fun quote_tr' f (t :: ts) =
          Term.list_comb (f $ Syntax_Trans.quote_tr' @{syntax_const "_antiquote"} t, ts)
      | quote_tr' _ _ = raise Match;

    val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});

    fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
          quote_tr' (Syntax.const name) (t :: ts)
      | bexp_tr' _ _ = raise Match;

    fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
          quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax_Trans.update_name_tr' f)
            (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
      | assign_tr' _ = raise Match;
  in
   [(@{const_syntax Collect}, K assert_tr'),
    (@{const_syntax Basic}, K assign_tr'),
    (@{const_syntax Cond}, K (bexp_tr' @{syntax_const "_Cond"})),
    (@{const_syntax While}, K (bexp_tr' @{syntax_const "_While_inv"}))]
  end
\<close>

subsection \<open>Rules for single-step proof \label{sec:hoare-isar}\<close>

text \<open>We are now ready to introduce a set of Hoare rules to be used
  in single-step structured proofs in Isabelle/Isar.  We refer to the
  concrete syntax introduce above.

  \medskip Assertions of Hoare Logic may be manipulated in
  calculational proofs, with the inclusion expressed in terms of sets
  or predicates.  Reversed order is supported as well.\<close>

lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast
lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast
lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast

lemma [trans]:
    "\<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)

lemma [trans]:
    "\<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)

text \<open>Identity and basic assignments.\footnote{The $\idt{hoare}$
  method introduced in \S\ref{sec:hoare-vcg} is able to provide proper
  instances for any number of basic assignments, without producing
  additional verification conditions.}\<close>

lemma skip [intro?]: "\<turnstile> P SKIP P"
proof -
  have "\<turnstile> {s. id s \<in> P} SKIP P" by (rule basic)
  then show ?thesis by simp
qed

lemma assign: "\<turnstile> P [\<acute>a/\<acute>x::'a] \<acute>x := \<acute>a P"
  by (rule basic)

text \<open>Note that above formulation of assignment corresponds to our
  preferred way to model state spaces, using (extensible) record types
  in HOL @{cite "Naraschewski-Wenzel:1998:HOOL"}.  For any record field
  $x$, Isabelle/HOL provides a functions $x$ (selector) and
  $\idt{x{\dsh}update}$ (update).  Above, there is only a place-holder
  appearing for the latter kind of function: due to concrete syntax
  \isa{\'x := \'a} also contains \isa{x\_update}.\footnote{Note that
  due to the external nature of HOL record fields, we could not even
  state a general theorem relating selector and update functions (if
  this were required here); this would only work for any particular
  instance of record fields introduced so far.}\<close>

text \<open>Sequential composition --- normalizing with associativity
  achieves proper of chunks of code verified separately.\<close>

lemmas [trans, intro?] = seq

lemma seq_assoc [simp]: "\<turnstile> P c1;(c2;c3) Q \<longleftrightarrow> \<turnstile> P (c1;c2);c3 Q"
  by (auto simp add: Valid_def)

text \<open>Conditional statements.\<close>

lemmas [trans, intro?] = cond

lemma [trans, intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c1 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace> c2 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> IF \<acute>b THEN c1 ELSE c2 FI Q"
    by (rule cond) (simp_all add: Valid_def)

text \<open>While statements --- with optional invariant.\<close>

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b P c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b undefined c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b INV \<lbrace>\<acute>P\<rbrace> DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

subsection \<open>Verification conditions \label{sec:hoare-vcg}\<close>

text \<open>We now load the \emph{original} ML file for proof scripts and
  tactic definition for the Hoare Verification Condition Generator
  (see @{file "~~/src/HOL/Hoare/"}).  As far as we
  are concerned here, the result is a proof method \name{hoare}, which
  may be applied to a Hoare Logic assertion to extract purely logical
  verification conditions.  It is important to note that the method
  requires \texttt{WHILE} loops to be fully annotated with invariants
  beforehand.  Furthermore, only \emph{concrete} pieces of code are
  handled --- the underlying tactic fails ungracefully if supplied
  with meta-variables or parameters, for example.\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
  by (auto simp add: Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
  by (auto simp: Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
  by (auto simp: Valid_def)

lemma CondRule:
  "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
    \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
  by (auto simp: Valid_def)

lemma iter_aux:
  "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
       (\<And>s s'. s \<in> I \<Longrightarrow> iter n b (Sem c) s s' \<Longrightarrow> s' \<in> I \<and> s' \<notin> b)"
  by (induct n) auto

lemma WhileRule:
    "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
  apply (clarsimp simp: Valid_def)
  apply (drule iter_aux)
    prefer 2
    apply assumption
   apply blast
  apply blast
  done

lemma Compl_Collect: "- Collect b = {x. \<not> b x}"
  by blast

lemmas AbortRule = SkipRule  -- "dummy version"

ML_file "~~/src/HOL/Hoare/hoare_tac.ML"

method_setup hoare =
  \<open>Scan.succeed (fn ctxt =>
    (SIMPLE_METHOD'
      (Hoare.hoare_tac ctxt
        (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm "Record.K_record_comp"}] )))))\<close>
  "verification condition generator for Hoare logic"

end


(*  Author:     Tobias Nipkow, 2007  *)

theory Cooper
imports PresArith
begin

subsection\<open>Cooper\<close>

text\<open>This section formalizes Cooper's algorithm~\<^cite>\<open>"Cooper72"\<close>.\<close>

lemma set_atoms0_iff:
 "qfree \<phi> \<Longrightarrow> a \<in> set(Z.atoms\<^sub>0 \<phi>) \<longleftrightarrow> a \<in> atoms \<phi> \<and> hd_coeff a \<noteq> 0"
by(induct \<phi>) (auto split:if_split_asm)

definition
"hd_coeffs1 \<phi> =
 (let m = zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))
  in And (Atom(Dvd m 0 [1])) (map\<^sub>f\<^sub>m (hd_coeff1 m) \<phi>))"

lemma I_hd_coeffs1:
assumes "qfree \<phi>"
shows "(\<exists>x. Z.I (hd_coeffs1 \<phi>) (x#xs)) = (\<exists>x. Z.I \<phi> (x#xs))" (is "?L = ?R")
proof -
  let ?l = "zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))"
  have "?l>0" by(simp add: zlcms_pos set_atoms0_iff[OF \<open>qfree \<phi>\<close>])
  have "?L = (\<exists>x. ?l dvd x+0 \<and> Z.I (map\<^sub>f\<^sub>m (hd_coeff1 ?l) \<phi>) (x#xs))"
    by(simp add:hd_coeffs1_def)
  also have "\<dots> = (\<exists>x. Z.I (map\<^sub>f\<^sub>m (hd_coeff1 ?l) \<phi>) (?l*x#xs))"
    by(rule unity_coeff_ex[THEN meta_eq_to_obj_eq,symmetric])
  also have "\<dots> = ?R"
    by(simp add: I_hd_coeff1_mult[OF \<open>?l>0\<close> \<open>qfree \<phi>\<close>] dvd_zlcms)
  finally show ?thesis .
qed

fun min_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>-") where
"inf\<^sub>- (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Atom(Le i (k#ks))) =
  (if k<0 then TrueF else if k>0 then FalseF else Atom(Le i (0#ks)))" |
"inf\<^sub>- \<phi> = \<phi>"

definition
"qe_cooper\<^sub>1 \<phi> =
 (let as = Z.atoms\<^sub>0 \<phi>; d = zlcms(map divisor as); ls = lbounds as
  in or (Disj [0..d - 1] (\<lambda>n. subst n [] (inf\<^sub>- \<phi>)))
        (Disj ls (\<lambda>(i,ks).
           Disj [0..d - 1] (\<lambda>n. subst (i + n) (-ks) \<phi>))))"

lemma min_inf:
  "nqfree f \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 f). hd_coeff_is1 a
   \<Longrightarrow> \<exists>x.\<forall>y<x. Z.I (inf\<^sub>- f) (y # xs) = Z.I f (y # xs)"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f rule: min_inf.induct)
  case (3 i k ks)
  { assume "k=0" hence ?case using 3 by simp }
  moreover
  { assume "k= -1"
    hence "?P (Atom(Le i (k#ks))) (-i + \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  moreover
  { assume "k=1"
    hence "?P (Atom(Le i (k#ks))) (i - \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  ultimately show ?case using 3 by auto
next
  case (1 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (min x1 x2)" by simp
  thus ?case ..
next
  case (2 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (min x1 x2)" by simp
  thus ?case ..
qed simp_all

lemma min_inf_repeats:
  "nqfree \<phi> \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d \<Longrightarrow>
  Z.I (inf\<^sub>- \<phi>) ((x - k*d)#xs) = Z.I (inf\<^sub>- \<phi>) (x#xs)"
proof(induct \<phi> rule:min_inf.induct)
  case ("4_4" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_4" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using \<open>da dvd d\<close>
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
next
  case ("4_5" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_5" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using \<open>da dvd d\<close>
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
qed simp_all

lemma atoms_subset: "qfree f \<Longrightarrow> set(Z.atoms\<^sub>0(f::atom fm)) \<le> atoms f"
by (induct f) auto

(* copied from Amine *)
lemma \<beta>:
  "\<lbrakk> nqfree \<phi>;  \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a;
     \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d; d > 0;
     \<not>(\<exists>j\<in>{0 .. d - 1}. \<exists>(i,ks) \<in> set(lbounds(Z.atoms\<^sub>0 \<phi>)).
         x = i - \<langle>ks,xs\<rangle> + j); Z.I \<phi> (x#xs) \<rbrakk>
  \<Longrightarrow> Z.I \<phi> ((x-d)#xs)"
proof(induct \<phi>)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Le i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Le Atom by simp
    next
      case (Cons k ks) thus ?thesis using Le Atom
        by (auto simp:lbounds_def Ball_def split:if_split_asm) arith
    qed
  next
    case (Dvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Dvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons Dvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons Dvd Atom by auto
        have "m dvd i + (x + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x - d + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d"
            by (metis \<open>m dvd d\<close> dvd_diff)
          thus ?thesis by(simp add:algebra_simps)
        qed
        thus ?thesis using Atom Dvd Cons by(auto split:if_split_asm)
      qed
    qed
  next
    case (NDvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using NDvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons NDvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons NDvd Atom by auto
        have "m dvd i + (x - d + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d" by(simp add:algebra_simps)
          thus ?thesis by (metis \<open>m dvd d\<close> zdvd_zdiffD)
        qed
        thus ?thesis using Atom NDvd Cons by(auto split:if_split_asm)
      qed
    qed
  qed
qed force+

lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j\<in>{0..d - 1}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d"
    by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  have "P(x mod d)" using dpos P Pmod by simp
  moreover have "x mod d \<in> {0..d - 1}" using dpos by auto
  ultimately show ?RHS ..
qed auto

lemma cpmi_eq: "(0::int) < D \<Longrightarrow> (\<exists>z. \<forall>x. x < z \<longrightarrow> (P x = P1 x))
\<Longrightarrow> \<forall>x.\<not>(\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)
\<Longrightarrow> \<forall>x. \<forall>k. P1 x = P1(x-k*D)
\<Longrightarrow> (\<exists>x. P(x)) = ((\<exists>j\<in>{0..D - 1}. P1(j)) \<or> (\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)))"
apply(rule iffI)
prefer 2
apply(drule minusinfinity)
apply assumption+
apply(fastforce)
apply clarsimp
apply(subgoal_tac "\<And>k. 0\<le>k \<Longrightarrow> \<forall>x. P x \<longrightarrow> P (x - k*D)")
apply(frule_tac x = x and z=z in decr_lemma)
apply(subgoal_tac "P1(x - (\<bar>x - z\<bar> + 1) * D)")
prefer 2
apply(subgoal_tac "0 \<le> (\<bar>x - z\<bar> + 1)")
prefer 2 apply arith
 apply fastforce
apply(drule (1)  periodic_finite_ex)
apply blast
apply(blast dest:decr_mult_lemma)
done

(* end of Amine *)

lemma qfree_min_inf[simp]: "qfree \<phi> \<Longrightarrow> qfree (inf\<^sub>- \<phi>)"
by (induct \<phi> rule:min_inf.induct) simp_all

lemma I_qe_cooper\<^sub>1:
assumes norm: "\<forall>a\<in>atoms \<phi>. divisor a \<noteq> 0"
and hd: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a" and "nqfree \<phi>"
shows "Z.I (qe_cooper\<^sub>1 \<phi>) xs = (\<exists>x. Z.I \<phi> (x#xs))"
proof -
  let ?as = "Z.atoms\<^sub>0 \<phi>"
  let ?d = "zlcms(map divisor ?as)"
  have "?d > 0" using norm atoms_subset[of \<phi>] \<open>nqfree \<phi>\<close>
    by(fastforce intro:zlcms_pos)
  have alld: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd ?d" by(simp add:dvd_zlcms)
  from cp_thm[OF \<open>nqfree \<phi>\<close> hd alld \<open>?d>0\<close>]
  show ?thesis using \<open>nqfree \<phi>\<close>
    by (simp add:qe_cooper\<^sub>1_def I_subst[symmetric] split_def algebra_simps) blast
qed

lemma divisor_hd_coeff1_neq0:
  "qfree \<phi> \<Longrightarrow> a \<in> atoms \<phi> \<Longrightarrow> divisor a \<noteq> 0 \<Longrightarrow>
   divisor (hd_coeff1 (zlcms (map hd_coeff (Z.atoms\<^sub>0 \<phi>))) a) \<noteq> 0"
apply (case_tac a)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp apply(simp split:if_split_asm)

apply simp
apply(rename_tac list)apply(case_tac list) apply simp
apply(clarsimp split:if_split_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a \<in> set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp
apply(clarsimp split:if_split_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a \<in> set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)
done

lemma hd_coeff_is1_hd_coeff1:
  "hd_coeff (hd_coeff1 m a) \<noteq> 0 \<longrightarrow> hd_coeff_is1 (hd_coeff1 m a)"
by (induct a rule: hd_coeff1.induct) (simp_all add:zsgn_def)

lemma I_cooper1_hd_coeffs1: "Z.normal \<phi> \<Longrightarrow> nqfree \<phi>
       \<Longrightarrow> Z.I (qe_cooper\<^sub>1(hd_coeffs1 \<phi>)) xs = (\<exists>x. Z.I \<phi> (x # xs))"
apply(simp add:Z.normal_def)
apply(subst I_qe_cooper\<^sub>1)
   apply(clarsimp simp:hd_coeffs1_def image_def set_atoms0_iff divisor_hd_coeff1_neq0)
  apply (clarsimp simp:hd_coeffs1_def qfree_map_fm set_atoms0_iff
                     hd_coeff_is1_hd_coeff1)
 apply(simp add:hd_coeffs1_def nqfree_map_fm)
apply(simp add: I_hd_coeffs1)
done

definition "qe_cooper = Z.lift_nnf_qe (qe_cooper\<^sub>1 \<circ> hd_coeffs1)"

lemma qfree_cooper1_hd_coeffs1: "qfree \<phi> \<Longrightarrow> qfree (qe_cooper\<^sub>1 (hd_coeffs1 \<phi>))"
by(auto simp:qe_cooper\<^sub>1_def hd_coeffs1_def qfree_map_fm
        intro!: qfree_or qfree_and qfree_list_disj qfree_min_inf)

lemma normal_min_inf: "Z.normal \<phi> \<Longrightarrow> Z.normal(inf\<^sub>- \<phi>)"
by(induct \<phi> rule:min_inf.induct) simp_all

lemma normal_cooper1: "Z.normal \<phi> \<Longrightarrow> Z.normal(qe_cooper\<^sub>1 \<phi>)"
by(simp add:qe_cooper\<^sub>1_def Logic.or_def Z.normal_map_fm normal_min_inf split_def)

lemma normal_hd_coeffs1: "qfree \<phi> \<Longrightarrow> Z.normal \<phi> \<Longrightarrow> Z.normal(hd_coeffs1 \<phi>)"
by(auto simp: hd_coeffs1_def image_def set_atoms0_iff
              divisor_hd_coeff1_neq0 Z.normal_def)

theorem I_cooper: "Z.normal \<phi> \<Longrightarrow>  Z.I (qe_cooper \<phi>) xs = Z.I \<phi> xs"
by(simp add:qe_cooper_def Z.I_lift_nnf_qe_normal qfree_cooper1_hd_coeffs1 I_cooper1_hd_coeffs1 normal_cooper1 normal_hd_coeffs1)

theorem qfree_cooper: "qfree (qe_cooper \<phi>)"
by(simp add:qe_cooper_def Z.qfree_lift_nnf_qe qfree_cooper1_hd_coeffs1)

end


(*  Title:      ZF/Induct/Binary_Trees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Binary trees\<close>

theory Binary_Trees imports Main begin

subsection \<open>Datatype definition\<close>

consts
  bt :: "i => i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

lemma Br_neq_left: "l \<in> bt(A) ==> Br(x, l, r) \<noteq> l"
  by (induct arbitrary: x r set: bt) auto

lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' & l = l' & r = r'"
  \<comment> "Proving a freeness theorem."
  by (fast elim!: bt.free_elims)

inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
  \<comment> "An elimination rule, for type-checking."

text \<open>
  \medskip Lemmas to justify using @{term bt} in other recursive type
  definitions.
\<close>

lemma bt_mono: "A \<subseteq> B ==> bt(A) \<subseteq> bt(B)"
  apply (unfold bt.defs)
  apply (rule lfp_mono)
    apply (rule bt.bnd_mono)+
  apply (rule univ_mono basic_monos | assumption)+
  done

lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
  apply (unfold bt.defs bt.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma bt_subset_univ: "A \<subseteq> univ(B) ==> bt(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule bt_mono)
  apply (rule bt_univ)
  done

lemma bt_rec_type:
  "[| t \<in> bt(A);
    c \<in> C(Lf);
    !!x y z r s. [| x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z) |] ==>
    h(x, y, z, r, s) \<in> C(Br(x, y, z))
  |] ==> bt_rec(c, h, t) \<in> C(t)"
  \<comment> \<open>Type checking for recursor -- example only; not really needed.\<close>
  apply (induct_tac t)
   apply simp_all
  done

subsection \<open>Number of nodes, with an example of tail-recursion\<close>

consts  n_nodes :: "i => i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) ==> n_nodes(t) \<in> nat"
  by (induct set: bt) auto

consts  n_nodes_aux :: "i => i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a, l, r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq:
    "t \<in> bt(A) ==> k \<in> nat ==> n_nodes_aux(t)`k = n_nodes(t) #+ k"
  apply (induct arbitrary: k set: bt)
   apply simp
  apply (atomize, simp)
  done

definition
  n_nodes_tail :: "i => i"  where
  "n_nodes_tail(t) == n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) ==> n_nodes_tail(t) = n_nodes(t)"
  by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection \<open>Number of leaves\<close>

consts
  n_leaves :: "i => i"
primrec
  "n_leaves(Lf) = 1"
  "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"

lemma n_leaves_type [simp]: "t \<in> bt(A) ==> n_leaves(t) \<in> nat"
  by (induct set: bt) auto

subsection \<open>Reflecting trees\<close>

consts
  bt_reflect :: "i => i"
primrec
  "bt_reflect(Lf) = Lf"
  "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"

lemma bt_reflect_type [simp]: "t \<in> bt(A) ==> bt_reflect(t) \<in> bt(A)"
  by (induct set: bt) auto

text \<open>
  \medskip Theorems about @{term n_leaves}.
\<close>

lemma n_leaves_reflect: "t \<in> bt(A) ==> n_leaves(bt_reflect(t)) = n_leaves(t)"
  by (induct set: bt) (simp_all add: add_commute)

lemma n_leaves_nodes: "t \<in> bt(A) ==> n_leaves(t) = succ(n_nodes(t))"
  by (induct set: bt) simp_all

text \<open>
  Theorems about @{term bt_reflect}.
\<close>

lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) ==> bt_reflect(bt_reflect(t)) = t"
  by (induct set: bt) simp_all

end