(* Title: Guessing_Many_One.thy
  Author: Andreas Lochbihler, ETH Zurich
  Author: S. Reza Sefidgar, ETH Zurich *)

subsection \<open>Reducing games with many adversary guesses to games with single guesses\<close>

theory Guessing_Many_One imports
  CryptHOL.Computational_Model
  CryptHOL.GPV_Bisim
begin

locale guessing_many_one =
  fixes init :: "('c_o \<times> 'c_a \<times> 's) spmf"
  and "oracle" :: "'c_o \<Rightarrow> 's \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's) spmf"
  and "eval" :: "'c_o \<Rightarrow> 'c_a \<Rightarrow> 's \<Rightarrow> 'guess \<Rightarrow> bool spmf"
begin

type_synonym ('c_a', 'guess', 'call', 'ret') adversary_single = "'c_a' \<Rightarrow> ('guess', 'call', 'ret') gpv"

definition game_single :: "('c_a, 'guess, 'call, 'ret) adversary_single \<Rightarrow> bool spmf"
where
  "game_single \<A> = do {
    (c_o, c_a, s) \<leftarrow> init;
    (guess, s') \<leftarrow> exec_gpv (oracle c_o) (\<A> c_a) s;
    eval c_o c_a s' guess
  }"

definition advantage_single :: "('c_a, 'guess, 'call, 'ret) adversary_single \<Rightarrow> real"
where "advantage_single \<A> = spmf (game_single \<A>) True"

type_synonym ('c_a', 'guess', 'call', 'ret') adversary_many = "'c_a' \<Rightarrow> (unit, 'call' + 'guess', 'ret' + unit) gpv"

definition eval_oracle :: "'c_o \<Rightarrow> 'c_a \<Rightarrow> bool \<times> 's \<Rightarrow> 'guess \<Rightarrow> (unit \<times> (bool \<times> 's)) spmf"
where
  "eval_oracle c_o c_a = (\<lambda>(b, s') guess. map_spmf (\<lambda>b'. ((), (b \<or> b', s'))) (eval c_o c_a s' guess))"

definition game_multi :: "('c_a, 'guess, 'call, 'ret) adversary_many \<Rightarrow> bool spmf"
where
  "game_multi \<A> = do {
     (c_o, c_a, s) \<leftarrow> init;
     (_, (b, _)) \<leftarrow> exec_gpv
       (\<dagger>(oracle c_o) \<oplus>\<^sub>O eval_oracle c_o c_a)
       (\<A> c_a)
       (False, s);
     return_spmf b
  }"

definition advantage_multi :: "('c_a, 'guess, 'call, 'ret) adversary_many \<Rightarrow> real"
where "advantage_multi \<A> = spmf (game_multi \<A>) True"

type_synonym 'guess' reduction_state = "'guess' + nat"

primrec process_call :: "'guess reduction_state \<Rightarrow> 'call \<Rightarrow> ('ret option \<times> 'guess reduction_state, 'call, 'ret) gpv"
where
  "process_call (Inr j) x = do {
    ret \<leftarrow> Pause x Done;
    Done (Some ret, Inr j)
  }"
| "process_call (Inl guess) x = Done (None, Inl guess)"

primrec process_guess :: "'guess reduction_state \<Rightarrow> 'guess \<Rightarrow> (unit option \<times> 'guess reduction_state, 'call, 'ret) gpv"
where
  "process_guess (Inr j) guess = Done (if j > 0 then (Some (), Inr (j - 1)) else (None, Inl guess))"
| "process_guess (Inl guess) _ = Done (None, Inl guess)"

abbreviation reduction_oracle :: "'guess + nat \<Rightarrow> 'call + 'guess \<Rightarrow> (('ret + unit) option \<times> ('guess + nat), 'call, 'ret) gpv"
where "reduction_oracle \<equiv> plus_intercept_stop process_call process_guess"

definition reduction :: "nat \<Rightarrow> ('c_a, 'guess, 'call, 'ret) adversary_many \<Rightarrow> ('c_a, 'guess, 'call, 'ret) adversary_single"
where
  "reduction q \<A> c_a = do {
    j_star \<leftarrow> lift_spmf (spmf_of_set {..<q});
    (_, s) \<leftarrow> inline_stop reduction_oracle (\<A> c_a) (Inr j_star);
    Done (projl s)
  }"

lemma many_single_reduction:
  assumes bound: "\<And>c_a c_o s. (c_o, c_a, s) \<in> set_spmf init \<Longrightarrow> interaction_bounded_by (Not \<circ> isl) (\<A> c_a) q"
  and lossless_oracle: "\<And>c_a c_o s s' x. (c_o, c_a, s) \<in> set_spmf init \<Longrightarrow> lossless_spmf (oracle c_o s' x)"
  and lossless_eval: "\<And>c_a c_o s s' guess. (c_o, c_a, s) \<in> set_spmf init \<Longrightarrow> lossless_spmf (eval c_o c_a s' guess)"
  shows "advantage_multi \<A> \<le> advantage_single (reduction q \<A>) * q"
  including lifting_syntax
proof -
  define eval_oracle'
    where "eval_oracle' = (\<lambda>c_o c_a ((id, occ :: nat option), s') guess.
    map_spmf (\<lambda>b'. case occ of Some j\<^sub>0 \<Rightarrow> ((), (Suc id, Some j\<^sub>0), s')
                                | None \<Rightarrow> ((), (Suc id, (if b' then Some id else None)), s'))
      (eval c_o c_a s' guess))"
  let ?multi'_body = "\<lambda>c_o c_a s. exec_gpv (\<dagger>(oracle c_o) \<oplus>\<^sub>O eval_oracle' c_o c_a) (\<A> c_a) ((0, None), s)"
  define game_multi' where "game_multi' = (\<lambda>c_o c_a s. do {
    (_, ((id, j\<^sub>0), s' :: 's)) \<leftarrow> ?multi'_body c_o c_a s;
    return_spmf (j\<^sub>0 \<noteq> None) })"

  define initialize :: "('c_o \<Rightarrow> 'c_a \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> bool spmf) \<Rightarrow> bool spmf" where
    "initialize body = do {
      (c_o, c_a, s) \<leftarrow> init;
      j\<^sub>s \<leftarrow> spmf_of_set {..<q};
      body c_o c_a s j\<^sub>s }" for body
  define body2 where "body2 c_o c_a s j\<^sub>s = do {
    (_, (id, j\<^sub>0), s') \<leftarrow> ?multi'_body c_o c_a s;
    return_spmf (j\<^sub>0 = Some j\<^sub>s) }" for c_o c_a s j\<^sub>s
  let ?game2 = "initialize body2"

  define stop_oracle where "stop_oracle = (\<lambda>c_o.
     (\<lambda>(idgs, s) x. case idgs of Inr _ \<Rightarrow> map_spmf (\<lambda>(y, s). (Some y, (idgs, s))) (oracle c_o s x) | Inl _ \<Rightarrow> return_spmf (None, (idgs, s)))
     \<oplus>\<^sub>O\<^sup>S
     (\<lambda>(idgs, s) guess :: 'guess. return_spmf (case idgs of Inr 0 \<Rightarrow> (None, Inl (guess, s), s) | Inr (Suc i) \<Rightarrow> (Some (), Inr i, s) | Inl _ \<Rightarrow> (None, idgs, s))))"
  define body3 where "body3 c_o c_a s j\<^sub>s = do {
    (_ :: unit option, idgs, _) \<leftarrow> exec_gpv_stop (stop_oracle c_o) (\<A> c_a) (Inr j\<^sub>s, s);
    (b' :: bool) \<leftarrow> case idgs of Inr _ \<Rightarrow> return_spmf False | Inl (g, s') \<Rightarrow> eval c_o c_a s' g;
    return_spmf b' }" for c_o c_a s j\<^sub>s
  let ?game3 = "initialize body3"

  { define S :: "bool \<Rightarrow> nat \<times> nat option \<Rightarrow> bool" where "S \<equiv> \<lambda>b' (id, occ). b' \<longleftrightarrow> (\<exists>j\<^sub>0. occ = Some j\<^sub>0)"
    let ?S = "rel_prod S (=)"

    define initial :: "nat \<times> nat option" where "initial = (0, None)"
    define result :: "nat \<times> nat option \<Rightarrow> bool" where "result p = (snd p \<noteq> None)" for p
    have [transfer_rule]: "(S ===> (=)) (\<lambda>b. b) result" by(simp add: rel_fun_def result_def S_def)
    have [transfer_rule]: "S False initial" by (simp add: S_def initial_def)

    have eval_oracle'[transfer_rule]:
      "((=) ===> (=) ===> ?S ===> (=) ===> rel_spmf (rel_prod (=) ?S))
       eval_oracle eval_oracle'"
      unfolding eval_oracle_def[abs_def] eval_oracle'_def[abs_def]
      by (auto simp add: rel_fun_def S_def map_spmf_conv_bind_spmf intro!: rel_spmf_bind_reflI split: option.split)

    have game_multi': "game_multi \<A> = bind_spmf init (\<lambda>(c_o, c_a, s). game_multi' c_o c_a s)"
      unfolding game_multi_def game_multi'_def initial_def[symmetric]
      by (rewrite in "case_prod \<hole>" in "bind_spmf _ (case_prod \<hole>)" in "_ = bind_spmf _ \<hole>" split_def)
         (fold result_def; transfer_prover) }
  moreover
  have "spmf (game_multi' c_o c_a s) True = spmf (bind_spmf (spmf_of_set {..<q}) (body2 c_o c_a s)) True * q"
    if "(c_o, c_a, s) \<in> set_spmf init" for c_o c_a s
  proof -
    have bnd: "interaction_bounded_by (Not \<circ> isl) (\<A> c_a) q" using bound that by blast

    have bound_occ: "j\<^sub>s < q" if that: "((), (id, Some j\<^sub>s), s') \<in> set_spmf (?multi'_body c_o c_a s)"
      for s' id j\<^sub>s
    proof -
      have "id \<le> q"
        by(rule oi_True.interaction_bounded_by'_exec_gpv_count[OF bnd that, where count="fst \<circ> fst", simplified])
          (auto simp add: eval_oracle'_def split: plus_oracle_split_asm option.split_asm)
      moreover let ?I = "\<lambda>((id, occ), s'). case occ of None \<Rightarrow> True | Some j\<^sub>s \<Rightarrow> j\<^sub>s < id"
      have "callee_invariant (\<dagger>(oracle c_o) \<oplus>\<^sub>O eval_oracle' c_o c_a) ?I"
        by(clarsimp simp add: split_def intro!: conjI[OF callee_invariant_extend_state_oracle_const'])
          (unfold_locales; auto simp add: eval_oracle'_def split: option.split_asm)
      from callee_invariant_on.exec_gpv_invariant[OF this that] have "j\<^sub>s < id" by simp
      ultimately show ?thesis by simp
    qed

    let ?M = "measure (measure_spmf (?multi'_body c_o c_a s))"
    have "spmf (game_multi' c_o c_a s) True = ?M {(u, (id, j\<^sub>0), s'). j\<^sub>0 \<noteq> None}"
      by(auto simp add: game_multi'_def map_spmf_conv_bind_spmf[symmetric] split_def spmf_conv_measure_spmf measure_map_spmf vimage_def)
    also have "{(u, (id, j\<^sub>0), s'). j\<^sub>0 \<noteq> None} =
      {((), (id, Some j\<^sub>s), s') |j\<^sub>s s' id. j\<^sub>s < q} \<union> {((), (id, Some j\<^sub>s), s') |j\<^sub>s s' id. j\<^sub>s \<ge> q}"
      (is "_ = ?A \<union> _") by auto
    also have "?M \<dots> = ?M ?A"
      by (rule measure_spmf.measure_zero_union)(auto simp add: measure_spmf_zero_iff dest: bound_occ)
    also have "\<dots> = measure (measure_spmf (pair_spmf (spmf_of_set {..< q}) (?multi'_body c_o c_a s)))
         {(j\<^sub>s, (), (id, j\<^sub>0), s') |j\<^sub>s j\<^sub>0 s' id. j\<^sub>0 = Some j\<^sub>s } * q"
      (is "_ = measure ?M' ?B * _")
    proof -
      have "?B = {(j\<^sub>s, (), (id, j\<^sub>0), s') |j\<^sub>s j\<^sub>0 s' id. j\<^sub>0 = Some j\<^sub>s \<and> j\<^sub>s < q} \<union>
        {(j\<^sub>s, (), (id, j\<^sub>0), s') |j\<^sub>s j\<^sub>0 s' id. j\<^sub>0 = Some j\<^sub>s \<and> j\<^sub>s \<ge> q}" (is "_ = ?Set1 \<union> ?Set2")
        by auto
      then have "measure ?M' ?B = measure ?M' (?Set1 \<union> ?Set2)" by simp
      also have "\<dots> = measure ?M' ?Set1"
        by (rule measure_spmf.measure_zero_union) (auto simp add: measure_spmf_zero_iff)
      also have "\<dots> = (\<Sum>j\<in>{0..<q}. measure ?M' ({j} \<times> {((), (id, Some j), s')|s' id. True}))"
        by(subst measure_spmf.finite_measure_finite_Union[symmetric])
          (auto intro!: arg_cong2[where f=measure] simp add: disjoint_family_on_def)
      also have "\<dots> = (\<Sum>j\<in>{0..<q}. 1 / q * measure (measure_spmf (?multi'_body c_o c_a s)) {((), (id, Some j), s')|s' id. True})"
        by(simp add: measure_pair_spmf_times spmf_conv_measure_spmf[symmetric] spmf_of_set)
      also have "\<dots> = 1 / q * measure (measure_spmf (?multi'_body c_o c_a s)) {((), (id, Some j\<^sub>s), s')|j\<^sub>s s' id. j\<^sub>s < q}"
        unfolding sum_distrib_left[symmetric]
        by(subst measure_spmf.finite_measure_finite_Union[symmetric])
          (auto intro!: arg_cong2[where f=measure] simp add: disjoint_family_on_def)
      finally show ?thesis by simp
    qed
    also have "?B = (\<lambda>(j\<^sub>s, _, (_, j\<^sub>0), _). j\<^sub>0 = Some j\<^sub>s) -` {True}"
      by (auto simp add: vimage_def)
    also have rw2: "measure ?M' \<dots> = spmf (bind_spmf (spmf_of_set {..<q}) (body2 c_o c_a s)) True"
      by (simp add: body2_def[abs_def] measure_map_spmf[symmetric] map_spmf_conv_bind_spmf
        split_def pair_spmf_alt_def spmf_conv_measure_spmf[symmetric])
    finally show ?thesis .
  qed
  hence "spmf (bind_spmf init (\<lambda>(c_a, c_o, s). game_multi' c_a c_o s)) True = spmf ?game2 True * q"
    unfolding initialize_def spmf_bind[where p=init]
    by (auto intro!: integral_cong_AE simp del: integral_mult_left_zero simp add: integral_mult_left_zero[symmetric])

  moreover
  have "ord_spmf (\<longrightarrow>) (body2 c_o c_a s j\<^sub>s) (body3 c_o c_a s j\<^sub>s)"
    if init: "(c_o, c_a, s) \<in> set_spmf init" and j\<^sub>s: "j\<^sub>s < Suc q" for c_o c_a s j\<^sub>s
  proof -
    define oracle2' where "oracle2' \<equiv> \<lambda>(b, (id, gs), s) guess. if id = j\<^sub>s then do {
        b' :: bool \<leftarrow> eval c_o c_a s guess;
        return_spmf ((), (Some b', (Suc id, Some (guess, s)), s))
      } else return_spmf ((), (b, (Suc id, gs), s))"

    let ?R = "\<lambda>((id1, j\<^sub>0), s1) (b', (id2, gs), s2). s1 = s2 \<and> id1 = id2 \<and> (j\<^sub>0 = Some j\<^sub>s \<longrightarrow> b' = Some True) \<and> (id2 \<le> j\<^sub>s \<longrightarrow> b' = None)"
    from init have "rel_spmf (rel_prod (=) ?R)
      (exec_gpv (extend_state_oracle (oracle c_o) \<oplus>\<^sub>O eval_oracle' c_o c_a) (\<A> c_a) ((0, None), s))
      (exec_gpv (extend_state_oracle (extend_state_oracle (oracle c_o)) \<oplus>\<^sub>O oracle2') (\<A> c_a) (None, (0, None), s))"
      by(intro exec_gpv_oracle_bisim[where X="?R"])(auto simp add: oracle2'_def eval_oracle'_def spmf_rel_map map_spmf_conv_bind_spmf[symmetric] rel_spmf_return_spmf2 lossless_eval o_def intro!: rel_spmf_reflI split: option.split_asm plus_oracle_split if_split_asm)
    then have "rel_spmf (\<longrightarrow>) (body2 c_o c_a s j\<^sub>s)
      (do {
        (_, b', _, _) \<leftarrow> exec_gpv (\<dagger>\<dagger>(oracle c_o) \<oplus>\<^sub>O oracle2') (\<A> c_a) (None, (0, None), s);
        return_spmf (b' = Some True) })"
      (is "rel_spmf _ _ ?body2'")
      \<comment> \<open>We do not get equality here because the right hand side may return @{const True} even
        when the bad event has happened before the @{text j\<^sub>s}-th iteration.\<close>
      unfolding body2_def by(rule rel_spmf_bindI) clarsimp
    also
    let ?guess_oracle = "\<lambda>((id, gs), s) guess. return_spmf ((), (Suc id, if id = j\<^sub>s then Some (guess, s) else gs), s)"
    let ?I = "\<lambda>(idgs, s). case idgs of (_, None) \<Rightarrow> False | (i, Some _) \<Rightarrow> j\<^sub>s < i"
    interpret I: callee_invariant_on "\<dagger>(oracle c_o) \<oplus>\<^sub>O ?guess_oracle" "?I" \<I>_full
      by(simp)(unfold_locales; auto split: option.split)

    let ?f = "\<lambda>s. case snd (fst s) of None \<Rightarrow> return_spmf False | Some a \<Rightarrow> eval c_o c_a (snd a) (fst a)"
    let ?X = "\<lambda>j\<^sub>s (b1, (id1, gs1), s1) (b2, (id2, gs2), s2). b1 = b2 \<and> id1 = id2 \<and> gs1 = gs2 \<and> s1 = s2 \<and> (b2 = None \<longleftrightarrow> gs2 = None) \<and> (id2 \<le> j\<^sub>s \<longrightarrow> b2 = None)"
    have "?body2' = do {
      (a, r, s) \<leftarrow> exec_gpv (\<lambda>(r, s) x. do {
               (y, s') \<leftarrow> (\<dagger>(oracle c_o) \<oplus>\<^sub>O ?guess_oracle) s x;
               if ?I s' \<and> r = None then map_spmf (\<lambda>r. (y, Some r, s')) (?f s') else return_spmf (y, r, s')
             })
         (\<A> c_a) (None, (0, None), s);
      case r of None \<Rightarrow> ?f s \<bind> return_spmf | Some r' \<Rightarrow> return_spmf r' }"
      unfolding oracle2'_def spmf_rel_eq[symmetric]
      by(rule rel_spmf_bindI[OF exec_gpv_oracle_bisim'[where X="?X j\<^sub>s"]])
        (auto simp add: bind_map_spmf o_def spmf.map_comp split_beta conj_comms map_spmf_conv_bind_spmf[symmetric] spmf_rel_map rel_spmf_reflI cong: conj_cong split: plus_oracle_split)
    also have "\<dots> = do {
        us' \<leftarrow> exec_gpv (\<dagger>(oracle c_o) \<oplus>\<^sub>O ?guess_oracle) (\<A> c_a) ((0, None), s);
        (b' :: bool) \<leftarrow> ?f (snd us');
        return_spmf b' }"
      (is "_ = ?body2''")
      by(rule I.exec_gpv_bind_materialize[symmetric])(auto split: plus_oracle_split_asm option.split_asm)
    also have "\<dots> = do {
        us' \<leftarrow> exec_gpv_stop (lift_stop_oracle (\<dagger>(oracle c_o) \<oplus>\<^sub>O ?guess_oracle)) (\<A> c_a) ((0, None), s);
        (b' :: bool) \<leftarrow> ?f (snd us');
        return_spmf b' }"
      supply lift_stop_oracle_transfer[transfer_rule] gpv_stop_transfer[transfer_rule] exec_gpv_parametric'[transfer_rule]
      by transfer simp
    also let ?S = "\<lambda>((id1, gs1), s1) ((id2, gs2), s2). gs1 = gs2 \<and> (gs2 = None \<longrightarrow> s1 = s2 \<and> id1 = id2) \<and> (gs1 = None \<longleftrightarrow> id1 \<le> j\<^sub>s)"
    have "ord_spmf (\<longrightarrow>) \<dots> (exec_gpv_stop ((\<lambda>((id, gs), s) x. case gs of None \<Rightarrow> lift_stop_oracle (\<dagger>(oracle c_o)) ((id, gs), s) x | Some _ \<Rightarrow> return_spmf (None, ((id, gs), s))) \<oplus>\<^sub>O\<^sup>S
            (\<lambda>((id, gs), s) guess. return_spmf (if id \<ge> j\<^sub>s then None else Some (), (Suc id, if id = j\<^sub>s then Some (guess, s) else gs), s)))
           (\<A> c_a) ((0, None), s) \<bind>
          (\<lambda>us'. case snd (fst (snd us')) of None \<Rightarrow> return_spmf False | Some a \<Rightarrow> eval c_o c_a (snd a) (fst a)))"
      unfolding body3_def stop_oracle_def
      by(rule ord_spmf_exec_gpv_stop[where stop = "\<lambda>((id, guess), _). guess \<noteq> None" and S="?S", THEN ord_spmf_bindI])
        (auto split: prod.split_asm plus_oracle_split_asm split!: plus_oracle_stop_split simp del: not_None_eq simp add: spmf.map_comp o_def apfst_compose ord_spmf_map_spmf1 ord_spmf_map_spmf2 split_beta ord_spmf_return_spmf2 intro!: ord_spmf_reflI)
    also let ?X = "\<lambda>((id, gs), s1) (idgs, s2). s1 = s2 \<and> (case (gs, idgs) of (None, Inr id') \<Rightarrow> id' = j\<^sub>s - id \<and> id \<le> j\<^sub>s | (Some gs, Inl gs') \<Rightarrow> gs = gs' \<and> id > j\<^sub>s | _ \<Rightarrow> False)"
    have "\<dots> = body3 c_o c_a s j\<^sub>s" unfolding body3_def spmf_rel_eq[symmetric] stop_oracle_def
      by(rule exec_gpv_oracle_bisim'[where X="?X", THEN rel_spmf_bindI])
        (auto split: option.split_asm plus_oracle_stop_split nat.splits split!: sum.split simp add: spmf_rel_map intro!: rel_spmf_reflI)
    finally show ?thesis by(rule pmf.rel_mono_strong)(auto elim!: option.rel_cases ord_option.cases)
  qed
  { then have "ord_spmf (\<longrightarrow>) ?game2 ?game3"
      by(clarsimp simp add: initialize_def intro!: ord_spmf_bind_reflI)
    also
    let ?X = "\<lambda>(gsid, s) (gid, s'). s = s' \<and> rel_sum (\<lambda>(g, s1) g'. g = g' \<and> s1 = s') (=) gsid gid"
    have "rel_spmf (\<longrightarrow>) ?game3 (game_single (reduction q \<A>))"
      unfolding body3_def stop_oracle_def game_single_def reduction_def split_def initialize_def
      apply(clarsimp simp add: bind_map_spmf exec_gpv_bind exec_gpv_inline intro!: rel_spmf_bind_reflI)
      apply(rule rel_spmf_bindI[OF exec_gpv_oracle_bisim'[where X="?X"]])
      apply(auto split: plus_oracle_stop_split elim!: rel_sum.cases simp add: map_spmf_conv_bind_spmf[symmetric] split_def spmf_rel_map rel_spmf_reflI rel_spmf_return_spmf1 lossless_eval split: nat.split)
      done
    finally have "ord_spmf (\<longrightarrow>) ?game2 (game_single (reduction q \<A>))"
      by(rule pmf.rel_mono_strong)(auto elim!: option.rel_cases ord_option.cases)
    from this[THEN ord_spmf_measureD, of "{True}"]
    have "spmf ?game2 True \<le> spmf (game_single (reduction q \<A>)) True" unfolding spmf_conv_measure_spmf
      by(rule ord_le_eq_trans)(auto intro: arg_cong2[where f=measure]) }
  ultimately show ?thesis unfolding advantage_multi_def advantage_single_def
    by(simp add: mult_right_mono)
qed

end

end


theory State_Monad_EX
imports
  Main
  "State_Monad_HL"
begin

record S1 =
  x_S1:: int
  y_S1:: int
  z_S1:: int

(* update functions *)

definition x_S1u:: "S1 \<Rightarrow> int \<Rightarrow> S1" where "x_S1u s v = s \<lparr> x_S1 := v \<rparr>"
definition y_S1u:: "S1 \<Rightarrow> int \<Rightarrow> S1" where "y_S1u s v = s \<lparr> y_S1 := v \<rparr>"
definition z_S1u:: "S1 \<Rightarrow> int \<Rightarrow> S1" where "z_S1u s v = s \<lparr> z_S1 := v \<rparr>"

theorem put_x_rule: "spec (\<lambda>x. p () (x \<lparr> x_S1 := v \<rparr>)) (put x_S1u v) p"
  by (simp add: spec_def put_def get_state_def put_state_def x_S1u_def)

theorem put_y_rule: "spec (\<lambda>x. p () (x \<lparr> y_S1 := v \<rparr>)) (put y_S1u v) p"
  by (simp add: spec_def put_def get_state_def put_state_def y_S1u_def)

theorem put_z_rule: "spec (\<lambda>x. p () (x \<lparr> z_S1 := v \<rparr>)) (put z_S1u v) p"
  by (simp add: spec_def put_def get_state_def put_state_def z_S1u_def)

(* simple programs *)

definition setx0:: "(S1, unit) state" where "setx0 = put x_S1u 0"
definition sety0:: "(S1, unit) state" where "sety0 = put y_S1u 0"
definition setz0:: "(S1, unit) state" where "setz0 = put z_S1u 0"

definition p0:: "S1 \<Rightarrow> bool" where "p0 s = (x_S1 s = 0 \<and> y_S1 s = 0 \<and> z_S1 s = 0)"

definition init0:: "(S1, unit) state" where
  "init0 = do { setx0; sety0; setz0 }"

lemma "spec TT init0 (GG p0)"
  apply(simp add: init0_def)
  apply(intro seq_rule[of _ _ "\<lambda>_ s. x_S1 s = 0"])
   apply(simp add: TT_def spec_def setx0_def put_def get_state_def put_state_def x_S1u_def)
  apply (intro allI)
  apply(intro seq_rule[of _ _ "\<lambda>_ s. x_S1 s = 0 \<and> y_S1 s = 0"])
   apply(simp add: spec_def sety0_def put_def get_state_def put_state_def y_S1u_def)
  by(simp add: spec_def setz0_def put_def get_state_def put_state_def GG_def p0_def z_S1u_def)

definition let0:: "(S1, unit) state" where "let0 = do { assign y_S1u x_S1; assign z_S1u x_S1 }"

definition q0:: "S1 \<Rightarrow> bool" where "q0 s = (x_S1 s = y_S1 s \<and> x_S1 s = z_S1 s)"

definition q1:: "unit \<Rightarrow> S1 \<Rightarrow> bool" where "q1 _ s = (x_S1 s = y_S1 s)"

lemma "spec TT let0 (GG q0)"
  apply (simp add: let0_def)
  apply (intro seq_rule[of _ _ "q1"])
   apply (simp add: spec_def q1_def assign_def return_def get_def put_def get_state_def put_state_def y_S1u_def)
  by (simp add: spec_def GG_def q1_def q0_def assign_def get_def return_def put_def get_state_def put_state_def z_S1u_def)

definition ifc0:: "(S1, unit) state" where "ifc0 = do { c \<leftarrow> get x_S1; if c < 0 then assign y_S1u x_S1 else assign z_S1u x_S1 }"

definition q2:: "S1 \<Rightarrow> bool" where "q2 s = (x_S1 s = z_S1 s)"

lemma "spec (\<lambda>s. x_S1 s > 0) ifc0 (GG q2)"
  apply (simp add: ifc0_def)
  apply (intro get_rule)
  apply (intro allI)
  apply (intro cond_rule)
   apply (simp add: spec_def assign_def get_def get_state_def return_def put_def put_state_def GG_def q2_def)
  by (simp add: spec_def assign_def get_def get_state_def return_def put_def put_state_def GG_def q2_def z_S1u_def)

definition dec0:: "(S1, unit) state" where "dec0 = do { assign z_S1u x_S1; assign x_S1u (\<lambda>x. x_S1 x - 1) }"

definition p3:: "int \<Rightarrow> S1 \<Rightarrow> bool" where "p3 N s = (x_S1 s = N)"
definition q3:: "int \<Rightarrow> S1 \<Rightarrow> bool" where "q3 N s = (x_S1 s < N \<and> z_S1 s = N)"

lemma "spec (p3 N) dec0 (GG (q3 N))"
  apply (simp add: dec0_def)
  apply(intro seq_rule[of _ _ "\<lambda>_ s. x_S1 s = N \<and> z_S1 s = N"])
  apply (simp add: spec_def assign_def put_def get_def get_state_def put_state_def return_def z_S1u_def p3_def)
  by (simp add: spec_def assign_def put_def get_def get_state_def put_state_def return_def x_S1u_def GG_def q3_def)
end


section "Implementing Labelled Transition Systems using a deterministic and a nondeterministic
  datastructure and choosing the right one automatically"
theory LTSByLTS_DLTS
imports LTSSpec LTSGA
begin

datatype ('a, 'b) LTS_choice = LTS 'a | DLTS 'b

find_consts name: LTS_choice

locale ltsbc_defs =
  l: lts l_\<alpha> l_invar +
  d: dlts d_\<alpha> d_invar
  for l_\<alpha> l_invar d_\<alpha> d_invar +
  constrains l_\<alpha> :: "'lts \<Rightarrow> ('Q \<times> 'A \<times> 'Q) set" and
             d_\<alpha> :: "'dlts \<Rightarrow> ('Q \<times> 'A \<times> 'Q) set"
begin

  definition ltsbc_\<alpha> :: "('Q,'A,('lts,'dlts) LTS_choice) lts_\<alpha>" where
     "ltsbc_\<alpha> =  case_LTS_choice l_\<alpha> d_\<alpha>"

  definition ltsbc_invar where
     "ltsbc_invar =  case_LTS_choice l_invar d_invar"

  definition (in -) ltsbc_emp_lts where
    "ltsbc_emp_lts l_emp = (\<lambda>_::unit. LTS (l_emp ()))"

  definition (in -) ltsbc_emp_dlts where
    "ltsbc_emp_dlts d_emp = (\<lambda>_::unit. DLTS (d_emp ()))"

  lemma ltsbc_empty_correct_dlts:
    "lts_empty d_\<alpha> d_invar d_emp \<Longrightarrow>
     lts_empty ltsbc_\<alpha> ltsbc_invar (ltsbc_emp_dlts d_emp)"
    unfolding lts_empty_def ltsbc_emp_dlts_def ltsbc_\<alpha>_def ltsbc_invar_def
    by simp

  lemma ltsbc_empty_correct_lts:
    "lts_empty l_\<alpha> l_invar l_emp \<Longrightarrow>
     lts_empty ltsbc_\<alpha> ltsbc_invar (ltsbc_emp_lts l_emp)"
    unfolding lts_empty_def ltsbc_emp_lts_def ltsbc_\<alpha>_def ltsbc_invar_def
    by simp

  lemma ltsbc_memb_correct:
    "lts_memb l_\<alpha> l_invar l_memb \<Longrightarrow>
     lts_memb d_\<alpha> d_invar d_memb \<Longrightarrow>
     lts_memb ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_memb d_memb)"
  unfolding lts_memb_def ltsbc_invar_def ltsbc_\<alpha>_def
  by (simp add: image_iff Bex_def split: LTS_choice.split)

  primrec (in -) ltsbc_add where
    "ltsbc_add l_add d_add d_succ copy (q::'Q) (a::'A) (q'::'Q) (LTS (l::'lts)) = LTS ((l_add q a q' l)::'lts)"
  | "ltsbc_add l_add d_add d_succ copy q a q' (DLTS d) =
     (case d_succ d q a of None \<Rightarrow> DLTS (d_add q a q' d)
                         | Some q'' \<Rightarrow> (if q'' = q' then DLTS d else
       LTS (l_add q a q' (copy (d::'dlts)))))"

  lemma ltsbc_add_correct:
    assumes l_add_OK: "lts_add l_\<alpha> l_invar l_add"
        and d_add_OK: "dlts_add d_\<alpha> d_invar d_add"
        and d_succ_OK: "dlts_succ d_\<alpha> d_invar d_succ"
        and copy_OK: "lts_copy d_\<alpha> d_invar l_\<alpha> l_invar copy"
    shows "lts_add ltsbc_\<alpha> ltsbc_invar (ltsbc_add l_add d_add d_succ copy)"
  proof (intro lts_add.intro)
    fix dl q a q'

    assume invar_dl: "ltsbc_invar dl"
    have "ltsbc_invar (ltsbc_add l_add d_add d_succ copy q a q' dl) \<and>
          ltsbc_\<alpha> (ltsbc_add l_add d_add d_succ copy q a q' dl) = insert (q, a, q') (ltsbc_\<alpha> dl)"
    proof (cases dl)
      case (LTS l)
      with lts_add.lts_add_correct[OF l_add_OK, of l q a q'] invar_dl
      show ?thesis by (simp add: ltsbc_\<alpha>_def ltsbc_invar_def)
    next
      case (DLTS d) note dl_eq[simp] = this

      from invar_dl have invar_d: "d_invar d" unfolding ltsbc_invar_def by simp

      note succ_eq = dlts_succ.dlts_succ_correct[OF d_succ_OK, OF invar_d, of q a]
      note d_add_props = dlts_add.dlts_add_correct[OF d_add_OK, OF invar_d, of q' q a]

      show ?thesis
      proof (cases "d_succ d q a")
        case None with d_add_props succ_eq show ?thesis
          by (simp add: ltsbc_invar_def ltsbc_\<alpha>_def)
      next
        case (Some q'') note succ_eq_q'' = this
        have in_D: "(q, a, q'') \<in> d_\<alpha> d" using succ_eq succ_eq_q'' by metis

        show ?thesis
        proof (cases "q'' = q'")
          case True with in_D show ?thesis
            by (auto simp add: invar_d ltsbc_invar_def ltsbc_\<alpha>_def succ_eq_q'' )
        next
          case False note q''_neq = this

          from lts_copy.copy_correct[OF copy_OK, OF invar_d]
               lts_add.lts_add_correct[OF l_add_OK, of "copy d" q a q']
          show ?thesis
            by (simp add: invar_d ltsbc_invar_def succ_eq_q'' ltsbc_\<alpha>_def q''_neq)
        qed
      qed
    qed
    thus "ltsbc_invar (ltsbc_add l_add d_add d_succ copy q a q' dl)"
         "ltsbc_\<alpha> (ltsbc_add l_add d_add d_succ copy q a q' dl) = insert (q, a, q') (ltsbc_\<alpha> dl)"
      by simp_all
  qed

  primrec (in -) ltsbc_add_simple :: "_ \<Rightarrow> _ \<Rightarrow> 'Q \<Rightarrow> 'A \<Rightarrow> 'Q \<Rightarrow> ('lts, 'dlts) LTS_choice \<Rightarrow> ('lts, 'dlts) LTS_choice" where
    "ltsbc_add_simple l_add copy q a q' (LTS l) = LTS ((l_add q a q' l))"
  | "ltsbc_add_simple l_add copy q a q' (DLTS d) = LTS (l_add q a q' (copy d))"

  lemma ltsbc_add_correct_simple:
    assumes l_add_OK: "lts_add l_\<alpha> l_invar l_add"
        and copy_OK: "lts_copy d_\<alpha> d_invar l_\<alpha> l_invar copy"
    shows "lts_add ltsbc_\<alpha> ltsbc_invar (ltsbc_add_simple l_add copy)"
  proof (intro lts_add.intro)
    fix dl q a q'

    assume invar_dl: "ltsbc_invar dl"
    have "ltsbc_invar (ltsbc_add_simple l_add copy q a q' dl) \<and>
          ltsbc_\<alpha> (ltsbc_add_simple l_add copy q a q' dl) = insert (q, a, q') (ltsbc_\<alpha> dl)"
    proof (cases dl)
      case (LTS l)
      with lts_add.lts_add_correct[OF l_add_OK, of l q a q'] invar_dl
      show ?thesis by (simp add: ltsbc_\<alpha>_def ltsbc_invar_def)
    next
      case (DLTS d)
      with lts_add.lts_add_correct[OF l_add_OK, of "copy d" q a q'] invar_dl
           lts_copy.copy_correct[OF copy_OK, of d]
      show ?thesis
        by (simp add: ltsbc_\<alpha>_def ltsbc_invar_def)
    qed
    thus "ltsbc_invar (ltsbc_add_simple l_add copy q a q' dl)"
         "ltsbc_\<alpha> (ltsbc_add_simple l_add copy q a q' dl) = insert (q, a, q') (ltsbc_\<alpha> dl)"
      by simp_all
  qed

  primrec (in -) ltsbc_add_succs :: "_ \<Rightarrow> _ \<Rightarrow> 'Q \<Rightarrow> 'A \<Rightarrow> 'Q list \<Rightarrow> ('lts, 'dlts) LTS_choice \<Rightarrow> ('lts, 'dlts) LTS_choice" where
    "ltsbc_add_succs l_add_succs copy q a qs (LTS l) = LTS ((l_add_succs q a qs l))"
  | "ltsbc_add_succs l_add_succs copy q a qs (DLTS d) = LTS (l_add_succs q a qs (copy d))"

  lemma ltsbc_add_succs_correct:
    assumes l_add_OK: "lts_add_succs l_\<alpha> l_invar l_add_succs"
        and copy_OK: "lts_copy d_\<alpha> d_invar l_\<alpha> l_invar copy"
    shows "lts_add_succs ltsbc_\<alpha> ltsbc_invar (ltsbc_add_succs l_add_succs copy)"
  proof (intro lts_add_succs.intro)
    fix dl q a qs

    assume invar_dl: "ltsbc_invar dl"
    have "ltsbc_invar (ltsbc_add_succs l_add_succs copy q a qs dl) \<and>
          ltsbc_\<alpha> (ltsbc_add_succs l_add_succs copy q a qs dl) =
               ltsbc_\<alpha> dl \<union> {(q, a, q') |q'. q' \<in> set qs}"
    proof (cases dl)
      case (LTS l)
      with lts_add_succs.lts_add_succs_correct[OF l_add_OK, of l q a qs] invar_dl
      show ?thesis by (simp add: ltsbc_\<alpha>_def ltsbc_invar_def)
    next
      case (DLTS d)
      with lts_add_succs.lts_add_succs_correct[OF l_add_OK, of "copy d" q a qs] invar_dl
           lts_copy.copy_correct[OF copy_OK, of d]
      show ?thesis
        by (simp add: ltsbc_\<alpha>_def ltsbc_invar_def)
    qed
    thus "ltsbc_invar (ltsbc_add_succs l_add_succs copy q a qs dl)"
         "ltsbc_\<alpha> (ltsbc_add_succs l_add_succs copy q a qs dl) =
               ltsbc_\<alpha> dl \<union> {(q, a, q') |q'. q' \<in> set qs}"
      by simp_all
  qed

  primrec (in -) dltsbc_add where
    "dltsbc_add l_add d_add (q::'Q) (a::'A) (q'::'Q) (LTS (l::'lts)) = LTS ((l_add q a q' l)::'lts)"
  | "dltsbc_add l_add d_add q a q' (DLTS (d::'dlts)) = DLTS ((d_add q a q' d)::'dlts)"

  lemma dltsbc_add_correct:
    assumes l_add_OK: "dlts_add l_\<alpha> l_invar l_add"
        and d_add_OK: "dlts_add d_\<alpha> d_invar d_add"
    shows "dlts_add ltsbc_\<alpha> ltsbc_invar (dltsbc_add l_add d_add)"
  using assms
  unfolding dlts_add_def ltsbc_\<alpha>_def ltsbc_invar_def dltsbc_add_def
  by (simp split: LTS_choice.split)

  primrec (in -) ltsbc_delete where
     "ltsbc_delete l_del d_del (q::'Q) (a::'A) (q'::'Q) (LTS (l::'lts)) = LTS ((l_del q a q' l)::'lts)"
   | "ltsbc_delete l_del d_del q a q' (DLTS (d::'dlts)) = DLTS ((d_del q a q' d)::'dlts)"

  lemma ltsbc_delete_correct:
    "lts_delete l_\<alpha> l_invar l_del \<Longrightarrow>
     lts_delete d_\<alpha> d_invar d_del \<Longrightarrow>
     lts_delete ltsbc_\<alpha> ltsbc_invar (ltsbc_delete l_del d_del)"
    unfolding lts_delete_def ltsbc_delete_def ltsbc_\<alpha>_def ltsbc_invar_def
    by (simp split: LTS_choice.split)

  lemma ltsbc_succ_it_correct :
    assumes "lts_succ_it l_\<alpha> l_invar l_it"
        and "lts_succ_it d_\<alpha> d_invar d_it"
    shows "lts_succ_it ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_it d_it)"
  using assms
  unfolding lts_succ_it_def ltsbc_invar_def ltsbc_\<alpha>_def
  by (simp split: LTS_choice.split)

  lemma ltsbc_succ_label_it_correct :
    assumes "lts_succ_label_it l_\<alpha> l_invar l_it"
    assumes "lts_succ_label_it d_\<alpha> d_invar d_it"
    shows "lts_succ_label_it ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_it d_it)"
  using assms
  unfolding lts_succ_label_it_def ltsbc_invar_def ltsbc_\<alpha>_def
  by (simp split: LTS_choice.split)

  primrec (in -) ltsbc_filter_it :: "('Q,'A,'\<sigma>,'lts) lts_filter_it \<Rightarrow> ('Q,'A,'\<sigma>,'dlts) lts_filter_it \<Rightarrow>
    _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _" where
     "ltsbc_filter_it l_it d_it P_q P_a P_q' P (LTS (l::'lts)) = (l_it P_q P_a P_q' P l)"
   | "ltsbc_filter_it l_it d_it P_q P_a P_q' P (DLTS (d::'dlts)) = (d_it P_q P_a P_q' P d)"

  lemma ltsbc_filter_it_correct :
    assumes "lts_filter_it l_\<alpha> l_invar l_it"
    assumes "lts_filter_it d_\<alpha> d_invar d_it"
    shows "lts_filter_it ltsbc_\<alpha> ltsbc_invar (ltsbc_filter_it l_it d_it)"
    using assms
    unfolding lts_filter_it_def ltsbc_filter_it_def ltsbc_invar_def ltsbc_\<alpha>_def
    by (simp split: LTS_choice.split)

  lemma ltsbc_it_correct :
    assumes "lts_iterator l_\<alpha> l_invar l_it"
        and "lts_iterator d_\<alpha> d_invar d_it"
    shows "lts_iterator ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_it d_it)"
    using assms
    unfolding lts_iterator_def ltsbc_filter_it_def ltsbc_invar_def ltsbc_\<alpha>_def
    by (simp split: LTS_choice.split)

  lemma ltsbc_pre_it_correct :
    assumes "lts_pre_it l_\<alpha> l_invar l_it"
        and "lts_pre_it d_\<alpha> d_invar d_it"
    shows "lts_pre_it ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_it d_it)"
  using assms
  unfolding lts_pre_it_def ltsbc_invar_def ltsbc_\<alpha>_def
  by (simp split: LTS_choice.split)

  lemma ltsbc_pre_label_it_correct :
    assumes "lts_pre_label_it l_\<alpha> l_invar l_it"
    assumes "lts_pre_label_it d_\<alpha> d_invar d_it"
    shows "lts_pre_label_it ltsbc_\<alpha> ltsbc_invar (case_LTS_choice l_it d_it)"
  using assms
  unfolding lts_pre_label_it_def ltsbc_invar_def ltsbc_\<alpha>_def
  by (simp split: LTS_choice.split)
end

end


(*  Title:      HOL/Quotient_Examples/Int_Pow.thy
    Author:     Ondrej Kuncar
    Author:     Lars Noschinski
*)

theory Int_Pow
imports Main "HOL-Algebra.Group"
begin

(*
  This file demonstrates how to restore Lifting/Transfer enviromenent.

  We want to define int_pow (a power with an integer exponent) by directly accessing
  the representation type "nat * nat" that was used to define integers.
*)

context monoid
begin

(* first some additional lemmas that are missing in monoid *)

lemma Units_nat_pow_Units [intro, simp]:
  "a \<in> Units G \<Longrightarrow> a [^] (c :: nat) \<in> Units G" by (induct c) auto

lemma Units_r_cancel [simp]:
  "[| z \<in> Units G; x \<in> carrier G; y \<in> carrier G |] ==>
   (x \<otimes> z = y \<otimes> z) = (x = y)"
proof
  assume eq: "x \<otimes> z = y \<otimes> z"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then have "x \<otimes> (z \<otimes> inv z) = y \<otimes> (z \<otimes> inv z)"
    by (simp add: m_assoc[symmetric] Units_closed del: Units_r_inv)
  with G show "x = y" by simp
next
  assume eq: "x = y"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then show "x \<otimes> z = y \<otimes> z" by simp
qed

lemma inv_mult_units:
  "[| x \<in> Units G; y \<in> Units G |] ==> inv (x \<otimes> y) = inv y \<otimes> inv x"
proof -
  assume G: "x \<in> Units G"  "y \<in> Units G"
  then have "x \<in> carrier G"  "y \<in> carrier G" by auto
  with G have "inv (x \<otimes> y) \<otimes> (x \<otimes> y) = (inv y \<otimes> inv x) \<otimes> (x \<otimes> y)"
    by (simp add: m_assoc) (simp add: m_assoc [symmetric])
  with G show ?thesis by (simp del: Units_l_inv)
qed

lemma mult_same_comm:
  assumes [simp, intro]: "a \<in> Units G"
  shows "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = inv (a [^] n) \<otimes> a [^] m"
proof (cases "m\<ge>n")
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case True
    then obtain k where *:"m = k + n" and **:"m = n + k" by (metis le_iff_add add.commute)
    have "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = a [^] k"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also have "\<dots> = inv (a [^] n) \<otimes> a [^] m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric])
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case False
    then obtain k where *:"n = k + m" and **:"n = m + k"
      by (metis le_iff_add add.commute nat_le_linear)
    have "a [^] (m::nat) \<otimes> inv (a [^] (n::nat)) = inv(a [^] k)"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also have "\<dots> = inv (a [^] n) \<otimes> a [^] m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc inv_mult_units)
    finally show ?thesis .
qed

lemma mult_inv_same_comm:
  "a \<in> Units G \<Longrightarrow> inv (a [^] (m::nat)) \<otimes> inv (a [^] (n::nat)) = inv (a [^] n) \<otimes> inv (a [^] m)"
by (simp add: inv_mult_units[symmetric] nat_pow_mult ac_simps Units_closed)

context
includes int.lifting (* restores Lifting/Transfer for integers *)
begin

lemma int_pow_rsp:
  assumes eq: "(b::nat) + e = d + c"
  assumes a_in_G [simp, intro]: "a \<in> Units G"
  shows "a [^] b \<otimes> inv (a [^] c) = a [^] d \<otimes> inv (a [^] e)"
proof(cases "b\<ge>c")
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case True
    then obtain n where "b = n + c" by (metis le_iff_add add.commute)
    then have "d = n + e" using eq by arith
    from \<open>b = _\<close> have "a [^] b \<otimes> inv (a [^] c) = a [^] n"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also from \<open>d = _\<close>  have "\<dots> = a [^] d \<otimes> inv (a [^] e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using \<open>a \<in> _\<close> by (rule Units_closed)
  case False
    then obtain n where "c = n + b" by (metis le_iff_add add.commute nat_le_linear)
    then have "e = n + d" using eq by arith
    from \<open>c = _\<close> have "a [^] b \<otimes> inv (a [^] c) = inv (a [^] n)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also from \<open>e = _\<close> have "\<dots> = a [^] d \<otimes> inv (a [^] e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    finally show ?thesis .
qed

(*
  This definition is more convinient than the definition in HOL/Algebra/Group because
  it doesn't contain a test z < 0 when a [^] z is being defined.
*)

lift_definition int_pow :: "('a, 'm) monoid_scheme \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> 'a" is
  "\<lambda>G a (n1, n2). if a \<in> Units G \<and> monoid G then (a [^]\<^bsub>G\<^esub> n1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> (a [^]\<^bsub>G\<^esub> n2)) else \<one>\<^bsub>G\<^esub>"
unfolding intrel_def by (auto intro: monoid.int_pow_rsp)

(*
  Thus, for example, the proof of distributivity of int_pow and addition
  doesn't require a substantial number of case distinctions.
*)

lemma int_pow_dist:
  assumes [simp]: "a \<in> Units G"
  shows "int_pow G a ((n::int) + m) = int_pow G a n \<otimes>\<^bsub>G\<^esub> int_pow G a m"
proof -
  {
    fix k l m :: nat
    have "a [^] l \<otimes> (inv (a [^] m) \<otimes> inv (a [^] k)) = (a [^] l \<otimes> inv (a [^] k)) \<otimes> inv (a [^] m)"
      (is "?lhs = _")
      by (simp add: mult_inv_same_comm m_assoc Units_closed)
    also have "\<dots> = (inv (a [^] k) \<otimes> a [^] l) \<otimes> inv (a [^] m)"
      by (simp add: mult_same_comm)
    also have "\<dots> = inv (a [^] k) \<otimes> (a [^] l \<otimes> inv (a [^] m))" (is "_ = ?rhs")
      by (simp add: m_assoc Units_closed)
    finally have "?lhs = ?rhs" .
  }
  then show ?thesis
    by (transfer fixing: G) (auto simp add: nat_pow_mult[symmetric] inv_mult_units m_assoc Units_closed)
qed

end

lifting_update int.lifting
lifting_forget int.lifting

end

end


theory SestoftConf
imports "../Launchbury/Terms" "../Launchbury/Substitution"
begin

datatype stack_elem = Alts exp exp | Arg var | Upd var | Dummy var

instantiation stack_elem :: pt
begin
definition  "\<pi> \<bullet> x = (case x of (Alts e1 e2) \<Rightarrow> Alts (\<pi> \<bullet> e1) (\<pi> \<bullet> e2) | (Arg v) \<Rightarrow> Arg (\<pi> \<bullet> v) | (Upd v) \<Rightarrow> Upd (\<pi> \<bullet> v) | (Dummy v) \<Rightarrow> Dummy (\<pi> \<bullet> v))"
instance
  by standard (auto simp add: permute_stack_elem_def split:stack_elem.split)
end

lemma Alts_eqvt[eqvt]: "\<pi> \<bullet> (Alts e1 e2) = Alts (\<pi> \<bullet> e1) (\<pi> \<bullet> e2)"
  and Arg_eqvt[eqvt]: "\<pi> \<bullet> (Arg v) = Arg (\<pi> \<bullet> v)"
  and Upd_eqvt[eqvt]: "\<pi> \<bullet> (Upd v) = Upd (\<pi> \<bullet> v)"
  and Dummy_eqvt[eqvt]: "\<pi> \<bullet> (Dummy v) = Dummy (\<pi> \<bullet> v)"
  by (auto simp add: permute_stack_elem_def split:stack_elem.split)

lemma supp_Alts[simp]: "supp (Alts e1 e2) = supp e1 \<union> supp e2" unfolding supp_def by (auto simp add: Collect_imp_eq Collect_neg_eq)
lemma supp_Arg[simp]: "supp (Arg v) = supp v"  unfolding supp_def by auto
lemma supp_Upd[simp]: "supp (Upd v) = supp v"  unfolding supp_def by auto
lemma supp_Dummy[simp]: "supp (Dummy v) = supp v"  unfolding supp_def by auto
lemma fresh_Alts[simp]: "a \<sharp> Alts e1 e2 = (a \<sharp> e1 \<and> a \<sharp> e2)" unfolding fresh_def by auto
lemma fresh_star_Alts[simp]: "a \<sharp>* Alts e1 e2 = (a \<sharp>* e1 \<and> a \<sharp>* e2)" unfolding fresh_star_def by auto
lemma fresh_Arg[simp]: "a \<sharp> Arg v = a \<sharp> v" unfolding fresh_def by auto
lemma fresh_Upd[simp]: "a \<sharp> Upd v = a \<sharp> v" unfolding fresh_def by auto
lemma fresh_Dummy[simp]: "a \<sharp> Dummy v = a \<sharp> v" unfolding fresh_def by auto
lemma fv_Alts[simp]: "fv (Alts e1 e2) = fv e1 \<union> fv e2"  unfolding fv_def by auto
lemma fv_Arg[simp]: "fv (Arg v) = fv v"  unfolding fv_def by auto
lemma fv_Upd[simp]: "fv (Upd v) = fv v"  unfolding fv_def by auto
lemma fv_Dummy[simp]: "fv (Dummy v) = fv v"  unfolding fv_def by auto

instance stack_elem :: fs
  by standard (case_tac x, auto simp add: finite_supp)

type_synonym stack = "stack_elem list"

fun ap :: "stack \<Rightarrow> var set" where
  "ap [] = {}"
| "ap (Alts e1 e2 # S) = ap S"
| "ap (Arg x # S) = insert x (ap S)"
| "ap (Upd x # S) = ap S"
| "ap (Dummy x # S) = ap S"
fun upds :: "stack \<Rightarrow> var set" where
  "upds [] = {}"
| "upds (Alts e1 e2 # S) = upds S"
| "upds (Upd x # S) = insert x (upds S)"
| "upds (Arg x # S) = upds S"
| "upds (Dummy x # S) = upds S"
fun dummies :: "stack \<Rightarrow> var set" where
  "dummies [] = {}"
| "dummies (Alts e1 e2 # S) = dummies S"
| "dummies (Upd x # S) = dummies S"
| "dummies (Arg x # S) = dummies S"
| "dummies (Dummy x # S) = insert x (dummies S)"
fun flattn :: "stack \<Rightarrow> var list" where
  "flattn [] = []"
| "flattn (Alts e1 e2 # S) = fv_list e1 @ fv_list e2 @ flattn S"
| "flattn (Upd x # S) = x # flattn S"
| "flattn (Arg x # S) = x # flattn S"
| "flattn (Dummy x # S) = x # flattn S"
fun upds_list :: "stack \<Rightarrow> var list" where
  "upds_list [] = []"
| "upds_list (Alts e1 e2 # S) = upds_list S"
| "upds_list (Upd x # S) = x # upds_list S"
| "upds_list (Arg x # S) = upds_list S"
| "upds_list (Dummy x # S) = upds_list S"

lemma set_upds_list[simp]:
  "set (upds_list S) = upds S"
  by (induction S rule: upds_list.induct) auto

lemma ups_fv_subset: "upds S \<subseteq> fv S"
  by (induction S rule: upds.induct) auto
lemma fresh_distinct_ups: "atom ` V \<sharp>* S \<Longrightarrow> V \<inter> upds S = {}"
   by (auto dest!: fresh_distinct_fv set_mp[OF ups_fv_subset])
lemma ap_fv_subset: "ap S \<subseteq> fv S"
  by (induction S rule: upds.induct) auto
lemma dummies_fv_subset: "dummies S \<subseteq> fv S"
  by (induction S rule: dummies.induct) auto

lemma fresh_flattn[simp]: "atom (a::var) \<sharp> flattn S \<longleftrightarrow> atom a \<sharp> S"
  by (induction S rule:flattn.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_flattn[simp]: "atom ` (as:: var set) \<sharp>* flattn S \<longleftrightarrow> atom ` as \<sharp>* S"
  by (auto simp add: fresh_star_def)
lemma fresh_upds_list[simp]: "atom a \<sharp> S \<Longrightarrow> atom (a::var) \<sharp> upds_list S"
  by (induction S rule:upds_list.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_upds_list[simp]: "atom ` (as:: var set) \<sharp>* S \<Longrightarrow> atom ` (as:: var set) \<sharp>* upds_list S"
  by (auto simp add: fresh_star_def)

lemma upds_append[simp]: "upds (S@S') = upds S \<union> upds S'"
  by (induction S rule: upds.induct) auto
lemma upds_map_Dummy[simp]: "upds (map Dummy l) = {}"
  by (induction l) auto

lemma upds_list_append[simp]: "upds_list (S@S') = upds_list S @ upds_list S'"
  by (induction S rule: upds.induct) auto
lemma upds_list_map_Dummy[simp]: "upds_list (map Dummy l) = []"
  by (induction l) auto

lemma dummies_append[simp]: "dummies (S@S') = dummies S \<union> dummies S'"
  by (induction S rule: dummies.induct) auto
lemma dummies_map_Dummy[simp]: "dummies (map Dummy l) = set l"
  by (induction l) auto

lemma map_Dummy_inj[simp]: "map Dummy l = map Dummy l' \<longleftrightarrow> l = l'"
  apply (induction l arbitrary: l')
  apply (case_tac [!] l')
  apply auto
  done

type_synonym conf = "(heap \<times> exp \<times> stack)"

inductive boring_step where
  "isVal e \<Longrightarrow> boring_step (\<Gamma>, e, Upd x # S)"

fun restr_stack :: "var set \<Rightarrow> stack \<Rightarrow> stack"
  where "restr_stack V [] = []"
      | "restr_stack V (Alts e1 e2 # S) = Alts e1 e2 # restr_stack V S"
      | "restr_stack V (Arg x # S) = Arg x # restr_stack V S"
      | "restr_stack V (Upd x # S) = (if x \<in> V then Upd x # restr_stack V S else restr_stack V S)"
      | "restr_stack V (Dummy x # S) = Dummy x # restr_stack V S"

lemma restr_stack_cong:
  "(\<And> x. x \<in> upds S \<Longrightarrow> x \<in> V \<longleftrightarrow> x \<in> V') \<Longrightarrow> restr_stack V S = restr_stack V' S"
  by (induction V S rule: restr_stack.induct) auto

lemma fresh_star_restict_stack[intro]:
  "a \<sharp>* S \<Longrightarrow> a \<sharp>* restr_stack V S"
  by (induction V S rule: restr_stack.induct) (auto simp add: fresh_star_Cons)

lemma restr_stack_restr_stack[simp]:
  "restr_stack V (restr_stack V' S) = restr_stack (V \<inter> V') S"
  by (induction V S rule: restr_stack.induct) auto

lemma Upd_eq_restr_stackD:
  assumes "Upd x # S = restr_stack V S'"
  shows "x \<in> V"
  using arg_cong[where f = upds, OF assms]
  by auto
lemma Upd_eq_restr_stackD2:
  assumes "restr_stack V S' = Upd x # S"
  shows "x \<in> V"
  using arg_cong[where f = upds, OF assms]
  by auto

lemma restr_stack_noop[simp]:
  "restr_stack V S = S \<longleftrightarrow> upds S \<subseteq> V"
  by (induction V S rule: restr_stack.induct)
     (auto dest: Upd_eq_restr_stackD2)

subsubsection {* Invariants of the semantics *}

inductive invariant :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "(\<And> x y. rel x y \<Longrightarrow> I x \<Longrightarrow> I y) \<Longrightarrow> invariant rel I"

lemmas invariant.intros[case_names step]

lemma invariantE:
  "invariant rel I \<Longrightarrow> rel x y \<Longrightarrow> I x \<Longrightarrow> I y" by (auto elim: invariant.cases)

lemma invariant_starE:
  "rtranclp rel x y \<Longrightarrow> invariant rel I \<Longrightarrow>  I x \<Longrightarrow> I y"
  by (induction rule: rtranclp.induct) (auto elim: invariantE)

lemma invariant_True:
  "invariant rel (\<lambda> _. True)"
by (auto intro: invariant.intros)

lemma invariant_conj:
  "invariant rel I1 \<Longrightarrow> invariant rel I2 \<Longrightarrow> invariant rel (\<lambda> x. I1 x \<and> I2 x)"
by (auto simp add: invariant.simps)

lemma rtranclp_invariant_induct[consumes 3, case_names base step]:
  assumes "r\<^sup>*\<^sup>* a b"
  assumes "invariant r I"
  assumes "I a"
  assumes "P a"
  assumes "(\<And>y z. r\<^sup>*\<^sup>* a y \<Longrightarrow> r y z \<Longrightarrow> I y \<Longrightarrow> I z \<Longrightarrow> P y \<Longrightarrow> P z)"
  shows "P b"
proof-
  from assms(1,3)
  have "P b" and "I b"
  proof(induction)
    case base
    from `P a` show "P a".
    from `I a` show "I a".
  next
    case (step y z)
    with `I a` have "P y" and "I y" by auto

    from assms(2) `r y z` `I y`
    show "I z" by (rule invariantE)

    from `r\<^sup>*\<^sup>* a y` `r y z` `I y` `I z` `P y`
    show "P z" by (rule assms(5))
  qed
  thus "P b" by-
qed

fun closed :: "conf \<Rightarrow> bool"
  where "closed (\<Gamma>, e, S) \<longleftrightarrow> fv (\<Gamma>, e, S) \<subseteq> domA \<Gamma> \<union> upds S"

fun heap_upds_ok where "heap_upds_ok (\<Gamma>,S) \<longleftrightarrow> domA \<Gamma> \<inter> upds S = {} \<and> distinct (upds_list S)"

abbreviation heap_upds_ok_conf :: "conf \<Rightarrow> bool"
  where "heap_upds_ok_conf c \<equiv> heap_upds_ok (fst c, snd (snd c))"

lemma heap_upds_okE: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> x \<in> domA \<Gamma> \<Longrightarrow> x \<notin> upds S"
  by auto

lemma heap_upds_ok_Nil[simp]: "heap_upds_ok (\<Gamma>, [])" by auto
lemma heap_upds_ok_app1: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>,Arg x # S)" by auto
lemma heap_upds_ok_app2: "heap_upds_ok (\<Gamma>, Arg x # S) \<Longrightarrow> heap_upds_ok (\<Gamma>, S)" by auto
lemma heap_upds_ok_alts1: "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>,Alts e1 e2 # S)" by auto
lemma heap_upds_ok_alts2: "heap_upds_ok (\<Gamma>, Alts e1 e2 # S) \<Longrightarrow> heap_upds_ok (\<Gamma>, S)" by auto

lemma heap_upds_ok_append:
  assumes "domA \<Delta> \<inter> upds S = {}"
  assumes "heap_upds_ok (\<Gamma>,S)"
  shows "heap_upds_ok (\<Delta>@\<Gamma>, S)"
  using assms
  unfolding heap_upds_ok.simps
  by auto

lemma heap_upds_ok_let:
  assumes "atom ` domA \<Delta> \<sharp>* S"
  assumes "heap_upds_ok (\<Gamma>, S)"
  shows "heap_upds_ok (\<Delta> @ \<Gamma>, S)"
using assms(2) fresh_distinct_fv[OF assms(1)]
by (auto intro: heap_upds_ok_append dest: set_mp[OF ups_fv_subset])

lemma heap_upds_ok_to_stack:
  "x \<in> domA \<Gamma> \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, Upd x #S)"
  by (auto)

lemma heap_upds_ok_to_stack':
  "map_of \<Gamma> x = Some e \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, Upd x #S)"
  by (metis Domain.DomainI domA_def fst_eq_Domain heap_upds_ok_to_stack map_of_SomeD)

lemma heap_upds_ok_delete:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (delete x \<Gamma>, S)"
  by auto

lemma heap_upds_ok_restrictA:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (restrictA V \<Gamma>, S)"
  by auto

lemma heap_upds_ok_restr_stack:
  "heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok (\<Gamma>, restr_stack V S)"
  apply auto
  by (induction V S rule: restr_stack.induct) auto

lemma heap_upds_ok_reorder:
  "x \<in> domA \<Gamma> \<Longrightarrow> heap_upds_ok (\<Gamma>, S) \<Longrightarrow> heap_upds_ok ((x,e) # delete x \<Gamma>, S)"
  by (intro heap_upds_ok_to_heap heap_upds_ok_to_stack)

lemma heap_upds_ok_upd:
"heap_upds_ok (\<Gamma>, Upd x # S) \<Longrightarrow> x \<notin> domA \<Gamma> \<and> x \<notin> upds S"
  by auto

lemmas heap_upds_ok_intros[intro] =
  heap_upds_ok_to_heap heap_upds_ok_to_stack heap_upds_ok_to_stack' heap_upds_ok_reorder
  heap_upds_ok_app1 heap_upds_ok_app2 heap_upds_ok_alts1 heap_upds_ok_alts2 heap_upds_ok_delete
  heap_upds_ok_restrictA heap_upds_ok_restr_stack
  heap_upds_ok_let
lemmas heap_upds_ok.simps[simp del]

end


theory Op
  imports Main
begin

section \<open>Keys, Versions, and Operations\<close>

text \<open>Our database is conceptually modeled as a map of keys to values. We don't demand anything of
our keys, other than that they exist and have equality.\<close>

typedecl key

text \<open>We're going to define our databases in terms of versions, arguments, and return value types
which are polymorphic. One option would be to have these as type parameters in... literally every
single function, but that's going to be exhausting, and it also means we can't use typeclasses,
because typeclasses can't return things with type variables. Another option is to define a version
explicitly as, say, a list of nats, but discussions with Galois engineers suggests that this is
counterproductive: we're forcing the solver to pull in a whole bunch of theorems that it doesn't
actually need, which makes automated proof search harder.

So... another option to try here might be to do this with *locales*, which... I honestly don't
understand even 10% of. I *think* they allow us to prove a bunch of properties about structures
involving type parameters without actually defining what those type parameters *are*, and... also
making those structures sort of... an implicitly available argument to every function we define? But
that leaves other questions, like... what if I have two arguments? Are locales meant to be more...
about universal structures? The Digraph library doesn't think so, but I don't understand half of
what it's doing. :(\<close>

text \<open>It'd be nice to define our versions, arguments, and return values as polymorphic type
parameters. However, owing to what I think is a limitation in Isabelle's typeclass system, we can't.
What we CAN do is fix our versions, arguments, and retvals as lists of naturals, naturals, and lists
of naturals, respectively. We can use this representation for lists, sets, counters, and registers
easily, by defining different types of graphs. Also, we won't have to carry these type parameters on
everything.\<close>

type_synonym "version" = "nat list"
type_synonym "writeArg" = "nat"
type_synonym "writeRet" = "nat list"

text \<open>Reads and writes are different types of operations. We're going to want to distinguish
them.\<close>

datatype opType = Read | Write

text \<open>Reads and writes have different types of arguments and return values. However, it's going to
be convenient to talk about and compare their arguments and return values without caring what type
of operation we performed. We define wrapper types for arguments and return values here.\<close>

datatype arg = WriteArg "writeArg" | ReadArg
datatype ret = WriteRet "writeRet" | ReadRet "version"

text \<open>An operation acts on the state of some key, taking a preversion of an object and, using an
argument, producing a postversion and a return value. In general, we don't know exactly what the
versions and return value are; we represent these as options.\<close>

class keyed =
  fixes key :: "'a \<Rightarrow> key"

class op =
  fixes op_type      :: "'a \<Rightarrow> opType"
  fixes pre_version  :: "'a \<Rightarrow> version option"
  fixes arg          :: "'a \<Rightarrow> arg"
  fixes post_version :: "'a \<Rightarrow> version option"
  fixes ret          :: "'a \<Rightarrow> ret option"

text \<open>We now define two types of operations. Abstract operations (beginning with a) have definite
versions and values. Observed operations may not know their versions and return values. Reads take
no argument and return their current version; writes may change their versions somehow.\<close>

datatype aop =
  ARead  "key" "version" |
  AWrite "key" "version" "writeArg" "version" "writeRet"

datatype oop =
  ORead  "key" "version option" |
  OWrite "key" "version option" "writeArg" "version option" "writeRet option"

text \<open>A few accessors for when we don't want to deal with optionals...\<close>

primrec apre_version :: "aop \<Rightarrow> version" where
"apre_version (ARead k v)           = v" |
"apre_version (AWrite k v1 a v2 r)  = v1"

primrec aret :: "aop \<Rightarrow> ret" where
"aret (ARead k v)           = (ReadRet v)" |
"aret (AWrite k v1 a v2 r)  = (WriteRet r)"

primrec apost_version :: "aop \<Rightarrow> version" where
"apost_version (ARead k v)           = v" |
"apost_version (AWrite k v1 a v2 r)  = v2"

definition aversions_in_op :: "aop \<Rightarrow> version set" where
"aversions_in_op op \<equiv> {apre_version op, apost_version op}"

text \<open>These accessors allow us to extract keys, versions, etc from all types of operations in
a uniform way.\<close>

instantiation aop :: keyed
begin
primrec key_aop :: "aop \<Rightarrow> key" where
"key_aop (ARead k v)           = k" |
"key_aop (AWrite k v1 a v2 r)  = k"
instance ..
end

instantiation aop :: op
begin
primrec op_type_aop :: "aop \<Rightarrow> opType" where
"op_type_aop (ARead k v)           = Read" |
"op_type_aop (AWrite k v1 a v2 r)  = Write"

primrec pre_version_aop :: "aop \<Rightarrow> version option" where
"pre_version_aop (ARead k v)          = Some v" |
"pre_version_aop (AWrite k v1 a v2 r) = Some v1"

primrec arg_aop :: "aop \<Rightarrow> arg" where
"arg_aop (ARead k v)           = ReadArg" |
"arg_aop (AWrite k v1 a v2 r)  = WriteArg a"

primrec post_version_aop :: "aop \<Rightarrow> version option" where
"post_version_aop (ARead k v)           = Some v" |
"post_version_aop (AWrite k v1 a v2 r)  = Some v2"

primrec ret_aop :: "aop \<Rightarrow> ret option" where
"ret_aop (ARead k v)           = Some (ReadRet v)" |
"ret_aop (AWrite k v1 a v2 r)  = Some (WriteRet r)"

instance ..
end

text \<open>As a quick test of these accessors...\<close>
lemma "arg (ARead k v) = ReadArg"
  by auto

lemma "pre_version (AWrite k v1 a v2 r) = Some v1"
  by auto

lemma "post_version (AWrite k v1 a v2 r) = Some v2"
  by auto

lemma "(key (ARead k v1)) = (key (AWrite k v2 a v3 r))"
  by auto

text \<open>Moving on to accessors for observed operations...\<close>

instantiation oop :: keyed
begin
primrec key_oop :: "oop \<Rightarrow> key" where
"key_oop (ORead k v)           = k" |
"key_oop (OWrite k v1 a v2 r)  = k"
instance ..
end

instantiation oop :: op
begin

primrec op_type_oop :: "oop \<Rightarrow> opType" where
"op_type_oop (ORead k v)           = Read" |
"op_type_oop (OWrite k v1 a v2 r)  = Write"

primrec pre_version_oop :: "oop \<Rightarrow> version option" where
"pre_version_oop (ORead k v)          = v" |
"pre_version_oop (OWrite k v1 a v2 r) = v1"

primrec arg_oop :: "oop \<Rightarrow> arg" where
"arg_oop (ORead k v)           = ReadArg" |
"arg_oop (OWrite k v1 a v2 r)  = WriteArg a"

primrec post_version_oop :: "oop \<Rightarrow> version option" where
"post_version_oop (ORead k v)           = v" |
"post_version_oop (OWrite k v1 a v2 r)  = v2"

primrec ret_oop :: "oop \<Rightarrow> ret option" where
"ret_oop (ORead k v)           = (case v of Some v \<Rightarrow> Some (ReadRet v) | None \<Rightarrow> None)" |
"ret_oop (OWrite k v1 a v2 r)  = (case r of Some r \<Rightarrow> Some (WriteRet r) | None \<Rightarrow> None)"

instance ..
end

text \<open>And as a quick check...\<close>
lemma "(post_version (ORead k1 (Some v))) =
       (pre_version (OWrite k2 (Some v) a None None))"
  by auto

text \<open>We're going to be asking a lot about "the set of all versions in <something>".\<close>
class all_versions =
  fixes all_versions :: "'a \<Rightarrow> version set"

instantiation aop :: all_versions
begin
primrec all_versions_aop :: "aop \<Rightarrow> version set" where
"all_versions_aop (ARead k v) = {v}" |
"all_versions_aop (AWrite k v1 a v2 r) = {v1, v2}"
instance ..
end

instantiation oop :: all_versions
begin
primrec all_versions_oop :: "oop \<Rightarrow> version set" where
"all_versions_oop (ORead k v) = (case v of None \<Rightarrow> {} | (Some v) \<Rightarrow> {v})" |
"all_versions_oop (OWrite k v1 a v2 r) = (case v1 of
                                    None \<Rightarrow> (case v2 of None \<Rightarrow> {} | (Some v2) \<Rightarrow> {v2}) |
                               (Some v1) \<Rightarrow> (case v2 of None \<Rightarrow> {v1} | (Some v2) \<Rightarrow> {v1, v2}))"
instance ..
end

text \<open>... And all keys in something \<close>
class all_keys =
  fixes all_keys :: "'a \<Rightarrow> key set"

text \<open>And similarly, we're going to want to talk about all operations in a transaction, version
graph, object, history, observation, etc...\<close>

class all_aops =
  fixes all_aops :: "'a \<Rightarrow> aop set"

class all_oops =
  fixes all_oops :: "'a \<Rightarrow> oop set"

text \<open>And if you have the set of all ops, you can filter that to the set of writes or reads.\<close>

definition all_owrites :: "'a::all_oops \<Rightarrow> oop set" where
"all_owrites a = {op. (op \<in> (all_oops a)) \<and> ((op_type op = Write))}"

definition all_oreads :: "'a::all_oops \<Rightarrow> oop set" where
"all_oreads a = {op. (op \<in> (all_oops a)) \<and> ((op_type op = Read))}"

definition all_awrites :: "'a::all_aops \<Rightarrow> aop set" where
"all_awrites a = {op. (op \<in> (all_aops a)) \<and> ((op_type op = Write))}"

definition all_areads :: "'a::all_aops \<Rightarrow> aop set" where
"all_areads a = {op. (op \<in> (all_aops a)) \<and> ((op_type op = Read))}"

text \<open>An observed operation is definite if its optional fields are known. Might want to break this
up later; it might be helpful to talk about postversion-definite, retval-definite, write-definite,
etc.\<close>

class definite =
  fixes is_definite :: "'a \<Rightarrow> bool"

(* Huh, can't instantiate a typeclass over a polymorphic type?
instantiation "'a option" :: definite
begin
*)

primrec is_definite_option :: "'a option \<Rightarrow> bool" where
"is_definite_option None     = False" |
"is_definite_option (Some x) = True"

instantiation oop :: definite
begin
primrec is_definite :: "oop \<Rightarrow> bool" where
"is_definite (ORead k v)          = is_definite_option v" |
"is_definite (OWrite k v1 a v2 r) = (is_definite_option v1 \<and>
                                     is_definite_option v2 \<and>
                                     is_definite_option r)"
instance ..
end

text \<open>We now define a notion of compatibility, which says whether an observed operation could
correspond to some abstract operation. The idea here is that the database executed the abstract
operation, but that we don't know, due to the client protocol, or perhaps due to missing responses,
exactly what happened. We compare Options to actual values, ensuring that either the optional is
None (e.g. we don't know), or if it's Some, that the values are equal.

I'd like to do this as a typeclass, but without multi-type-parameter typeclasses, we can't
write a generic function over a \<Rightarrow> b \<Rightarrow> bool. This seems like something I'm likely to mess up,
so instead, we write a family of compatibility functions with type names.\<close>

primrec is_compatible_option :: "'a option \<Rightarrow> 'a \<Rightarrow> bool" where
"is_compatible_option None     y = True" |
"is_compatible_option (Some x) y = (x = y)"

text \<open>An observed operation is compatible with an abstract operation if their types, keys,
versions, arguments, and return values are all compatible.\<close>
definition is_compatible_op :: "oop \<Rightarrow> aop \<Rightarrow> bool" where
"is_compatible_op oop aop \<equiv>
  (((op_type oop) = (op_type aop)) \<and>
   ((key oop) = (key aop)) \<and>
   (is_compatible_option (pre_version oop)  (apre_version aop)) \<and>
   ((arg oop) = (arg aop)) \<and>
   (is_compatible_option (ret oop)          (aret aop)) \<and>
   (is_compatible_option (post_version oop) (apost_version aop)))"

text \<open>Some basic lemmata around compatibility. These are... surprisingly expensive proofs for
sledgehammer to find...\<close>

lemma compatible_same_type: "is_compatible_op oop aop \<Longrightarrow> ((op_type oop) = (op_type aop))"
  using is_compatible_op_def by blast

lemma compatible_same_key: "is_compatible_op oop aop \<Longrightarrow> ((key oop) = (key aop))"
  using is_compatible_op_def by blast

lemma compatible_same_arg: "is_compatible_op oop aop \<Longrightarrow> ((arg oop) = (arg aop))"
  using is_compatible_op_def by blast

lemma compatible_pre_version:
  "is_compatible_op oop aop \<Longrightarrow> (((pre_version oop) = None) \<or>
                                 ((pre_version oop) = Some (apre_version aop)))"
  by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq)

lemma compatible_post_version:
  "is_compatible_op oop aop \<Longrightarrow> (((post_version oop) = None) \<or>
                                 ((post_version oop) = Some (apost_version aop)))"
  by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq)

lemma compatible_ret:
  "is_compatible_op oop aop \<Longrightarrow> (((ret oop) = None) \<or>
                                 ((ret oop) = Some (aret aop)))"
  by (metis is_compatible_op_def is_compatible_option.simps(2) not_Some_eq)

lemma compatible_definite_same_pre_version:
  "(is_compatible_op oop aop \<and> is_definite oop) \<Longrightarrow> ((pre_version oop) = (pre_version aop))"
  by (smt aop.exhaust apre_version.simps(1) apre_version.simps(2) is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(1) is_definite.simps(2) is_definite_option.simps(1) oop.exhaust option.exhaust pre_version_aop.simps(1) pre_version_aop.simps(2) pre_version_oop.simps(1) pre_version_oop.simps(2))

lemma compatible_definite_same_post_version:
  "(is_compatible_op oop aop \<and> is_definite oop) \<Longrightarrow> ((post_version oop) = (post_version aop))"
  by (smt aop.exhaust apost_version.simps(2) compatible_definite_same_pre_version is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(2) is_definite_option.simps(1) oop.exhaust opType.distinct(1) op_type_aop.simps(1) op_type_aop.simps(2) op_type_oop.simps(1) op_type_oop.simps(2) option.exhaust post_version_aop.simps(1) post_version_aop.simps(2) post_version_oop.simps(1) post_version_oop.simps(2) pre_version_aop.simps(1) pre_version_oop.simps(1))

lemma compatible_definite_same_ret:
  "(is_compatible_op oop aop \<and> is_definite oop) \<Longrightarrow> ((ret oop) = (ret aop))"
  by (smt aop.exhaust aret.simps(1) aret.simps(2) is_compatible_op_def is_compatible_option.simps(2) is_definite.simps(1) is_definite.simps(2) is_definite_option.simps(1) not_None_eq oop.exhaust option.case(2) ret_aop.simps(1) ret_aop.simps(2) ret_oop.simps(1) ret_oop.simps(2))

text \<open>If two operations are compatible and the observed one is definite, they share exactly
the same values.\<close>

lemma definite_compatible_same:
"is_compatible_op oop aop \<and> is_definite oop \<Longrightarrow>
  (((pre_version oop)  = (pre_version aop)) \<and>
   ((post_version oop) = (post_version aop)) \<and>
   ((ret oop)          = (ret aop)))"
  by (simp add: compatible_definite_same_post_version compatible_definite_same_pre_version compatible_definite_same_ret)

end


chapter\<open>Uniqueness Results: Syntactic Relations are Functions\<close>

theory Functions
imports Coding_Predicates
begin

subsection \<open>SeqStTermP\<close>

lemma not_IndP_VarP: "{IndP x, VarP x} \<turnstile> A"
proof -
  obtain m::name  where "atom m \<sharp> (x,A)"
    by (metis obtain_fresh)
  thus ?thesis
    by  (auto simp: fresh_Pair) (blast intro: ExFalso cut_same [OF VarP_cong [THEN Iff_MP_same]])
qed

text\<open>It IS a pair, but not just any pair.\<close>
lemma IndP_HPairE: "insert (IndP (HPair (HPair Zero (HPair Zero Zero)) x)) H \<turnstile> A"
proof -
  obtain m::name  where "atom m \<sharp> (x,A)"
    by (metis obtain_fresh)
  hence "{ IndP (HPair (HPair Zero (HPair Zero Zero)) x) } \<turnstile> A"
    by (auto simp: IndP.simps [of m] HTuple_minus_1 intro: thin1)
  thus ?thesis
    by (metis Assume cut1)
qed

lemma atom_HPairE:
  assumes "H \<turnstile> x EQ HPair (HPair Zero (HPair Zero Zero)) y"
    shows "insert (IndP x OR x NEQ v) H \<turnstile> A"
proof -
  have "{ IndP x OR x NEQ v, x EQ HPair (HPair Zero (HPair Zero Zero)) y } \<turnstile> A"
    by (auto intro!: OrdNotEqP_OrdP_E IndP_HPairE
             intro: cut_same [OF IndP_cong [THEN Iff_MP_same]]
                    cut_same [OF OrdP_cong [THEN Iff_MP_same]])
  thus ?thesis
    by (metis Assume assms rcut2)
qed

lemma SeqStTermP_lemma:
  assumes "atom m \<sharp> (v,i,t,u,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,i,t,u,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,i,t,u,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,i,t,u,s,k,sn,sn')"
          "atom sn \<sharp> (v,i,t,u,s,k,sn')" "atom sn' \<sharp> (v,i,t,u,s,k)"
    shows "{ SeqStTermP v i t u s k }
           \<turnstile> ((t EQ v AND u EQ i) OR
              ((IndP t OR t NEQ v) AND u EQ t)) OR
              Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqStTermP v i (Var sm) (Var sm') s (Var m) AND
                       SeqStTermP v i (Var sn) (Var sn') s (Var n) AND
                       t EQ Q_Eats (Var sm) (Var sn) AND
                       u EQ Q_Eats (Var sm') (Var sn')))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where "atom l \<sharp> (v,i,t,u,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,i,t,u,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,i,t,u,s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l s k v i sl sl' m n sm sm' sn sn'])
    apply (rule Conj_EH Ex_EH All2_SUCC_E [THEN rotate2] | simp)+
    apply (rule cut_same [where A = "HPair t u EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume AssumeH(4) LstSeqP_EQ)
    apply clarify
    apply (rule Disj_EH)
    apply (rule Disj_I1)
    apply (rule anti_deduction)
    apply (rule Var_Eq_subst_Iff [THEN Sym_L, THEN Iff_MP_same])
    apply (rule Sym_L [THEN rotate2])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], force)
    \<comment> \<open>now the quantified case\<close>
    \<comment> \<open>auto could be used but is VERY SLOW\<close>
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Disj_I2)
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp_all add: SeqStTermP.simps [of l s _ v i sl sl' m n sm sm' sn sn'])
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    \<comment> \<open>first SeqStTermP subgoal\<close>
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>next SeqStTermP subgoal\<close>
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>finally, the equality pair\<close>
    apply (blast intro: Trans)
    done
qed

lemma SeqStTermP_unique: "{SeqStTermP v a t u s kk, SeqStTermP v a t u' s' kk'} \<turnstile> u' EQ u"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',v,a,t,u,u')"   "atom j \<sharp> (s,s',v,a,t,i,t,u,u')"
                  "atom j' \<sharp> (s,s',v,a,t,i,j,t,u,u')"
                  "atom k \<sharp> (s,s',v,a,t,u,u',kk',i,j,j')" "atom k' \<sharp> (s,s',v,a,t,u,u',k,i,j,j')"
                  "atom l \<sharp> (s,s',v,a,t,i,j,j',k,k')"
                  "atom m \<sharp> (s,s',v,a,i,j,j',k,k',l)"   "atom n \<sharp> (s,s',v,a,i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{ OrdP (Var k), VarP v }
       \<turnstile> All i (All j (All j' (All k' (SeqStTermP v a (Var i) (Var j) s (Var k)
                                  IMP (SeqStTermP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqStTermP_lemma [of m v a "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqStTermP_lemma [of m2 v a "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    \<comment> \<open>case 1, both sides equal @{term v}\<close>
    apply (blast intro: Trans Sym)
    \<comment> \<open>case 2, @{term "Var i EQ v"} and also @{term "IndP (Var i) OR Var i NEQ v"}\<close>
    apply (rule Conj_EH Disj_EH)+
    apply (blast intro: IndP_cong [THEN Iff_MP_same] not_IndP_VarP [THEN cut2])
    apply (metis Assume OrdNotEqP_E)
    \<comment> \<open>case 3, both a variable and a pair\<close>
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule cut_same [where A = "VarP (Q_Eats (Var sm) (Var sn))"])
    apply (blast intro: Trans Sym VarP_cong [where x=v, THEN Iff_MP_same] Hyp, blast)
    \<comment> \<open>towards remaining cases\<close>
    apply (rule Disj_EH Ex_EH)+
    \<comment> \<open>case 4, @{term "Var i EQ v"} and also @{term "IndP (Var i) OR Var i NEQ v"}\<close>
    apply (blast intro: IndP_cong [THEN Iff_MP_same] not_IndP_VarP [THEN cut2] OrdNotEqP_E)
    \<comment> \<open>case 5, @{term "Var i EQ v"} for both\<close>
    apply (blast intro: Trans Sym)
    \<comment> \<open>case 6, both an atom and a pair\<close>
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule atom_HPairE)
    apply (simp add: HTuple.simps)
    apply (blast intro: Trans)
    \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    \<comment> \<open>case 7, both an atom and a pair\<close>
    apply (rule cut_same [where A = "VarP (Q_Eats (Var sm2) (Var sn2))"])
    apply (blast intro: Trans Sym VarP_cong [where x=v, THEN Iff_MP_same] Hyp, blast)
    \<comment> \<open>case 8, both an atom and a pair\<close>
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule atom_HPairE)
    apply (simp add: HTuple.simps)
    apply (blast intro: Trans)
    \<comment> \<open>case 9, two Eats terms\<close>
    apply (rule Ex_EH Disj_EH Conj_EH)+
    apply simp_all
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule cut_same [where A = "Q_Eats (Var sm) (Var sn) EQ Q_Eats (Var sm2) (Var sn2)"])
    apply (blast intro: Sym Trans, clarify)
    apply (rule cut_same [where A = "SeqStTermP v a (Var sn) (Var sn2') s' (Var n2)"])
    apply (blast intro: Hyp SeqStTermP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule cut_same [where A = "SeqStTermP v a (Var sm) (Var sm2') s' (Var m2)"])
    apply (blast intro: Hyp SeqStTermP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (blast intro: HPair_cong Trans [OF Hyp Sym])
    done
  hence p1: "{OrdP (Var k), VarP v}
             \<turnstile> (All j (All j' (All k' (SeqStTermP v a (Var i) (Var j) s (Var k)
                 IMP (SeqStTermP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))(i::=t)"
    by (metis All_D)
  have p2: "{OrdP (Var k), VarP v}
         \<turnstile> (All j' (All k' (SeqStTermP v a t (Var j) s (Var k)
                 IMP (SeqStTermP v a t (Var j') s' (Var k') IMP Var j' EQ Var j))))(j::=u)"
    apply (rule All_D)
    using atoms p1 by simp
  have p3: "{OrdP (Var k), VarP v}
             \<turnstile> (All k' (SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t (Var j') s' (Var k') IMP Var j' EQ u)))(j'::=u')"
    apply (rule All_D)
    using atoms p2 by simp
  have p4: "{OrdP (Var k), VarP v}
          \<turnstile> (SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' (Var k') IMP u' EQ u))(k'::=kk')"
    apply (rule All_D)
    using atoms p3 by simp
  hence "{SeqStTermP v a t u s (Var k), VarP v} \<turnstile> SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    using atoms apply simp
    by (metis SeqStTermP_imp_OrdP rcut1)
  hence "{VarP v} \<turnstile> ((SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)))"
    by (metis Assume MP_same Imp_I)
  hence "{VarP v} \<turnstile> ((SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)))(k::=kk)"
   using atoms by (force intro!: Subst)
  hence "{VarP v} \<turnstile> SeqStTermP v a t u s kk IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    using atoms by simp
  hence "{SeqStTermP v a t u s kk} \<turnstile> SeqStTermP v a t u s kk IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    by (metis SeqStTermP_imp_VarP rcut1)
  thus ?thesis
    by (metis Assume AssumeH(2) MP_same rcut1)
qed

theorem SubstTermP_unique: "{SubstTermP v tm t u, SubstTermP v tm t u'} \<turnstile> u' EQ u"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (v,tm,t,u,u',k,k')" "atom s' \<sharp> (v,tm,t,u,u',k,k',s)"
          "atom k \<sharp> (v,tm,t,u,u')" "atom k' \<sharp> (v,tm,t,u,u',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstTermP.simps [of s v tm t u k]  SubstTermP.simps [of s' v tm t u' k'])
       (metis SeqStTermP_unique rotate3 thin1)
qed

subsection\<open>@{term SubstAtomicP}\<close>

lemma SubstTermP_eq:
  "\<lbrakk>H \<turnstile> SubstTermP v tm x z; insert (SubstTermP v tm y z) H \<turnstile> A\<rbrakk> \<Longrightarrow> insert (x EQ y) H \<turnstile> A"
  by (metis Assume rotate2 Iff_E1 cut_same thin1 SubstTermP_cong [OF Refl Refl _ Refl])

lemma SubstAtomicP_unique: "{SubstAtomicP v tm x y, SubstAtomicP v tm x y'} \<turnstile> y' EQ y"
proof -
  obtain t::name and ts::name and u::name and us::name
     and t'::name and ts'::name and u'::name and us'::name
    where "atom t \<sharp> (v,tm,x,y,y',ts,u,us)"  "atom ts \<sharp> (v,tm,x,y,y',u,us)"
          "atom u \<sharp> (v,tm,x,y,y',us)"       "atom us \<sharp> (v,tm,x,y,y')"
          "atom t' \<sharp> (v,tm,x,y,y',t,ts,u,us,ts',u',us')" "atom ts' \<sharp> (v,tm,x,y,y',t,ts,u,us,u',us')"
          "atom u' \<sharp> (v,tm,x,y,y',t,ts,u,us,us')"        "atom us' \<sharp> (v,tm,x,y,y',t,ts,u,us)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: SubstAtomicP.simps [of t v tm x y ts u us]
                     SubstAtomicP.simps [of t' v tm x y' ts' u' us'])
    apply (rule Ex_EH Disj_EH Conj_EH)+
    apply simp_all
    apply (rule Eq_Trans_E [OF Hyp], auto simp: HTS)
    apply (rule SubstTermP_eq [THEN thin1], blast)
    apply (rule SubstTermP_eq [THEN rotate2], blast)
    apply (rule Trans [OF Hyp Sym], blast)
    apply (rule Trans [OF Hyp], blast)
    apply (metis Assume AssumeH(8) HPair_cong Refl cut2 [OF SubstTermP_unique] thin1)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Eq_Trans_E [OF Hyp], auto simp: HTS)
    apply (rule SubstTermP_eq [THEN thin1], blast)
    apply (rule SubstTermP_eq [THEN rotate2], blast)
    apply (rule Trans [OF Hyp Sym], blast)
    apply (rule Trans [OF Hyp], blast)
    apply (metis Assume AssumeH(8) HPair_cong Refl cut2 [OF SubstTermP_unique] thin1)
    done
qed

subsection\<open>@{term SeqSubstFormP}\<close>

lemma SeqSubstFormP_lemma:
  assumes "atom m \<sharp> (v,u,x,y,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,u,x,y,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,u,x,y,s,k,sm',sn,sn')"  "atom sm' \<sharp> (v,u,x,y,s,k,sn,sn')"
          "atom sn \<sharp> (v,u,x,y,s,k,sn')"         "atom sn' \<sharp> (v,u,x,y,s,k)"
  shows "{ SeqSubstFormP v u x y s k }
         \<turnstile> SubstAtomicP v u x y  OR
           Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqSubstFormP v u (Var sm) (Var sm') s (Var m) AND
                       SeqSubstFormP v u (Var sn) (Var sn') s (Var n) AND
                       (((x EQ Q_Disj (Var sm) (Var sn) AND y EQ Q_Disj (Var sm') (Var sn')) OR
                        (x EQ Q_Neg (Var sm) AND y EQ Q_Neg (Var sm')) OR
                        (x EQ Q_Ex (Var sm) AND y EQ Q_Ex (Var sm'))))))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where "atom l \<sharp> (v,u,x,y,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,u,x,y,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,u,x,y,s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqSubstFormP.simps [of l s k v u sl sl' m n sm sm' sn sn'])
    apply (rule Conj_EH Ex_EH All2_SUCC_E [THEN rotate2] | simp)+
    apply (rule cut_same [where A = "HPair x y EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume AssumeH(4) LstSeqP_EQ)
    apply clarify
    apply (rule Disj_EH)
    apply (blast intro: Disj_I1 SubstAtomicP_cong [THEN Iff_MP2_same])
    \<comment> \<open>now the quantified cases\<close>
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Disj_I2)
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp_all add: SeqSubstFormP.simps [of l s _ v u sl sl' m n sm sm' sn sn'])
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    \<comment> \<open>first SeqSubstFormP subgoal\<close>
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>next SeqSubstFormP subgoal\<close>
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>finally, the equality pairs\<close>
    apply (rule anti_deduction [THEN thin1])
    apply (rule Sym_L [THEN rotate4])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same])
    apply (rule Sym_L [THEN rotate5])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], force)
    done
qed

lemma
  shows Neg_SubstAtomicP_Fls:  "{y EQ Q_Neg z,  SubstAtomicP v tm y y'} \<turnstile> Fls"    (is ?thesis1)
    and Disj_SubstAtomicP_Fls: "{y EQ Q_Disj z w, SubstAtomicP v tm y y'} \<turnstile> Fls"  (is ?thesis2)
    and Ex_SubstAtomicP_Fls:   "{y EQ Q_Ex z,   SubstAtomicP v tm y y'} \<turnstile> Fls"    (is ?thesis3)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (z,w,v,tm,y,y',t',u,u')" "atom t' \<sharp> (z,w,v,tm,y,y',u,u')"
          "atom u \<sharp> (z,w,v,tm,y,y',u')" "atom u' \<sharp> (z,w,v,tm,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: SubstAtomicP.simps [of t v tm y y' t' u u'] HTS  intro: Eq_Trans_E [OF Hyp])
qed

lemma SeqSubstFormP_eq:
  "\<lbrakk>H \<turnstile> SeqSubstFormP v tm x z s k; insert (SeqSubstFormP v tm y z s k) H \<turnstile> A\<rbrakk>
   \<Longrightarrow> insert (x EQ y) H \<turnstile> A"
  apply (rule cut_same [OF SeqSubstFormP_cong [OF Assume Refl Refl Refl, THEN Iff_MP_same]])
  apply (auto simp: insert_commute intro: thin1)
  done

lemma SeqSubstFormP_unique: "{SeqSubstFormP v a x y s kk, SeqSubstFormP v a x y' s' kk'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',v,a,x,y,y')"   "atom j \<sharp> (s,s',v,a,x,i,x,y,y')"
                  "atom j' \<sharp> (s,s',v,a,x,i,j,x,y,y')"
                  "atom k \<sharp> (s,s',v,a,x,y,y',kk',i,j,j')" "atom k' \<sharp> (s,s',v,a,x,y,y',k,i,j,j')"
                  "atom l \<sharp> (s,s',v,a,x,i,j,j',k,k')"
                  "atom m \<sharp> (s,s',v,a,i,j,j',k,k',l)"   "atom n \<sharp> (s,s',v,a,i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{ OrdP (Var k) }
       \<turnstile> All i (All j (All j' (All k' (SeqSubstFormP v a (Var i) (Var j) s (Var k)
                                  IMP (SeqSubstFormP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqSubstFormP_lemma [of m v a "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqSubstFormP_lemma [of m2 v a "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    \<comment> \<open>case 1, both sides are atomic\<close>
    apply (blast intro: cut2 [OF SubstAtomicP_unique])
    \<comment> \<open>case 2, atomic and also not\<close>
    apply (rule Ex_EH Conj_EH Disj_EH)+
    apply simp_all
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Disj_SubstAtomicP_Fls])
    apply (rule Conj_EH Disj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Neg_SubstAtomicP_Fls])
    apply (rule Conj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Ex_SubstAtomicP_Fls])
    \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Disj_SubstAtomicP_Fls])
    apply (rule Conj_EH Disj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Neg_SubstAtomicP_Fls])
    apply (rule Conj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Ex_SubstAtomicP_Fls])
    \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    \<comment> \<open>case two Disj terms\<close>
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule rotate3)
    apply (rule Eq_Trans_E [OF Hyp], blast)
    apply (clarsimp simp add: HTS)
    apply (rule thin1)
    apply (rule Disj_EH [OF ContraProve], blast intro: thin1 SeqSubstFormP_eq)+
    apply (blast intro: HPair_cong Trans [OF Hyp Sym])
    \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH)+
    \<comment> \<open>Negation = Disjunction?\<close>
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
   \<comment> \<open>Existential = Disjunction?\<close>
    apply (rule Conj_EH)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
     \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    \<comment> \<open>Disjunction = Negation?\<close>
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Conj_EH Disj_EH)+
    \<comment> \<open>case two Neg terms\<close>
    apply (rule Eq_Trans_E [OF Hyp], blast, clarify)
    apply (rule thin1)
    apply (rule All_E' [OF Hyp, where x="Var m"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule Disj_EH [OF ContraProve], blast intro: SeqSubstFormP_eq Sym_L)+
    apply (blast intro: HPair_cong Sym Trans [OF Hyp])
    \<comment> \<open>Existential = Negation?\<close>
    apply (rule Conj_EH)+
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
     \<comment> \<open>towards remaining cases\<close>
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    \<comment> \<open>Disjunction = Existential\<close>
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Conj_EH Disj_EH Ex_EH)+
    \<comment> \<open>Negation = Existential\<close>
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
   \<comment> \<open>case two Ex terms\<close>
    apply (rule Conj_EH)+
    apply (rule Eq_Trans_E [OF Hyp], blast, clarify)
    apply (rule thin1)
    apply (rule All_E' [OF Hyp, where x="Var m"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule Disj_EH [OF ContraProve], blast intro: SeqSubstFormP_eq Sym_L)+
    apply (blast intro: HPair_cong Sym Trans [OF Hyp])
    done
  hence p1: "{OrdP (Var k)}
             \<turnstile> (All j (All j' (All k' (SeqSubstFormP v a (Var i) (Var j) s (Var k)
                 IMP (SeqSubstFormP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))(i::=x)"
    by (metis All_D)
  have p2: "{OrdP (Var k)}
            \<turnstile> (All j' (All k' (SeqSubstFormP v a x (Var j) s (Var k)
                 IMP (SeqSubstFormP v a x (Var j') s' (Var k') IMP Var j' EQ Var j))))(j::=y)"
    apply (rule All_D)
    using atoms p1 by simp
  have p3: "{OrdP (Var k)}
            \<turnstile> (All k' (SeqSubstFormP v a x y s (Var k)
                 IMP (SeqSubstFormP v a x (Var j') s' (Var k') IMP Var j' EQ y)))(j'::=y')"
    apply (rule All_D)
    using atoms p2 by simp
  have p4: "{OrdP (Var k)}
          \<turnstile> (SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' (Var k') IMP y' EQ y))(k'::=kk')"
    apply (rule All_D)
    using atoms p3 by simp
  hence "{OrdP (Var k)} \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    using atoms by simp
  hence "{SeqSubstFormP v a x y s (Var k)}
         \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    by (metis SeqSubstFormP_imp_OrdP rcut1)
  hence "{} \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    by (metis Assume Disj_Neg_2 Disj_commute anti_deduction Imp_I)
  hence "{} \<turnstile> ((SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)))(k::=kk)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by simp (metis DisjAssoc2 Disj_commute anti_deduction)
qed

subsection\<open>@{term SubstFormP}\<close>

theorem SubstFormP_unique: "{SubstFormP v tm x y, SubstFormP v tm x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (v,tm,x,y,y',k,k')" "atom s' \<sharp> (v,tm,x,y,y',k,k',s)"
          "atom k \<sharp> (v,tm,x,y,y')" "atom k' \<sharp> (v,tm,x,y,y',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstFormP.simps [of s v tm x y k]  SubstFormP.simps [of s' v tm x y' k']
                    SeqSubstFormP_unique rotate3 thin1)
qed

end