theory Lander2
    imports ContinuousInv  Complementlemma
begin

text \<open>Variables\<close>

definition Fc :: char where "Fc = CHR ''a''"
definition M :: char where "M = CHR ''b''"
definition V :: char where "V = CHR ''c''"
definition T :: char where "T = CHR ''d''"
definition W :: char where "W = CHR ''e''"

definition Period :: real where "Period = 0.128"

lemma train_vars_distinct [simp]: "T \<noteq> V" "T \<noteq> W"
                                  "V \<noteq> T" "V \<noteq> W"
                                  "W \<noteq> T" "W \<noteq> V"
  unfolding T_def V_def W_def by auto

definition W_upd :: "real \<Rightarrow> real \<Rightarrow> real" where
  "W_upd v w = (-(w - 3.732) * 0.01 + 3.732 - (v - (-1.5)) * 0.6)"

text \<open>Processes\<close>

(*
    Fc ::= (\<lambda>_. 2835);
*)
definition P0 :: proc where
  "P0 =
    Rep (
      Wait (\<lambda>_. Period);
      Cm (''ch_v''[?]V);
      Cm (''ch_m''[?]W);
      Cm (''ch_Fc''[!](\<lambda>s. W_upd (s V) (s W)))
    )"

(*
    V ::= (\<lambda>_. -1.5);
    M ::= (\<lambda>_. 759.5);
*)

fun P0_inv :: "real \<times> real \<Rightarrow> (real\<times> real) list \<Rightarrow> tassn" where
  "P0_inv (v, w) [] = emp\<^sub>t"
| "P0_inv (v, w) ((v', w') # vwrest) =
   Wait\<^sub>t Period (\<lambda>t. State ((\<lambda>_. 0)(V := v, W := w))) ({}, {}) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(V := v, W := w))) ''ch_v'' v' @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(V := v', W := w))) ''ch_m'' w' @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(V := v', W := w'))) ''ch_Fc'' (W_upd v' w') @\<^sub>t
   P0_inv (v', w') (vwrest)"

fun last_P0_inv :: "real \<times> real \<Rightarrow> (real\<times> real) list \<Rightarrow> real\<times>real" where
  "last_P0_inv (v, w) [] = (v, w)"
| "last_P0_inv (v, w) ((v', w') # vwrest) = last_P0_inv (v', w') vwrest"

lemma P0_inv_snoc:
  "P0_inv (v, w) (vwlist @ [(v', w')]) =
   P0_inv (v, w) vwlist @\<^sub>t Wait\<^sub>t Period (\<lambda>t. State ((\<lambda>_. 0)(V := fst(last_P0_inv (v, w) vwlist), W := snd(last_P0_inv (v, w) vwlist)))) ({}, {}) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(V := fst(last_P0_inv (v, w) vwlist), W := snd(last_P0_inv (v, w) vwlist)))) ''ch_v'' v' @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(V := v', W := snd(last_P0_inv (v, w) vwlist)))) ''ch_m'' w' @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(V := v', W := w'))) ''ch_Fc'' (W_upd v' w')"
  apply (induct vwlist arbitrary: v w)
  by (auto simp add: join_assoc)

lemma last_P0_inv_snoc [simp]:
  "last_P0_inv (v, w) (vwlist @ [(v', w')]) = (v', w')"
  apply (induct vwlist arbitrary: v w) by auto

lemma P0_rep:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v, W := w) \<and> emp\<^sub>t tr}
      P0
    {\<lambda>s tr. \<exists>vwlist. s = (\<lambda>_. 0)(V := fst(last_P0_inv (v, w) vwlist), W := snd(last_P0_inv (v, w) vwlist)) \<and> P0_inv (v, w) vwlist tr}"
  apply (rule Valid_weaken_pre)
  unfolding P0_def
   prefer 2 apply (rule Valid_rep)
   apply (rule Valid_ex_pre)
  subgoal for vwlist
    apply (rule Valid_seq)
    apply (rule Valid_wait_sp_st) apply (auto simp add:Period_def)
    apply (rule Valid_seq)
     apply (rule Valid_receive_sp_st)
    apply (rule Valid_ex_pre)
    subgoal for v'
       apply (rule Valid_seq)
        apply (rule Valid_receive_sp_st)
      apply (rule Valid_ex_pre)
      subgoal for w'
        apply (rule Valid_strengthen_post)
        prefer 2 apply (rule Valid_send_sp_st)
      apply (auto simp add: entails_def)
      apply (rule exI[where x="vwlist@[(v',w')]"])
        apply (auto simp add: P0_inv_snoc join_assoc Period_def)
        by (simp add: fun_upd_twist)
      done
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def)

definition P1 :: proc where
  "P1 =
    Rep (
      Interrupt (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))) ((\<lambda>_. True))
      [(''ch_v''[!](\<lambda>s. s V), Cm (''ch_m''[!](\<lambda>s. s W)); Cm (''ch_Fc''[?]W); T ::= (\<lambda>_.0))]
    )"

fun P1_inv :: "real \<times> real \<Rightarrow> real list \<Rightarrow> tassn" where
  "P1_inv (v, w) [] = emp\<^sub>t"
| "P1_inv (v, w) (Fc1 # Fcs) =
   (\<lambda>tr. \<exists>st'. (
      ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
        (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732), W := (\<lambda>s. (s W)^2 / 2500), T := (\<lambda>_. 1))))
        ((\<lambda>_. True)) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
      Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
      In\<^sub>t (State st') ''ch_Fc'' Fc1 @\<^sub>t
      P1_inv (st' V, Fc1) Fcs) tr)"

inductive P1_inv_ind :: "real \<Rightarrow> real \<Rightarrow> real list \<Rightarrow> real \<Rightarrow> real \<Rightarrow> tassn" where
  "P1_inv_ind v w [] v w []"
| "(ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
      (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732), W := (\<lambda>s. (s W)^2 / 2500), T := (\<lambda>_. 1))))
      ((\<lambda>_. True)) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1) tr1 \<Longrightarrow>
   P1_inv_ind (st' V) Fc1 Fcs v' w' tr2 \<Longrightarrow>
   P1_inv_ind v w (Fc1 # Fcs) v' w' (tr1 @ tr2)"

lemma join_assnI:
  "P tr1 \<Longrightarrow> Q tr2 \<Longrightarrow> (P @\<^sub>t Q) (tr1 @ tr2)"
  unfolding join_assn_def by auto

lemma join_assnE:
  "(P @\<^sub>t Q) tr \<Longrightarrow> (\<And>tr1 tr2. P tr1 \<Longrightarrow> Q tr2 \<Longrightarrow> tr = tr1 @ tr2 \<Longrightarrow> R) \<Longrightarrow> R"
  unfolding join_assn_def by auto

lemma P1_inv_ind_cons1:
  "P1_inv_ind v w (Fc1 # Fcs) v' w' \<Longrightarrow>\<^sub>t
   (\<exists>\<^sub>tst'. (ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
      (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732), W := (\<lambda>s. (s W)^2 / 2500), T := (\<lambda>_. 1))))
      ((\<lambda>_. True)) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1) @\<^sub>t P1_inv_ind (st' V) Fc1 Fcs v' w')"
  apply (auto simp add: entails_tassn_def ex_assn_def)
  subgoal for tr
  proof (induct v w "Fc1 # Fcs" v' w' tr rule: P1_inv_ind.induct)
    case (2 v w st' tr1 v' w' tr2)
    show ?case
      apply (rule exI[where x=st'])
      apply (rule join_assnI)
      using 2 by auto
  qed
  done

lemma P1_inv_ind_cons2:
  "(\<exists>\<^sub>tst'. (ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
      (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732), W := (\<lambda>s. (s W)^2 / 2500), T := (\<lambda>_. 1))))
      ((\<lambda>_. True)) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1) @\<^sub>t P1_inv_ind (st' V) Fc1 Fcs v' w') \<Longrightarrow>\<^sub>t
  P1_inv_ind v w (Fc1 # Fcs) v' w'"
  apply (auto simp add: entails_tassn_def ex_assn_def)
  subgoal premises pre for tr st'
  proof -
    obtain tr1 tr2 where a: "((ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
       (ODE ((\<lambda>_ _. 0)(V := \<lambda>s. s W - 933 / 250, W := \<lambda>s. (s W)\<^sup>2 / 2500, T := \<lambda>_. 1)))
       (\<lambda>_. True) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
      Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
      In\<^sub>t (State st') ''ch_Fc'' Fc1) tr1)"
     "P1_inv_ind (st' V) Fc1 Fcs v' w' tr2"
     "tr = tr1 @ tr2"
      using pre join_assnE by blast
    show ?thesis
      unfolding a(3) apply (rule P1_inv_ind.intros(2))
      using a by auto
  qed
  done

lemma P1_inv_ind_cons:
  "P1_inv_ind v w (Fc1 # Fcs) v' w' =
   (\<exists>\<^sub>tst'. (ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
      (ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732), W := (\<lambda>s. (s W)^2 / 2500), T := (\<lambda>_. 1))))
      ((\<lambda>_. True)) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1) @\<^sub>t P1_inv_ind (st' V) Fc1 Fcs v' w')"
  using P1_inv_ind_cons1 P1_inv_ind_cons2 entails_tassn_def by auto

lemma P1_inv_ind_empty':
  "P1_inv_ind v w Fcs v2 w2 tr \<Longrightarrow> Fcs = [] \<Longrightarrow> tr = [] \<and> v = v2 \<and> w = w2"
  apply (induct rule: P1_inv_ind.induct) by auto

lemma P1_inv_ind_empty:
  "P1_inv_ind v w [] v2 w2 tr \<Longrightarrow> tr = [] \<and> v = v2 \<and> w = w2"
  using P1_inv_ind_empty' by auto

lemma P1_inv_ind_empty_rw:
  "P1_inv_ind v w [] v2 w2 = (\<up>(v = v2) \<and>\<^sub>t \<up>(w = w2) \<and>\<^sub>t emp\<^sub>t)"
  apply (auto simp add: conj_assn_def emp_assn_def pure_assn_def)
  apply (rule ext)
  apply (auto simp add: P1_inv_ind_empty)
  by (auto intro: P1_inv_ind.intros(1))

lemma P1_inv_snoc:
  "P1_inv_ind v0 w0 Fcs v w tr1 \<Longrightarrow>
   (ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
            (ODE ((\<lambda>_ _. 0)
               (V := \<lambda>s. s W - 3.732, W := \<lambda>s. (s W)\<^sup>2 / 2500,
                T := \<lambda>_. 1)))
            (\<lambda>_. True) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1) tr2 \<Longrightarrow>
  P1_inv_ind v0 w0 (Fcs @ [Fc1]) (st' V) Fc1 (tr1 @ tr2)"
proof (induct rule: P1_inv_ind.induct)
  case (1 v w)
  have "P1_inv_ind v w (Fc1 # []) (st' V) Fc1 (tr2 @ [])"
    apply (rule P1_inv_ind.intros(2)[where st'=st'])
    subgoal using 1
      by blast
    subgoal
      by (rule P1_inv_ind.intros(1))
    done
  then show ?case
    by auto
next
  case (2 v w st'' Fc1' tr1 Fcs v' w' tr2')
  have a: "P1_inv_ind (st'' V) Fc1' (Fcs @ [Fc1]) (st' V) Fc1 (tr2' @ tr2)"
    apply (rule 2(3)) by (rule 2(4))
  show ?case
    apply auto
    apply (rule P1_inv_ind.intros(2))
     prefer 2 apply (rule a)
    by (rule 2(1))
qed

lemma P1_inv_snoc':
  "(P1_inv_ind v0 w0 Fcs v w @\<^sub>t
   (ODEout\<^sub>t ((\<lambda>_. 0)(V := v, W := w))
            (ODE ((\<lambda>_ _. 0)
               (V := \<lambda>s. s W - 3.732, W := \<lambda>s. (s W)\<^sup>2 / 2500,
                T := \<lambda>_. 1)))
            (\<lambda>_. True) st' ''ch_v'' (\<lambda>s. s V) ({''ch_v''}, {}) @\<^sub>t
    Out\<^sub>t (State st') ''ch_m'' (st' W) @\<^sub>t
    In\<^sub>t (State st') ''ch_Fc'' Fc1)) tr \<Longrightarrow> P1_inv_ind v0 w0 (Fcs @ [Fc1]) (st' V) Fc1 tr"
  unfolding join_assn_def
  apply auto
  subgoal for tr1 tr2a tr2b tr2c
    apply(rule P1_inv_snoc [of v0 w0 Fcs v w tr1 st' Fc1 "tr2a @ tr2b @ tr2c"])
     apply auto
    unfolding join_assn_def
    by auto
  done

lemma P1_rep:
  "\<Turnstile> {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, W := w0) \<and> (emp\<^sub>t tr)}
    P1
   {\<lambda>s tr. \<exists>v w Fc . s = (\<lambda>_. 0)(V := v, W := w) \<and>
               P1_inv_ind v0 w0 Fc v w tr}"
  unfolding P1_def
  apply (rule Valid_weaken_pre)
  prefer 2
  apply(rule Valid_rep)
   apply(rule Valid_ex_pre)
 apply (rule Valid_ex_pre)
  apply (rule Valid_ex_pre)
  subgoal for v w Fc
    apply (rule Valid_interrupt_Out_sp2[where VS="{V,W,T}"])
    apply (rule Valid_ex_pre)
    subgoal for st'
      apply (rule Valid_seq)
       apply (rule Valid_send_sp)
      apply (rule Valid_seq)
       apply (rule Valid_receive_sp)
      apply (rule Valid_ex_pre)
      subgoal for w'
        apply (rule Valid_strengthen_post)
         prefer 2 apply (rule Valid_assign_sp)
        apply (auto simp add: entails_def pure_assn_def conj_assn_def)
        subgoal for s tr x
          apply (rule exI[where x="s V"])
          apply (rule exI[where x="s W"])
          apply auto
          subgoal
            apply (rule ext)
            apply auto
            subgoal premises pre for xa
            proof(rule ccontr)
              assume a:"s xa \<noteq> 0"
              then have 1:"xa \<noteq> T"
                using pre(1) by auto
              then have 2:"(s (T := x, W := w')) xa \<noteq> 0"
                using pre(5,6) a by auto
              then have 3:"xa \<in> {V, W, T}"
                using pre(3) unfolding supp_def by auto
              have 4:"xa\<notin> {V, W, T}"
                using pre(5,6) 1 by auto
              show False using 3 4 by auto
            qed
            done
          apply (rule exI[where x="Fc @ [s W]"])
          subgoal premises pre
            using P1_inv_snoc'[of v0 w0 Fc v w "s(T := x, W := w')" "s W" tr]
            using pre(1,4) apply simp
            by (simp add: join_assoc)
          done
        done
      done
    apply (auto simp add: supp_def)
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x=v0]) apply (rule exI[where x=w0])
  apply auto apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def intro: P1_inv_ind.intros)

inductive tol_inv_ind :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> tassn" where
  "tol_inv_ind v0 w0 v1 w1 0 []"
| "(ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period)
   \<Longrightarrow> p 0 = (\<lambda>_. 0)(V := v1, W := w1)
   \<Longrightarrow> (((Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {})
    @\<^sub>t IO\<^sub>t ''ch_v'' (p Period V)) @\<^sub>t IO\<^sub>t ''ch_m'' (p Period W)) @\<^sub>t IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W))) tr1
   \<Longrightarrow> tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n tr2
   \<Longrightarrow> tol_inv_ind v0 w0 v1 w1 (Suc n) (tr1 @ tr2)
"
lemma tol_inv_ind_empty':
  "tol_inv_ind v0 w0 v1 w1 n tr \<Longrightarrow> n = 0  \<Longrightarrow> tr = []"
  apply (induct rule:tol_inv_ind.inducts)
  by auto

lemma tol_inv_ind_empty:
  "tol_inv_ind v0 w0 v1 w1 0 = emp\<^sub>t"
  using tol_inv_ind_empty' unfolding emp_assn_def apply auto
  using tol_inv_ind.intros(1) by auto

lemma tol_inv_ind_suc:
  assumes"(ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period) "
   and" p 0 = (\<lambda>_. 0)(V := v1, W := w1) "
 shows" (((Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {})
    @\<^sub>t IO\<^sub>t ''ch_v'' (p Period V)) @\<^sub>t IO\<^sub>t ''ch_m'' (p Period W)) @\<^sub>t IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W)))
    @\<^sub>t tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n
    \<Longrightarrow>\<^sub>t tol_inv_ind v0 w0 v1 w1 (Suc n)"
  apply (auto simp add: entails_tassn_def)
  subgoal for tr
    subgoal premises pre
  proof-
obtain tr1 and tr2 where a:"(((Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t)))
         ({''ch_v''}, {}) @\<^sub>t
        IO\<^sub>t ''ch_v'' (p Period V)) @\<^sub>t
       IO\<^sub>t ''ch_m'' (p Period W)) @\<^sub>t
      IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W))) tr1"
"tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n tr2"
"tr = tr1 @ tr2" using pre join_assnE by blast
  show ?thesis
    using a(3) apply auto
    apply(rule tol_inv_ind.intros)
    using assms a by auto
  qed
  done
  done

lemma tol_inv_ind_suc':
"\<up>(((ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period)) \<and>
       (p 0 = (\<lambda>_. 0)(V := v1, W := w1))) \<and>\<^sub>t
 (((Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {})
    @\<^sub>t IO\<^sub>t ''ch_v'' (p Period V)) @\<^sub>t IO\<^sub>t ''ch_m'' (p Period W)) @\<^sub>t IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W)))
    @\<^sub>t tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n
    \<Longrightarrow>\<^sub>t tol_inv_ind v0 w0 v1 w1 (Suc n)"
  using tol_inv_ind_suc unfolding entails_tassn_def conj_assn_def pure_assn_def by auto

lemma tol_inv_ind_suc'':
  assumes"(ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period) "
   and" p 0 = (\<lambda>_. 0)(V := v1, W := w1) "
 shows" Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {})
    @\<^sub>t IO\<^sub>t ''ch_v'' (p Period V) @\<^sub>t IO\<^sub>t ''ch_m'' (p Period W) @\<^sub>t IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W))
    @\<^sub>t tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n
    \<Longrightarrow>\<^sub>t tol_inv_ind v0 w0 v1 w1 (Suc n)"
  using tol_inv_ind_suc[of p v1 w1 v0 w0 n] assms
  apply auto
  using join_assoc
  by fastforce

lemma tol_inv_ind_suc''':
  assumes"(ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period) "
   and" p 0 = (\<lambda>_. 0)(V := v1, W := w1) "
   and " Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {}) tr1"
   and " IO\<^sub>t ''ch_v'' (p Period V) tr2"
   and "IO\<^sub>t ''ch_m'' (p Period W) tr3"
   and "IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W)) tr4"
   and "tol_inv_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n tr5"
 shows" tol_inv_ind v0 w0 v1 w1 (Suc n) (tr1 @ tr2 @ tr3 @ tr4 @ tr5)"
  using tol_inv_ind_suc''[of p v1 w1 v0 w0 n] assms
  apply (auto simp add: entails_tassn_def join_assn_def)
  by blast

lemma combine_assn_emp_ODEout':
  "ch \<in> chs \<Longrightarrow> combine_assn chs emp\<^sub>t (ODEout\<^sub>t s ode b s' ch e rdy @\<^sub>t P) = false\<^sub>A"
  unfolding combine_assn_def
  apply (rule ext)
  apply (auto simp add: false_assn_def emp_assn_def join_assn_def elim!: ode_out_assn.cases)
  by (auto elim: sync_elims)

lemma combine_assn_emp_ODEout:
  assumes "ch \<in> chs"
  shows "combine_assn chs emp\<^sub>t (ODEout\<^sub>t s ode b s' ch e rdy @\<^sub>t P) \<Longrightarrow>\<^sub>t false\<^sub>A"
  using combine_assn_emp_ODEout' assms by auto

lemma combine_assn_wait_in_odeout:
  assumes "ch \<in> chs"
    and "d>0"
    and "ch \<in> fst rdy2"
    and "compat_rdy rdy rdy2"
  shows "combine_assn chs (Wait\<^sub>t d p rdy @\<^sub>t In\<^sub>t ss ch v @\<^sub>t P) (ODEout\<^sub>t s ode b s' ch e rdy2 @\<^sub>t Q)\<Longrightarrow>\<^sub>t
        ((\<exists>\<^sub>t p3. \<up>(ODEsol ode p3 d \<and> p3 0 = s) \<and>\<^sub>t \<up>(p3 d = s') \<and>\<^sub>t
          (Wait\<^sub>t d (\<lambda>t. ParState (p t) (State (p3 t))) (merge_rdy rdy rdy2))) @\<^sub>t (\<up>(e s' = v) \<and>\<^sub>t (IO\<^sub>t ch v)) @\<^sub>t
          combine_assn chs P Q)"
proof -
  have *: "((\<exists>\<^sub>t p3. \<up>(ODEsol ode p3 d \<and> p3 0 = s) \<and>\<^sub>t \<up>(p3 d = s') \<and>\<^sub>t
          (Wait\<^sub>t d (\<lambda>t. ParState (p t) (State (p3 t))) (merge_rdy rdy rdy2))) @\<^sub>t (\<up>(e s' = v) \<and>\<^sub>t (IO\<^sub>t ch v)) @\<^sub>t
          combine_assn chs P Q) tr"
    if "(Wait\<^sub>t d p rdy @\<^sub>t In\<^sub>t ss ch v @\<^sub>t P) tr1"
       "(ODEout\<^sub>t s ode b s' ch e rdy2 @\<^sub>t Q) tr2"
       "combine_blocks chs tr1 tr2 tr" for tr tr1 tr2
proof -
    from that(1)[unfolded join_assn_def]
    obtain tr11 tr12 tr13 where a: "Wait\<^sub>t d p rdy tr11" "In\<^sub>t ss ch v tr12" "P tr13" "tr1 = tr11 @ tr12 @ tr13"
      by auto
    from that(2)[unfolded join_assn_def]
    obtain tr21 tr22 where b: "ODEout\<^sub>t s ode b s' ch e rdy2 tr21" "Q tr22" "tr2 = tr21 @ tr22"
      by auto
    show ?thesis
      using a(1) apply (cases rule: wait_assn.cases)
       prefer 2 using assms apply auto
      using b(1) apply (cases rule: ode_out_assn.cases)
      subgoal
        using that(3) unfolding a(4) b(3)
        apply auto
        using assms combine_blocks_pairE2' by blast
      subgoal premises pre for d' p3'
      proof-
        have "d>d' \<or> d<d' \<or> d=d'" by auto
        then show ?thesis
      proof (elim disjE)
        assume d1:"d>d'"
        from that(3)[unfolded a(4) b(3) pre(1,7)]
        obtain tr' where tr':"tr = WaitBlk d' (\<lambda>t. ParState (p t) (State(p3' t))) (merge_rdy rdy rdy2) # tr' "
           "combine_blocks chs (WaitBlk (d - d') (\<lambda>t. p (t + d')) rdy # tr12 @ tr13) ([OutBlock ch (e (p3' d'))] @ tr22) tr'"
          using combine_blocks_waitE4[of chs d p rdy "tr12@tr13" d' "(\<lambda>\<tau>. State (p3' \<tau>))" rdy2
         "[OutBlock ch (e (p3' d'))] @ tr22" tr]
          using pre(8,5) d1
          by auto
        show ?thesis
          using tr'(2) pre(2)
          by (metis append_Cons combine_blocks_pairE2')
      next
        assume d2: "d'>d"
        thm pre
        from that(3)[unfolded a(4) b(3) pre(1,7)]
        obtain tr' where tr':"tr = WaitBlk d (\<lambda>t. ParState (p t) (State(p3' t))) (merge_rdy rdy rdy2) # tr' "
           "combine_blocks chs (tr12 @ tr13) (WaitBlk (d' - d) (\<lambda>t. State (p3' (t + d))) rdy2 # [OutBlock ch (e (p3' d'))] @ tr22) tr'"
          using combine_blocks_waitE3[of chs d p rdy "tr12@tr13" d' "(\<lambda>\<tau>. State (p3' \<tau>))" rdy2
         "[OutBlock ch (e (p3' d'))] @ tr22" tr]
        using pre(3,5) d2 by auto
      show ?thesis
        using a(2) apply(cases rule: in_assn.cases)
        subgoal using tr'(2)
          by (metis (no_types, lifting) append_Cons combine_blocks_pairE2 pre(2))
        subgoal for d'' using tr'(2)
          using combine_blocks_waitE1[of chs d'' "(\<lambda>_. ss)" "({}, {ch})" "[InBlock ch v]@tr13"
                 "d'-d" "(\<lambda>t. State (p3' (t + d)))" rdy2 "[OutBlock ch (e (p3' d'))] @ tr22" tr']
          using assms(3) apply auto
          apply (subgoal_tac "\<not> compat_rdy ({}, {ch}) rdy2")
           apply auto
          apply (subgoal_tac "{ch} \<inter> fst rdy2 \<noteq> {}")
           apply (smt (verit, ccfv_threshold) compat_rdy.elims(2) compat_rdy.simps fst_conv)
          by auto
        subgoal using tr'(2)
          using combine_blocks_waitE1[of chs "\<infinity>" "(\<lambda>_. ss)" "({}, {ch})" "tr13"
                 "d'-d" "(\<lambda>t. State (p3' (t + d)))" rdy2 "[OutBlock ch (e (p3' d'))] @ tr22" tr']
          using assms(3) apply auto
          apply (subgoal_tac "\<not> compat_rdy ({}, {ch}) rdy2")
           apply auto
          apply (subgoal_tac "{ch} \<inter> fst rdy2 \<noteq> {}")
           apply (smt (verit, ccfv_threshold) compat_rdy.elims(2) compat_rdy.simps fst_conv)
          by auto
        done
    next
      assume d3:"d=d'"
        thm pre
        from that(3)[unfolded a(4) b(3) pre(1,7) d3]
        obtain tr' where tr':"tr = WaitBlk d' (\<lambda>t. ParState (p t) (State(p3' t))) (merge_rdy rdy rdy2) # tr' "
           "combine_blocks chs (tr12 @ tr13) ([OutBlock ch (e (p3' d'))] @ tr22) tr'"
          using combine_blocks_waitE2[of chs d' p rdy "tr12@tr13" "(\<lambda>\<tau>. State (p3' \<tau>))" rdy2 "[OutBlock ch (e (p3' d'))] @ tr22" tr]
          using pre(5) by auto
        show ?thesis
          using a(2) apply(cases rule: in_assn.cases)
          subgoal using tr'(2) pre(2)
            apply(auto elim!: combine_blocks_pairE)
            subgoal for tr''
              apply(auto simp add: join_assn_def)
              apply(rule exI[where x="[WaitBlk d' (\<lambda>t. ParState (p t) (State(p3' t))) (merge_rdy rdy rdy2)]"])
              apply auto
              subgoal
                apply(auto simp add: ex_assn_def conj_assn_def pure_assn_def)
                apply(rule exI[where x="p3'"])
                apply(auto simp add: pre d3)
                using pre(8) wait_assn.intros(1) apply blast
                done
              subgoal
                apply (rule exI[where x="tr'"])
                using tr' apply (auto simp add: conj_assn_def pure_assn_def pre)
                apply (rule exI[where x="[IOBlock ch (e (p3' d'))]"])
                apply auto
                using io_assn.intros apply auto[1]
                using a(3) b(2)
                by (auto simp add: combine_assn_def)
              done
            done
          subgoal for d''
            using tr'(2)
            by (metis (no_types, lifting) append_Cons combine_blocks_pairE2' pre(2))
          subgoal using tr'(2)
            by (metis (no_types, lifting) append_Cons combine_blocks_pairE2' pre(2))
          done
      qed
    qed
       done
  qed
  show ?thesis
    apply (subst combine_assn_def)
    apply (auto simp add: entails_tassn_def)
    using * by auto
qed

lemma combine_tol:
"combine_assn {''ch_v'', ''ch_m'', ''ch_Fc''} (P0_inv (v0,w0) p0list) (P1_inv_ind v1 w1 p1list v1e w1e) \<Longrightarrow>\<^sub>t
   tol_inv_ind v0 w0 v1 w1 (length p1list)"
proof (induct p1list arbitrary: p0list v0 w0 v1 w1 v1e w1e)
  case Nil
  note nil1 = Nil
  then show ?case
  proof (cases p0list)
    case Nil
    note nil0 = Nil
    then show ?thesis
      apply auto
      using P1_inv_ind_empty tol_inv_ind_empty
      unfolding combine_assn_def entails_tassn_def emp_assn_def apply auto
      using combine_blocks_emptyE1 by blast
  next
    case (Cons p0pair p0rest)
    note con0 = Cons
    then show ?thesis
    proof (cases p0pair)
      case (Pair a b)
      then show ?thesis
        using con0 P1_inv_ind_empty_rw tol_inv_ind_empty
        apply auto
        unfolding combine_assn_def
        apply (auto simp add: entails_tassn_def join_assn_def pure_assn_def conj_assn_def emp_assn_def wait_assn.simps)
         apply (auto elim: sync_elims)
        by(auto simp add:Period_def)
   qed
 qed
next
  case (Cons p1 p1rest)
  note con1 = Cons
  then show ?case
  proof(cases p0list)
    case Nil
    note nil0 = Nil
    then show ?thesis
      apply auto
      apply (auto simp add:ex_assn_def P1_inv_ind_cons)
      apply(rule combine_assn_ex_pre_right)
      subgoal for s'
        apply (rule entails_tassn_trans)
         apply(auto simp add: join_assoc)
         apply (rule combine_assn_emp_ODEout)
        by auto
      done
  next
    case (Cons p0pair p0rest)
    note con0 = Cons
    then show ?thesis
    proof (cases p0pair)
      case (Pair a b)
      then show ?thesis
        apply (auto simp add:con0 Pair)
        apply (auto simp add:ex_assn_def P1_inv_ind_cons)
        apply(rule combine_assn_ex_pre_right)
        subgoal for s'
          apply (rule entails_tassn_trans)
         apply (subst join_assoc)
           apply (rule combine_assn_wait_in_odeout)
          apply simp
              apply (auto simp add:Period_def)[1]
          apply auto
          apply (rule entails_tassn_trans)
           apply (rule entails_tassn_cancel_left)
          apply auto
           apply (rule entails_tassn_cancel_left)
           apply (subst join_assoc)
           apply (rule entails_tassn_trans)
            apply(rule combine_assn_in_out)
            apply auto[1]
          apply auto[1]
           apply (rule entails_tassn_trans)
            apply (rule entails_tassn_cancel_left)
            apply (rule entails_tassn_trans)
            apply(rule combine_assn_out_in)
             apply auto[1]
            apply auto[1]
            apply (rule entails_tassn_cancel_left)
            apply(rule con1)
           apply (rule entails_tassn_refl)
          apply(auto simp add: entails_tassn_def join_assn_def)
          subgoal for tr1 tr2 tr3 tr4 tr5
            apply(auto simp add: ex_assn_def conj_assn_def pure_assn_def)
            subgoal for p3
              using tol_inv_ind_suc'''[of p3 v1 w1 v0 w0 tr1 tr2 tr3 tr4 "(length p1rest)" tr5]
              by auto
            done
          done
        done
    qed
qed
qed

lemma system_Prop:
"\<Turnstile>\<^sub>p {pair_assn (\<lambda> s. s = (\<lambda>_. 0)(V := v0, W := w0)) (\<lambda> s. s = (\<lambda>_. 0)(V := v1, W := w1))}
        Parallel (Single P0){''ch_v'', ''ch_m'',''ch_Fc''}(Single P1)
     {\<exists>\<^sub>g n. trace_gassn (tol_inv_ind v0 w0 v1 w1 n)}"
  apply (rule ParValid_conseq')
  apply (rule ParValid_Parallel')
     apply (rule P0_rep)
    apply (rule P1_rep)
  apply auto[1]
   apply (subst sing_gassn_split sing_gassn_ex)+
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for list1 v1 w1 list2
 unfolding sync_gassn_state_left sync_gassn_state_right
  apply (rule entails_ex_gassn)
  apply(rule exI[where x="length list2"])
apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
  apply (rule entails_tassn_trans)
   prefer 2
  apply (rule combine_tol)
  apply (rule combine_assn_mono)
  by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done

definition landerinv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
"landerinv t v w = (15025282795421706426953 - 38191371615549881350000*t +
  9482947285373987200000*t^2 - 90382078252408000000*t^3 -
  12597135205472000000*t^4 + 5070724623344300111384 * v +
  29051341984741759604000 * t * v + 12905500940447680000000*t^2 * v -
  3452247087952000000*t^3 * v + 3754952256975690758168 * v^2 -
  4369639740028640264000*t * v^2 + 4290324517728000000000*t^2 * v^2 +
  10509874347360 * v^3 - 8711967253392000*t * v^3 + 1751645724560 * v^4 -
  6016579819909859424000*w + 32152462695621728000000*t*w +
  63926169690400000000*t^2*w + 1659591880613072768000 * v *w -
  11298598523808000000000*t * v *w + 2216823024256000 * v^2*w +
  1139598426176000000000*w^2 - 6579819920896000000000*t*w^2)/(160000000000000000000)"

lemma landerinv_prop2:
  "landerinv Period v w \<le> 0 \<Longrightarrow> landerinv 0 v (W_upd v w) \<le> 0"
  sorry

definition landerInv :: "state \<Rightarrow> real" where
  "landerInv s = landerinv (s T) (s V) (s W)"

definition landerode :: "var \<Rightarrow> exp" where
  " landerode = ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))"

lemma landerode_prop:
 assumes "\<forall>x. ((\<lambda>v. landerInv (vec2state v)) has_derivative g' (x)) (at x within UNIV)"
    and "\<forall>S. (S T \<le> Period)\<longrightarrow> (S T \<ge> 0)\<longrightarrow>((landerInv S = 0) \<longrightarrow>
       g' (state2vec S) (ODE2Vec (ODE landerode) S) < 0)"
    and "(ODEsol(ODE landerode))  (p) (Period)"
    and "p 0  = (\<lambda>_. 0)(V := v1, W := w1)"
    and "landerInv ((\<lambda>_. 0)(V := v1, W := w1)) \<le> 0"
  shows "\<forall>t\<in>{0..Period}. landerInv (p t) \<le> 0 \<and> p t T = t"
  apply auto
  subgoal premises pre for t
  proof-
    obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec (ODE landerode) (p t))) {-e .. Period+e}"
      using pre assms unfolding ODEsol_def by auto
    have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. (ODE2Vec (ODE landerode) (p t)) $ T)) {-e .. Period+e}"
      apply (rule has_vderiv_on_proj)
      using e by auto
    then have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. 1)) {-e .. Period+e}"
      by(auto simp add: landerode_def state2vec_def)
    then have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. 1)) {0 .. tt}" if "tt\<in>{0..Period}" for tt
      apply(rule has_vderiv_on_subset)
      using e that by auto
    then have "x\<in>{0..tt} \<Longrightarrow>((\<lambda>t. state2vec (p t) $ T) has_derivative (\<lambda> x. x)) (at x within {0..tt})" if "tt\<in>{0..Period}" for tt x
      apply(auto simp add: has_vderiv_on_def has_vector_derivative_def)
      using that by auto
    then have tt:"p tt T = tt" if "tt\<in>{0..Period}" for tt
      using mvt_simple[of 0 tt "\<lambda> t. p t T" "\<lambda> _ x. x"] that assms(4)
      apply (auto simp add: state2vec_def)
      by fastforce
    have 1: "\<forall>t\<in>{-e .. Period+e}. ((\<lambda>t. landerInv(p t)) has_derivative  (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE landerode) (p t)))) (at t within {-e .. Period+e})"
        using pre assms e
        using chainrule'[of landerInv "\<lambda>x. g'(state2vec x)" p "(ODE landerode)" e Period]
        by auto
    have 2: "\<forall>s. g' (state2vec(p t)) ((s *\<^sub>R 1) *\<^sub>R ODE2Vec (ODE landerode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (1 *\<^sub>R ODE2Vec (ODE landerode) (p t))" if "t\<in>{-e .. Period+e}" for t
        using 1 unfolding has_derivative_def bounded_linear_def
        using that linear_iff[of "(\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE landerode) (p t)))"]
        by blast
    have 3: "(s *\<^sub>R 1) = s" and "(1 *\<^sub>R s) = s"
      apply simp by simp
      have 4: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE landerode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (ODE2Vec (ODE landerode) (p t))" if "t\<in>{-e .. Period+e}" for t
        using 2 3 that by auto
      have 5: "\<forall>t\<in>{0..<Period}. landerInv(p t) = 0 \<longrightarrow>  g' (state2vec(p t)) (ODE2Vec (ODE landerode) (p t))< 0" if "t\<in>{0 ..<Period}" for t
        apply auto
        subgoal for tt
          apply(subgoal_tac "p tt T < Period")
          using assms(2) apply auto
          using tt[of tt] by auto
        done
      show ?thesis
        using real_inv_le[OF 1, of 0]
        using 5 assms e pre by auto
    qed
subgoal premises pre for t
  proof-
    obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec (ODE landerode) (p t))) {-e .. Period+e}"
      using pre assms unfolding ODEsol_def by auto
    have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. (ODE2Vec (ODE landerode) (p t)) $ T)) {-e .. Period+e}"
      apply (rule has_vderiv_on_proj)
      using e by auto
    then have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. 1)) {-e .. Period+e}"
      by(auto simp add: landerode_def state2vec_def)
    then have "((\<lambda>t. (state2vec (p t)) $ T) has_vderiv_on (\<lambda>t. 1)) {0 .. tt}" if "tt\<in>{0..Period}" for tt
      apply(rule has_vderiv_on_subset)
      using e that by auto
    then have "x\<in>{0..tt} \<Longrightarrow>((\<lambda>t. state2vec (p t) $ T) has_derivative (\<lambda> x. x)) (at x within {0..tt})" if "tt\<in>{0..Period}" for tt x
      apply(auto simp add: has_vderiv_on_def has_vector_derivative_def)
      using that by auto
    then have tt:"p tt T = tt" if "tt\<in>{0..Period}" for tt
      using mvt_simple[of 0 tt "\<lambda> t. p t T" "\<lambda> _ x. x"] that assms(4)
      apply (auto simp add: state2vec_def)
      by fastforce
    show ?thesis
      using tt pre by auto
  qed
  done

inductive tol_inv_prop_ind :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> tassn" where
  "tol_inv_prop_ind v0 w0 v1 w1 0 []"
| "(ODEsol(ODE ((\<lambda>_ _. 0)(V := (\<lambda>s. s W - 3.732),
                           W := (\<lambda>s. (s W)^2 / 2500 ),
                           T := (\<lambda>_. 1)))))  (p) (Period)
   \<Longrightarrow> p 0 = (\<lambda>_. 0)(V := v1, W := w1)
   \<Longrightarrow> \<forall> t\<in>{0..Period} . landerInv (p t) \<le> 0
   \<Longrightarrow> (((Wait\<^sub>t Period (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, W := w0))) (State (p t))) ({''ch_v''}, {})
    @\<^sub>t IO\<^sub>t ''ch_v'' (p Period V)) @\<^sub>t IO\<^sub>t ''ch_m'' (p Period W)) @\<^sub>t IO\<^sub>t ''ch_Fc'' (W_upd (p Period V) (p Period W))) tr1
   \<Longrightarrow> tol_inv_prop_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n tr2
   \<Longrightarrow> tol_inv_prop_ind v0 w0 v1 w1 (Suc n) (tr1 @ tr2)"

lemma inv_prop:
  "landerInv ((\<lambda>_. 0)(V := v1, W := w1)) \<le> 0 \<Longrightarrow> tol_inv_ind v0 w0 v1 w1 n \<Longrightarrow>\<^sub>t tol_inv_prop_ind v0 w0 v1 w1 n"
proof (induction n arbitrary: v0 w0 v1 w1)
  case 0
  then show ?case
    apply(auto simp add: entails_tassn_def)
    subgoal for tr
      using tol_inv_ind_empty' tol_inv_prop_ind.intros(1) by blast
    done
next
  case suc:(Suc n)
  show ?case
    apply(auto simp add: entails_tassn_def)
    subgoal premises pre for tr
      using pre
      apply(induct rule: tol_inv_ind.cases)
       apply auto
      subgoal premises pre2 for p tr1 tr2
      proof-
        have 1:"\<forall>t\<in>{0..Period}. landerInv (p t) \<le> 0 \<and> p t T = t"
          apply (rule landerode_prop)
              apply clarify
       apply(simp add:vec2state_def landerInv_def landerinv_def)
              apply (fast intro!: derivative_intros)
             apply(auto simp add:state2vec_def entails_def landerInv_def landerinv_def)
          subgoal for S
            apply (auto simp add: landerode_def)
            sorry
          using pre2(2) apply(simp add: landerode_def)
          using pre2(3) apply simp
          using suc(2)
          by(simp add: landerInv_def landerinv_def)
        have 2:"\<forall>t\<in>{0..Period}. landerInv (p t) \<le> 0"
          using 1 by auto
        have 3:"p Period T = Period"
          using 1 Period_def by auto
        have 4:"landerInv (p Period) \<le> 0"
          using 2 Period_def by auto
        have 5:"tol_inv_prop_ind (p Period V) (p Period W) (p Period V) (W_upd (p Period V) (p Period W)) n tr2"
          using suc(1)[unfolded entails_tassn_def landerInv_def,of "(p Period V)" "(W_upd (p Period V) (p Period W))" "(p Period V)" "(p Period W)"]
          apply simp
          using landerinv_prop2[of "(p Period V)" "(p Period W)"]
          using 4[unfolded landerInv_def 3]
          using pre2(5) by auto
        show ?thesis
          using tol_inv_prop_ind.intros(2)[of p v1 w1 v0 w0 tr1 n tr2]
          using pre2 2 5 by auto
      qed
      done
    done
qed

lemma system_Prop1:
  assumes "landerInv ((\<lambda>_. 0)(V := v1, W := w1)) \<le> 0"
  shows"\<Turnstile>\<^sub>p {pair_assn (\<lambda> s. s = (\<lambda>_. 0)(V := v0, W := w0)) (\<lambda> s. s = (\<lambda>_. 0)(V := v1, W := w1))}
        Parallel (Single P0){''ch_v'', ''ch_m'',''ch_Fc''}(Single P1)
     {\<exists>\<^sub>g n. trace_gassn (tol_inv_prop_ind v0 w0 v1 w1 n)}"
  apply(rule ParValid_conseq)
    apply(rule system_Prop)
   apply (auto simp add: ex_gassn_def trace_gassn_def)
  subgoal for tr n
    apply(rule exI[where x="n"])
    using assms inv_prop
    by (simp add: entails_tassn_def)
  done

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Semantics\<close>

theory Semantics
imports Sequence Intensional
begin

text \<open>
  This theory mechanises a \emph{shallow} embedding of \tlastar{} using the
  \<open>Sequence\<close> and \<open>Intensional\<close> theories. A shallow embedding
  represents \tlastar{} using Isabelle/HOL predicates, while a \emph{deep}
  embedding would represent \tlastar{} formulas and pre-formulas as mutually
  inductive datatypes\footnote{See e.g. \cite{Wildmoser04} for a discussion
  about deep vs. shallow embeddings in Isabelle/HOL.}.
  The choice of a shallow over a deep embedding is motivated by the following
  factors: a shallow embedding is usually less involved, and existing Isabelle
  theories and tools can be applied more directly to enhance automation; due to
  the lifting in the \<open>Intensional\<close> theory, a shallow embedding can reuse
  standard logical operators, whilst a deep embedding requires a different
  set of operators for both formulas and pre-formulas. Finally, since our
  target is system verification rather than proving meta-properties of \tlastar{},
  which requires a deep embedding, a shallow embedding is more fit for purpose.
\<close>

subsection "Types of Formulas"

text \<open>
  To mechanise the \tlastar{} semantics, the following
  type abbreviations are used:
\<close>

type_synonym ('a,'b) formfun = "'a seq \<Rightarrow> 'b"
type_synonym 'a formula = "('a,bool) formfun"
type_synonym ('a,'b) stfun = "'a \<Rightarrow> 'b"
type_synonym 'a stpred = "('a,bool) stfun"

instance
 "fun" :: (type,type) world ..

instance
 "prod" :: (type,type) world ..

text \<open>
  Pair and function are instantiated to be of type class world.
  This allows use of the lifted intensional logic for formulas, and
  standard logical connectives can therefore be used.
\<close>

subsection "Semantics of TLA*"

text \<open>The semantics of \tlastar{} is defined.\<close>

definition always :: "('a::world) formula \<Rightarrow> 'a formula"
where "always F \<equiv> \<lambda> s. \<forall> n. (s |\<^sub>s n) \<Turnstile> F"

definition nexts :: "('a::world) formula \<Rightarrow> 'a formula"
where "nexts F \<equiv> \<lambda> s. (tail s) \<Turnstile> F"

definition before :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "before f \<equiv> \<lambda> s. (first s) \<Turnstile> f"

definition after :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "after f \<equiv> \<lambda> s. (second s) \<Turnstile> f"

definition unch  :: "('a::world,'b) stfun \<Rightarrow> 'a formula"
where "unch v \<equiv> \<lambda> s. s \<Turnstile> (after v) = (before v)"

definition action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "action P v \<equiv> \<lambda> s. \<forall> i. ((s |\<^sub>s i) \<Turnstile> P) \<or> ((s |\<^sub>s i) \<Turnstile> unch v)"

subsubsection "Concrete Syntax"

text\<open>This is the concrete syntax for the (abstract) operators above.\<close>

syntax
 "_always" :: "lift \<Rightarrow> lift" ("(\<box>_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(\<circle>_)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<box>[_]'_(_))" [20,1000] 90)
 "_before"    :: "lift \<Rightarrow> lift"  ("($_)" [100] 99)
 "_after"     :: "lift \<Rightarrow> lift"  ("(_$)" [100] 99)
 "_prime"     :: "lift \<Rightarrow> lift"  ("(_`)" [100] 99)
 "_unch"     :: "lift \<Rightarrow> lift"  ("(Unchanged _)" [100] 99)
 "TEMP"  :: "lift \<Rightarrow> 'b" ("(TEMP _)")

syntax (ASCII)
 "_always" :: "lift \<Rightarrow> lift" ("([]_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(Next _)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("([][_]'_(_))" [20,1000] 90)

translations
 "_always" \<rightleftharpoons> "CONST always"
 "_nexts" \<rightleftharpoons> "CONST nexts"
 "_action" \<rightleftharpoons> "CONST action"
 "_before"    \<rightleftharpoons> "CONST before"
 "_after"     \<rightleftharpoons> "CONST after"
 "_prime"     \<rightharpoonup> "CONST after"
 "_unch"     \<rightleftharpoons> "CONST unch"
 "TEMP F" \<rightharpoonup> "(F:: (nat \<Rightarrow> _) \<Rightarrow> _)"

subsection "Abbreviations"

text \<open>Some standard temporal abbreviations, with their concrete syntax.\<close>

definition actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "actrans P v \<equiv> TEMP(P \<or> unch v)"

definition eventually :: "('a::world) formula \<Rightarrow> 'a formula"
where "eventually F \<equiv> LIFT(\<not>\<box>(\<not>F))"

definition angle_action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_action P v \<equiv> LIFT(\<not>\<box>[\<not>P]_v)"

definition angle_actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_actrans P v \<equiv> TEMP (\<not> actrans (LIFT(\<not>P)) v)"

definition leadsto :: "('a::world) formula \<Rightarrow> 'a formula \<Rightarrow> 'a formula"
where "leadsto P Q \<equiv> LIFT \<box>(P \<longrightarrow> eventually Q)"

subsubsection "Concrete Syntax"

syntax (ASCII)
  "_actrans" :: "[lift,lift] \<Rightarrow> lift" ("([_]'_(_))"  [20,1000] 90)
  "_eventually" :: "lift \<Rightarrow> lift" ("(<>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(<><_>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(<_>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ ~> _)" [26,25] 25)

syntax
  "_eventually" :: "lift \<Rightarrow> lift" ("(\<diamond>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<diamond>\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ \<leadsto> _)" [26,25] 25)

translations
  "_actrans" \<rightleftharpoons> "CONST actrans"
  "_eventually" \<rightleftharpoons> "CONST eventually"
  "_angle_action" \<rightleftharpoons> "CONST angle_action"
  "_angle_actrans" \<rightleftharpoons> "CONST angle_actrans"
  "_leadsto" \<rightleftharpoons> "CONST leadsto"

subsection "Properties of Operators"

text \<open>The following lemmas show that these operators have the expected semantics.\<close>

lemma eventually_defs: "(w \<Turnstile> \<diamond> F) = (\<exists> n. (w |\<^sub>s n) \<Turnstile> F)"
  by (simp add: eventually_def always_def)

lemma angle_action_defs: "(w \<Turnstile> \<diamond>\<langle>P\<rangle>_v) = (\<exists> i. ((w |\<^sub>s i) \<Turnstile> P) \<and> ((w |\<^sub>s i) \<Turnstile> v$ \<noteq> $v))"
  by (simp add: angle_action_def action_def unch_def)

lemma unch_defs: "(w \<Turnstile> Unchanged v) = (((second w) \<Turnstile> v) = ((first w) \<Turnstile> v))"
  by (simp add: unch_def before_def nexts_def after_def tail_def suffix_def first_def second_def)

lemma linalw:
  assumes h1: "a \<le> b" and h2: "(w |\<^sub>s a) \<Turnstile> \<box>A"
  shows "(w |\<^sub>s b) \<Turnstile> \<box>A"
proof (clarsimp simp: always_def)
  fix n
  from h1 obtain k where g1: "b = a + k" by (auto simp: le_iff_add)
  with h2 show "(w |\<^sub>s b |\<^sub>s n) \<Turnstile> A" by (auto simp: always_def suffix_plus ac_simps)
qed

subsection "Invariance Under Stuttering"

text \<open>
  A key feature of \tlastar{} is that specification at different abstraction
  levels can be compared. The soundness of this relies on the stuttering invariance
  of formulas. Since the embedding is shallow, it cannot be shown that a generic
  \tlastar{} formula is stuttering invariant. However, this section will show that
  each operator is stuttering invariant or preserves stuttering invariance in an
  appropriate sense, which can be used to show stuttering invariance
  for given specifications.

  Formula \<open>F\<close> is stuttering invariant if for any two similar behaviours
  (i.e., sequences of states), \<open>F\<close> holds in one iff it holds in the other.
  The definition is generalised to arbitrary expressions, and not just predicates.
\<close>

definition stutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "stutinv F \<equiv> \<forall> \<sigma> \<tau>. \<sigma> \<approx> \<tau> \<longrightarrow> (\<sigma> \<Turnstile> F) = (\<tau> \<Turnstile> F)"

text\<open>
  The requirement for stuttering invariance is too strong for pre-formulas.
  For example, an action formula specifies a relation between the first two states
  of a behaviour, and will rarely be satisfied by a stuttering step. This is why
  pre-formulas are ``protected'' by (square or angle) brackets in \tlastar{}:
  the only place a pre-formula \<open>P\<close> can be used is inside an action:
  \<open>\<box>[P]_v\<close>.
  To show that \<open>\<box>[P]_v\<close> is stuttering invariant, is must be shown that a
  slightly weaker predicate holds for @{term P}. For example, if @{term P} contains
  a term of the form \<open>\<circle>\<circle>Q\<close>, then it is not a well-formed pre-formula, thus
  \<open>\<box>[P]_v\<close> is not stuttering invariant. This weaker version of
  stuttering invariance has been named \emph{near stuttering invariance}.
\<close>

definition nstutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "nstutinv P \<equiv> \<forall> \<sigma> \<tau>. (first \<sigma> = first \<tau>) \<and> (tail \<sigma>) \<approx> (tail \<tau>) \<longrightarrow> (\<sigma> \<Turnstile> P) = (\<tau> \<Turnstile> P)"

syntax
  "_stutinv" :: "lift \<Rightarrow> bool" ("(STUTINV _)" [40] 40)
  "_nstutinv" :: "lift \<Rightarrow> bool" ("(NSTUTINV _)" [40] 40)

translations
  "_stutinv" \<rightleftharpoons> "CONST stutinv"
  "_nstutinv" \<rightleftharpoons> "CONST nstutinv"

text \<open>
  Predicate @{term "stutinv F"} formalises stuttering invariance for
  formula @{term F}. That is if two sequences are similar @{term "s \<approx> t"} (equal up
  to stuttering) then the validity of @{term F} under both @{term s} and @{term t}
  are equivalent. Predicate @{term "nstutinv P"} should be read as \emph{nearly
  stuttering invariant} -- and is required for some stuttering invariance proofs.
\<close>

lemma stutinv_strictly_stronger:
  assumes h: "STUTINV F" shows "NSTUTINV F"
  unfolding nstutinv_def
proof (clarify)
  fix s t :: "nat \<Rightarrow> 'a"
  assume a1: "first s = first t" and a2: "(tail s) \<approx> (tail t)"
  have "s \<approx> t"
  proof -
    have tg1: "(first s) ## (tail s) = s" by (rule seq_app_first_tail)
    have tg2: "(first t) ## (tail t) = t" by (rule seq_app_first_tail)
    with a1 have tg2': "(first s) ## (tail t) = t" by simp
    from a2 have "(first s) ## (tail s) \<approx> (first s) ## (tail t)" by (rule app_seqsimilar)
    with tg1 tg2' show ?thesis by simp
  qed
  with h show "(s \<Turnstile> F) = (t \<Turnstile> F)" by (simp add: stutinv_def)
qed

subsubsection "Properties of @{term stutinv}"

text \<open>
  This subsection proves stuttering invariance, preservation of stuttering invariance
  and introduction of stuttering invariance for different formulas.
  First, state predicates are stuttering invariant.
\<close>

theorem stut_before: "STUTINV $F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a1: "s \<approx> t"
  hence "(first s) = (first t)" by (rule sim_first)
  thus "(s \<Turnstile> $F) = (t \<Turnstile> $F)" by (simp add: before_def)
qed

lemma nstut_after: "NSTUTINV F$"
proof (clarsimp simp: nstutinv_def)
  fix s t :: "'a seq"
  assume a1: "tail s \<approx> tail t"
  thus "(s \<Turnstile> F$) = (t \<Turnstile> F$)" by (simp add: after_def tail_sim_second)
qed

text\<open>The always operator preserves stuttering invariance.\<close>

theorem stut_always: assumes H:"STUTINV F" shows "STUTINV \<box>F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a2: "s \<approx> t"
  show "(s \<Turnstile> (\<box> F)) = (t \<Turnstile> (\<box> F))"
  proof
    assume a1: "t \<Turnstile> \<box> F"
    show "s \<Turnstile> \<box> F"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN sim_step] obtain m where m: "s |\<^sub>s n \<approx> t |\<^sub>s m" by blast
      from a1 have "(t |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(s |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  next
    assume a1: "s \<Turnstile> (\<box> F)"
    show "t \<Turnstile> (\<box> F)"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN seqsim_sym, THEN sim_step] obtain m where m: "t |\<^sub>s n \<approx> s |\<^sub>s m" by blast
      from a1 have "(s |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(t |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  qed
qed

text \<open>
  Assuming that formula @{term P} is nearly suttering invariant
  then \<open>\<box>[P]_v\<close> will be stuttering invariant.
\<close>

lemma stut_action_lemma:
  assumes H: "NSTUTINV P" and st: "s \<approx> t" and P: "t \<Turnstile> \<box>[P]_v"
  shows "s \<Turnstile> \<box>[P]_v"
proof (clarsimp simp: action_def)
  fix n
  assume "\<not> ((s |\<^sub>s n) \<Turnstile> Unchanged v)"
  hence v: "v (s (Suc n)) \<noteq> v (s n)"
    by (simp add: unch_defs first_def second_def suffix_def)
  from st[THEN sim_step] obtain m where
    a2': "s |\<^sub>s n \<approx> t |\<^sub>s m
          \<and> (s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m)" ..
  hence g1: "(s |\<^sub>s n \<approx> t |\<^sub>s m)" by simp
  hence g1'': "first (s |\<^sub>s n) = first (t |\<^sub>s m)" by (simp add: sim_first)
  hence g1': "s n = t m" by (simp add: suffix_def first_def)
  from a2' have g2: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m" by simp
  from P have a1': "((t |\<^sub>s m) \<Turnstile> P) \<or> ((t |\<^sub>s m) \<Turnstile> Unchanged v)" by (simp add: action_def)
  from g2 show "(s |\<^sub>s n) \<Turnstile> P"
  proof
    assume "s |\<^sub>s Suc n \<approx> t |\<^sub>s m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s m)" by (simp add: sim_first)
    hence "s (Suc n) = t m" by (simp add: suffix_def first_def)
    with g1' v show ?thesis by simp  \<comment> \<open>by contradiction\<close>
  next
    assume a3: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s Suc m)" by (simp add: sim_first)
    hence a3': "s (Suc n) = t (Suc m)" by (simp add: suffix_def first_def)
    from a1' show ?thesis
    proof
      assume "(t |\<^sub>s m) \<Turnstile> Unchanged v"
      hence "v (t (Suc m)) = v (t m)"
        by (simp add: unch_defs first_def second_def suffix_def)
      with g1' a3' v show ?thesis by simp  \<comment> \<open>again, by contradiction\<close>
    next
      assume a4: "(t |\<^sub>s m) \<Turnstile> P"
      from a3 have "tail (s |\<^sub>s n) \<approx> tail (t |\<^sub>s m)" by (simp add: tail_def suffix_plus)
      with H g1'' a4 show ?thesis by (auto simp: nstutinv_def)
    qed
  qed
qed

theorem stut_action: assumes H: "NSTUTINV P" shows "STUTINV \<box>[P]_v"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume st: "s \<approx> t"
  show "(s \<Turnstile> \<box>[P]_v) = (t \<Turnstile> \<box>[P]_v)"
  proof
    assume "t \<Turnstile> \<box>[P]_v"
    with H st show "s \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  next
    assume "s \<Turnstile> \<box>[P]_v"
    with H st[THEN seqsim_sym] show "t \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  qed
qed

text \<open>
  The lemmas below shows that propositional and predicate operators
  preserve stuttering invariance.
\<close>

lemma stut_and: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<and> G)"
  by (simp add: stutinv_def)

lemma stut_or: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<or> G)"
  by (simp add: stutinv_def)

lemma stut_imp: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<longrightarrow> G)"
  by (simp add: stutinv_def)

lemma stut_eq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F = G)"
  by (simp add: stutinv_def)

lemma stut_noteq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<noteq> G)"
  by (simp add: stutinv_def)

lemma stut_not: "STUTINV F \<Longrightarrow> STUTINV (\<not> F)"
  by (simp add: stutinv_def)

lemma stut_all: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<forall> x. F x)"
  by (simp add: stutinv_def)

lemma stut_ex: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<exists> x. F x)"
  by (simp add: stutinv_def)

lemma stut_const: "STUTINV #c"
  by (simp add: stutinv_def)

lemma stut_fun1: "STUTINV X \<Longrightarrow> STUTINV (f <X>)"
  by (simp add: stutinv_def)

lemma stut_fun2: "\<lbrakk>STUTINV X;STUTINV Y\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y>)"
  by (simp add: stutinv_def)

lemma stut_fun3: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z>)"
  by (simp add: stutinv_def)

lemma stut_fun4: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z; STUTINV W\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z,W>)"
  by (simp add: stutinv_def)

lemma stut_plus: "\<lbrakk>STUTINV x;STUTINV y\<rbrakk> \<Longrightarrow> STUTINV (x+y)"
  by (simp add: stutinv_def)

subsubsection "Properties of @{term nstutinv}"

text \<open>
  This subsection shows analogous properties about near stuttering
  invariance.

  If a formula @{term F} is stuttering invariant then \<open>\<circle>F\<close> is
  nearly stuttering invariant.
\<close>

lemma nstut_nexts: assumes H: "STUTINV F" shows "NSTUTINV \<circle>F"
using H by (simp add: stutinv_def nstutinv_def nexts_def)

text \<open>
  The lemmas below shows that propositional and predicate operators
  preserves near stuttering invariance.
\<close>

lemma nstut_and: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<and> G)"
  by (auto simp: nstutinv_def)

lemma nstut_or: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<or> G)"
  by (auto simp: nstutinv_def)

lemma nstut_imp: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<longrightarrow> G)"
  by (auto simp: nstutinv_def)

lemma nstut_eq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F = G)"
  by (force simp: nstutinv_def)

lemma nstut_not: "NSTUTINV F \<Longrightarrow> NSTUTINV (\<not> F)"
  by (auto simp: nstutinv_def)

lemma nstut_noteq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<noteq> G)"
  by (simp add: nstut_eq nstut_not)

lemma nstut_all: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<forall> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_ex: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<exists> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_const: "NSTUTINV #c"
  by (auto simp: nstutinv_def)

lemma nstut_fun1: "NSTUTINV X \<Longrightarrow> NSTUTINV (f <X>)"
  by (force simp: nstutinv_def)

lemma nstut_fun2: "\<lbrakk>NSTUTINV X; NSTUTINV Y\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y>)"
  by (force simp: nstutinv_def)

lemma nstut_fun3: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z>)"
  by (force simp: nstutinv_def)

lemma nstut_fun4: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z; NSTUTINV W\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z,W>)"
  by (force simp: nstutinv_def)

lemma nstut_plus: "\<lbrakk>NSTUTINV x;NSTUTINV y\<rbrakk> \<Longrightarrow> NSTUTINV (x+y)"
  by (simp add: nstut_fun2)

subsubsection "Abbreviations"

text \<open>
  We show the obvious fact that the same properties holds for abbreviated
  operators.
\<close>

lemmas nstut_before = stut_before[THEN stutinv_strictly_stronger]

lemma nstut_unch: "NSTUTINV (Unchanged v)"
proof (unfold unch_def)
  have g1: "NSTUTINV v$" by (rule nstut_after)
  have "NSTUTINV $v" by (rule stut_before[THEN stutinv_strictly_stronger])
  with g1 show "NSTUTINV (v$ = $v)" by (rule nstut_eq)
qed

text\<open>
  Formulas \<open>[P]_v\<close> are not \tlastar{} formulas by themselves,
  but we need to reason about them when they appear wrapped
  inside \<open>\<box>[-]_v\<close>. We only require that it preserves nearly
  stuttering invariance. Observe that \<open>[P]_v\<close> trivially holds for
  a stuttering step, so it cannot be stuttering invariant.
\<close>

lemma nstut_actrans: "NSTUTINV P \<Longrightarrow> NSTUTINV [P]_v"
  by (simp add: actrans_def nstut_unch nstut_or)

lemma stut_eventually: "STUTINV F \<Longrightarrow> STUTINV \<diamond>F"
  by (simp add: eventually_def stut_not stut_always)

lemma stut_leadsto: "\<lbrakk>STUTINV F; STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<leadsto> G)"
  by (simp add: leadsto_def stut_always stut_eventually stut_imp)

lemma stut_angle_action: "NSTUTINV P \<Longrightarrow> STUTINV \<diamond>\<langle>P\<rangle>_v"
  by (simp add: angle_action_def nstut_not stut_action stut_not)

lemma nstut_angle_acttrans: "NSTUTINV P \<Longrightarrow> NSTUTINV \<langle>P\<rangle>_v"
  by (simp add: angle_actrans_def nstut_not nstut_actrans)

lemmas stutinvs = stut_before stut_always stut_action
  stut_and stut_or stut_imp stut_eq stut_noteq stut_not
  stut_all stut_ex stut_eventually stut_leadsto stut_angle_action stut_const
  stut_fun1 stut_fun2 stut_fun3 stut_fun4

lemmas nstutinvs =  nstut_after nstut_nexts nstut_actrans
  nstut_unch nstut_and nstut_or nstut_imp nstut_eq nstut_noteq nstut_not
  nstut_all nstut_ex nstut_angle_acttrans stutinv_strictly_stronger
  nstut_fun1 nstut_fun2 nstut_fun3 nstut_fun4 stutinvs[THEN stutinv_strictly_stronger]

lemmas bothstutinvs = stutinvs nstutinvs

end


theory DDL_Tests imports DDL        (* Ali Farjami, Christoph Benzmüller, Xavier Parent, 2020  *)

begin (* Some Tests on the Meta-Theory of DDL*)
lemma True nitpick [satisfy,user_axioms,expect=genuine] oops  (* Consistency confirmed by Nitpick *)

lemma MP: "\<lbrakk>\<lfloor>A\<rfloor>; \<lfloor>A \<^bold>\<rightarrow> B\<rfloor>\<rbrakk> \<Longrightarrow> \<lfloor>B\<rfloor>" by simp
lemma Nec: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>A\<rfloor>" by simp
lemma Neca: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>"  by simp
lemma Necp: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>p A\<rfloor>"  by simp

(* "\<^bold>\<box>" is an S5 modality *)
lemma C_1_refl: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> A\<rfloor>" by simp
lemma C_1_trans: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<box>A))\<rfloor>"  by simp
lemma C_1_sym: "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<diamond>A))\<rfloor>"  by simp

(* "\<^bold>\<box>\<^sub>p" is an KT modality *)
lemma C_9_p_refl: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> A\<rfloor>"  by (simp add: ax_4b)
lemma "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>p(\<^bold>\<box>\<^sub>pA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>p(\<^bold>\<diamond>\<^sub>pA))\<rfloor>"   nitpick [user_axioms] oops (* countermodel *)

(* "\<^bold>\<box>\<^sub>a" is an KD modality *)
lemma C_10_a_serial: "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sub>aA\<rfloor>"  by (simp add: ax_3a)
lemma "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> A\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>a(\<^bold>\<box>\<^sub>aA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>a(\<^bold>\<diamond>\<^sub>aA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)

(* Relationship between "\<^bold>\<box>,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_11: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>pA\<rfloor>" sledgehammer by simp
lemma C_12: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aA\<rfloor>"  using ax_4a by auto

(* Characterisation of "\<^bold>O" *)
lemma C_2: "\<lfloor>\<^bold>O\<^bold>\<langle>A\<^bold>|B\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<diamond>(B \<^bold>\<and> A)\<rfloor>"  by (metis ax_5a ax_5b)
lemma C_3: "\<lfloor>(\<^bold>\<diamond>(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> ) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(B \<^bold>\<and> C)\<^bold>|A\<^bold>\<rangle>\<rfloor>" by (simp add: ax_5c) (*longer proof*)
lemma C_4: "\<lfloor>(\<^bold>\<box>(A \<^bold>\<rightarrow> B) \<^bold>\<and> (\<^bold>\<diamond>(A \<^bold>\<and> C)) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>\<rfloor>"   using ax_5e by blast
lemma C_5: "\<lfloor>\<^bold>\<box>(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>)\<rfloor>"  by presburger
lemma C_6: "\<lfloor>\<^bold>\<box>(C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>A\<^bold>|C\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|C\<^bold>\<rangle>)\<rfloor>"  by (smt ax_5b)
lemma C_7: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by blast
lemma C_8: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle>\<rfloor>" sledgehammer sorry (*longer proof*)

(* Relationship between "\<^bold>O\<^sub>a,\<^bold>O\<^sub>p,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_13_a: "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>a(\<^bold>\<not>A))\<rfloor>"  by (metis (full_types) ax_5a ax_5b)
lemma C_13_b: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>pA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>p(\<^bold>\<not>A))\<rfloor>"   by (metis (full_types) ax_5a ax_5b)
lemma C_14_a: "\<lfloor>\<^bold>\<box>\<^sub>a(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>aA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>aB)\<rfloor>"  by (metis ax_5b)
lemma C_14_b: "\<lfloor>\<^bold>\<box>\<^sub>p(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>pA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>pB)\<rfloor>"  by (metis ax_5b)

(* Relationship between "\<^bold>O\<^sub>,\<^bold>O\<^sub>a,\<^bold>O\<^sub>p,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_15_a: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>aA \<^bold>\<and> \<^bold>\<diamond>\<^sub>aB \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>aB\<rfloor>"  using ax_5e by blast
lemma C_15_b: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>pA \<^bold>\<and> \<^bold>\<diamond>\<^sub>pB \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(\<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>pB\<rfloor>"  using ax_5e by blast

(* Rules to consistently add "\<^bold>O(/)" formulas *)

(* Observation II-2-1 *)
lemma ax_5b': "ob X Y \<longleftrightarrow> ob X (\<lambda>z. X z \<and> Y z)" by (metis (no_types, lifting) ax_5b)

(* Soundness and consistency *)
lemma II_3_1: "((\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>\<rfloor>) \<and> (\<exists>x. Z(x) \<and> A(x) \<and> B(x))) \<longrightarrow> ob(Z)(A \<^bold>\<rightarrow> B)"
  proof
     assume L1: "(\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>\<rfloor>) \<and> (\<exists>x. Z(x) \<and> A(x) \<and> B(x))"
     have L2: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>\<rfloor>" by (simp add: L1)
     fix w::i
     from L1 have L3: "(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)(w)"  by auto
     from L1 L3 have L4: "(\<exists>x. A x \<and> B x) \<and> (\<forall>X. (\<forall>y. X y \<longrightarrow> A y) \<and> (\<exists>z. X z \<and> B z) \<longrightarrow> ob X B)" using ax_5e by metis
     from L4 have L5: "(\<exists>x. A x \<and> B x) \<and> ((\<forall>y. (\<lambda>z. A z \<and> Z z) y \<longrightarrow> A y) \<and> (\<exists>z. (\<lambda>z. A z \<and> Z z) z \<and> B z) \<longrightarrow> ob (\<lambda>z. A z \<and> Z z) B)" by auto
     from L1 L5 have L6: "ob (\<lambda>z. A z \<and> Z z) B" by blast
     have L7: "ob (\<lambda>z. A z \<and> Z z) B \<longleftrightarrow> ob (\<lambda>z. A z \<and> Z z) (\<lambda>z. (\<lambda>z. A z \<and> Z z) z \<and> B z)" using ax_5b' by blast
     from L7 have L8: "ob (\<lambda>z. A z \<and> Z z) B \<longleftrightarrow> ob (\<lambda>z. A z \<and> Z z) (\<lambda>z. A z \<and> Z z \<and> B z)" by simp
     from L6 L8 have L9: "ob (\<lambda>z. A z \<and> Z z) (\<lambda>z. A z \<and> Z z \<and> B z)" by blast
     have L10: "(\<lambda>z. A z \<and> Z z) = (\<lambda>z. Z z \<and> A z)" by metis
     have L11: "(\<lambda>z. A z \<and> Z z \<and> B z) = (\<lambda>z. Z z \<and> A z \<and> B z)"  by metis
     from L9 have L12: "ob (\<lambda>z. Z z \<and> A z) (\<lambda>z. Z z \<and> A z \<and> B z)" by (simp add:L10 L11)
     have L13: "(\<forall>z. (Z z \<and> A z \<and> B z) \<longrightarrow> (Z z \<and> A z))" by auto
     have L14: "(\<forall>z. (Z z \<and> A z) \<longrightarrow> Z z)" by auto
     from L12 have L15: "(\<forall>z. (Z z \<and> A z \<and> B z) \<longrightarrow> (Z z \<and> A z)) \<and> ob (\<lambda>z. Z z \<and> A z) (\<lambda>z. Z z \<and> A z \<and> B z)  \<and> (\<forall>z. (Z z \<and> A z) \<longrightarrow> Z z)" by (simp add: L12)
     have L16: "((\<forall>z. (Z z \<and> A z \<and> B z) \<longrightarrow> (Z z \<and> A z)) \<and> ob (\<lambda>z. Z z \<and> A z) (\<lambda>z. Z z \<and> A z \<and> B z)  \<and> (\<forall>z. (Z z \<and> A z) \<longrightarrow> Z z))
                   \<longrightarrow> ob Z (\<lambda>w. (Z w \<and> \<not>(Z w \<and> A w)) \<or> (Z w \<and> A w \<and> B w))" by (metis (mono_tags) ax_5d)
     from L15 L16 have L17: "ob Z (\<lambda>w. (Z w \<and> \<not>(Z w \<and> A w)) \<or> (Z w \<and> A w \<and> B w))" by blast
     from L17 have L18: "ob Z (\<lambda>w. A w \<longrightarrow> B w)" by (smt ax_5b)
     from L18 show L19: "ob(Z)(A \<^bold>\<rightarrow> B)"  by auto
     qed

(* Some theorems and derived (proof) rules *)
lemma II_4_1: "\<lfloor>\<^bold>\<box>(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (C(A) \<^bold>\<leftrightarrow> C(B))\<rfloor>"  using ext by blast
lemma obs_II_4_1_a  : "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>C(A) \<^bold>\<leftrightarrow> C(B)\<rfloor>"  using ext by blast
lemma obs_II_4_1_b  : "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<diamond>(A \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>\<rfloor>"  using ax_5e by blast
lemma obs_II_4_1_c_1: "\<lfloor>\<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>))\<rfloor>"  by blast
lemma obs_II_4_1_c_2: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by auto
lemma obs_II_4_1_c_3: "\<lfloor>\<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by blast
lemma obs_II_4_1_c_4: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<not>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>))\<rfloor>"  by blast

lemma res_II_4_1_a_1: "\<lfloor>\<^bold>\<not>(\<^bold>O\<^bold>\<langle>\<^bold>\<bottom>\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by (simp add: ax_5a)
lemma res_II_4_1_a_2: "\<lfloor>(\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(B \<^bold>\<and> C)\<^bold>|A\<^bold>\<rangle>\<rfloor>"  using C_3  by auto

lemma res_II_4_1_a_3: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_a_4: "\<lfloor>\<^bold>\<diamond>\<^sub>p(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p(\<^bold>O\<^bold>\<langle>B\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>)\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_a_5: "\<lfloor>(\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)

lemma res_II_4_1_b_1:  "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_b_2:  "\<lfloor>C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>O\<^bold>\<langle>A\<^bold>|C\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|C\<^bold>\<rangle>\<rfloor>"  by (smt ax_5b)

lemma obs_II_4_2_1: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B)))\<rfloor>"  by blast
lemma obs_II_4_2_2: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle>\<rfloor>" by (simp add: C_8)

lemma obs_II_4_2_3: "\<lfloor>(\<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>a\<^bold>\<top> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B))) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"  by (smt ax_5e)
lemma obs_II_4_2_4: "\<lfloor>\<^bold>\<box>\<^sub>a\<^bold>\<top>\<rfloor>"  by simp
lemma obs_II_4_2_5: "\<lfloor>(\<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B))) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"  by (smt ax_5e)
lemma obs_II_4_2_6: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"   by (simp add: II_3_1)

lemma a_DD: "\<lfloor>(\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<and> B)\<rfloor>" sledgehammer oops (* longer proof *)
lemma p_DD: "\<lfloor>(\<^bold>O\<^sub>pA \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>p(A \<^bold>\<and> B)\<rfloor>" sledgehammer oops (* longer proof *)

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor Addition\<close>

theory Tensor_Plus
imports Tensor_Subtensor
begin

(* Problem: typeclass plus only has one zero element. If this is the empty tensor, other zero tensors cannot be of rank 0.*)

definition "vec_plus a b = map (\<lambda>(x,y). plus x y) (zip a b)"

definition plus_base::"'a::semigroup_add tensor \<Rightarrow> 'a tensor \<Rightarrow> 'a tensor"
where "plus_base A B = (tensor_from_vec (dims A) (vec_plus (vec A) (vec B)))"

instantiation tensor:: (semigroup_add) plus
begin
  definition plus_def: "A + B = (if (dims A = dims B)
                  then plus_base A B
                  else undefined)"
  instance ..
end

lemma plus_dim1[simp]: "dims A = dims B \<Longrightarrow> dims (A + B) = dims A" unfolding plus_def plus_base_def
  using dims_tensor length_vec length_map map_fst_zip vec_plus_def by (metis (full_types))
lemma plus_dim2[simp]: "dims A = dims B \<Longrightarrow> dims (A + B) = dims B" using plus_dim1 by metis
lemma plus_base: "dims A = dims B \<Longrightarrow> A + B = plus_base A B" unfolding plus_def by metis

lemma fixed_length_sublist_plus:
assumes "length xs1 = c * l" "length xs2 = c * l" "i < c"
shows "fixed_length_sublist (vec_plus xs1 xs2) l i
          = vec_plus (fixed_length_sublist xs1 l i) (fixed_length_sublist xs2 l i)"
unfolding vec_plus_def fixed_length_sublist_def using drop_map drop_zip take_map take_zip by metis

lemma vec_plus[simp]:
assumes "dims A = dims B"
shows "vec (A+B) = vec_plus (vec A) (vec B)"
  unfolding plus_def plus_base_def vec_plus_def using assms
  by (auto; metis (no_types, lifting) length_map length_tensor_vec_from_lookup map_fst_zip tensor_lookup tensor_from_lookup_def vec_tensor)

lemma subtensor_plus:
fixes A::"'a::semigroup_add tensor" and B::"'a::semigroup_add tensor"
assumes "i < hd (dims A)"
and "dims A = dims B"
and "dims A \<noteq> []"
shows "subtensor (A + B) i = subtensor A i + subtensor B i"
proof -
   have "length (vec A) =  hd (dims A) * prod_list (tl (dims A))"
        "length (Tensor.vec B) = hd (dims A) * prod_list (tl (dims A))"
     using length_vec prod_list.Cons assms by (metis (no_types) list.exhaust_sel)+
   then show ?thesis
     using Tensor_Plus.vec_plus assms fixed_length_sublist_plus vec_subtensor tensor_eqI
     dims_subtensor plus_dim1 by fastforce
qed

lemma lookup_plus[simp]:
assumes "dims A = dims B"
and "is \<lhd> dims A"
shows "lookup (A + B) is = lookup A is + lookup B is"
using assms proof (induction "A+B" arbitrary:A B "is" rule: subtensor_induct)
  case (order_0 A B "is")
  then have "is = []" by auto
  have 1:"[] \<lhd> dims A" using order_0 \<open>is = []\<close> by auto
  have 2:"[] \<lhd> dims B" using order_0 \<open>is = []\<close> by auto
  have 3:"[] \<lhd> dims (A + B)" using order_0 \<open>is = []\<close> by auto
  have "length (vec A) = 1" "length (vec B) = 1"
    by (metis length_vec prod_list.Nil order_0.hyps order_0.prems(1) plus_dim1)+
  then show ?case unfolding lookup_subtensor[OF 1] lookup_subtensor[OF 2] lookup_subtensor[OF 3] \<open>is = []\<close>
    fold_simps(1) vec_plus[OF order_0.prems(1)] unfolding vec_plus_def using  order_0.prems  length_map
    list.map_sel(1) list.size(3)  map_fst_zip map_snd_zip order_0.hyps
    zero_neq_one case_prod_unfold length_vec by metis
next
  case (order_step A B "is")
  then obtain i is' where "is = i # is'" by auto
  have 1:"is \<lhd> dims A" using order_step by auto
  have 2:"is \<lhd> dims B" using order_step by auto
  have 3:"is \<lhd> dims (A + B)" using order_step by auto
  have "lookup (subtensor A i + subtensor B i) is' = lookup (subtensor A i) is' + lookup (subtensor B i) is'"
     apply (rule order_step.hyps(2)[of i])
        using \<open>is = i # is'\<close> 3 hd_conv_nth length_greater_0_conv nth_Cons_0 order_step.hyps(1) valid_index_lt
        apply auto[1]
       apply (metis "2" \<open>is = i # is'\<close> list.inject list.sel(1) list.simps(3) order_step.prems(1) subtensor_plus valid_index.cases)
      using "1" \<open>is = i # is'\<close> order_step.prems(1) plus_dim1 apply auto[1]
     using "1" \<open>is = i # is'\<close> plus_dim1 by auto
  then show ?case using lookup_subtensor[OF 1] lookup_subtensor[OF 2] lookup_subtensor[OF 3]
    using order_step \<open>is = i # is'\<close> plus_dim1 lookup_subtensor1 list.sel(1) subtensor_plus valid_index_dimsE by metis
qed

lemma plus_assoc:
assumes dimsA:"dims A = ds" and dimsB:"dims B = ds" and dimsC:"dims C = ds"
shows "(A + B) + C = A + (B + C)"
by (rule tensor_lookup_eqI; simp add: dimsA dimsB dimsC add.assoc)+

lemma tensor_comm[simp]:
fixes A::"'a::ab_semigroup_add tensor"
shows "A + B = B + A"
proof (cases "dims A = dims B")
  case True
  then show ?thesis unfolding plus_def plus_base_def
    using add.commute lookup_plus[OF True] plus_dim1[OF True] tensor_lookup_eqI[OF True] vec_plus[OF True]
    by (metis lookup_plus plus_dim1 tensor_lookup_eqI vec_plus)
next
  case False
  then show ?thesis unfolding plus_def plus_base_def by simp
qed

definition "vec0 n = replicate n 0"

definition tensor0::"nat list \<Rightarrow> 'a::zero tensor" where
"tensor0 d = tensor_from_vec d (vec0 (prod_list d))"

lemma dims_tensor0[simp]: "dims (tensor0 d) = d"
and   vec_tensor0[simp]:  "vec (tensor0 d) = vec0 (prod_list d)"
  unfolding tensor0_def vec0_def by simp_all

lemma lookup_is_in_vec: "is \<lhd> (dims A) \<Longrightarrow> lookup A is \<in> set (vec A)"
proof (induction arbitrary:"is" rule:subtensor_induct)
  case order_0
  then show ?case unfolding lookup_def using lookup_base_Nil
    by (metis length_0_conv length_vec list.set_sel(1) prod_list.Nil valid_index_length zero_neq_one)
next
  case (order_step A "is")
  then obtain i is' where "is = i # is'" using valid_index_dimsE by blast
  then have 1:"i < hd (dims A)" using dims_def order_step.prems by auto
  have 2:"is' \<lhd> dims (subtensor A i)" using \<open>is = i # is'\<close> dims_subtensor order_step.prems by auto
  have "lookup A is \<in> set (Tensor.vec (subtensor A i))"
    using order_step.IH [OF 1 2] lookup_subtensor1 \<open>is = i # is'\<close> order_step.prems by auto
  then show ?case using vec_subtensor fixed_length_sublist_def by (metis "1" in_set_dropD in_set_takeD order_step.hyps)
qed

lemma lookup_tensor0:
assumes "is \<lhd> ds"
shows "lookup (tensor0 ds) is = 0"
proof -
  have "lookup (tensor0 ds) is \<in> set (vec (tensor0 ds))" using lookup_is_in_vec assms by (metis dims_tensor0)
  moreover have "set (vec (tensor0 ds)) \<subseteq> {0}" unfolding vec_tensor0 vec0_def by (metis in_set_replicate singleton_iff subsetI)
  ultimately show ?thesis by auto
qed

lemma
fixes A::"'a::monoid_add tensor"
shows tensor_add_0_right[simp]: "A + tensor0 (dims A) = A"
  unfolding plus_def plus_base_def dims_tensor0
   apply (simp_all)
    apply (rule tensor_lookup_eqI)
   apply (metis (no_types, lifting)  dims_tensor dims_tensor0 length_vec plus_dim2 vec_plus vec_tensor0)
  by (metis add.right_neutral dims_tensor0 lookup_plus lookup_tensor0 plus_dim2 tensor_from_vec_simp vec_plus vec_tensor0)

lemma
fixes A::"'a::monoid_add tensor"
shows tensor_add_0_left[simp]:  "tensor0 (dims A) + A = A"
  unfolding plus_def plus_base_def dims_tensor0
   apply (simp_all)
    apply (rule tensor_lookup_eqI)
   apply (metis (no_types, lifting)  dims_tensor dims_tensor0 length_vec plus_dim2 vec_plus vec_tensor0)
  by (metis add.left_neutral dims_tensor0 lookup_plus lookup_tensor0 plus_dim2 tensor_from_vec_simp vec_plus vec_tensor0)

definition listsum::"nat list \<Rightarrow> 'a::monoid_add tensor list \<Rightarrow> 'a tensor" where
"listsum ds As = foldr (+) As (tensor0 ds)"

definition listsum'::"'a::monoid_add tensor list \<Rightarrow> 'a tensor" where
"listsum' As = listsum (dims (hd As)) As"

lemma listsum_Nil: "listsum ds [] = tensor0 ds" by (simp add: Tensor_Plus.listsum_def)

lemma listsum_one: "listsum (dims A) [A] = A" unfolding listsum_def by simp

lemma listsum_Cons: "listsum ds (A # As) = A + listsum ds As"
  unfolding listsum_def by auto

lemma listsum_dims:
assumes "\<And>A. A\<in>set As \<Longrightarrow> dims A = ds"
shows "dims (listsum ds As) = ds"
using assms proof (induction As)
  case Nil
  then show ?case by (metis dims_tensor0 listsum_Nil)
next
  case (Cons A As)
  then show ?case using listsum_Cons
    by (metis list.set_intros(1) list.set_intros(2) plus_dim2)
qed

lemma subtensor0:
assumes "ds \<noteq> []" and "i<hd ds"
shows "subtensor (tensor0 ds) i = tensor0 (tl ds)"
proof (rule tensor_lookup_eqI)
  show 1:"dims (subtensor (tensor0 ds) i) = dims (tensor0 (tl ds))" by (simp add: assms(1) assms(2))
  fix "is" assume "is \<lhd> dims (subtensor (tensor0 ds) i)"
  then have "i # is \<lhd> dims (tensor0 ds)" using assms(1) assms(2) valid_index.Cons by fastforce
  then show "lookup (subtensor (tensor0 ds) i) is = lookup (tensor0 (tl ds)) is"
    using lookup_subtensor1  1 \<open>is \<lhd> dims (subtensor (tensor0 ds) i)\<close> dims_tensor0 lookup_tensor0
    by metis
qed

lemma subtensor_listsum:
assumes "\<And>A. A\<in>set As \<Longrightarrow> dims A = ds"
and "ds \<noteq> []" and "i<hd ds"
shows "subtensor (listsum ds As) i = listsum (tl ds) (map (\<lambda>A. subtensor A i) As)"
using assms proof (induction As)
  case Nil
  then show ?case using lookup_tensor0 assms(2) assms(3) subtensor0 by (auto simp add: listsum_Nil)
next
  case (Cons A As)
  then show ?case  by (simp add: listsum_Cons; metis subtensor_plus listsum_dims)
qed

lemma listsum0:
assumes "\<And>A. A\<in>set As \<Longrightarrow> A = tensor0 ds"
shows "listsum ds As = tensor0 ds"
using assms proof (induction As)
  case Nil
  show ?case by (simp add: listsum_Nil)
next
  case Cons
  then show ?case using listsum_Cons
    by (metis dims_tensor0 list.set_intros(1) set_subset_Cons subsetCE tensor_add_0_right)
qed

lemma listsum_all_0_but_one:
assumes "\<And>i. i\<noteq>j \<Longrightarrow> i<length As \<Longrightarrow> As!i = tensor0 ds"
and "dims (As!j) = ds"
and "j < length As"
shows "listsum ds As = As!j"
using assms proof (induction As arbitrary:j)
  case Nil
  then show ?case by auto
next
  case (Cons A As j)
  then show ?case
  proof (cases j)
    case 0
    then have "\<And>i. i < length As \<Longrightarrow> As ! i = tensor0 ds" using Cons using Suc_less_eq length_Cons list.sel(3) nat.simps(3) nth_tl by fastforce
    then have "listsum ds As = tensor0 ds" using listsum0 by (metis in_set_conv_nth)
    then show ?thesis by (metis "0" Cons.prems(2) listsum_Cons nth_Cons_0 tensor_add_0_right)
  next
    case (Suc j')
    then have "listsum ds As = As!j'" by (metis (no_types, lifting) Cons.IH Cons.prems(1) Cons.prems(2) Cons.prems(3) Suc_less_eq length_Cons less_Suc_eq list.sel(3) not_less_eq nth_tl)
    then show ?thesis by (metis Cons.prems(1) Cons.prems(2) Suc length_greater_0_conv list.simps(3) listsum_Cons nat.simps(3) nth_Cons_0 nth_Cons_Suc tensor_add_0_left)
  qed
qed

lemma lookup_listsum:
assumes "is \<lhd> ds"
and "\<And>A. A \<in> set As \<Longrightarrow> dims A = ds"
shows "lookup (listsum ds As) is = (\<Sum>A\<leftarrow>As. lookup A is)"
using assms proof (induction As)
  case Nil
  then show ?case by (simp add: assms(1) listsum_Nil lookup_tensor0)
next
  case (Cons A As)
  then show ?case by (simp add: listsum_Cons list.set_intros listsum_dims)
qed

end