theory OneThirdRuleProof
imports OneThirdRuleDefs "../Reduction" "../Majorities"
begin

text \<open>
  We prove that \emph{One-Third Rule} solves the Consensus problem
  under the communication predicate defined above. The proof is
  split into proofs of the Integrity, Agreement, and Termination
  properties.
\<close>

subsection \<open>Proof of Integrity\<close>

text \<open>
  Showing integrity of the algorithm is a simple, if slightly tedious
  exercise in invariant reasoning. The following inductive invariant
  asserts that the values of the \<open>x\<close> and \<open>decide\<close> fields
  of the process states are limited to the \<open>x\<close> values present
  in the initial states since the algorithm does not introduce any
  new values.
\<close>

definition VInv where
  "VInv rho n \<equiv>
   let xinit = (range (x \<circ> (rho 0)))
   in  range (x \<circ> (rho n)) \<subseteq> xinit
     \<and> range (decide \<circ> (rho n)) \<subseteq> {None} \<union> (Some ` xinit)"

lemma vinv_invariant:
  assumes run:"HORun OTR_M rho HOs"
  shows "VInv rho n"
proof (induct n)
  from run show "VInv rho 0"
    by (simp add: HORun_eq HOinitConfig_eq OTR_HOMachine_def initState_def
                  OTR_initState_def VInv_def image_def)
next
  fix m
  assume ih: "VInv rho m"
  let ?xinit = "range (x \<circ> (rho 0))"
  have "range (x \<circ> (rho (Suc m))) \<subseteq> ?xinit"
  proof (clarsimp cong del: image_cong_simp)
    fix p
    from run
    have nxt: "OTR_nextState m p (rho m p)
                        (HOrcvdMsgs OTR_M m p (HOs m p) (rho m))
                        (rho (Suc m) p)"
          (is "OTR_nextState _ _ ?st ?msgs ?st'")
     by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
    show "x ?st' \<in> ?xinit"
    proof (cases "(2*N) div 3 < card (HOs m p)")
      case True
      hence HO: "HOs m p \<noteq> {}" by auto
      let ?MFRs = "{v. MFR ?msgs v}"
      have "Min ?MFRs \<in> ?MFRs"
      proof (rule Min_in)
        from HO have "?MFRs \<subseteq> (the \<circ> ?msgs)`(HOs m p)"
          by (auto simp: image_def intro: MFR_in_msgs)
        thus "finite ?MFRs" by (auto elim: finite_subset)
      next
        from MFR_exists show "?MFRs \<noteq> {}" by auto
      qed
      with HO have "\<exists>q \<in> HOs m p. Min ?MFRs = the (?msgs q)"
        by (intro MFR_in_msgs) auto
      hence "\<exists>q \<in> HOs m p. Min ?MFRs = x (rho m q)"
        by (auto simp: HOrcvdMsgs_def OTR_HOMachine_def OTR_sendMsg_def)
     moreover
      from True nxt have "x ?st' = Min ?MFRs"
        by (simp add: OTR_nextState_def HOrcvdMsgs_def)
     ultimately
        show ?thesis using ih by (auto simp: VInv_def image_def)
    next
      case False
      with nxt ih show ?thesis
        by (auto simp: OTR_nextState_def VInv_def HOrcvdMsgs_def Let_def)
    qed
  qed
  moreover
  have "\<forall>p. decide ((rho (Suc m)) p) \<in> {None} \<union> (Some ` ?xinit)"
  proof
    fix p
    from run
    have nxt: "OTR_nextState m p (rho m p)
                        (HOrcvdMsgs OTR_M m p (HOs m p) (rho m))
                        (rho (Suc m) p)"
          (is "OTR_nextState _ _ ?st ?msgs ?st'")
      by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
    show "decide ?st' \<in> {None} \<union> (Some ` ?xinit)"
    proof (cases "(2*N) div 3 < card {q. ?msgs q \<noteq> None}")
      assume HO: "(2*N) div 3 < card {q. ?msgs q \<noteq> None}"
      show ?thesis
      proof (cases "\<exists>v. TwoThirds ?msgs v")
        case True
        let ?dec = "\<some>v. TwoThirds ?msgs v"
        from True have "TwoThirds ?msgs ?dec" by (rule someI_ex)
        hence "HOV ?msgs ?dec \<noteq> {}" by (auto simp add: TwoThirds_def)
        then obtain q where "x (rho m q) = ?dec"
          by (auto simp: HOV_def HOrcvdMsgs_def OTR_HOMachine_def
                         OTR_sendMsg_def)
        from sym[OF this] nxt ih show ?thesis
          by (auto simp: OTR_nextState_def VInv_def image_def)
      next
        case False
        with HO nxt ih show ?thesis
          by (auto simp: OTR_nextState_def VInv_def HOrcvdMsgs_def image_def)
      qed
    next
      case False
      with nxt ih show ?thesis
        by (auto simp: OTR_nextState_def VInv_def image_def)
    qed
  qed
  hence "range (decide \<circ> (rho (Suc m))) \<subseteq> {None} \<union> (Some ` ?xinit)" by auto
  ultimately
  show "VInv rho (Suc m)" by (auto simp: VInv_def image_def)
qed

text \<open>
  Integrity is an immediate consequence.
\<close>
theorem OTR_integrity:
  assumes run:"HORun OTR_M rho HOs" and dec: "decide (rho n p) = Some v"
  shows "\<exists>q. v = x (rho 0 q)"
proof -
  let ?xinit = "range (x \<circ> (rho 0))"
  from run have "VInv rho n" by (rule vinv_invariant)
  hence "range (decide \<circ> (rho n)) \<subseteq> {None} \<union> (Some ` ?xinit)"
    by (auto simp: VInv_def Let_def)
  hence "decide ((rho n) p) \<in> {None} \<union> (Some ` ?xinit)"
    by (auto simp: image_def)
  with dec show ?thesis by auto
qed

subsection \<open>Proof of Agreement\<close>

text \<open>
  The following lemma \<open>A1\<close> asserts that if process \<open>p\<close>
  decides in a round on a value \<open>v\<close> then more than $2/3$ of
  all processes have \<open>v\<close> as their \<open>x\<close> value in their
  local state.

  We show a few simple lemmas in preparation.
\<close>

lemma nextState_change:
  assumes "HORun OTR_M rho HOs"
      and "\<not> ((2*N) div 3
              < card {q. (HOrcvdMsgs OTR_M n p (HOs n p) (rho n)) q \<noteq> None})"
  shows "rho (Suc n) p = rho n p"
  using assms
  by (auto simp: HORun_eq HOnextConfig_eq OTR_HOMachine_def
                 nextState_def OTR_nextState_def)

lemma nextState_decide:
  assumes run:"HORun OTR_M rho HOs"
  and chg: "decide (rho (Suc n) p) \<noteq> decide (rho n p)"
  shows "TwoThirds (HOrcvdMsgs OTR_M n p (HOs n p) (rho n))
                   (the (decide (rho (Suc n) p)))"
proof -
  from run
  have "OTR_nextState n p (rho n p)
                    (HOrcvdMsgs OTR_M n p (HOs n p) (rho n)) (rho (Suc n) p)"
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  with chg show ?thesis by (auto simp: OTR_nextState_def elim: someI)
qed

text \<open>
  The following lemma \<open>A2\<close> contains the crucial correctness argument:
  if more than $2/3$ of all processes send \<open>v\<close> and process \<open>p\<close>
  hears from more than $2/3$ of all processes then the \<open>x\<close> field of
  \<open>p\<close> will be updated to \<open>v\<close>.
\<close>

lemma A2:
  assumes run: "HORun OTR_M rho HOs"
  and HO: "(2*N) div 3
             < card { q . HOrcvdMsgs OTR_M n p (HOs n p) (rho n) q \<noteq> None }"
  and maj: "(2*N) div 3 < card { q . x (rho n q) = v }"
  shows "x (rho (Suc n) p) = v"
proof -
  from run
  have nxt: "OTR_nextState n p (rho n p)
                      (HOrcvdMsgs OTR_M n p (HOs n p) (rho n))
                      (rho (Suc n) p)"
        (is "OTR_nextState _ _ ?st ?msgs ?st'")
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  let ?HOVothers = "\<Union> { HOV ?msgs w | w . w \<noteq> v}"
  \<comment> \<open>processes from which @{text p} received values different from @{text v}\<close>

  have w: "card ?HOVothers \<le> N div 3"
  proof -
    have "card ?HOVothers \<le> card (UNIV - { q . x (rho n q) = v })"
      by (auto simp: HOV_def HOrcvdMsgs_def OTR_HOMachine_def OTR_sendMsg_def
               intro: card_mono)
    also have "\<dots> = N - card { q . x (rho n q) = v }"
      by (auto simp: card_Diff_subset)
    also from maj have "\<dots> \<le> N div 3" by auto
    finally show ?thesis .
  qed

  have hov: "HOV ?msgs v = { q . ?msgs q \<noteq> None } - ?HOVothers"
    by (auto simp: HOV_def) blast

  have othHO: "?HOVothers \<subseteq> { q . ?msgs q \<noteq> None }"
    by (auto simp: HOV_def)

  txt \<open>Show that \<open>v\<close> has been received from more than $N/3$ processes.\<close>
  from HO have "N div 3 < card { q . ?msgs q \<noteq> None } - (N div 3)"
    by auto
  also from w HO have "\<dots> \<le> card { q . ?msgs q \<noteq> None } - card ?HOVothers"
    by auto
  also from hov othHO have "\<dots> = card (HOV ?msgs v)"
    by (auto simp: card_Diff_subset)
  finally have HOV: "N div 3 < card (HOV ?msgs v)" .

  txt \<open>All other values are received from at most $N/3$ processes.\<close>
  have "\<forall>w. w \<noteq> v \<longrightarrow> card (HOV ?msgs w) \<le> card ?HOVothers"
    by (force intro: card_mono)
  with w have cardw: "\<forall>w. w \<noteq> v \<longrightarrow> card (HOV ?msgs w) \<le> N div 3" by auto

  txt \<open>In particular, \<open>v\<close> is the single most frequently received value.\<close>
  with HOV have "MFR ?msgs v" by (auto simp: MFR_def)

  moreover
  have "\<forall>w. w \<noteq> v \<longrightarrow> \<not>(MFR ?msgs w)"
  proof (auto simp: MFR_def not_le)
    fix w
    assume "w \<noteq> v"
    with cardw HOV have "card (HOV ?msgs w) < card (HOV ?msgs v)" by auto
    thus "\<exists>v. card (HOV ?msgs w) < card (HOV ?msgs v)" ..
  qed

  ultimately
  have mfrv: "{ w . MFR ?msgs w } = {v}" by auto

  have "card { q . ?msgs q = Some v } \<le> card { q . ?msgs q \<noteq> None }"
    by (auto intro: card_mono)
  with HO mfrv nxt show ?thesis by (auto simp: OTR_nextState_def)
qed

text \<open>
  Therefore, once more than two thirds of the processes hold \<open>v\<close>
  in their \<open>x\<close> field, this will remain true forever.
\<close>

lemma A3:
  assumes run:"HORun OTR_M rho HOs"
      and n: "(2*N) div 3 < card { q . x (rho n q) = v }" (is "?twothird n")
  shows "?twothird (n+k)"
proof (induct k)
  from n show "?twothird (n+0)" by simp
next
  fix m
  assume m: "?twothird (n+m)"
  have "\<forall>q. x (rho (n+m) q) = v \<longrightarrow> x (rho (n + Suc m) q) = v"
  proof (rule+)
    fix q
    assume q: "x ((rho (n+m)) q) = v"
    let ?msgs = "HOrcvdMsgs OTR_M (n+m) q (HOs (n+m) q) (rho (n+m))"
    show "x (rho (n + Suc m) q) = v"
    proof (cases "(2*N) div 3 < card { q . ?msgs q \<noteq> None }")
      case True
      from m have "(2*N) div 3 < card { q . x (rho (n+m) q) = v }" by simp
      with True run show ?thesis by (auto elim: A2)
    next
      case False
      with run q show ?thesis by (auto dest: nextState_change)
    qed
  qed
  hence "card {q. x (rho (n+m) q) = v} \<le> card {q. x (rho (n + Suc m) q) = v}"
    by (auto intro: card_mono)
  with m show "?twothird (n + Suc m)" by simp
qed

text \<open>
  It now follows that once a process has decided on some value \<open>v\<close>,
  more than two thirds of all processes continue to hold \<open>v\<close> in
  their \<open>x\<close> field.
\<close>

lemma A4:
  assumes run: "HORun OTR_M rho HOs"
  and dec: "decide (rho n p) = Some v" (is "?dec n")
  shows "\<forall>k. (2*N) div 3 < card { q . x (rho (n+k) q) = v }"
        (is "\<forall>k. ?twothird (n+k)")
using dec proof (induct n)
  \<comment> \<open>The base case is trivial since no process has decided\<close>
  assume "?dec 0" with run show "\<forall>k. ?twothird (0+k)"
    by (simp add: HORun_eq HOinitConfig_eq OTR_HOMachine_def
                  initState_def OTR_initState_def)
next
  \<comment> \<open>For the inductive step, we assume that process @{text p} has decided on @{text v}.\<close>
  fix m
  assume ih: "?dec m \<Longrightarrow> \<forall>k. ?twothird (m+k)" and m: "?dec (Suc m)"
  show "\<forall>k. ?twothird ((Suc m) + k)"
  proof
    fix k
    have "?twothird (m + Suc k)"
    txt \<open>
      There are two cases to consider: if \<open>p\<close> had already decided on \<open>v\<close>
      before, the assertion follows from the induction hypothesis. Otherwise, the
      assertion follows from lemmas \<open>A1\<close> and \<open>A3\<close>.
\<close>
    proof (cases "?dec m")
      case True with ih show ?thesis by blast
    next
      case False
      with run m have "?twothird m" by (auto elim: A1)
      with run show ?thesis by (blast dest: A3)
    qed
    thus "?twothird ((Suc m) + k)" by simp
  qed
qed

text \<open>
  The Agreement property follows easily from lemma \<open>A4\<close>: if processes
  \<open>p\<close> and \<open>q\<close> decide values \<open>v\<close> and \<open>w\<close>,
  respectively, then more than two thirds of the processes must propose
  \<open>v\<close> and more than two thirds must propose \<open>w\<close>.
  Because these two majorities must have an intersection, we must have
  \<open>v=w\<close>.

  We first prove an ``asymmetric'' version of the agreement property before
  deriving the general agreement theorem.
\<close>

lemma A5:
  assumes run:"HORun OTR_M rho HOs"
  and p: "decide (rho n p) = Some v"
  and p': "decide (rho (n+k) p') = Some w"
  shows "v = w"
proof -
  from run p
  have "(2*N) div 3 < card {q. x (rho (n+k) q) = v}" (is "_ < card ?V")
    by (blast dest: A4)
  moreover
  from run p'
  have "(2*N) div 3 < card {q. x (rho ((n+k)+0) q) = w}" (is "_ < card ?W")
    by (blast dest: A4)
  ultimately
  have "N < card ?V + card ?W" by auto
  then obtain proc where "proc \<in> ?V \<inter> ?W" by (auto dest: majorities_intersect)
  thus ?thesis by auto
qed

theorem OTR_agreement:
  assumes run:"HORun OTR_M rho HOs"
  and p: "decide (rho n p) = Some v"
  and p': "decide (rho m p') = Some w"
  shows "v = w"
proof (cases "n \<le> m")
  case True
  then obtain k where "m = n+k" by (auto simp add: le_iff_add)
  with run p p' show ?thesis by (auto elim: A5)
next
  case False
  hence "m \<le> n" by auto
  then obtain k where "n = m+k"  by (auto simp add: le_iff_add)
  with run p p' have "w = v" by (auto elim: A5)
  thus ?thesis ..
qed

subsection \<open>Proof of  Termination\<close>

text \<open>
  We now show that every process must eventually decide.

  The idea of the proof is to observe that the communication predicate
  guarantees the existence of two uniform rounds where every process hears
  from the same two-thirds majority of processes. The first such round
  serves to ensure that all \<open>x\<close> fields hold the same value, the
  second round copies that value into all decision fields.

  Lemma \<open>A2\<close> is instrumental in this proof.
\<close>

theorem OTR_termination:
  assumes run: "HORun OTR_M rho HOs"
      and commG: "HOcommGlobal OTR_M HOs"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG obtain r0 \<Pi> where
    pi: "\<forall>q. HOs r0 q = \<Pi>" and pic: "card \<Pi> > (2*N) div 3"
    by (auto simp: OTR_HOMachine_def OTR_commGlobal_def)
  let "?msgs q r" = "HOrcvdMsgs OTR_M r q (HOs r q) (rho r)"

  from run pi have "\<forall>p q. ?msgs q r0 = ?msgs p r0"
    by (auto simp: HORun_eq OTR_HOMachine_def HOrcvdMsgs_def OTR_sendMsg_def)
  then obtain \<mu> where "\<forall>q. ?msgs q r0 = \<mu>" by auto
  moreover
  from pi pic have "\<forall>p. (2*N) div 3 < card {q. ?msgs p r0 q \<noteq> None}"
    by (auto simp: HORun_eq HOnextConfig_eq HOrcvdMsgs_def)
  with run have "\<forall>q. x (rho (Suc r0) q) = Min {v . MFR (?msgs q r0) v}"
    by (auto simp: HORun_eq HOnextConfig_eq OTR_HOMachine_def
                   nextState_def OTR_nextState_def)
  ultimately
  have "\<forall>q. x (rho (Suc r0) q) = Min {v . MFR \<mu> v}" by auto
  then obtain v where v:"\<forall>q. x (rho (Suc r0) q) = v" by auto

  have P:"\<forall>k. \<forall>q. x (rho (Suc r0+k) q) = v"
  proof
    fix k
    show "\<forall>q. x (rho (Suc r0+k) q) = v"
    proof (induct k)
      from v show "\<forall>q. x (rho (Suc r0+0) q) = v" by simp
    next
      fix k
      assume ih:"\<forall>q. x (rho (Suc r0 + k) q) = v"
      show "\<forall>q. x (rho (Suc r0 + Suc k) q) = v"
      proof
        fix q
        show "x (rho (Suc r0 + Suc k) q) = v"
        proof (cases "(2*N) div 3 < card { p . ?msgs q (Suc r0 + k) p \<noteq> None }")
          case True
          have "N > 0" by (rule finite_UNIV_card_ge_0) simp
          with ih
          have "(2*N) div 3 < card { p . x (rho (Suc r0 + k) p) = v }" by auto
          with True run show ?thesis by (auto elim: A2)
        next
          case False
          with run ih show ?thesis by (auto dest: nextState_change)
        qed
      qed
    qed
  qed

  from commG obtain r0' \<Pi>'
    where r0': "r0' \<ge> Suc r0"
      and pi': "\<forall>q. HOs r0' q = \<Pi>'"
      and pic': "card \<Pi>' > (2*N) div 3"
    by (force simp: OTR_HOMachine_def OTR_commGlobal_def)
  from r0' P have v':"\<forall>q. x (rho r0' q) = v" by (auto simp: le_iff_add)

  from run
  have "OTR_nextState r0' p (rho r0' p) (?msgs p r0') (rho (Suc r0') p)"
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  moreover
  from pi' pic' have "(2*N) div 3 < card {q. (?msgs p r0') q \<noteq> None}"
    by (auto simp: HOrcvdMsgs_def OTR_sendMsg_def)
  moreover
  from pi' pic' v' have "TwoThirds (?msgs p r0') v"
    by (simp add: TwoThirds_def HOrcvdMsgs_def OTR_HOMachine_def
                  OTR_sendMsg_def HOV_def)
  ultimately
  have "decide (rho (Suc r0') p) = Some (\<some>v. TwoThirds (?msgs p r0') v)"
    by (auto simp: OTR_nextState_def)
  thus ?thesis by blast
qed

subsection \<open>\emph{One-Third Rule} Solves Consensus\<close>

text \<open>
  Summing up, all (coarse-grained) runs of \emph{One-Third Rule} for
  HO collections that satisfy the communication predicate satisfy
  the Consensus property.
\<close>

theorem OTR_consensus:
  assumes run: "HORun OTR_M rho HOs" and commG: "HOcommGlobal OTR_M HOs"
  shows "consensus (x \<circ> (rho 0)) decide rho"
  using OTR_integrity[OF run] OTR_agreement[OF run] OTR_termination[OF run commG]
  by (auto simp: consensus_def image_def)

text \<open>
  By the reduction theorem, the correctness of the algorithm also follows
  for fine-grained runs of the algorithm. It would be much more tedious
  to establish this theorem directly.
\<close>

theorem OTR_consensus_fg:
  assumes run: "fg_run OTR_M rho HOs HOs (\<lambda>r q. undefined)"
      and commG: "HOcommGlobal OTR_M HOs"
  shows "consensus (\<lambda>p. x (state (rho 0) p)) decide (state \<circ> rho)"
    (is "consensus ?inits _ _")
proof (rule local_property_reduction[OF run consensus_is_local])
  fix crun
  assume crun: "CSHORun OTR_M crun HOs HOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "HORun OTR_M crun HOs" by (unfold HORun_def SHORun_def)
  from this commG have "consensus (x \<circ> (crun 0)) decide crun" by (rule OTR_consensus)
  with init show "consensus ?inits decide crun" by (simp add: o_def)
qed

end


section \<open> Train Hybrid System \<close>

theory utp_trains
  imports
    "UTP1-Hybrid.utp_hybrid"
    "HOL-Decision_Procs.Approximation"
begin recall_syntax

subsection \<open> Constants \<close>

abbreviation "max_speed :: real \<equiv> 4.16"
abbreviation "normal_accel :: real \<equiv> 0.25"
abbreviation "normal_deceleration :: real \<equiv> -1.4"

abbreviation "track1_length \<equiv> 100"

subsection \<open> State-space \<close>

alphabet cst_train =
  accel :: real \<comment> \<open> Acceleration \<close>
  vel   :: real \<comment> \<open> Velocity \<close>
  pos   :: real \<comment> \<open> Position \<close>

term accel

print_theorems

setup_lifting type_definition_cst_train_ext

text \<open> Proof that the state-space is a T2 topological space. \<close>

instantiation cst_train_ext :: (t2_space) t2_space
begin
  lift_definition open_cst_train_ext :: "'a cst_train_scheme set \<Rightarrow> bool" is "open" .
  instance by (intro_classes, (transfer, auto simp add: separation_t2)+)
end

lemma continuous_Rep_cst_train_ext [continuous_intros]:
  "continuous_on UNIV Rep_cst_train_ext"
  by (metis continuous_on_open_vimage image_vimage_eq open_Int open_UNIV open_cst_train_ext.rep_eq)

lemma continuous_Abs_cst_train_ext  [continuous_intros]:
  "continuous_on UNIV (Abs_cst_train_ext :: _ \<Rightarrow> 'a::t2_space cst_train_scheme)"
  apply (subst continuous_on_open_vimage)
  apply (auto simp add: open_cst_train_ext.rep_eq)
  apply (metis Rep_cst_train_ext_inverse UNIV_I UNIV_eq_I image_eqI open_cst_train_ext.abs_eq open_cst_train_ext.rep_eq surj_image_vimage_eq)
done

text \<open> All three variable lenses are continuous \<close>

lemma continuous_get_accel [continuous_intros]: "continuous_on UNIV get\<^bsub>accel\<^esub>"
  by (simp add: lens_defs cst_train.select_defs iso_tuple_fst_def tuple_iso_tuple_def
      cst_train_ext_Tuple_Iso_def Topological_Spaces.continuous_on_fst continuous_Rep_cst_train_ext)

lemma continuous_get_vel [continuous_intros]: "continuous_on UNIV get\<^bsub>vel\<^esub>"
  by (simp add: lens_defs cst_train.select_defs iso_tuple_fst_def iso_tuple_snd_def tuple_iso_tuple_def
      cst_train_ext_Tuple_Iso_def Topological_Spaces.continuous_on_snd Topological_Spaces.continuous_on_fst continuous_Rep_cst_train_ext)

lemma continuous_get_pos [continuous_intros]: "continuous_on UNIV get\<^bsub>pos\<^esub>"
  by (simp add: lens_defs cst_train.select_defs iso_tuple_fst_def iso_tuple_snd_def tuple_iso_tuple_def
      cst_train_ext_Tuple_Iso_def Topological_Spaces.continuous_on_snd Topological_Spaces.continuous_on_fst continuous_Rep_cst_train_ext)

subsection \<open> Differential Equations and Solutions \<close>

abbreviation train_ode :: "real \<Rightarrow> real \<times> real \<times> real \<Rightarrow> real \<times> real \<times> real" where
"train_ode \<equiv> (\<lambda> t (a, v, p). (0, a, v))"

abbreviation train_sol :: "(real \<times> real \<times> real) \<Rightarrow> real \<Rightarrow> real \<times> real \<times> real" where
"train_sol \<equiv> (\<lambda> (a\<^sub>0, v\<^sub>0, p\<^sub>0) t. (a\<^sub>0, v\<^sub>0 + a\<^sub>0*t, p\<^sub>0 + v\<^sub>0*t + (a\<^sub>0*t\<^sup>2) / 2))"

lemma train_ode_sol:
  "l > 0 \<Longrightarrow> (train_sol (a\<^sub>0, v\<^sub>0, p\<^sub>0) solves_ode train_ode) {0..l} UNIV"
  by ode_cert

lemma train_ode_uniq_sol:
  assumes "l > 0"
  shows "(train_sol (a\<^sub>0, v\<^sub>0, p\<^sub>0) usolves_ode train_ode from 0) {0..l} UNIV"
proof -
  from assms have 1:"unique_on_strip 0 {0..l} train_ode 1"
    by (unfold_locales, auto intro!: continuous_on_Pair continuous_on_const Topological_Spaces.continuous_on_fst Topological_Spaces.continuous_on_snd continuous_on_snd simp add: lipschitz_on_def dist_Pair_Pair prod.case_eq_if)
  from assms have 2:"((train_sol (a\<^sub>0, v\<^sub>0, p\<^sub>0)) solves_ode train_ode) {0..l} UNIV"
    by (fact train_ode_sol)
  from 1 2 show sol:"((train_sol (a\<^sub>0, v\<^sub>0, p\<^sub>0)) usolves_ode train_ode from 0) {0..l} UNIV"
    by (auto, rule_tac uos_impl_uniq_sol[where L=1], simp_all)
qed

lemma train_sol:
  "\<langle>{&accel,&vel,&pos} \<bullet> train_ode(ti)\<rangle>\<^sub>h =
    {&accel,&vel,&pos} \<leftarrow>\<^sub>h \<guillemotleft>train_sol\<guillemotright>(($accel,$vel,$pos)\<^sub>u)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
    apply (subst ode_solution[where \<F>="train_sol"])
    apply (simp add: lens_indep_sym)
    apply (rule allI)
    apply (rule allI)
    apply (rule impI)
    apply (rename_tac x l)
    apply (case_tac x)
    apply (simp only:)
    apply (rule train_ode_uniq_sol, simp)
    apply (simp)
    apply (rel_auto)
done

lemma train_sol':
  "\<langle>{&accel,&vel,&pos} \<bullet> train_ode(ti)\<rangle>\<^sub>h =
    {&accel,&vel,&pos} \<leftarrow>\<^sub>h \<guillemotleft>train_sol\<guillemotright>(($accel,$vel,$pos)\<^sub>u)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
  by (ode_solve train_sol) (rel_auto)

subsection \<open> Braking train scenario \<close>

definition
"BrakingTrain =
   (\<^bold>c:accel, \<^bold>c:vel, \<^bold>c:pos) :=\<^sub>r (\<guillemotleft>normal_deceleration\<guillemotright>, \<guillemotleft>max_speed\<guillemotright>, \<guillemotleft>0\<guillemotright>) ;;
   \<langle>{&accel,&vel,&pos} \<bullet> train_ode(ti)\<rangle>\<^sub>h until\<^sub>h ($vel\<acute> \<le>\<^sub>u 0) ;; \<^bold>c:accel :=\<^sub>r 0"

theorem braking_train_pos_le:
 "($st:\<^bold>c:accel\<acute> =\<^sub>u 0 \<and> \<lceil>$pos\<acute> <\<^sub>u 44\<rceil>\<^sub>h) \<sqsubseteq> BrakingTrain" (is "?lhs \<sqsubseteq> ?rhs")
proof -
  \<comment> \<open> Solve ODE, replacing it with an explicit solution: @{term train_sol}. \<close>
  have "?rhs =
    (\<^bold>c:accel, \<^bold>c:vel, \<^bold>c:pos) :=\<^sub>r (\<guillemotleft>-1.4\<guillemotright>, \<guillemotleft>4.16\<guillemotright>, \<guillemotleft>0\<guillemotright>) ;;
    {&accel,&vel,&pos} \<leftarrow>\<^sub>h \<guillemotleft>train_sol\<guillemotright>($accel,$vel,$pos)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a until\<^sub>h ($vel\<acute> \<le>\<^sub>u 0) ;;
    \<^bold>c:accel :=\<^sub>r 0"
  by (simp only: BrakingTrain_def train_sol)
  \<comment> \<open> Set up initial values for the ODE solution using assigned variables. \<close>
  also have "... =
    {&accel,&vel,&pos} \<leftarrow>\<^sub>h \<guillemotleft>train_sol(-1.4,4.16,0)(ti)\<guillemotright> until\<^sub>h ($vel\<acute> \<le>\<^sub>u 0) ;; \<^bold>c:accel :=\<^sub>r 0"
    by (rel_auto)
  \<comment> \<open> Find the point at which the train stops \<close>
  also have "... =
    (({&accel,&vel,&pos} \<leftarrow>\<^sub>h(\<guillemotleft>416/140\<guillemotright>) \<guillemotleft>train_sol(-1.4,4.16,0)(ti)\<guillemotright>)) ;; \<^bold>c:accel :=\<^sub>r 0"
    apply (literalise)
    apply (subst hUntil_solve[of _ "416/140"])
    apply (simp_all add: usubst unrest)
    apply (force intro: continuous_intros)
    apply (force simp add: pr_var_def intro: continuous_intros)
    apply (pred_auto)
    done
  \<comment> \<open> Prove that this satisfies the continuous invariant \<close>
  also have "?lhs \<sqsubseteq> ..."
  proof (rel_simp)
    fix tr tr' :: "'a cst_train_scheme ttrace" and t::real
    assume "end\<^sub>t (tr' - tr) * 35 = 104" "0 \<le> t" "t < end\<^sub>t (tr' - tr)"
    hence "t \<in> {0..416/140}"
      by auto
    thus "104 * t / 25 - 7 * t\<^sup>2 / 10 < 44"
      by (approximation 4)
  qed
  finally show ?thesis .
qed

end


theory ComputationConGlob imports "ComputationCon"
begin
section \<open>Auxiliary lemmas\<close>

lemma eq_list_i:
  assumes a0:"length ba = length b" and a1:"\<forall>j. j \<noteq> i \<longrightarrow> ba ! j = b ! j" and
          a3:"i < length b"
        shows " take i b @ drop (Suc i) b = take i ba @ drop (Suc i) ba"
proof-
  have "b=  take i b @ b!i # drop (Suc i) b" and "ba =  take i ba @ ba!i # drop (Suc i) ba"
    using  a0 a3 by (auto simp add: id_take_nth_drop)
  then have  "\<forall>j<i. take i b = take i ba" using a0 a1 a3
    by (metis less_imp_le_nat less_irrefl_nat nth_take_lemma)
  moreover have  "\<forall>j< length ( drop (Suc i) ba).  drop (Suc i) b!j = drop (Suc i) ba!j"
    using a0 a1 a3
    by simp
  ultimately show ?thesis using a0 a3
    by (metis append_Nil append_eq_conv_conj length_drop linorder_neqE_nat list.size(3) not_less_zero nth_equalityI)
qed

section \<open>Computation: @{text "\<Gamma>\<turnstile>(c, s) \<rightarrow>\<^sub>i\<^sub>c\<^sub>e  (c', s')"}\<close>

type_synonym ('g,'l) par_state = "('g \<times> 'l list)"
type_synonym ('g,'l,'p,'f,'e) gconf = "('g \<times> 'l,'p,'f,'e)com  \<times> ('g,'l)par_state"
type_synonym ('g,'l,'p,'f,'e) gconfs = "('g\<times>'l,'p,'f,'e) body \<times> (('g,'l,'p,'f,'e) gconf) list"
type_synonym ('s) tran = "'s \<times> 's"
type_synonym ('s1,'s2) rel = "('s1 \<times> 's2) set"

definition toParState::"nat \<Rightarrow> ('g\<times>'l)\<times>('l list) \<Rightarrow>   ('g,'l)par_state"
  where "toParState i s \<equiv> let ((g,l),ls) = s in
             (g, (take i ls)@ (l#(drop i ls)))"

lemma toPar_li:"i \<le> length ls  \<Longrightarrow>
       (g',ls') = toParState i ((g,l),ls) \<Longrightarrow>
       ls' ! i = l"
  unfolding toParState_def
  by (auto, metis (no_types) length_take min.absorb2 nth_append_length)

lemma toPar_gi:"
       (g',ls') = toParState i ((g,l),ls) \<Longrightarrow>
       g' = g"
  unfolding toParState_def Let_def by auto

lemma toPar_ljlti:assumes a0:"i \<le> length ls" and a1:"j< i" and
       a2:"(g',ls') = toParState i ((g,l),ls)"
     shows" ls' ! j = ls!j"
proof -
  have "\<forall>as. take i as = take i ls \<or> ls' \<noteq> as"
    using a2 a0
    unfolding toParState_def by (simp add: append_eq_conv_conj min.absorb2)
  then show ?thesis
    using a2
    by (metis a1 nth_take)
qed

lemma toPar_ljgti:assumes a0:"i \<le> length ls" and a1:"j > i" and a1': "j< length ls'" and
       a2:"(g',ls') = toParState i ((g,l),ls)"
     shows" ls' ! j = ls!(j-1)"
proof-
  have ls':"ls' = take i ls @ l # drop i ls" using a2 unfolding toParState_def by auto
  then have "length ls' = length ls+1"
    by auto
  have j:"j < Suc (min (length ls) i + length ls - i)"
    using a0 a1 a1' a2 unfolding toParState_def by auto
  moreover { assume "(length ls) \<le> i + length ls - i"
    then have ?thesis using ls' a0 a1 ls'
      by (auto simp add: min.absorb2 nth_append)
  }
  moreover
  {assume "(length ls) > i + length ls - i"
    then have ?thesis using ls' a0 a1 ls'
      using diff_add_inverse min.strict_order_iff by auto
  }
  ultimately show ?thesis by auto
qed

lemma len_toParState:"length (snd (toParState i s )) = length (snd s) +1"
  unfolding toParState_def Let_def split_beta
  by simp

definition toSeqState::"nat \<Rightarrow>  ('g,'l)par_state \<Rightarrow> ('g\<times>'l)\<times>('l list)"
  where "toSeqState i s \<equiv> let (g,ls) = s in ((g,ls!i), take i ls @ drop (i+1) ls)"

lemma len_toSeqState:"i<length (snd s) \<Longrightarrow> length (snd (toSeqState i s)) = length (snd s) -1"
  unfolding toSeqState_def Let_def split_beta
  by simp

lemma i_less_toSeq:"i<length (snd (toSeqState i s)) \<Longrightarrow> i<length (snd s)"
  unfolding toSeqState_def Let_def split_beta
  by (metis Suc_eq_plus1 append_Nil2 drop_all
       less_imp_le_nat not_le_imp_less not_less_eq snd_conv take_all)

lemma Par2Seq0:"i\<le>length ls \<Longrightarrow> toSeqState i (toParState i ((g,l),ls)) = ((g,l),ls)"
proof (induct  rule: rev_induct)
  case Nil
  then show ?case  unfolding toSeqState_def toParState_def
    by (simp add: split_beta)
next
  case (snoc x xs)
  then show ?case unfolding toSeqState_def toParState_def Let_def
  proof(auto simp add: split_beta)
    assume "i \<le> Suc (length xs)"
    then show "(take i xs @ take (i - length xs) [x] @ l # drop i xs @ drop (i - length xs) [x]) ! i = l"
      by (metis append_assoc   length_append_singleton
          length_take min.absorb2 nth_append_length take_append)
  next
    assume a0:"i \<le> length xs \<Longrightarrow>
     (take i xs @ l # drop i xs) ! i = l \<and>
     take i xs @ drop (Suc i - min (length xs) i) (l # drop i xs) = xs" and
        a1:"i \<le> Suc (length xs)"
    show "take i xs @
        take (min (i - min (length xs) i) (i - length xs)) [x] @
        drop (Suc i - (min (length xs) i + min (Suc 0) (i - length xs)))
         (l # drop i xs @ drop (i - length xs) [x]) =
        xs @ [x]"
      using a0 a1
      by (simp add: Suc_diff_le drop_Cons' min_def not_less_eq_eq)
  qed
qed

lemma Par2Seq0f:"i\<le>length (snd s) \<Longrightarrow> toSeqState i (toParState i s) = s"
  using Par2Seq0
  by (metis snd_conv surj_pair)

lemma Par2Seq1:"i=length ls \<Longrightarrow> toSeqState i (toParState i (g,ls)) = (g,ls)"
  unfolding toSeqState_def toParState_def Let_def split_beta
  by auto

lemma Par2Seq1f:"i=length (snd s) \<Longrightarrow> toSeqState i (toParState i s) = s"
  using Par2Seq1
  by (metis snd_conv surj_pair)

lemma Par2Seq:"i\<le>length ls \<Longrightarrow> toSeqState i (toParState i (g,ls)) = (g,ls)"
  using Par2Seq0
  by (metis surj_pair)

lemma len_toParState_list:"(g',ls') = toParState i ((g,l),ls) \<Longrightarrow> length ls' = length ls +1"
  unfolding toParState_def by auto

lemma len_toSeqState_list:"i<length ls \<Longrightarrow> ((g',l),ls') = toSeqState i (g,ls) \<Longrightarrow> length ls = length ls' +1"
  unfolding toSeqState_def
  by auto

lemma Seq2Par:"i<length ls \<Longrightarrow> toParState i (toSeqState i (g,ls)) = (g,ls)"
proof (induct  rule: rev_induct)
  case Nil
  then show ?case unfolding toSeqState_def toParState_def Let_def
    by auto
next
  case (snoc x xs)
  then show ?case unfolding toSeqState_def toParState_def Let_def
    apply (auto simp add: split_beta)
    by (metis butlast_snoc drop_append id_take_nth_drop snoc.prems take_butlast)
qed

(* lemma assumes a0:"i<length sl" and
       a1:"length (snd (toParState (toSeqState i (sg, sl)) i)) =
       length (snd (toParState (toSeqState i (sg', sl')) i))"
     shows "length sl = length sl'"
proof-
  have "toParState (toSeqState i (sg, sl)) i = (sg, sl)"
    using a0
    by (simp add: Seq2Par)
qed *)

(* typedef ('g,'l) global_s = "{(i,g::('g\<times>'l)\<times>('l list)).  i \<le> length (snd g)  \<and> (\<exists>g'. g' = toParState i g)}"
  unfolding toParState_def
  by auto *)

typedef ('g,'l) global_s = "{(i,g::('g\<times>'l)\<times>('l list)).  i \<le> length (snd g)  \<and> (\<exists>g'. g' = toParState i g)}"
  unfolding toParState_def
  by auto

typedef ('g,'l) global_s1 = "{(g'::('g\<times>'l list)).  (\<exists>i g. i \<le> length (snd g')  \<and> (g' = toParState i g))}"
  unfolding toParState_def
  by auto

setup_lifting type_definition_global_s

lift_definition global_s_of_local::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow> ('g,'l) global_s"
  is "\<lambda>l. (((fst l) mod (length (snd (snd l)) +1), snd l))"
  by auto

(*
definition global_s_of_local::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow> ('g,'l) global_s"
  where "global_s_of_local l \<equiv> Abs_global_s (((fst l) mod length (snd (snd l)), snd l))"
 *)
definition transfer_global_s ::"(nat\<times>('g\<times>'l)\<times>('l list)) \<Rightarrow>('g,'l) global_s \<Rightarrow> bool"
  where "transfer_global_s l g \<equiv> g = global_s_of_local l"

print_theorems

typedef ('g,'l) type_global = "{g::('g,'l)par_state. \<forall>i<length (snd g). (\<exists>g'. g = toParState i g')}"
  unfolding toParState_def Let_def split_beta
  by fastforce

print_theorems

thm Abs_type_global_inject Rep_type_global Abs_type_global_inverse Rep_type_global_inverse

term Rep_type_global
term Abs_type_global

definition toSeqCptn:: "nat \<Rightarrow> (('g,'l,'p,'f,'e) gconf list) \<Rightarrow> ('g, 'l,  'p,'f,'e) config_gs list"
  where "toSeqCptn p cpt \<equiv>
     map (\<lambda>cfg. (fst cfg, toSeqState p (snd cfg))) cpt
"

lemma toSeqCptn_simp:"toSeqCptn i (x#xs) = (fst x, toSeqState i (snd x)) # (toSeqCptn i xs)"
  by (simp add: toSeqCptn_def)

lemma toSeqCptn_j:"j<length cpt \<Longrightarrow> (toSeqCptn p cpt)!j = (fst (cpt!j), toSeqState p (snd (cpt!j)))"
  unfolding toSeqCptn_def by auto

definition toParCptn::"nat \<Rightarrow> ('g, 'l,  'p,'f,'e) config_gs list \<Rightarrow> (('g,'l,'p,'f,'e) gconf list)"
  where "toParCptn p cpt \<equiv>
   map (\<lambda>cfg. (fst cfg, toParState p (snd cfg))) cpt
"

lemma toParCptn_simp:"toParCptn i (x#xs) = (fst x, toParState i (snd x)) # (toParCptn i xs)"
  by (simp add: toParCptn_def)

lemma toParCptn_j:"j<length cpt \<Longrightarrow> (toParCptn p cpt)!j = (fst (cpt!j), toParState p (snd (cpt!j)))"
  unfolding toParCptn_def by auto

definition Par_pred::"nat \<Rightarrow> (('g,'l) c_state)  set  \<Rightarrow> (('g,'l) par_state set)"
  where "Par_pred i p \<equiv> (toParState i) ` p"

definition Par_rel::"nat \<Rightarrow> (('g1,'l1) c_state, ('g2,'l2) c_state) rel  \<Rightarrow>
                      (('g1,'l1) par_state, ('g2,'l2) par_state) rel"
  where "Par_rel i r \<equiv> (\<lambda>(x,y). ((toParState i x), (toParState i y))) ` r"

definition Seq_pred::"nat \<Rightarrow> (('g,'l) par_state set) \<Rightarrow> (('g,'l) c_state)  set"
  where "Seq_pred i p \<equiv> (toSeqState i) ` p"

definition Seq_rel::"nat \<Rightarrow> (('g1,'l1) par_state, ('g2,'l2) par_state) rel \<Rightarrow> (('g1,'l1) c_state, ('g2,'l2) c_state) rel"
  where "Seq_rel i r \<equiv> (\<lambda>(x,y). ((toSeqState i x), (toSeqState i y))) ` r"

lemma Seq_Par_pred_ID:"\<forall>s\<in>p. i\<le>length (snd s) \<Longrightarrow> Seq_pred i (Par_pred i p) = p "
  unfolding Seq_pred_def Par_pred_def apply auto
  apply (simp add: Ball_def_raw Par2Seq0)
  by (metis Par2Seq0 rev_image_eqI snd_conv)

lemma Par_Seq_pred_ID:"\<forall>s\<in>p. i<length (snd s) \<Longrightarrow> Par_pred i (Seq_pred i p) = p "
  unfolding Seq_pred_def Par_pred_def apply auto
  apply (metis Seq2Par snd_conv)
  by (metis Seq2Par image_eqI snd_conv)

lemma Seq_Par_rel_ID:"\<forall>(x,y)\<in>(r::((('a,'b) c_state ) tran) set).
                     i\<le>length (snd x) \<and> i\<le>length (snd y) \<Longrightarrow>
                  Seq_rel i (Par_rel i r) =r"
  unfolding Seq_rel_def Par_rel_def split_beta image_def apply auto
  by (metis Par2Seq0 fst_conv  prod.exhaust_sel snd_conv)+

lemma Par_Seq_rel_ID:"\<forall>(x,y)\<in>(r::((('a,'b) par_state) tran) set).
                      i<length (snd x) \<and>  i<length (snd y) \<Longrightarrow>
                  Par_rel i (Seq_rel i r) =r"
  unfolding Seq_rel_def Par_rel_def split_beta image_def apply auto
   apply (metis Seq2Par fst_conv snd_conv)
  by (metis Seq2Par fst_conv  prod.exhaust_sel snd_conv)

lemma eq_toParSeqCptn:
   "\<forall>j<length ls. i< length (snd (snd (ls!j))) \<Longrightarrow>
        toParCptn i (toSeqCptn i ls) = ls"
  unfolding toParCptn_def toSeqCptn_def
  apply (rule nth_equalityI, auto) using Seq2Par
  by (metis Seq2Par prod.collapse)

lemma eq_toSeqParCptn:
   "\<forall>j<length ls.  i\<le> length (snd (snd (ls!j))) \<Longrightarrow>
        toSeqCptn i (toParCptn i ls) = ls"
  unfolding toParCptn_def toSeqCptn_def
  apply (rule nth_equalityI, auto) using Par2Seq
  by (metis prod.exhaust_sel)

inductive
 "step_cei"::"[('g\<times>'l,'p,'f,'e) body,nat,('g, 'l, 'p,'f,'e) gconf,('g, 'l, 'p,'f,'e) gconf] \<Rightarrow> bool"
                                ("_\<turnstile>\<^sub>c\<^sub>_ (_ \<rightarrow>\<^sub>c\<^sub>e/ _)" [81,81,81,81] 100)
  for \<Gamma>::"('g\<times>'l,'p,'f,'e) body"
  where
c_stepi: "\<lbrakk>\<Gamma>\<turnstile>\<^sub>c (c,sg) \<rightarrow>\<^sub>c\<^sub>e (c',sg')\<rbrakk> \<Longrightarrow>
          \<Gamma>\<turnstile>\<^sub>c\<^sub>i (c,toParState i sg ) \<rightarrow>\<^sub>c\<^sub>e (c', toParState i sg')"

inductive_cases step_cei:
 "\<Gamma>\<turnstile>\<^sub>c\<^sub>i cfg \<rightarrow>\<^sub>c\<^sub>e cfg'"

inductive_set cptni :: "(nat\<times>('g,'l,'p,'f,'e) gconfs) set"
where
  CptnOnei: " (i,\<Gamma>, [(P,s)]) \<in> cptni"
| Cptni: "\<lbrakk>\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t); (i,\<Gamma>,(Q, t)#xs) \<in> cptni \<rbrakk> \<Longrightarrow>
             (i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni"

inductive_cases cptni_cases:
"(i,\<Gamma>, [(P,s)]) \<in> cptni"
"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni"

lemma step_cei_ce: assumes a0:"i<length (snd s)" and
              a1:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  shows "\<Gamma>\<turnstile>\<^sub>c(P,toSeqState i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeqState i t)"
proof-
  obtain ss st where ce:"\<Gamma>\<turnstile>\<^sub>c(P,ss) \<rightarrow>\<^sub>c\<^sub>e (Q,st)" and
                  s1:"s=toParState i ss" and
                  s2:"t=toParState i st"
    by (auto intro:step_cei[OF a1])
  then have "length (snd s) = length (snd ss) + 1"
    using  s1 a0 len_toParState_list[of "fst s" "snd s" _ "fst (fst ss)" "snd (fst ss)" "snd ss"]
    by auto
  then have len_i:"i\<le> length (snd ss)"
    using a0 by linarith
  show ?thesis
    by (metis Par2Seq0 ce ce_eq_length len_i prod.exhaust_sel s1 s2)
qed

lemma step_cei_normal_normal_same_len:
  assumes  a0:"\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
  shows "length (snd s) = length (snd t)"
proof-
  obtain ssj ssj1 where "s = toParState i ssj" and "t = toParState i ssj1" and
                                 "\<Gamma>\<turnstile>\<^sub>c (P,ssj) \<rightarrow>\<^sub>c\<^sub>e (Q,ssj1)"
    using  step_cei.simps a0 by blast
  moreover  have "length (snd ssj) = length (snd ssj1)"
    using calculation ce_eq_length by blast
  ultimately show ?thesis
    by (metis  eq_snd_iff len_toParState_list)
qed

lemma step_ce_to_step_cei2:
  assumes a0:"i<length (snd s)"  and
          a2:"length (snd s) = length (snd t)" and
          a1:"\<Gamma>\<turnstile>\<^sub>c(P,toSeqState i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toSeqState i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P, s) \<rightarrow>\<^sub>c\<^sub>e (Q,t)"
 using c_stepi[OF a1, of i] using a0  a1  a2
  by (metis Seq2Par prod.exhaust_sel)

lemma same_local_sublist_toSeq_State:
  assumes a0:"(\<forall>j\<noteq>i. (snd s)!j = (snd t)!j)" and a1:"length (snd s) = length (snd t)" and
          a2:" i<length (snd s)"
        shows  "snd(toSeqState i s) = snd (toSeqState i t)"
  using a0 a1 a2  unfolding toSeqState_def Let_def split_beta eq_list_i
  apply simp
  by (metis append_eq_append_conv eq_list_i  length_take)

lemma step_cei_i1:
  assumes a0:"(\<forall>j\<noteq>i. (snd s)!j = (snd t)!j) \<and> length (snd s) = length (snd t)" and
          a1:"i<length (snd s)" and
          a2:"\<Gamma>\<turnstile>\<^sub>c (c, toSeq (toSeqState i s)) \<rightarrow> (c', toSeq (toSeqState i t))"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(c,s) \<rightarrow>\<^sub>c\<^sub>e (c',t)"
proof-
  have a1': "i<length (snd t)"
    using a0 a1 by auto
  have "snd (toSeqState i s) = snd (toSeqState i t)"
    using same_local_sublist_toSeq_State
    by (simp add: same_local_sublist_toSeq_State a0 a1')
  then have  c:"\<Gamma>\<turnstile>\<^sub>c (c, toSeqState i s) \<rightarrow>\<^sub>c\<^sub>e (c', toSeqState i t)"
    using c_step[OF a2]  by auto
  show ?thesis using c_stepi[OF c] a1 a1'
    by (simp add: a0 c step_ce_to_step_cei2)
qed

lemma step_cei_i2:
  assumes a0:"length (snd s) = length (snd t)" and
          a1:"i<length (snd s)" and
          a2:"\<Gamma>\<turnstile>\<^sub>c (c, toSeqState i s) \<rightarrow>\<^sub>e (c, toSeqState i t)"
        shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(c,s) \<rightarrow>\<^sub>c\<^sub>e (c,t)" using a0 a1 a2
  by (simp add: e_step step_ce_to_step_cei2)

lemma sublist:"j<(length c)-1 \<Longrightarrow> \<exists>c' c''. c = c'@([c!j,c!(j+1)]@c'')"
proof (induct j arbitrary: c)
  case 0
  then show ?case
    by (metis One_nat_def Suc_less_eq add.left_neutral append.assoc append_Cons append_Nil
               id_take_nth_drop less_Suc_eq take_Suc_conv_app_nth zero_less_diff)
next
  case (Suc j)
  then have "j<length c - 1 -1"
    by simp
  then show ?case using Suc
    by (metis Suc_eq_plus1 Suc_lessD append.assoc append_Cons append_Nil
             id_take_nth_drop less_diff_conv take_Suc_conv_app_nth)
qed

lemma cptni_dest:"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,(Q,t)#xs)\<in> cptni"
by (auto dest: cptni_cases)

lemma cptni_dest_pair:"(i,\<Gamma>,x#x1#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,x1#xs)\<in> cptni"
proof -
  assume "(i,\<Gamma>,x#x1#xs) \<in> cptni"
  thus ?thesis using cptni_dest prod.collapse by metis
qed

lemma cptni_dest1:"(i,\<Gamma>,(P,s)#(Q,t)#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,(P,s)#[(Q,t)])\<in> cptni"
proof -
  assume a1: "(i,\<Gamma>, (P, s) # (Q, t) # xs) \<in> cptni"
  have "(i,\<Gamma>, [(Q, t)]) \<in> cptni"
    by (meson cptni.CptnOnei)
  thus ?thesis
    using a1 cptni.Cptni cptni_cases(2) by blast
qed

lemma cptni_dest1_pair:"(i,\<Gamma>,x#x1#xs) \<in> cptni \<Longrightarrow> (i,\<Gamma>,x#[x1])\<in> cptni"
proof -
  assume "(i,\<Gamma>,x#x1#xs) \<in> cptni"
  thus ?thesis using cptni_dest1 prod.collapse by metis
qed

lemma cptni_append_is_cptni [rule_format]:
 "\<forall>b a. (i,\<Gamma>,b#c1)\<in>cptni \<longrightarrow>  (i,\<Gamma>,a#c2)\<in>cptni \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> (i,\<Gamma>,b#c1@c2)\<in>cptni"
apply(induct c1)
 apply simp
apply clarify
apply(erule cptni.cases,simp_all)
  using cptni.Cptni by blast
(* apply (simp add: cptn.CptnEnv)
by (simp add: cptn.CptnComp) *)

lemma cptni_dest_2:
  "(i,\<Gamma>,a#xs@ys) \<in> cptni  \<Longrightarrow> (i,\<Gamma>,a#xs)\<in> cptni"
proof (induct "xs" arbitrary: a)
  case Nil thus ?case using cptni.simps
    by (smt cptnip.CptnOnei cptnip_cptni_eq surj_pair)
next
  case (Cons x xs')
  then have "(i,\<Gamma>,a#[x])\<in>cptni" by (simp add: cptni_dest1_pair)
  also have "(i,\<Gamma>, x # xs') \<in> cptni"
    using Cons.hyps Cons.prems cptni_dest_pair by fastforce
  ultimately show ?case using cptni_append_is_cptni [of i \<Gamma> a "[x]" x xs']
    by force
qed

lemma tl_in_cptni: "\<lbrakk> (i,g,a#xs) \<in>cptni; xs\<noteq>[] \<rbrakk> \<Longrightarrow> (i,g,xs)\<in>cptni"
  by (force elim: cptni.cases)

lemma sublist_in_cptni:"(i,\<Gamma>, ys@ xs) \<in> cptni \<Longrightarrow> xs\<noteq> [] \<Longrightarrow> (i,\<Gamma>, xs) \<in> cptni"
proof(induct ys)
  case Nil
  then show ?case by auto
next
  case (Cons a ys)
  then have "(i,\<Gamma>, a # (ys @ xs)) \<in> cptni" by auto
  then show ?case using cptni_cases
    by (metis Cons.hyps Cons.prems(2) Nil_is_append_conv tl_in_cptni)
qed

lemma cptni_step_cei:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1"
  shows "\<Gamma>\<turnstile>\<^sub>c\<^sub>i (c!j) \<rightarrow>\<^sub>c\<^sub>e (c!(j+1))"
proof-
 obtain c' c'' where "c = c'@([c!j,c!(j+1)]@c'')" using sublist[OF a1] by auto
  then have "(i,\<Gamma>,c!j#(c!(j+1))#c'') \<in>cptni" using a0 sublist_in_cptni
    by (metis append_Cons append_Nil list.distinct(1))
  then obtain pj sj pj1 sj1
    where cptni:"(i,\<Gamma>,(pj,sj)#(pj1,sj1)#c'') \<in>cptni" and
          cj:"c!j = (pj,sj)" and cj1:"c!(j+1) =(pj1,sj1)"
    by (metis prod.exhaust_sel)
  then show ?thesis using cptni_cases(2)[OF cptni] by auto
qed

lemma step_cei_notNormal:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1" and
    a2:"fst (c!j) = Skip \<or> fst (c!j) = Throw \<or> fst (c!j) = Stuck \<or> (\<exists>f. fst (c!j) = Fault f)"
  shows "fst (c!j) = fst (c!(j+1))"
proof-
  obtain ca ca' sj sj' where
    "\<Gamma>\<turnstile>\<^sub>c (ca, sj) \<rightarrow>\<^sub>c\<^sub>e (ca', sj')" and
    "(c!j) = (ca, toParState i sj)" and "(c!(j+1)) = (ca', toParState i sj')"
    using step_cei[OF cptni_step_cei[OF a0 a1]]
    by metis
  moreover have "\<Gamma>\<turnstile>\<^sub>c (ca, (toSeq sj)) \<rightarrow> (ca', toSeq  sj') \<or>
             \<Gamma>\<turnstile>\<^sub>c (ca, sj) \<rightarrow>\<^sub>e (ca', sj')"
    using step_ce_dest calculation by blast
  ultimately show ?thesis apply auto using a2
    apply (fastforce elim:  stepc_elim_cases)
    by (drule stepe_elim_cases1, auto)
qed

lemma "i<length ls \<Longrightarrow> (gs,lss) = toParState i ((g,l),ls) \<Longrightarrow> lss!i = l"
  by (meson less_le toPar_li)

lemma step_cei_end_local_i:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1" and
          a2:"c!j = (p, (g,l))" and a2':"c!(j+1) = (p', (g',l'))" and
         a3:"i < length l" and a4:"p = Skip \<or> p = Throw \<or> p = Stuck \<or> (\<exists>f. p = Fault f)"
  shows "l!i = l'!i"
proof-
  obtain ca ca' sj sj' where
    "\<Gamma>\<turnstile>\<^sub>c (ca, sj) \<rightarrow>\<^sub>c\<^sub>e (ca', sj')" and
    cj:"(c!j) = (ca, toParState i sj)" and cj':"(c!(j+1)) = (ca', toParState i sj')"
    using step_cei[OF cptni_step_cei[OF a0 a1]]
    by metis
  moreover obtain sjg sjl sjls  sjg' sjl' sjls' where
    sj:"sj = ((sjg,sjl), sjls)" and sj':"sj' = ((sjg',sjl'), sjls')"
    using calculation
    by (metis prod.exhaust_sel)
  moreover have step:"\<Gamma>\<turnstile>\<^sub>c (ca, (toSeq sj)) \<rightarrow> (ca', toSeq  sj') \<or>
             \<Gamma>\<turnstile>\<^sub>c (ca, sj) \<rightarrow>\<^sub>e (ca', sj')"
    using step_ce_dest calculation by blast
  have isjls:"i\<le> length sjls" using a3 sj a2 cj
    by (metis Suc_eq_plus1 Suc_leI len_toParState not_less snd_conv)
  then have isjls':"i\<le>length sjls'"
    using a3 sj a2 cj len_toParState
    using calculation(1) ce_eq_length isjls sj' by fastforce

  { assume "\<Gamma>\<turnstile>\<^sub>c (ca, (toSeq sj)) \<rightarrow> (ca', toSeq  sj')"
    then have ?thesis apply auto using a2 a2'
      by (metis SmallStepCon.final_def SmallStepCon.no_step_final a4 calculation(2) fst_conv)
  }
  moreover { assume "\<Gamma>\<turnstile>\<^sub>c (ca, sj) \<rightarrow>\<^sub>e (ca', sj')"
    then have "sjl = sjl'" using sj sj'
      by (simp add: env_normal_same_local)
    moreover have "l!i = sjl" using sj cj a2 toPar_li[OF isjls, of g l sjg sjl] by auto
    moreover have "l'!i = sjl'" using sj' cj' a2' toPar_li[OF isjls', of g' l' sjg' sjl'] by auto
    ultimately have ?thesis using a2 a2' sj sj' cj cj' by auto
  }
  ultimately show ?thesis using step by auto
qed

lemma cptni_normal_normal_same_length:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and a1:"j<(length c)-1" and a2:"(c!j) = (p,(g,l))" and
       a3:"(c!(j+1)) = (p',(g',l'))"
     shows "length l = length l'"
  using cptni_step_cei[OF a0 a1] a2 a3 step_cei_normal_normal_same_len
  by fastforce

lemma cptni_i_normal_len:
    "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>  length c > 1 \<Longrightarrow> j<length c \<Longrightarrow> j'<length c \<Longrightarrow> j'\<ge>j \<Longrightarrow>
      (c!j) = (p,(g,l))  \<Longrightarrow> c!j' = (p',(g',l')) \<Longrightarrow>
      length l = length l'"
proof (induct "j'-j" arbitrary: j p p' g' g l l')
  case 0
  then show ?case by auto
next
  case (Suc x)
  {assume "x = 0"
    then have ?case using Suc step_cei_notNormal[OF Suc(3)]
   cptni_normal_normal_same_length[OF  Suc(3)]
      by (metis (no_types, lifting) One_nat_def le_add_diff_inverse less_diff_conv)
  }
  moreover { assume "x\<noteq>0"
    then have j:"j<(length c)-1" using Suc
      by linarith
    have x:"x=j' - (j+1)"
        by (metis (no_types) Suc.hyps(2) diff_Suc_1 diff_diff_add)
    moreover have j1_len:"j+1 < length c"
      using \<open>j < length c - 1\<close> less_diff_conv by blast
    moreover have  j_j':"j+1 \<le> j'"
      using \<open>x \<noteq> 0\<close> calculation(1) by auto
    ultimately have ?case using Suc  x j1_len j_j' j Suc(1)[OF x Suc(3,4) j1_len Suc(6) j_j']
               cptni_normal_normal_same_length[OF  Suc(3)]  by (metis prod_cases3)
  }
  ultimately show ?case by auto
qed

lemma length_locs_less_i:
  assumes a0:"(i,\<Gamma>,c) \<in> cptni" and
       a1:"length c > 0" and a2:"c!0 = (p, (g,l))" and
       a3:"i< length l"
     shows "\<forall>j<length c. i< length (snd (snd (c!j)))"
proof (cases "length c = 1")
  assume "length c = 1"
  then show ?thesis using a0 a1 a2 a3 by auto
next
  assume "length c\<noteq>1"
  then have l0:"length c>1" using a1 by linarith
  { fix j
    assume a00:"j<length c"
    have "0 \<le> j"
     by blast
   then have "i< length (snd (snd (c!j)))"
     using cptni_i_normal_len[OF a0 l0 a1 a00]  a2 a3
     by (metis prod.exhaust_sel)
  } thus ?thesis by auto
qed

lemma cptni_cptn:
 "(i,\<Gamma>,c) \<in> cptni \<Longrightarrow>
  c!0 = (p,(g,ls))   \<Longrightarrow> i< length ls \<Longrightarrow>
 (\<Gamma>, toSeqCptn i c) \<in> cptn"
proof (induct arbitrary: p g ls rule:cptni.induct)
  case (CptnOnei i \<Gamma> P s)
  then show ?case unfolding toSeqCptn_def
    by (simp add: cptn.CptnOne)
next
  case (Cptni \<Gamma> i P s Q t xs)
  have f1: "s = snd (p, g, ls)"
    using Cptni.prems(1) by fastforce
  then have f2: "(\<Gamma>, toSeqCptn i ((Q, t) # xs)) \<in> cptn"
    by (metis (no_types) Cptni.hyps(1) Cptni.hyps(3) Cptni.prems(2) eq_snd_iff
              nth_Cons_0 step_cei_normal_normal_same_len)
  have "\<Gamma>\<turnstile>\<^sub>c\<^sub>i (fst (P, s), snd (p, g, ls)) \<rightarrow>\<^sub>c\<^sub>e (fst (Q, t), t)"
    using Cptni.hyps(1) Cptni.prems(1) by auto
  then show ?case
    using f2 f1 by (simp add: Cptni.prems(2) cptn.Cptn step_cei_ce toSeqCptn_simp)
qed

lemma cptn_cptni:
 "(\<Gamma>,c) \<in> cptn \<Longrightarrow>
  c!0 = (p, ((g,l), ls))   \<Longrightarrow> i\<le> length ls \<Longrightarrow>
 (i,\<Gamma>, toParCptn i c) \<in> cptni"
proof (induct arbitrary: p g l ls rule:cptn.induct)
  case (CptnOne \<Gamma> P s)
  then show ?case unfolding toParCptn_def
    by (simp add: cptni.CptnOnei)
next
  case (Cptn \<Gamma> P s Q t xs)
  then have  "\<Gamma>\<turnstile>\<^sub>c\<^sub>i(P,toParState i s) \<rightarrow>\<^sub>c\<^sub>e (Q,toParState i t)"
    using c_stepi by blast
  moreover have " (i,\<Gamma>, toParCptn i ((Q, t) # xs)) \<in> cptni"
    using Cptn.hyps(3) Cptn.prems(2) using Cptn.hyps(1) Cptn.hyps(3) Cptn.prems(2)  ce_eq_length
    by (metis Cptn.prems(1) nth_Cons_0 prod.exhaust_sel snd_conv)
  ultimately show ?case using toParCptn_simp
    by (simp add: toParCptn_simp cptni.Cptni)
qed

lemma cptn_length_locs_less_i:
     assumes a0:"(\<Gamma>,c) \<in> cptn" and
       a1:"c!0= (p, ((g,l), ls))" and a2:"i\<le> length ls"
     shows "\<forall>j<length c. i\<le> length (snd (snd (c!j)))"
proof(cases "length c")
  case 0
  then show ?thesis by auto
next
  case (Suc nat)
  then have len:"length c>0" by auto
  have  cptni:"(i,\<Gamma>, toParCptn i c) \<in> cptni" using cptn_cptni[OF a0 a1 a2] by auto
  moreover obtain p' g' ls' where "toParCptn i c!0 = (p',(g',ls'))"
    by (metis surj_pair)
  ultimately have " i< length ls'"
    using a1 a2 len unfolding toParCptn_def
    unfolding toParState_def by auto
  then have "\<forall>j<length (toParCptn i c).
                          i<length (snd (snd ((toParCptn i c)!j)))"
    using \<open>toParCptn i c ! 0 = (p', g', ls')\<close> cptni length_locs_less_i by fastforce
  then show ?thesis using len unfolding toParCptn_def
    by (simp add: len_toParState less_Suc_eq_le)
qed

(* definition toParPred:: "(((('g, 'l, 'p,'f,'e) config_gs) list) \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ((('g,'l,'p,'f,'e) gconf list) \<Rightarrow> bool)"
  where "toParPred Q i \<equiv> (\<lambda>x. Q (toSeqCptn i x) )"

lemma "(\<Gamma>,c) \<in> cptn \<Longrightarrow> P c \<Longrightarrow> \<forall>sn. snd(c!0) = Normal sn \<or> snd(c!0) = Abrupt sn \<longrightarrow>  i\<le> length (snd sn) \<Longrightarrow>
       (\<lambda>x. P (toSeqCptn i x)) (toParCptn i c)" *)

definition final_glob:: "('g,'l,'p,'f,'e) config_gs \<Rightarrow> bool" where
  "final_glob cfg \<equiv>  fst cfg=Skip \<or> (fst cfg=Throw) \<or> (\<exists>f. fst cfg= Fault f ) \<or> (fst cfg = Stuck)"

lemma final_eq:"final_glob cfg = SmallStepCon.final (fst cfg, toSeq (snd cfg))"
  unfolding final_def final_glob_def SmallStepCon.final_def
  by (cases "snd cfg",auto)

definition cpi1 :: "nat \<Rightarrow> ('g\<times>'l,'p,'f,'e) body \<Rightarrow> ('g\<times>'l,'p,'f,'e)com  \<Rightarrow>
                   ('g,'l)par_state \<Rightarrow> (nat \<times>('g,'l,'p,'f,'e) gconfs) set" where
  "cpi1 i \<Gamma> P s \<equiv> {(i1,\<Gamma>1,l). l!0=(P,s) \<and> (i,\<Gamma>,l) \<in> cptni \<and> \<Gamma>1=\<Gamma>}"

lemma cpi1_sub:
  assumes a0: "(i,\<Gamma>,(x#l0)@l1) \<in> cpi1 i \<Gamma> P s"
  shows "(i,\<Gamma>,(x#l0)) \<in> cpi1 i \<Gamma> P s"
proof -
  show ?thesis using a0 unfolding cpi1_def
    using cptni_dest_2 by fastforce
qed

definition wf_state:: "nat \<Rightarrow> ('g,'l)par_state \<Rightarrow> bool"
  where "wf_state i s \<equiv> i < length (snd s)"

definition cpi :: "nat \<Rightarrow> ('g\<times>'l,'p,'f,'e) body \<Rightarrow> ('g\<times>'l,'p,'f,'e)com  \<Rightarrow>
                   ('g,'l)par_state \<Rightarrow> (('g,'l,'p,'f,'e) gconfs) set" where
  "cpi i \<Gamma> P s \<equiv> {(\<Gamma>1,l). l!0=(P,s) \<and> (i,\<Gamma>,l) \<in> cptni \<and> \<Gamma>1=\<Gamma> \<and> wf_state i s}"

lemma cpi_sub:
  assumes a0: "(\<Gamma>,(x#l0)@l1) \<in> cpi  i \<Gamma> P s"
  shows "(\<Gamma>,(x#l0)) \<in> cpi  i \<Gamma> P s"
proof -
  show ?thesis using a0 unfolding cpi_def
    using cptni_dest_2 by fastforce
qed

end


theory Inits
imports Main "~~/src/HOL/Library/Sublist"
begin

fun inits where
  "inits [] = [[]]"
| "inits (i#is) = [] # map (op # i) (inits is)"

lemma inits_Snoc[simp]:
  "inits (is@[i]) = inits is @ [is@[i]]"
by (induction "is") auto

lemma inits_eq_Snoc:
  "inits is = xs @ [x] \<longleftrightarrow> (is = [] \<and> xs = [] \<or> (\<exists> i is'. is = is'@[i] \<and> xs = inits is')) \<and> x = is"
by (cases "is" rule: rev_cases) auto

lemma in_set_inits[simp]: "is' \<in> set (inits is) \<longleftrightarrow> prefixeq is' is"
  by (induction "is'" arbitrary: "is"; rename_tac "is", case_tac "is"; auto)

lemma prefixeq_snocD: "prefixeq (xs@[x]) ys \<Longrightarrow> prefix xs ys"
  by (simp add: prefixI' prefix_order.dual_order.strict_trans1)

lemma prefixeq_butlast: "prefixeq (butlast xs) xs"
  by (metis append_butlast_last_id butlast.simps(1) prefixI' prefix_order.eq_iff prefix_order.less_imp_le)

lemma prefixeq_app_Cons_elim:
  assumes "prefixeq (xs@[y]) (z#zs)"
  obtains "xs = []" and "y = z"
   | xs' where "xs = z#xs'" and "prefixeq (xs'@[y]) zs"
using assms by (cases xs) auto

lemma prefixeq_app_Cons_simp:
  "prefixeq (xs@[y]) (z#zs) \<longleftrightarrow> xs = [] \<and> y = z \<or> xs = z#tl xs \<and> prefixeq (tl xs@[y]) zs"
 by (cases xs) auto

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_07
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (nil2) y = y"
| "qrev (cons2 z xs) y = qrev xs (cons2 z y)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y xs) = S (length xs)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((length (qrev x y)) = (t2 (length x) (length y)))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul3_assoc3
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x1 (mul3 x2 x3 x4) x5) = (mul3 x1 x2 (mul3 x3 x4 x5)))"
  oops

end


theory Numbers
imports Complex_Main
begin

text{*

numeric literals; default simprules; can re-orient
*}

lemma "2 * m = m + m"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

fun h :: "nat \<Rightarrow> nat" where
"h i = (if i = 3 then 2 else i)"

text{*
@{term"h 3 = 2"}
@{term"h i  = i"}
*}

text{*
@{thm[display] numeral_1_eq_1[no_vars]}
\rulename{numeral_1_eq_1}

@{thm[display] add_2_eq_Suc[no_vars]}
\rulename{add_2_eq_Suc}

@{thm[display] add_2_eq_Suc'[no_vars]}
\rulename{add_2_eq_Suc'}

@{thm[display] add.assoc[no_vars]}
\rulename{add.assoc}

@{thm[display] add.commute[no_vars]}
\rulename{add.commute}

@{thm[display] add.left_commute[no_vars]}
\rulename{add.left_commute}

these form ac_simps; similarly there is ac_simps
*}

lemma "Suc(i + j*l*k + m*n) = f (n*m + i + k*j*l)"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply (simp add: ac_simps ac_simps)
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

text{*

@{thm[display] div_le_mono[no_vars]}
\rulename{div_le_mono}

@{thm[display] diff_mult_distrib[no_vars]}
\rulename{diff_mult_distrib}

@{thm[display] mult_mod_left[no_vars]}
\rulename{mult_mod_left}

@{thm[display] nat_diff_split[no_vars]}
\rulename{nat_diff_split}
*}

lemma "(n - 1) * (n + 1) = n * n - (1::nat)"
apply (clarsimp split: nat_diff_split iff del: less_Suc0)
 --{* @{subgoals[display,indent=0,margin=65]} *}
apply (subgoal_tac "n=0", force, arith)
done

lemma "(n - 2) * (n + 2) = n * n - (4::nat)"
apply (simp split: nat_diff_split, clarify)
 --{* @{subgoals[display,indent=0,margin=65]} *}
apply (subgoal_tac "n=0 | n=1", force, arith)
done

text{*
@{thm[display] mod_if[no_vars]}
\rulename{mod_if}

@{thm[display] mod_div_equality[no_vars]}
\rulename{mod_div_equality}

@{thm[display] div_mult1_eq[no_vars]}
\rulename{div_mult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] div_mult2_eq[no_vars]}
\rulename{div_mult2_eq}

@{thm[display] mod_mult2_eq[no_vars]}
\rulename{mod_mult2_eq}

@{thm[display] div_mult_mult1[no_vars]}
\rulename{div_mult_mult1}

@{thm[display] div_by_0 [no_vars]}
\rulename{div_by_0}

@{thm[display] mod_by_0 [no_vars]}
\rulename{mod_by_0}

@{thm[display] dvd_antisym[no_vars]}
\rulename{dvd_antisym}

@{thm[display] dvd_add[no_vars]}
\rulename{dvd_add}

For the integers, I'd list a few theorems that somehow involve negative
numbers.*}

text{*
Division, remainder of negatives

@{thm[display] pos_mod_sign[no_vars]}
\rulename{pos_mod_sign}

@{thm[display] pos_mod_bound[no_vars]}
\rulename{pos_mod_bound}

@{thm[display] neg_mod_sign[no_vars]}
\rulename{neg_mod_sign}

@{thm[display] neg_mod_bound[no_vars]}
\rulename{neg_mod_bound}

@{thm[display] zdiv_zadd1_eq[no_vars]}
\rulename{zdiv_zadd1_eq}

@{thm[display] mod_add_eq[no_vars]}
\rulename{mod_add_eq}

@{thm[display] zdiv_zmult1_eq[no_vars]}
\rulename{zdiv_zmult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] zdiv_zmult2_eq[no_vars]}
\rulename{zdiv_zmult2_eq}

@{thm[display] zmod_zmult2_eq[no_vars]}
\rulename{zmod_zmult2_eq}
*}

lemma "abs (x+y) \<le> abs x + abs (y :: int)"
by arith

lemma "abs (2*x) = 2 * abs (x :: int)"
by (simp add: abs_if)

text {*Induction rules for the Integers

@{thm[display] int_ge_induct[no_vars]}
\rulename{int_ge_induct}

@{thm[display] int_gr_induct[no_vars]}
\rulename{int_gr_induct}

@{thm[display] int_le_induct[no_vars]}
\rulename{int_le_induct}

@{thm[display] int_less_induct[no_vars]}
\rulename{int_less_induct}
*}

text {*FIELDS

@{thm[display] dense[no_vars]}
\rulename{dense}

@{thm[display] times_divide_eq_right[no_vars]}
\rulename{times_divide_eq_right}

@{thm[display] times_divide_eq_left[no_vars]}
\rulename{times_divide_eq_left}

@{thm[display] divide_divide_eq_right[no_vars]}
\rulename{divide_divide_eq_right}

@{thm[display] divide_divide_eq_left[no_vars]}
\rulename{divide_divide_eq_left}

@{thm[display] minus_divide_left[no_vars]}
\rulename{minus_divide_left}

@{thm[display] minus_divide_right[no_vars]}
\rulename{minus_divide_right}

This last NOT a simprule

@{thm[display] add_divide_distrib[no_vars]}
\rulename{add_divide_distrib}
*}

lemma "3/4 < (7/8 :: real)"
by simp

lemma "P ((3/4) * (8/15 :: real))"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply simp
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

lemma "(3/4) * (8/15) < (x :: real)"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply simp
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

text{*
Ring and Field

Requires a field, or else an ordered ring

@{thm[display] mult_eq_0_iff[no_vars]}
\rulename{mult_eq_0_iff}

@{thm[display] mult_cancel_right[no_vars]}
\rulename{mult_cancel_right}

@{thm[display] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
*}

text{*
effect of show sorts on the above

@{thm[display,show_sorts] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
*}

text{*
absolute value

@{thm[display] abs_mult[no_vars]}
\rulename{abs_mult}

@{thm[display] abs_le_iff[no_vars]}
\rulename{abs_le_iff}

@{thm[display] abs_triangle_ineq[no_vars]}
\rulename{abs_triangle_ineq}

@{thm[display] power_add[no_vars]}
\rulename{power_add}

@{thm[display] power_mult[no_vars]}
\rulename{power_mult}

@{thm[display] power_abs[no_vars]}
\rulename{power_abs}

*}

end