section \<open>Implementing Graphs by Maps\<close>
theory GraphByMap
imports
  GraphSpec
  GraphGA
begin

definition "map_Sigma M1 F2 \<equiv> {
  (x,y). \<exists>v. M1 x = Some v \<and> y\<in>F2 v
}"

lemma map_Sigma_alt: "map_Sigma M1 F2 = Sigma (dom M1) (\<lambda>x.
  F2 (the (M1 x)))"
  unfolding map_Sigma_def
  by auto

(* TODO: Move to Misc *)
lemma ranE:
  assumes "v\<in>ran m"
  obtains k where "m k = Some v"
  using assms
by (metis ran_restrictD restrict_map_self)
lemma option_bind_alt:
  "Option.bind x f = (case x of None \<Rightarrow> None | Some v \<Rightarrow> f v)"
  by (auto split: option.split)

locale GraphByMapDefs =
  m1: StdMapDefs m1_ops +
  m2: StdMapDefs m2_ops +
  s3: StdSetDefs s3_ops
  for m1_ops::"('V,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('V,'s3,'m2,_) map_ops_scheme"
  and s3_ops::"('W,'s3,_) set_ops_scheme"
  and m1_mvif :: "('V \<Rightarrow> 'm2 \<rightharpoonup> 'm2) \<Rightarrow> 'm1 \<Rightarrow> 'm1"
begin
  definition gbm_\<alpha> :: "('V,'W,'m1) graph_\<alpha>" where
    "gbm_\<alpha> m1 \<equiv>
    \<lparr> nodes = dom (m1.\<alpha> m1),
      edges = {(v,w,v').
        \<exists>m2 s3. m1.\<alpha> m1 v = Some m2
          \<and> m2.\<alpha> m2 v' = Some s3
          \<and> w\<in>s3.\<alpha> s3
      }
    \<rparr>"

  definition "gbm_invar m1 \<equiv>
    m1.invar m1 \<and>
    (\<forall>m2\<in>ran (m1.\<alpha> m1). m2.invar m2 \<and>
      (\<forall>s3\<in>ran (m2.\<alpha> m2). s3.invar s3)
    ) \<and> valid_graph (gbm_\<alpha> m1)"

  definition gbm_empty :: "('V,'W,'m1) graph_empty" where
    "gbm_empty \<equiv> m1.empty"

  definition gbm_add_node :: "('V,'W,'m1) graph_add_node" where
    "gbm_add_node v g \<equiv> case m1.lookup v g of
    None \<Rightarrow> m1.update v (m2.empty ()) g |
    Some _ \<Rightarrow> g"

  definition gbm_delete_node :: "('V,'W,'m1) graph_delete_node" where
    "gbm_delete_node v g \<equiv> let g=m1.delete v g in
    m1_mvif (\<lambda>_ m2. Some (m2.delete v m2)) g"

  definition gbm_add_edge :: "('V,'W,'m1) graph_add_edge" where
    "gbm_add_edge v e v' g \<equiv>
    let g = (case m1.lookup v' g of
      None \<Rightarrow> m1.update v' (m2.empty ()) g | Some _ \<Rightarrow> g
    ) in
    case m1.lookup v g of
      None \<Rightarrow> (m1.update v (m2.sng v' (s3.sng e)) g) |
      Some m2 \<Rightarrow> (case m2.lookup v' m2 of
        None \<Rightarrow> m1.update v (m2.update v' (s3.sng e) m2) g |
        Some s3 \<Rightarrow> m1.update v (m2.update v' (s3.ins e s3) m2) g)
    "

  definition gbm_delete_edge :: "('V,'W,'m1) graph_delete_edge" where
    "gbm_delete_edge v e v' g \<equiv>
    case m1.lookup v g of
      None \<Rightarrow> g |
      Some m2 \<Rightarrow> (
        case m2.lookup v' m2 of
          None \<Rightarrow> g |
          Some s3 \<Rightarrow> m1.update v (m2.update v' (s3.delete e s3) m2) g
      )
    "

  definition gbm_nodes_list_it
    :: "('V,'W,'V list,'m1) graph_nodes_it"
    where
    "gbm_nodes_list_it g \<equiv> map_iterator_dom (m1.iteratei g)"
  local_setup \<open>Locale_Code.lc_decl_del @{term gbm_nodes_list_it}\<close>

  definition gbm_edges_list_it
    :: "('V,'W,('V\<times>'W\<times>'V) list,'m1) graph_edges_it"
    where
    "gbm_edges_list_it g \<equiv> set_iterator_image
      (\<lambda>((v1,m1),(v2,m2),w). (v1,w,v2))
      (set_iterator_product (m1.iteratei g)
        (\<lambda>(v,m2). set_iterator_product
          (m2.iteratei m2) (\<lambda>(w,s3). s3.iteratei s3)))
    "
  local_setup \<open>Locale_Code.lc_decl_del @{term gbm_edges_list_it}\<close>

  definition gbm_succ_list_it ::
    "('V,'W,('W\<times>'V) list,'m1) graph_succ_it"
    where
  "gbm_succ_list_it g v \<equiv> case m1.lookup v g of
    None \<Rightarrow> set_iterator_emp |
    Some m2 \<Rightarrow>
      set_iterator_image (\<lambda>((v',m2),w). (w,v'))
        (set_iterator_product (m2.iteratei m2) (\<lambda>(v',s). s3.iteratei s))
    "
  local_setup \<open>Locale_Code.lc_decl_del @{term gbm_succ_list_it}\<close>

  definition
    "gbm_from_list \<equiv> gga_from_list gbm_empty gbm_add_node gbm_add_edge"

  lemma gbm_nodes_list_it_unf:
    "it_to_it (gbm_nodes_list_it g)
    \<equiv> map_iterator_dom (it_to_it (m1.list_it g))"
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_nodes_list_it_def m1.iteratei_def
    by (intro icf_proper_iteratorI)

  lemma gbm_edges_list_it_unf:
    "it_to_it (gbm_edges_list_it g)
    \<equiv> set_iterator_image
      (\<lambda>((v1,m1),(v2,m2),w). (v1,w,v2))
      (set_iterator_product (it_to_it (m1.list_it g))
        (\<lambda>(v,m2). set_iterator_product
          (it_to_it (m2.list_it m2)) (\<lambda>(w,s3). (it_to_it (s3.list_it s3)))))
    "
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_edges_list_it_def
      m1.iteratei_def m2.iteratei_def s3.iteratei_def
    apply (intro icf_proper_iteratorI allI impI, (simp split: prod.split)?)+
    done

  lemma gbm_succ_list_it_unf:
  "it_to_it (gbm_succ_list_it g v) \<equiv>
    case m1.lookup v g of
      None \<Rightarrow> set_iterator_emp |
      Some m2 \<Rightarrow>
        set_iterator_image (\<lambda>((v',m2),w). (w,v'))
          (set_iterator_product (it_to_it (m2.list_it m2))
            (\<lambda>(v',s). (it_to_it (s3.list_it s))))
      "
    apply (rule eq_reflection)
    apply (rule it_to_it_fold)
    unfolding gbm_succ_list_it_def
      m2.iteratei_def s3.iteratei_def
    apply (simp split: prod.split option.split)
    apply (intro icf_proper_iteratorI allI impI conjI,
      (simp split: prod.split option.split)?)+
    done

end

sublocale GraphByMapDefs < graph_nodes_it_defs gbm_nodes_list_it .
sublocale GraphByMapDefs < graph_edges_it_defs gbm_edges_list_it .
sublocale GraphByMapDefs < graph_succ_it_defs gbm_succ_list_it .
sublocale GraphByMapDefs
  < gga_to_list_defs_loc gbm_nodes_list_it gbm_edges_list_it .

context GraphByMapDefs
begin

  definition [icf_rec_def]: "gbm_ops \<equiv> \<lparr>
    gop_\<alpha> = gbm_\<alpha>,
    gop_invar = gbm_invar,
    gop_empty = gbm_empty,
    gop_add_node = gbm_add_node,
    gop_delete_node = gbm_delete_node,
    gop_add_edge = gbm_add_edge,
    gop_delete_edge = gbm_delete_edge,
    gop_from_list = gbm_from_list,
    gop_to_list = gga_to_list,
    gop_nodes_list_it = gbm_nodes_list_it,
    gop_edges_list_it = gbm_edges_list_it,
    gop_succ_list_it  = gbm_succ_list_it
    \<rparr>"
  local_setup \<open>Locale_Code.lc_decl_del @{term gbm_ops}\<close>
end

locale GraphByMap = GraphByMapDefs m1_ops m2_ops s3_ops m1_mvif +
  m1: StdMap m1_ops +
  m2: StdMap m2_ops +
  s3: StdSet s3_ops +
  m1: map_value_image_filter m1.\<alpha> m1.invar m1.\<alpha> m1.invar m1_mvif
  for m1_ops::"('V,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('V,'s3,'m2,_) map_ops_scheme"
  and s3_ops::"('W,'s3,_) set_ops_scheme"
  and m1_mvif :: "('V \<Rightarrow> 'm2 \<rightharpoonup> 'm2) \<Rightarrow> 'm1 \<Rightarrow> 'm1"
begin
  lemma gbm_invar_split:
    assumes "gbm_invar g"
    shows
    "m1.invar g"
    "\<And>v m2. m1.\<alpha> g v = Some m2 \<Longrightarrow> m2.invar m2"
    "\<And>v m2 v' s3. m1.\<alpha> g v = Some m2 \<Longrightarrow> m2.\<alpha> m2 v' = Some s3 \<Longrightarrow> s3.invar s3"
    "valid_graph (gbm_\<alpha> g)"
    using assms unfolding gbm_invar_def
    by (auto intro: ranI)

end

sublocale GraphByMap < graph gbm_\<alpha> gbm_invar
proof
  fix g
  assume INV: "gbm_invar g"
  then interpret vg: valid_graph "(gbm_\<alpha> g)" by (simp add: gbm_invar_def)

  from vg.E_valid
  show "fst ` edges (gbm_\<alpha> g) \<subseteq> nodes (gbm_\<alpha> g)" and
    "snd ` snd ` edges (gbm_\<alpha> g) \<subseteq> nodes (gbm_\<alpha> g)" .

  from INV show "finite (nodes (gbm_\<alpha> g))"
    unfolding gbm_invar_def gbm_\<alpha>_def by auto

  note [simp] = gbm_invar_split[OF INV]

  show "finite (edges (gbm_\<alpha> g))"
    apply (rule finite_imageD[where f="\<lambda>(v,e,v'). (v,v',e)"])
    apply (rule finite_subset[where B=
      "map_Sigma (m1.\<alpha> g) (\<lambda>m2. map_Sigma (m2.\<alpha> m2) (s3.\<alpha>))"])
    apply (auto simp add: map_Sigma_def gbm_\<alpha>_def) []
    apply (unfold map_Sigma_alt)
    apply (auto intro!: finite_SigmaI inj_onI)
    done
qed

context GraphByMap
begin

  lemma gbm_empty_impl:
    "graph_empty gbm_\<alpha> gbm_invar gbm_empty"
    apply (unfold_locales)
    unfolding gbm_\<alpha>_def gbm_invar_def gbm_empty_def
    apply (auto simp: m1.correct Graph.empty_def)
    apply (unfold_locales)
    apply auto
    done

  lemma gbm_add_node_impl:
    "graph_add_node gbm_\<alpha> gbm_invar gbm_add_node"
  proof
    fix g v
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_add_node v g) = add_node v (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_add_node_def
      by (auto simp: m1.correct m2.correct s3.correct add_node_def
        split: option.split if_split_asm)

    thus "gbm_invar (gbm_add_node v g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_add_node_def add_node_def
      apply (auto simp: m1.correct m2.correct s3.correct add_node_def
        split: option.split if_split_asm elim!: ranE)
      done
  qed

  lemma gbm_delete_node_impl:
    "graph_delete_node gbm_\<alpha> gbm_invar gbm_delete_node"
  proof
    fix g v
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_delete_node v g) = delete_node v (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_delete_node_def
      by (auto simp: restrict_map_def option_bind_alt
        m1.correct m2.correct s3.correct m1.map_value_image_filter_correct
        delete_node_def
        split: option.split if_split_asm option.split_asm)

    thus "gbm_invar (gbm_delete_node v g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_delete_node_def delete_node_def
      apply (auto simp: restrict_map_def option_bind_alt
        m1.correct m2.correct s3.correct m1.map_value_image_filter_correct
        split: option.split if_split_asm option.split_asm elim!: ranE)
      done
  qed

  lemma gbm_add_edge_impl:
    "graph_add_edge gbm_\<alpha> gbm_invar gbm_add_edge"
  proof
    fix g v e v'
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_add_edge v e v' g) = add_edge v e v' (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_add_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split if_split_asm)
      unfolding add_edge_def
      (* Strange: This is at the limit of auto's capabilities:
        Iterated auto [] works., but auto on all goals seems not to
        terminate. Using fastforce instead.
        *)
      apply (fastforce split: if_split_asm
        simp: m1.correct m2.correct s3.correct
      )+
      done

    thus "gbm_invar (gbm_add_edge v e v' g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_add_edge_def
      apply (force simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split if_split_asm elim!: ranE)
      done
  qed

  lemma gbm_delete_edge_impl:
    "graph_delete_edge gbm_\<alpha> gbm_invar gbm_delete_edge"
  proof
    fix g v e v'
    assume INV: "gbm_invar g"
    note [simp]= gbm_invar_split[OF INV]
    show "gbm_\<alpha> (gbm_delete_edge v e v' g) = delete_edge v e v' (gbm_\<alpha> g)"
      unfolding gbm_\<alpha>_def gbm_delete_edge_def delete_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split if_split_asm)
      done

    thus "gbm_invar (gbm_delete_edge v e v' g)"
      unfolding gbm_invar_def
      apply (simp)
      unfolding gbm_\<alpha>_def gbm_delete_edge_def
      apply (auto simp: m1.correct m2.correct s3.correct
        Let_def
        split: option.split if_split_asm elim!: ranE)
      done
  qed

  lemma gbm_nodes_list_it_impl:
    shows "graph_nodes_it gbm_\<alpha> gbm_invar gbm_nodes_list_it"
  proof
    fix g
    assume "gbm_invar g"
    hence MINV: "map_op_invar m1_ops g" unfolding gbm_invar_def by auto
    from map_iterator_dom_correct[OF m1.iteratei_correct[OF MINV]]
    show "set_iterator (gbm_nodes_list_it g) (nodes (gbm_\<alpha> g))"
      unfolding gbm_nodes_list_it_def gbm_\<alpha>_def by simp
  qed

  lemma gbm_edges_list_it_impl:
    shows "graph_edges_it gbm_\<alpha> gbm_invar gbm_edges_list_it"
  proof
    fix g
    assume INV: "gbm_invar g"

    from INV have I1: "m1.invar g" unfolding gbm_invar_def by auto
    from INV have I2: "\<And>v m2. (v,m2)\<in>map_to_set (m1.\<alpha> g) \<Longrightarrow> m2.invar m2"
      unfolding gbm_invar_def map_to_set_def
      by (auto simp: ran_def)
    from INV have I3: "\<And>v m2 v' s. \<lbrakk>
      (v,m2)\<in>map_to_set (m1.\<alpha> g);
      (v',s)\<in>map_to_set (m2.\<alpha> m2)\<rbrakk>
      \<Longrightarrow> s3.invar s"
      unfolding gbm_invar_def map_to_set_def
      by (auto simp: ran_def)

    show "set_iterator (gbm_edges_list_it g) (edges (gbm_\<alpha> g))"
      unfolding gbm_edges_list_it_def
      apply (rule set_iterator_image_correct)
      apply (rule set_iterator_product_correct)
      apply (rule m1.iteratei_correct)
      apply (rule I1)
      apply (case_tac a)
      apply clarsimp
      apply (rule set_iterator_product_correct)
      apply (drule I2)
      apply (subgoal_tac "map_iterator (m2.iteratei ba)
        (map_op_\<alpha> m2_ops (snd (aa,ba)))")
      apply assumption
      apply (simp add: m2.iteratei_correct)

      apply (case_tac a)
      apply clarsimp
      apply (subgoal_tac "set_iterator (s3.iteratei bb)
        (s3.\<alpha> (snd (ab,bb)))")
      apply assumption
      apply (simp add: s3.iteratei_correct I3)

      apply (auto simp: inj_on_def map_to_set_def) []

      apply (force simp: gbm_\<alpha>_def map_to_set_def) []
      done
    qed

  lemma gbm_succ_list_it_impl:
    shows "graph_succ_it gbm_\<alpha> gbm_invar gbm_succ_list_it"
  proof
    fix g v
    assume INV: "gbm_invar g"
    hence I1[simp]: "m1.invar g" unfolding gbm_invar_def by auto

    show "set_iterator (gbm_succ_list_it g v) (succ (gbm_\<alpha> g) v)"
    proof (cases "m1.lookup v g")
      case None hence "(succ (gbm_\<alpha> g) v) = {}"
        unfolding succ_def gbm_\<alpha>_def by (auto simp: m1.lookup_correct)
      with None show ?thesis unfolding gbm_succ_list_it_def
        by (auto simp: set_iterator_emp_correct)
    next
      case (Some m2)
      hence [simp]: "m2.invar m2" using gbm_invar_split[OF INV]
        by (simp add: m1.lookup_correct)

      from INV Some have
        I2: "\<And>v' s. (v', s) \<in> map_to_set (map_op_\<alpha> m2_ops m2) \<Longrightarrow> s3.invar s"
        unfolding gbm_invar_def
        by (auto simp: map_to_set_def ran_def m1.lookup_correct)

      from Some show ?thesis
        unfolding gbm_succ_list_it_def apply simp
        apply (rule set_iterator_image_correct)
        apply (rule set_iterator_product_correct)
        apply (rule m2.iteratei_correct)
        apply simp
        apply (case_tac a, simp)
        apply (subgoal_tac "set_iterator (s3.iteratei b) (s3.\<alpha> (snd (aa, b)))")
        apply assumption
        apply simp
        apply (rule s3.iteratei_correct)
        apply (simp add: I2)

        apply (auto simp: inj_on_def map_to_set_def) []

        apply (force simp: succ_def gbm_\<alpha>_def map_to_set_def m1.lookup_correct)
        done
    qed
  qed

  lemma gbm_from_list_impl:
    shows "graph_from_list gbm_\<alpha> gbm_invar gbm_from_list"
    unfolding gbm_from_list_def
    apply (rule gga_from_list_correct)
    apply (rule gbm_empty_impl gbm_add_node_impl gbm_add_edge_impl)+
    done

end

sublocale GraphByMap < graph_nodes_it gbm_\<alpha> gbm_invar gbm_nodes_list_it
  by (rule gbm_nodes_list_it_impl)
sublocale GraphByMap < graph_edges_it gbm_\<alpha> gbm_invar gbm_edges_list_it
  by (rule gbm_edges_list_it_impl)
sublocale GraphByMap < graph_succ_it gbm_\<alpha> gbm_invar gbm_succ_list_it
  by (rule gbm_succ_list_it_impl)

sublocale GraphByMap
  < gga_to_list_loc gbm_\<alpha> gbm_invar gbm_nodes_list_it gbm_edges_list_it
  by unfold_locales

context GraphByMap
begin
  lemma gbm_to_list_impl: "graph_to_list gbm_\<alpha> gbm_invar gga_to_list"
    by (rule gga_to_list_correct)

  lemma gbm_ops_impl: "StdGraph gbm_ops"
    apply (rule StdGraph.intro)
    apply (simp_all add: icf_rec_unf)
    apply icf_locales
    apply (rule gbm_empty_impl gbm_add_node_impl gbm_delete_node_impl
      gbm_add_edge_impl gbm_delete_edge_impl gbm_from_list_impl
      gbm_to_list_impl)+
    done
end

setup \<open>
  (Record_Intf.add_unf_thms_global @{thms
    GraphByMapDefs.gbm_nodes_list_it_unf
    GraphByMapDefs.gbm_edges_list_it_unf
    GraphByMapDefs.gbm_succ_list_it_unf
  })
\<close>

end


(*  Title:       A while language
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

section "Hoare Logics for While"

theory Lang imports Main begin

subsection\<open>The language \label{sec:lang}\<close>

text\<open>We start by declaring a type of states:\<close>

typedecl state

text\<open>\noindent
Our approach is completely parametric in the state space.
We define expressions (\<open>bexp\<close>) as functions from states
to the booleans:\<close>

type_synonym bexp = "state \<Rightarrow> bool"

text\<open>
Instead of modelling the syntax of boolean expressions, we
model their semantics. The (abstract and concrete)
syntax of our programming is defined as a recursive datatype:
\<close>

datatype com = Do "(state \<Rightarrow> state set)"
             | Semi  com com            ("_; _"  [60, 60] 10)
             | Cond  bexp com com     ("IF _ THEN _ ELSE _"  60)
             | While bexp com           ("WHILE _ DO _"  60)
             | Local "(state \<Rightarrow> state)" com "(state \<Rightarrow> state \<Rightarrow> state)"
               ("LOCAL _; _; _" [0,0,60] 60)

text\<open>\noindent Statements in this language are called
\emph{commands}.  They are modelled as terms of type @{typ
com}. @{term"Do f"} represents an atomic nondeterministic command that
changes the state from @{term s} to some element of @{term"f s"}.
Thus the command that does nothing, often called \texttt{skip}, can be
represented by @{term"Do(\<lambda>s. {s})"}. Again we have chosen to model the
semantics rather than the syntax, which simplifies matters
enormously. Of course it means that we can no longer talk about
certain syntactic matters, but that is just fine.

The constructors @{term Semi}, @{term Cond} and @{term While}
represent sequential composition, conditional and while-loop.
The annotations allow us to write
\begin{center}
@{term"c\<^sub>1;c\<^sub>2"} \qquad @{term"IF b THEN c\<^sub>1 ELSE c\<^sub>2"}
 \qquad @{term"WHILE b DO c"}
\end{center}
instead of @{term[source]"Semi c\<^sub>1 c\<^sub>2"}, @{term[source]"Cond b c\<^sub>1 c\<^sub>2"}
and @{term[source]"While b c"}.

The command @{term"LOCAL f;c;g"} applies function \<open>f\<close> to the state,
executes @{term c}, and then combines initial and final state via function
\<open>g\<close>. More below.
The semantics of commands is defined inductively by a so-called
big-step semantics.\<close>

inductive
  exec :: "state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool" ("_/ -_\<rightarrow>/ _" [50,0,50] 50)
where
  (*<*)Do:(*>*)"t \<in> f s \<Longrightarrow> s -Do f\<rightarrow> t"

| (*<*)Semi:(*>*)"\<lbrakk> s0 -c1\<rightarrow> s1; s1 -c2\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c1;c2\<rightarrow> s2"

| (*<*)IfT:(*>*)"\<lbrakk>  b s; s -c1\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"
| (*<*)IfF:(*>*)"\<lbrakk> \<not>b s; s -c2\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"

| (*<*)WhileF:(*>*)"\<not>b s \<Longrightarrow> s -WHILE b DO c\<rightarrow> s"
| (*<*)WhileT:(*>*)"\<lbrakk> b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u \<rbrakk> \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"

| (*<*)Local:(*>*) "f s -c\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g\<rightarrow> g s t"

text\<open>Assuming that the state is a function from variables to values,
the declaration of a new local variable \<open>x\<close> with inital value
\<open>a\<close> can be modelled as
\<open>LOCAL (\<lambda>s. s(x := a s)); c; (\<lambda>s t. t(x := s x))\<close>.\<close>

lemma exec_Do_iff[iff]: "(s -Do f\<rightarrow> t) = (t \<in> f s)"
by(auto elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -IF b THEN c ELSE d\<rightarrow> t) =
              (s -if b s then c else d\<rightarrow> t)"
apply auto
apply(blast elim: exec.cases intro:exec.intros)+
done

lemma [iff]: "(s -LOCAL f; c; g\<rightarrow> u) = (\<exists>t. f s -c\<rightarrow> t \<and> u = g s t)"
by(fastforce elim: exec.cases intro:exec.intros)

lemma unfold_while:
 "(s -WHILE b DO c\<rightarrow> u) =
  (s -IF b THEN c;WHILE b DO c ELSE Do(\<lambda>s. {s})\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros split:if_split_asm)

lemma while_lemma[rule_format]:
"s -w\<rightarrow> t \<Longrightarrow> \<forall>b c. w = WHILE b DO c \<and> P s \<and>
                    (\<forall>s s'. P s \<and> b s \<and> s -c\<rightarrow> s' \<longrightarrow> P s') \<longrightarrow> P t \<and> \<not>b t"
apply(erule exec.induct)
apply clarify+
defer
apply clarify+
apply(subgoal_tac "P t")
apply blast
apply blast
done

lemma while_rule:
 "\<lbrakk>s -WHILE b DO c\<rightarrow> t; P s; \<forall>s s'. P s \<and> b s \<and> s -c\<rightarrow> s' \<longrightarrow> P s'\<rbrakk>
  \<Longrightarrow> P t \<and> \<not>b t"
apply(drule while_lemma)
prefer 2 apply assumption
apply blast
done

end


(* Author: Lukas Koller *)
theory DoubleTree
  imports Main tsp.MinSpanningTree tsp.TravelingSalesman tsp.EulerianTour "HOL-Hoare.Hoare_Logic"
begin

section \<open>\textsc{DoubleTree} Approximation Algorithm for \textsc{mTSP}\<close>

text \<open>Compute a Hamiltonian Cycle of an Eulerian Tour.\<close>
fun comp_hc_of_et :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "comp_hc_of_et [] H = H"
| "comp_hc_of_et [v] H = v#H"
| "comp_hc_of_et (v#P) H = (if v \<in> set H then comp_hc_of_et P H else comp_hc_of_et P (v#H))"

lemma comp_hc_of_et_tl_simps:
  shows "P \<noteq> [] \<Longrightarrow> hd P \<in> set H \<Longrightarrow> tl P \<noteq> [] \<Longrightarrow> comp_hc_of_et P H = comp_hc_of_et (tl P) H"
  and  "P \<noteq> [] \<Longrightarrow> hd P \<notin> set H \<or> tl P = [] \<Longrightarrow> comp_hc_of_et P H = comp_hc_of_et (tl P) (hd P#H)"
  by (induction P arbitrary: H rule: list012.induct) auto

lemma comp_hc_of_et_remdups_aux:
  assumes "distinct H" "length P > 0"
  shows "comp_hc_of_et P H = last P # remdups (rev (butlast P) @ H)"
  using assms
proof (induction P H rule: comp_hc_of_et.induct)
  case (3 u v P H)
  thus ?case by (fastforce simp: remdups_append)
qed (auto simp: distinct_remdups_id)

text \<open>This lemma is not needed. Just to show a different way of implementing \<open>comp_hc_of_et\<close>
using \<open>remdups\<close>.\<close>
lemma comp_hc_of_et_remdups:
  "comp_hc_of_et P [] = (if length P > 0 then last P#remdups (rev (butlast P)) else [])"
  using comp_hc_of_et_remdups_aux[of "[]" P] by auto

lemma hc_of_et_hd: "P \<noteq> [] \<Longrightarrow> last P = hd (comp_hc_of_et P H)"
  by (induction P H rule: comp_hc_of_et.induct) auto

lemma hc_of_et_last_aux: "H \<noteq> [] \<Longrightarrow> last H = last (comp_hc_of_et P H)"
  by (induction P H rule: comp_hc_of_et.induct) auto

lemma hc_of_et_last: "P \<noteq> [] \<Longrightarrow> hd P = last (comp_hc_of_et P [])"
proof (induction P rule: list012.induct)
  case (3 u v P)
  then show ?case
    using hc_of_et_last_aux[of "[u]" "v#P"] by auto
qed auto

lemma hc_of_et_set_eq: "set P \<union> set H = set (comp_hc_of_et P H)"
  by (induction P H rule: comp_hc_of_et.induct) auto

lemma hc_of_et_non_nil: "P \<noteq> [] \<Longrightarrow> (comp_hc_of_et P H) \<noteq> []"
  by (induction P H rule: comp_hc_of_et.induct) auto

lemma hc_of_et_distinct: "distinct H \<Longrightarrow> distinct (tl (comp_hc_of_et P H))"
  by (induction P H rule: comp_hc_of_et.induct) (auto simp: Let_def distinct_tl)

lemma hc_of_et_vs:
  assumes "is_et X P"
  shows "set (comp_hc_of_et P []) = mVs X"
proof
  show "set (comp_hc_of_et P []) \<subseteq> mVs X"
    using assms mem_path_Vs[of "set_mset X" P] is_etE[of X P]
          hc_of_et_set_eq[of P "[]"] by (auto simp: mpath_def2 mVs_def)
next
  show "mVs X \<subseteq> set (comp_hc_of_et P [])"
    unfolding mVs_def
  proof
    fix v
    assume "v \<in> Vs (set_mset X)"
    then obtain e where "e \<in># X" "v \<in> e"
      by (auto elim: vs_member_elim)
    moreover hence "e \<in># mset (edges_of_path P)"
      using assms is_etE[of X P] by auto
    ultimately show "v \<in> set (comp_hc_of_et P [])"
      using v_in_edge_in_path_gen[of e P v] hc_of_et_set_eq[of P] by auto
  qed
qed

lemma et_distinct_adj:
  assumes "mgraph_invar X" "is_et X P"
  shows "distinct_adj P"
proof -
  have "path (set_mset X) P"
    using assms is_etE by (auto simp: mpath_def2)
  thus ?thesis
    using assms path_distinct_adj by (auto simp: mgraph_invar_def2)
qed

lemma distinct_adj_tl_comp_hc_of_et:
  assumes "distinct_adj P" "distinct H"
  shows "distinct_adj (tl (comp_hc_of_et P H))"
  using assms by (induction P H rule: comp_hc_of_et.induct)
    (auto simp: distinct_tl distinct_distinct_adj)

lemma hd_remdups_append:
  assumes "x = hd (remdups (xs@[x]))"
  shows "xs = [] \<or> xs = [x] \<or> \<not> distinct_adj xs"
  using assms by (induction xs) (auto split: if_splits simp: distinct_adj_Cons)

lemma hd_tl_comp_hc_of_et_not_distinct_adj:
  assumes "u = hd (tl (comp_hc_of_et (u#P@[u]) []))"
  shows "\<not> distinct_adj (u#P@[u])" (is "\<not> distinct_adj ?P")
proof -
  have "u = hd (remdups (rev P@[u]))"
    using assms by (auto simp: comp_hc_of_et_remdups[of ?P])
  then consider "P = []" | "P = [u]" | "\<not> distinct_adj P"
    using hd_remdups_append[of u "rev P"] by auto
  thus ?thesis
    by cases (auto simp: distinct_adj_Cons distinct_adj_append_iff)
qed

lemma distinct_adj_last_neq_hd_tl:
  assumes "distinct_adj P" "length P > 1" "hd P = last P"
  shows "last P \<noteq> hd (tl (comp_hc_of_et P []))"
proof (rule ccontr; simp)
  assume "last P = hd (tl (comp_hc_of_et P []))"
  moreover obtain u P' where "P = u#P'@[u]"
    using assms
    by (metis append_butlast_last_id append_self_conv2 distinct_hd_last_neq distinct_singleton
        dual_order.strict_trans length_greater_0_conv less_one list.collapse tl_append2)
    (* TODO: clean up! *)
  ultimately have "\<not> distinct_adj P"
    using hd_tl_comp_hc_of_et_not_distinct_adj[of u P'] by auto
  thus "False"
    using assms by auto
qed

lemma distinct_adj_comp_hc_of_et:
  assumes "distinct_adj P" "P \<noteq> [] \<Longrightarrow> hd P = last P"
  shows "distinct_adj (comp_hc_of_et P [])"
  using assms
proof (induction  P rule: list012.induct) (* induction just for case distinction *)
  case (3 u v P)
  moreover hence "last (u#v#P) \<noteq> hd (tl (comp_hc_of_et (u#v#P) []))"
    using distinct_adj_Cons[of u "v#P"] distinct_adj_last_neq_hd_tl[of "u#v#P"] by auto
  moreover have "distinct_adj (tl (comp_hc_of_et (u#v#P) []))"
    using distinct_distinct_adj[OF hc_of_et_distinct[of "[]" "u#v#P"]] by auto
  ultimately show ?case
    using comp_hc_of_et_remdups[of "u#v#P"] by (auto simp: distinct_adj_Cons)
qed auto

locale hc_of_et =
  metric_graph_abs E c +
  mst E c comp_mst +
  eulerian comp_et for E :: "'a set set" and c comp_mst and comp_et :: "'a mgraph \<Rightarrow> 'a list"
begin

lemma hc_of_et_path:
  assumes "is_et X P" "set_mset X \<subseteq> E"
  shows "path E (comp_hc_of_et P [])" (is "path E ?H")
proof -
  have "set P \<subseteq> Vs E"
    using assms Vs_subset[of "set_mset X" E] is_etE[of X P]
    by (auto simp: mpath_def2 mem_path_Vs subsetI)
  hence "set ?H \<subseteq> Vs E"
    using hc_of_et_set_eq[of P "[]"] by auto
  moreover have "mgraph_invar X"
    using assms graph finite_subset[OF Vs_subset, of "set_mset X" E]
    by (auto simp: mgraph_invar_def2)
  moreover have "distinct_adj (comp_hc_of_et P [])"
    using calculation assms et_distinct_adj distinct_adj_comp_hc_of_et by (fastforce simp: is_etE)
  ultimately show ?thesis
    unfolding mpath_def using path_complete_graph[of ?H] by auto
qed

lemma hc_of_et_cycle:
  assumes "P \<noteq> []" "is_et X P"
  shows "hd (comp_hc_of_et P []) = last (comp_hc_of_et P [])" (is "hd ?H = last ?H")
proof -
  have "hd ?H = last P"
    using assms hc_of_et_hd[of P "[]"] by auto
  also have "... = hd P"
    using assms by (auto simp: is_etE)
  also have "... = last ?H"
    using assms hc_of_et_last by auto
  finally show ?thesis .
qed

lemma hc_of_et_walk_betw:
  assumes "P \<noteq> []" "is_et X P" "set_mset X \<subseteq> E"
  obtains v where "walk_betw E v (comp_hc_of_et P []) v"
proof
  let ?H="comp_hc_of_et P []"
  let ?v="hd ?H"
  show "walk_betw E ?v ?H ?v"
  proof (rule nonempty_path_walk_between)
    show "path E ?H" "?H \<noteq> []" "hd ?H = ?v" "last ?H = ?v"
      using assms hc_of_et_path[of X P] hc_of_et_non_nil[of P "[]"] hc_of_et_cycle[of P X] by auto
  qed
qed

lemma hc_of_et_correct:
  assumes "is_et X P" "mVs X = Vs E" "set_mset X \<subseteq> E"
  shows "is_hc E (comp_hc_of_et P [])"
proof (cases "P = []")
  assume "P = []"
  hence "X = {#}"
    using assms et_nil[of X] by auto
  hence "Vs E = {}"
    using assms by (auto simp: mVs_def Vs_def)
  hence "E = {}"
    using vs_member[of _ E] graph by fastforce
  then show ?thesis
    using \<open>P = []\<close> hc_nil_iff by auto
next
  assume "P \<noteq> []"
  then obtain v where "comp_hc_of_et P [] \<noteq> []" "walk_betw E v (comp_hc_of_et P []) v"
    using assms hc_of_et_non_nil by (auto elim: hc_of_et_walk_betw[of P X])
  then show ?thesis
    apply (rule is_hcI_nonnil)
    using assms hc_of_et_walk_betw[of P X] hc_of_et_vs[of X P] hc_of_et_distinct[of "[]" P]
          hc_of_et_cycle[of P X] by auto
qed

lemma cost_of_path_hc_of_et:
  assumes "set P \<union> set H \<subseteq> Vs E"
  shows "cost_of_path\<^sub>c (comp_hc_of_et P H) \<le> cost_of_path\<^sub>c (rev P @ H)"
  using assms
proof (induction P H rule: comp_hc_of_et.induct)
  case (3 u v P H)
  then show ?case
    using cost_of_path_app_tri_ineq[of "rev (v#P)" H u] by auto
qed auto

lemma hc_of_et_reduces_cost:
  "set P \<subseteq> Vs E \<Longrightarrow> cost_of_path\<^sub>c (comp_hc_of_et P []) \<le> cost_of_path\<^sub>c P"
  using cost_of_path_hc_of_et[of P "[]"] cost_of_path_rev[of P] by auto

end

locale double_tree_algo =
  metric_graph_abs E c +
  mst E c comp_mst +
  eulerian comp_et for E :: "'a set set" and c comp_mst and comp_et :: "'a mgraph \<Rightarrow> 'a list"
begin

definition double_tree where
  "double_tree = (
    let T = comp_mst c E;
        T\<^sub>2\<^sub>x = mset_set T + mset_set T;
        P = comp_et T\<^sub>2\<^sub>x in
        comp_hc_of_et P [])"

lemma T2x_eulerian:
  assumes "is_mst E c T" "T\<^sub>2\<^sub>x = mset_set T + mset_set T"
  shows "is_eulerian T\<^sub>2\<^sub>x"
  using assms[unfolded is_mst_def is_st_def] finite_E finite_subset[of T E]
        double_graph_eulerian[of T T\<^sub>2\<^sub>x] by auto

lemma T2x_vs:
  assumes "is_mst E c T" "T\<^sub>2\<^sub>x = mset_set T + mset_set T"
  shows "mVs T\<^sub>2\<^sub>x = Vs E"
  using assms[unfolded is_mst_def is_st_def] finite_subset[OF _ finite_E] by (auto simp: mVs_def)

lemma T2x_edges:
  assumes "is_mst E c T" "T\<^sub>2\<^sub>x = mset_set T + mset_set T"
  shows "set_mset T\<^sub>2\<^sub>x \<subseteq> E"
  using assms[unfolded is_mst_def is_st_def] finite_subset[OF _ finite_E] by auto

lemmas dt_correctness = T2x_eulerian[OF mst] T2x_vs[OF mst] T2x_edges[OF mst]

end

subsection \<open>Feasibility of \textsc{DoubleTree}\<close>

locale double_tree_algo_feasibility =
  hc_of_et +
  double_tree_algo
begin

lemma dt_is_hc: "is_hc E (double_tree)"
  unfolding double_tree_def Let_def
  apply (rule hc_of_et_correct, rule eulerian)
  using dt_correctness[OF is_connected] by auto

end

subsection \<open>Approximation of \textsc{DoubleTree}\<close>

locale mtsp_opt =
  metric_graph_abs E c for E :: "'a set set" and c +
  fixes OPT
  assumes opt: "is_mtsp OPT"
begin

lemma tl_hc_acyclic:
  assumes "is_hc E H"
  shows "is_acyclic (set (tl (edges_of_path H)))" (is "is_acyclic ?E\<^sub>H")
proof (rule ccontr)
  assume "\<not> is_acyclic ?E\<^sub>H"
  moreover have "path E (tl H)"
    using assms is_hc_path tl_path_is_path by auto
  moreover have "distinct (tl H)"
    using assms by (auto elim: is_hcE_nonnil)
  ultimately show "False"
    using non_acyclic_path_not_distinct[of "tl H", OF \<open>path E (tl H)\<close>]
    by (auto simp: edges_of_path_tl[of H])
qed

lemma tl_hc_Vs:
  assumes "is_hc E H"
  shows "Vs E = Vs (set (tl (edges_of_path H)))" (is "Vs E = Vs ?E\<^sub>H'")
proof -
  have "Vs E = set (tl H)"
    using assms by (auto simp: is_hcE)
  also have "... = Vs (set (edges_of_path (tl H)))"
    apply (cases "H = []")
    using vs_member[of _ "{}"] apply fastforce
    using hc_non_nil_length_gr2[of H, OF assms] vs_edges_path_eq[of "tl H"] apply auto
    done
  also have "... = Vs ?E\<^sub>H'"
    by (auto simp: edges_of_path_tl[of H])
  finally show ?thesis .
qed

lemma hc_connected_component:
  assumes "is_hc E H" "u = (tl H) ! i\<^sub>u" "i\<^sub>u < length (tl H)" "v = (tl H) ! i\<^sub>v" "i\<^sub>v < length (tl H)"
          "i\<^sub>u < i\<^sub>v"
  shows "u \<in> connected_component (set (edges_of_path (tl H))) v"
    (is "u \<in> connected_component ?E' v")
proof -
  let ?P="drop (i\<^sub>u + 1) (take (i\<^sub>v + 2) H)"
  let ?P'="drop i\<^sub>u (take (i\<^sub>v + 1) (tl H))"
  have "?P = ?P'"
    using drop_tl[of "i\<^sub>u + 1" "take (i\<^sub>v + 2) H"] tl_take[of "i\<^sub>v + 2" H] by auto

  have "u = H ! (i\<^sub>u + 1)" "v = H ! (i\<^sub>v + 1)"
    using assms nth_tl[of _ H] by auto
  hence "walk_betw E u ?P v" "length ?P > 1"
    using assms hc_walk_betw1[of E H "i\<^sub>u + 1" "i\<^sub>v + 1"] by auto
  hence "walk_betw (set (edges_of_path ?P')) u ?P' v"
    using assms \<open>?P = ?P'\<close> walk_on_edges_of_path[of E u ?P v] by auto
  hence "walk_betw ?E' u ?P' v"
    using edges_of_path_drop_take_subset[of i\<^sub>u "i\<^sub>v + 1" "tl H"]
            walk_subset[of "set (edges_of_path ?P')" ?E'] by auto
  then show "u \<in> connected_component ?E' v"
    using walk_symmetric[of ?E' u _ v] by auto
qed

lemma tl_hc_connected:
  assumes "is_hc E H"
  shows "is_connected (set (tl (edges_of_path H)))" (is "is_connected ?E'")
proof (rule is_connectedI)
  fix u v
  assume "u \<in> Vs ?E'" "v \<in> Vs ?E'"
  hence "u \<in> Vs (set (edges_of_path (tl H)))" "v \<in> Vs (set (edges_of_path (tl H)))"
    by (auto simp: edges_of_path_tl)
  hence "u \<in> set (tl H)" "v \<in> set (tl H)"
    using assms edges_of_path_Vs[of "tl H"] by auto
  then obtain i\<^sub>u i\<^sub>v where i\<^sub>u_i\<^sub>v_simps:"u = (tl H) ! i\<^sub>u" "i\<^sub>u < length (tl H)"
    "v = (tl H) ! i\<^sub>v" "i\<^sub>v < length (tl H)"
    using set_conv_nth[of "tl H"] by auto

  consider "i\<^sub>u = i\<^sub>v" | "i\<^sub>u < i\<^sub>v" | "i\<^sub>v < i\<^sub>u"
    by linarith
  then show "u \<in> connected_component ?E' v"
  proof cases
    assume "i\<^sub>u = i\<^sub>v"
    hence "u = v"
      using i\<^sub>u_i\<^sub>v_simps by auto
    then show "u \<in> connected_component ?E' v"
      using in_own_connected_component by auto
  next
    assume "i\<^sub>u < i\<^sub>v"
    then show "u \<in> connected_component ?E' v"
      using assms i\<^sub>u_i\<^sub>v_simps hc_connected_component by (auto simp: edges_of_path_tl)
  next
    assume "i\<^sub>v < i\<^sub>u"
    hence "v \<in> connected_component ?E' u"
      using assms i\<^sub>u_i\<^sub>v_simps hc_connected_component by (auto simp: edges_of_path_tl)
    then show "u \<in> connected_component ?E' v"
      using connected_components_member_sym[of v ?E' u] by auto
  qed
qed

lemma tl_hc_tree:
  assumes "is_hc E H"
  shows "is_tree (set (tl (edges_of_path H)))"
  using tl_hc_connected[OF assms] tl_hc_acyclic[OF assms] by (auto intro: is_treeI)

lemma tl_hc_st:
  assumes "is_hc E H"
  shows "is_st E (set (tl (edges_of_path H)))" (is "is_st E ?E\<^sub>H'")
  using assms hc_edges_subset set_tl_subset[of "edges_of_path H"] tl_hc_Vs tl_hc_tree
  by (intro is_stI) auto

lemma mst_mtsp_approx:
  assumes "is_mst E c T"
  shows "cost_of_st\<^sub>c T \<le> cost_of_path\<^sub>c OPT"
  using assms
proof cases
  assume "OPT = []"
  hence "E = {}"
    using opt assms hc_nil_iff by (auto simp: is_tspE)
  hence "T = {}"
    using assms is_stE[OF is_mstE(1)] by auto
  hence "cost_of_st\<^sub>c T = 0"
    by auto
  then show ?thesis
    using cost_of_path_pos by auto
next
  assume "OPT \<noteq> []"
  let ?E'="edges_of_path OPT"
  let ?e="hd (edges_of_path OPT)"
  have "is_st E (set (tl ?E'))"
    using opt assms tl_hc_st[of OPT] by (auto simp: is_tspE)
  hence "cost_of_st\<^sub>c T \<le> cost_of_st\<^sub>c (set (tl ?E'))"
    using assms by (auto elim: is_mstE)
  also have "... \<le> sum c (set ?E')"
    using costs_ge_0 sum_mono2[of "set ?E'" "set (tl ?E')" c] by (auto simp: set_tl_subset)
  also have "... \<le> cost_of_path\<^sub>c OPT"
    using cost_of_path_leq_sum[of OPT] by auto
  finally show ?thesis .
qed

end

locale double_tree_algo_approx =
  hc_of_et +
  double_tree_algo +
  mtsp_opt
begin

lemma cost_of_et:
  assumes "is_et T\<^sub>2 P"
  shows "cost_of_path\<^sub>c P = \<Sum>\<^sub># (image_mset c T\<^sub>2)"
  using assms cost_of_path_sum[of c P] et_edges[of T\<^sub>2 P] by auto

lemma et_not_single_v:
  assumes "is_mst E c T" "is_et T\<^sub>2 P"
  shows "length P \<noteq> 1"
  using assms
proof (induction P rule: list012.induct) (* induction just for case distinction *)
  case (2 v)
  hence "T\<^sub>2 = {#}" "mpath T\<^sub>2 [v]"
    using is_etE[of T\<^sub>2 "[v]"] by auto
  hence "mVs T\<^sub>2 = {}" "v \<in> mVs T\<^sub>2"
    unfolding mpath_def2 by (auto simp: mVs_def Vs_def)
  then show ?case by auto
qed auto

lemma hc_of_et_cost_le_dt:
  assumes "is_mst E c T" "T\<^sub>2 = mset_set T + mset_set T" "is_et T\<^sub>2 P"
  shows "cost_of_path\<^sub>c (comp_hc_of_et P []) \<le> 2 * cost_of_st\<^sub>c T"
proof -
  have "set P \<subseteq> Vs E"
    using assms et_vertices_len_neq_1[of T\<^sub>2 P, OF _ et_not_single_v] T2x_vs[of T T\<^sub>2] by auto
  hence "cost_of_path\<^sub>c (comp_hc_of_et P []) \<le> cost_of_path\<^sub>c P"
    using hc_of_et_reduces_cost[of P] by auto
  also have "... = \<Sum>\<^sub># (image_mset c T\<^sub>2)"
    using assms cost_of_et by auto
  also have "... = sum c T + sum c T"
    using assms by (simp add: sum_unfold_sum_mset)
  also have "... = 2 * cost_of_st\<^sub>c T"
    using mult_2 by auto
  finally show ?thesis .
qed

lemma dt_mst_approx:
  assumes "is_mst E c T"
  shows "cost_of_path\<^sub>c double_tree \<le> 2 * cost_of_st\<^sub>c T"
proof -
  let ?T="comp_mst c E"
  let ?T\<^sub>2="mset_set ?T + mset_set ?T"
  let ?P="comp_et ?T\<^sub>2"

  have "cost_of_path\<^sub>c double_tree = cost_of_path\<^sub>c (comp_hc_of_et ?P [])"
    unfolding double_tree_def by (auto simp: Let_def)
  also have "... \<le> 2 * cost_of_st\<^sub>c ?T"
    using mst[OF is_connected] hc_of_et_cost_le_dt[of ?T ?T\<^sub>2 ?P]
      eulerian[OF T2x_eulerian, of ?T ?T\<^sub>2] by auto
  also have "... = 2 * cost_of_st\<^sub>c T"
    using assms is_connected mst_eq_cost[OF mst] by auto
  finally show ?thesis .
qed

lemma dt_approx: "cost_of_path\<^sub>c double_tree \<le> 2 * cost_of_path\<^sub>c OPT"
proof -
  have "cost_of_path\<^sub>c double_tree \<le> 2 * cost_of_st\<^sub>c (comp_mst c E)"
    using is_connected dt_mst_approx[OF mst] by auto
  also have "... \<le> 2 * cost_of_path\<^sub>c OPT"
    using is_connected mst_mtsp_approx[OF mst] by (auto simp: mult_2_mono)
  finally show ?thesis .
qed

end

context metric_graph_abs
begin

abbreviation "double_tree \<equiv> double_tree_algo.double_tree E c"

theorem dt_is_hc:
  assumes mst: "\<And>E. is_connected E \<Longrightarrow> is_mst E c (comp_mst c E)"
      and eulerian: "\<And>E. is_eulerian E \<Longrightarrow> is_et E (comp_et E)"
    shows "is_hc E (double_tree comp_mst comp_et)"
  using assms by (intro double_tree_algo_feasibility.dt_is_hc) unfold_locales

theorem dt_approx:
  assumes mst: "\<And>E. is_connected E \<Longrightarrow> is_mst E c (comp_mst c E)"
      and eulerian: "\<And>E. is_eulerian E \<Longrightarrow> is_et E (comp_et E)"
      and "is_mtsp OPT"
    shows "cost_of_path\<^sub>c (double_tree comp_mst comp_et) \<le> 2 * cost_of_path\<^sub>c OPT"
  using assms
  by (intro double_tree_algo_approx.dt_approx) unfold_locales

(* ----- refine Double-Tree algorithm with Hoare-Logic ----- *)

lemma refine_double_tree:
  assumes mst: "\<And>E. is_connected E \<Longrightarrow> is_mst E c (comp_mst c E)"
    and eulerian: "\<And>E. is_eulerian E \<Longrightarrow> is_et E (comp_et E)"
    and "is_mtsp OPT"
  shows "VARS T T\<^sub>2\<^sub>x v P P' H { True }
  T := comp_mst c E;
  T\<^sub>2\<^sub>x := mset_set T + mset_set T;
  P := comp_et T\<^sub>2\<^sub>x;
  P' := P;
  H := [];
  WHILE P' \<noteq> []
  INV { comp_hc_of_et P [] = comp_hc_of_et P' H \<and> P = comp_et T\<^sub>2\<^sub>x \<and> T\<^sub>2\<^sub>x = mset_set T + mset_set T
    \<and> T = comp_mst c E }
  DO
    v := hd P';
    P' := tl P';
    IF v \<in> set H \<and> P' \<noteq> [] THEN
      H := H
    ELSE
      H := v#H
    FI
  OD { is_hc E H \<and> cost_of_path\<^sub>c H \<le> 2 * cost_of_path\<^sub>c OPT }"
proof (vcg, goal_cases)
  case (1 T T\<^sub>2\<^sub>x v P P' H)
  then show ?case
    by (auto simp: comp_hc_of_et_tl_simps)
next
  case (2 T T\<^sub>2\<^sub>x v P P' H)
  moreover hence "H = double_tree comp_mst comp_et"
    using assms 2
    apply (subst double_tree_algo.double_tree_def) (* TODO: why do I need subst here?! *)
    apply unfold_locales
    apply (auto simp: Let_def)
    done
  ultimately show ?case
    using assms dt_is_hc dt_approx by auto
qed

end

end


(*
    Author:   Salomon Sickert
    Author:   Benedikt Seidl
    Author:   Alexander Schimpf (original entry: CAVA/LTL_Rewrite.thy)
    License:  BSD
*)

section \<open>Rewrite Rules for LTL Simplification\<close>

theory Rewriting
imports
  LTL "HOL-Library.Extended_Nat"
begin

text \<open>This theory provides rewrite rules for the simplification of LTL formulas. It supports:
  \begin{itemize}
    \item Constants Removal
    \item @{const Next_ltln}-Normalisation
    \item Modal Simplification (based on pure eventual, pure universal, or suspendable formulas)
    \item Syntactic Implication Checking
  \end{itemize}
  It reuses parts of LTL\_Rewrite.thy (CAVA, LTL\_TO\_GBA). Furthermore, some rules were taken from
  \<^cite>\<open>"DBLP:conf/cav/SomenziB00"\<close> and \<^cite>\<open>"DBLP:conf/tacas/BabiakKRS12"\<close>. All functions are defined for @{type ltln}.\<close>

subsection \<open>Constant Eliminating Constructors\<close>

definition mk_and
where
  "mk_and x y \<equiv> case x of false\<^sub>n \<Rightarrow> false\<^sub>n | true\<^sub>n \<Rightarrow> y | _ \<Rightarrow> (case y of false\<^sub>n \<Rightarrow> false\<^sub>n | true\<^sub>n \<Rightarrow> x | _ \<Rightarrow> x and\<^sub>n y)"

definition mk_or
where
  "mk_or x y \<equiv> case x of false\<^sub>n \<Rightarrow> y | true\<^sub>n \<Rightarrow> true\<^sub>n | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> x | _ \<Rightarrow> x or\<^sub>n y)"

fun remove_strong_ops
where
  "remove_strong_ops (x U\<^sub>n y) = remove_strong_ops y"
| "remove_strong_ops (x M\<^sub>n y) = x and\<^sub>n y"
| "remove_strong_ops (x or\<^sub>n y) = remove_strong_ops x or\<^sub>n remove_strong_ops y"
| "remove_strong_ops x = x"

fun remove_weak_ops
where
  "remove_weak_ops (x R\<^sub>n y) = remove_weak_ops y"
| "remove_weak_ops (x W\<^sub>n y) = x or\<^sub>n y"
| "remove_weak_ops (x and\<^sub>n y) = remove_weak_ops x and\<^sub>n remove_weak_ops y"
| "remove_weak_ops x = x"

definition mk_finally
where
  "mk_finally x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> F\<^sub>n (remove_strong_ops x)"

definition mk_globally
where
  "mk_globally x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> G\<^sub>n (remove_weak_ops x)"

definition mk_until
where
  "mk_until x y \<equiv> case x of false\<^sub>n \<Rightarrow> y
    | true\<^sub>n \<Rightarrow> mk_finally y
    | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x U\<^sub>n y)"

definition mk_release
where
  "mk_release x y \<equiv> case x of true\<^sub>n \<Rightarrow> y
    | false\<^sub>n \<Rightarrow> mk_globally y
    | _ \<Rightarrow> (case y of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x R\<^sub>n y)"

definition mk_weak_until
where
  "mk_weak_until x y \<equiv> case y of true\<^sub>n \<Rightarrow> true\<^sub>n
    | false\<^sub>n \<Rightarrow> mk_globally x
    | _ \<Rightarrow> (case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> y | _ \<Rightarrow> x W\<^sub>n y)"

definition mk_strong_release
where
  "mk_strong_release x y \<equiv> case y of false\<^sub>n \<Rightarrow> false\<^sub>n
    | true\<^sub>n \<Rightarrow> mk_finally x
    | _ \<Rightarrow> (case x of true\<^sub>n \<Rightarrow> y | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> x M\<^sub>n y)"

definition mk_next
where
  "mk_next x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> X\<^sub>n x"

definition mk_next_pow ("X\<^sub>n''")
where
  "mk_next_pow n x \<equiv> case x of true\<^sub>n \<Rightarrow> true\<^sub>n | false\<^sub>n \<Rightarrow> false\<^sub>n | _ \<Rightarrow> (Next_ltln ^^ n) x"

lemma mk_and_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_and x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x and\<^sub>n y"
  unfolding mk_and_def by (cases x; cases y; simp)

lemma mk_or_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_or x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x or\<^sub>n y"
  unfolding mk_or_def by (cases x; cases y; simp)

lemma remove_strong_ops_sound [simp]:
  "w \<Turnstile>\<^sub>n F\<^sub>n (remove_strong_ops y) \<longleftrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n y"
  by (induction y arbitrary: w) (auto; force)+

lemma remove_weak_ops_sound [simp]:
  "w \<Turnstile>\<^sub>n G\<^sub>n (remove_weak_ops y) \<longleftrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n y"
  by (induction y arbitrary: w) (auto; force)+

lemma mk_finally_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_finally x \<longleftrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n x"
  by (simp add: mk_finally_def del: semantics_ltln.simps(8,9) remove_strong_ops.simps split: ltln.splits)

lemma mk_globally_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_globally x \<longleftrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n x"
  by (simp add: mk_globally_def del: semantics_ltln.simps(8,9) remove_weak_ops.simps split: ltln.splits)

lemma mk_until_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_until x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x U\<^sub>n y"
proof (cases x)
  case (True_ltln)
    show ?thesis
      unfolding True_ltln mk_until_def
      by (cases y) auto
next
  case (False_ltln)
    thus ?thesis
      by (force simp: mk_until_def)
qed (cases y; force simp: mk_until_def)+

lemma mk_release_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_release x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x R\<^sub>n y"
proof (cases x)
  case (False_ltln)
    thus ?thesis
      unfolding False_ltln mk_release_def
      by (cases y) auto
next
  case (True_ltln)
    thus ?thesis
      by (force simp: mk_release_def)
qed (cases y; force simp: mk_release_def)+

lemma mk_weak_until_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_weak_until x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x W\<^sub>n y"
proof (cases y)
  case (False_ltln)
    thus ?thesis
      unfolding False_ltln mk_weak_until_def
      by (cases x) auto
next
  case (True_ltln)
    thus ?thesis
      by (force simp: mk_weak_until_def)
qed (cases x; force simp: mk_weak_until_def)+

lemma mk_strong_release_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_strong_release x y \<longleftrightarrow> w \<Turnstile>\<^sub>n x M\<^sub>n y"
proof (cases y)
  case (True_ltln)
    show ?thesis
      unfolding True_ltln mk_strong_release_def
      by (cases x) auto
next
  case (False_ltln)
    thus ?thesis
      by (force simp: mk_strong_release_def)
qed (cases x; force simp: mk_strong_release_def)+

lemma mk_next_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_next x \<longleftrightarrow> w \<Turnstile>\<^sub>n X\<^sub>n x"
  unfolding mk_next_def by (cases x; auto)

lemma mk_next_pow_semantics [simp]:
  "w \<Turnstile>\<^sub>n mk_next_pow i x \<longleftrightarrow> suffix i w \<Turnstile>\<^sub>n x"
  by (induction i arbitrary: w; cases x)
     (auto simp: mk_next_pow_def)

lemma mk_next_pow_simp [simp, code_unfold]:
  "mk_next_pow 0 x = x"
  "mk_next_pow 1 x = mk_next x"
  by (cases x; simp add: mk_next_pow_def mk_next_def)+

subsection \<open>Constant Propagation\<close>

fun is_constant :: "'a ltln \<Rightarrow> bool"
where
  "is_constant true\<^sub>n = True"
| "is_constant false\<^sub>n = True"
| "is_constant _ = False"

lemma is_constant_constructorsI:
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_and x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_and x y)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_or x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_or x y)"
  "is_constant x \<Longrightarrow>  is_constant (mk_finally x)"
  "\<not>is_constant x \<Longrightarrow>  \<not>is_constant (mk_finally x)"
  "is_constant x \<Longrightarrow> is_constant (mk_globally x)"
  "\<not>is_constant x \<Longrightarrow>  \<not>is_constant (mk_globally x)"
  "is_constant x \<Longrightarrow> is_constant (mk_until y x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_until y x)"
  "is_constant x \<Longrightarrow> is_constant (mk_release y x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_release y x)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_weak_until x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_weak_until x y)"
  "is_constant x \<Longrightarrow> is_constant y \<Longrightarrow> is_constant (mk_strong_release x y)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant y \<Longrightarrow> \<not>is_constant (mk_strong_release x y)"
  "is_constant x \<Longrightarrow> is_constant (mk_next x)"
  "\<not>is_constant x \<Longrightarrow> \<not>is_constant (mk_next x)"
  "is_constant x \<Longrightarrow> is_constant (mk_next_pow n x)"
  by (cases x; cases y; simp add: mk_and_def mk_or_def mk_finally_def mk_globally_def mk_until_def mk_release_def mk_weak_until_def mk_strong_release_def mk_next_def mk_next_pow_def)+

lemma is_constant_constructors_simps:
  "mk_next_pow n x = false\<^sub>n \<longleftrightarrow> x = false\<^sub>n"
  "mk_next_pow n x = true\<^sub>n \<longleftrightarrow> x = true\<^sub>n"
  "is_constant (mk_next_pow n x) \<longleftrightarrow> is_constant x"
  by (induction n) (cases x; simp add: mk_next_pow_def)+

lemma is_constant_constructors_simps2:
  "is_constant (mk_and x y) \<longleftrightarrow> (x = true\<^sub>n \<and> y = true\<^sub>n \<or> x = false\<^sub>n \<or> y = false\<^sub>n)"
  "is_constant (mk_or x y) \<longleftrightarrow> (x = false\<^sub>n \<and> y = false\<^sub>n \<or> x = true\<^sub>n \<or> y = true\<^sub>n)"
  "is_constant (mk_finally x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_globally x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_until y x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_release y x) \<longleftrightarrow> is_constant x"
  "is_constant (mk_next x) \<longleftrightarrow> is_constant x"
  by ((cases x; cases y; simp add: mk_and_def),
      (cases x; cases y; simp add: mk_or_def),
      (meson is_constant_constructorsI)+)

lemma is_constant_constructors_simps3:
  "is_constant (mk_weak_until x y) \<longleftrightarrow> (x = false\<^sub>n \<and> y = false\<^sub>n \<or> x = true\<^sub>n \<or> y = true\<^sub>n)"
  "is_constant (mk_strong_release x y) \<longleftrightarrow> (x = true\<^sub>n \<and> y = true\<^sub>n \<or> x = false\<^sub>n \<or> y = false\<^sub>n)"
  by (cases x; cases y; simp add: mk_weak_until_def mk_strong_release_def is_constant_constructors_simps2)+

lemma is_constant_semantics:
  "is_constant \<phi> \<Longrightarrow> ((\<forall>w. w \<Turnstile>\<^sub>n \<phi>) \<or> \<not>(\<exists>w. w \<Turnstile>\<^sub>n \<phi>))"
  by (cases \<phi>) auto

lemma until_constant_simp:
  "is_constant \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (cases \<psi>) auto

lemma release_constant_simp:
  "is_constant \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (cases \<psi>) auto

lemma mk_next_pow_dist:
  "mk_next_pow (i + j) \<phi> = mk_next_pow i (mk_next_pow j \<phi>)"
  by (cases j; simp) (cases \<phi>; simp add: mk_next_pow_def funpow_add; simp add: funpow_swap1)

lemma mk_next_pow_until:
  "suffix (min i j) w \<Turnstile>\<^sub>n (mk_next_pow (i - j) \<phi>) U\<^sub>n (mk_next_pow (j - i) \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (mk_next_pow i \<phi>) U\<^sub>n (mk_next_pow j \<psi>)"
  by (simp add: mk_next_pow_dist min_def add.commute)

lemma mk_next_pow_release:
  "suffix (min i j) w \<Turnstile>\<^sub>n (mk_next_pow (i - j) \<phi>) R\<^sub>n (mk_next_pow (j - i) \<psi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n (mk_next_pow i \<phi>) R\<^sub>n (mk_next_pow j \<psi>)"
  by (simp add: mk_next_pow_dist min_def add.commute)

subsection \<open>X-Normalisation\<close>

text \<open>The following rewrite functions pulls the X-operator up in the syntax tree. This preprocessing
  step enables the removal of X-operators in front of suspendable formulas. Furthermore constants are
  removed as far as possible.\<close>

fun the_enat_0 :: "enat \<Rightarrow> nat"
where
  "the_enat_0 i = i"
| "the_enat_0 \<infinity> = 0"

lemma the_enat_0_simp [simp]:
  "the_enat_0 0 = 0"
  "the_enat_0 1 = 1"
  by (simp add: zero_enat_def one_enat_def)+

fun combine :: "('a ltln \<Rightarrow> 'a ltln \<Rightarrow> 'a ltln) \<Rightarrow> ('a ltln * enat) \<Rightarrow> ('a ltln * enat) \<Rightarrow> ('a ltln * enat)"
where
  "combine binop (\<phi>, i) (\<psi>, j) = (
    let
      \<chi> = binop (mk_next_pow (the_enat_0 (i - j)) \<phi>) (mk_next_pow (the_enat_0 (j - i)) \<psi>)
    in
      (\<chi>, if is_constant \<chi> then \<infinity> else min i j))"

lemma fst_combine:
  "fst (combine binop (\<phi>, i) (\<psi>, j)) = binop (mk_next_pow (the_enat_0 (i - j)) \<phi>) (mk_next_pow (the_enat_0 (j - i)) \<psi>)"
  unfolding combine.simps by (meson fstI)

abbreviation to_ltln :: "('a ltln * enat) \<Rightarrow> 'a ltln"
where
  "to_ltln x \<equiv> mk_next_pow (the_enat_0 (snd x)) (fst x)"

fun rewrite_X_enat :: "'a ltln \<Rightarrow> ('a ltln * enat)"
where
  "rewrite_X_enat true\<^sub>n = (true\<^sub>n, \<infinity>)"
| "rewrite_X_enat false\<^sub>n = (false\<^sub>n, \<infinity>)"
| "rewrite_X_enat prop\<^sub>n(a) = (prop\<^sub>n(a), 0)"
| "rewrite_X_enat nprop\<^sub>n(a) = (nprop\<^sub>n(a), 0)"
| "rewrite_X_enat (\<phi> and\<^sub>n \<psi>) = combine mk_and (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> or\<^sub>n \<psi>) = combine mk_or (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> U\<^sub>n \<psi>) = combine mk_until (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> R\<^sub>n \<psi>) = combine mk_release (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> W\<^sub>n \<psi>) = combine mk_weak_until (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (\<phi> M\<^sub>n \<psi>) = combine mk_strong_release (rewrite_X_enat \<phi>) (rewrite_X_enat \<psi>)"
| "rewrite_X_enat (X\<^sub>n \<phi>) = (\<lambda>(\<phi>, n). (\<phi>, eSuc n)) (rewrite_X_enat \<phi>)"

definition
  "rewrite_X \<phi> = to_ltln (rewrite_X_enat \<phi>)"

lemma combine_infinity_invariant:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant x"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant y"
  shows "combine mk_and (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_or (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_until (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_release (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_weak_until (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
    and "combine mk_strong_release (x, i) (y, j) = (z, k) \<Longrightarrow> (k = \<infinity> \<longleftrightarrow> is_constant z)"
  by (cases i; cases j; simp add: assms Let_def; force intro: is_constant_constructorsI)+

lemma combine_and_or_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_and (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) and\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_or (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) or\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: min_def is_constant_constructors_simps is_constant_constructors_simps2 assms),
      (cases \<psi>; insert assms; auto),
      (cases \<phi>; insert assms; auto),
      (blast elim!: is_constant.elims))+

lemma combine_until_release_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_until (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) U\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_release (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) R\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: is_constant_constructors_simps is_constant_constructors_simps2
       until_constant_simp release_constant_simp mk_next_pow_until mk_next_pow_release del: semantics_ltln.simps),
      (blast dest: is_constant_semantics),
      (cases \<psi>; simp add: assms),
      (cases \<phi>; insert assms; auto simp: add.commute))+

(* TODO this proof is a bit slow and could be optimized *)
lemma combine_weak_until_strong_release_semantics:
  assumes "i = \<infinity> \<longleftrightarrow> is_constant \<phi>"
  assumes "j = \<infinity> \<longleftrightarrow> is_constant \<psi>"
  shows "w \<Turnstile>\<^sub>n to_ltln (combine mk_weak_until (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) W\<^sub>n to_ltln (\<psi>, j)"
    and "w \<Turnstile>\<^sub>n to_ltln (combine mk_strong_release (\<phi>, i) (\<psi>, j)) \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (\<phi>, i) M\<^sub>n to_ltln (\<psi>, j)"
  by ((cases i; cases j; simp add: min_def is_constant_constructors_simps is_constant_constructors_simps3 del: semantics_ltln.simps),
      (cases \<phi>; simp add: assms),
      (cases \<psi>; insert assms; auto simp: add.commute))+

lemma rewrite_X_enat_infinity_invariant:
  "snd (rewrite_X_enat \<phi>) = \<infinity> \<longleftrightarrow> is_constant (fst (rewrite_X_enat \<phi>))"
proof (induction \<phi>)
  case (And_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF And_ltln(1,2), unfolded prod.collapse])
next
  case (Or_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Or_ltln(1,2), unfolded prod.collapse])
next
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Until_ltln(1,2), unfolded prod.collapse])
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF Release_ltln(1,2), unfolded prod.collapse])
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF WeakUntil_ltln(1,2), unfolded prod.collapse])
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      by (simp add: combine_infinity_invariant[OF StrongRelease_ltln(1,2), unfolded prod.collapse])
next
  case (Next_ltln \<phi>)
    thus ?case
      by (simp add: split_def) (metis eSuc_infinity eSuc_inject)
qed auto

lemma rewrite_X_enat_correct:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat \<phi>)"
proof (induction \<phi> arbitrary: w)
  case (And_ltln \<phi> \<psi>)
    thus ?case
      using combine_and_or_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant] by fastforce
next
  case (Or_ltln \<phi> \<psi>)
    thus ?case
      using combine_and_or_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant] by fastforce
next
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_until_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_until_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_weak_until_strong_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      unfolding rewrite_X_enat.simps combine_weak_until_strong_release_semantics[OF rewrite_X_enat_infinity_invariant rewrite_X_enat_infinity_invariant, unfolded prod.collapse] by fastforce
next
  case (Next_ltln \<phi>)
  moreover
    have " w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat (X\<^sub>n \<phi>)) \<longleftrightarrow> suffix 1 w \<Turnstile>\<^sub>n to_ltln (rewrite_X_enat \<phi>)"
      by (simp add: split_def; cases "snd (rewrite_X_enat \<phi>) \<noteq> \<infinity>")
         (auto simp: eSuc_def, auto simp: rewrite_X_enat_infinity_invariant eSuc_def dest: is_constant_semantics)
    ultimately
    show ?case
       using semantics_ltln.simps(7) by blast
qed auto

lemma rewrite_X_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_X \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using rewrite_X_enat_correct unfolding rewrite_X_def Let_def by auto

subsection \<open>Pure Eventual, Pure Universal, and Suspendable Formulas\<close>

fun pure_eventual :: "'a ltln \<Rightarrow> bool"
where
  "pure_eventual true\<^sub>n = True"
| "pure_eventual false\<^sub>n = True"
| "pure_eventual (\<mu> and\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> or\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> U\<^sub>n \<mu>') = (\<mu> = true\<^sub>n \<or> pure_eventual \<mu>')"
| "pure_eventual (\<mu> R\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> W\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>')"
| "pure_eventual (\<mu> M\<^sub>n \<mu>') = (pure_eventual \<mu> \<and> pure_eventual \<mu>' \<or> \<mu>' = true\<^sub>n)"
| "pure_eventual (X\<^sub>n \<mu>) = pure_eventual \<mu>"
| "pure_eventual _ = False"

fun pure_universal :: "'a ltln \<Rightarrow> bool"
where
  "pure_universal true\<^sub>n = True"
| "pure_universal false\<^sub>n = True"
| "pure_universal (\<nu> and\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> or\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> U\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (\<nu> R\<^sub>n \<nu>') = (\<nu> = false\<^sub>n \<or> pure_universal \<nu>')"
| "pure_universal (\<nu> W\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>' \<or> \<nu>' = false\<^sub>n)"
| "pure_universal (\<nu> M\<^sub>n \<nu>') = (pure_universal \<nu> \<and> pure_universal \<nu>')"
| "pure_universal (X\<^sub>n \<nu>) = pure_universal \<nu>"
| "pure_universal _ = False"

fun suspendable :: "'a ltln \<Rightarrow> bool"
where
  "suspendable true\<^sub>n = True"
| "suspendable false\<^sub>n = True"
| "suspendable (\<xi> and\<^sub>n \<xi>') = (suspendable \<xi> \<and> suspendable \<xi>')"
| "suspendable (\<xi> or\<^sub>n \<xi>') = (suspendable \<xi> \<and> suspendable \<xi>')"
| "suspendable (\<phi> U\<^sub>n \<xi>) = (\<phi> = true\<^sub>n \<and> pure_universal \<xi> \<or> suspendable \<xi>)"
| "suspendable (\<phi> R\<^sub>n \<xi>) = (\<phi> = false\<^sub>n \<and> pure_eventual \<xi> \<or> suspendable \<xi>)"
| "suspendable (\<phi> W\<^sub>n \<xi>) = (suspendable \<phi> \<and> suspendable \<xi> \<or> pure_eventual \<phi> \<and> \<xi> = false\<^sub>n)"
| "suspendable (\<phi> M\<^sub>n \<xi>) = (suspendable \<phi> \<and> suspendable \<xi> \<or> pure_universal \<phi> \<and> \<xi> = true\<^sub>n)"
| "suspendable (X\<^sub>n \<xi>) = suspendable \<xi>"
| "suspendable _ = False"

lemma pure_eventual_left_append:
  "pure_eventual \<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<mu> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu>"
proof (induction \<mu> arbitrary: u w)
  case (Until_ltln \<mu> \<mu>')
    moreover
    then obtain i where "suffix i w \<Turnstile>\<^sub>n \<mu>'"
      by auto
    hence "\<mu> = true\<^sub>n \<Longrightarrow> ?case"
      by simp (metis suffix_conc_length suffix_suffix)
    moreover
    have "pure_eventual \<mu>' \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu>'"
      by (metis \<open>suffix i w \<Turnstile>\<^sub>n \<mu>'\<close> Until_ltln(2) prefix_suffix)
    hence "pure_eventual \<mu>' \<Longrightarrow> ?case"
      by force
    ultimately
    show ?case
      by fastforce
next
  case (Release_ltln \<mu> \<mu>')
    thus ?case
      by (cases "\<forall>i. suffix i w \<Turnstile>\<^sub>n \<mu>'"; simp_all)
         (metis linear suffix_conc_snd gr0I not_less0 prefix_suffix suffix_0)+
next
  case (WeakUntil_ltln \<mu> \<mu>')
    thus ?case
      by (cases "\<forall>i. suffix i w \<Turnstile>\<^sub>n \<mu>'"; simp_all)
         (metis zero_le le0 nat_le_linear prefix_suffix suffix_0 suffix_conc_length suffix_conc_snd suffix_subseq_join)+
next
  case (StrongRelease_ltln \<mu> \<mu>')
    moreover
    then obtain i where "suffix i w \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'"
      by auto
    hence "\<mu>' = true\<^sub>n \<Longrightarrow> ?case"
      by simp (metis suffix_conc_length suffix_suffix)
    moreover
    have "pure_eventual \<mu> \<Longrightarrow> pure_eventual \<mu>' \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'"
      by (metis \<open>suffix i w \<Turnstile>\<^sub>n \<mu> and\<^sub>n \<mu>'\<close> calculation(1) calculation(2) prefix_suffix semantics_ltln.simps(5))
    hence "pure_eventual \<mu> \<Longrightarrow> pure_eventual \<mu>' \<Longrightarrow> ?case"
      by force
    ultimately
    show ?case
      by fastforce
qed (auto, metis diff_zero le_0_eq not_less_eq_eq suffix_conc_length suffix_conc_snd word_split)

lemma pure_universal_suffix_closed:
  "pure_universal \<nu> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<nu>"
proof (induction \<nu> arbitrary: u w)
  case (Until_ltln \<nu> \<nu>')
    hence "\<exists>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu>' \<and> (\<forall>j<i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>)"
      using semantics_ltln.simps(8) by blast
    thus ?case
      by simp (metis Until_ltln(1-3) le_0_eq le_eq_less_or_eq le_less_linear prefix_suffix pure_universal.simps(5) suffix_conc_fst suffix_conc_snd)
next
  case (Release_ltln \<nu> \<nu>')
    moreover
    hence "\<forall>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu>' \<or> (\<exists>j<i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>)"
      by simp
    ultimately
    show ?case
      by simp (metis semantics_ltln.simps(2) not_less0 prefix_suffix suffix_0 suffix_conc_length suffix_suffix)
next
  case (WeakUntil_ltln \<nu> \<nu>')
    moreover
    hence "\<forall>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<or> (\<exists>j\<le>i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>')"
      by simp
    ultimately
    show ?case
      by simp (metis (full_types) le_antisym prefix_suffix semantics_ltln.simps(2) suffix_0 suffix_conc_length suffix_suffix zero_le)
next
  case (StrongRelease_ltln \<nu> \<nu>')
    hence "\<exists>i. suffix i (u \<frown> w) \<Turnstile>\<^sub>n \<nu> \<and> (\<forall>j\<le>i. suffix j (u \<frown> w) \<Turnstile>\<^sub>n \<nu>')"
      using semantics_ltln.simps(11) by blast
    thus ?case
      by simp (metis StrongRelease_ltln(1-3) diff_is_0_eq nat_le_linear prefix_conc_length prefix_suffix pure_universal.simps(8) subsequence_length suffix_conc_snd suffix_subseq_join)
next
  case (Next_ltln \<mu>)
    thus ?case
      by (metis prefix_suffix pure_universal.simps(9) semantics_ltln.simps(7) semiring_normalization_rules(24) suffix_conc_length suffix_suffix)
qed auto

lemma suspendable_prefix_invariant:
  "suspendable \<xi> \<Longrightarrow> (u \<frown> w) \<Turnstile>\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>"
proof (induction \<xi> arbitrary: u w)
  case (Until_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi>'")
      case False
        hence "\<xi> = true\<^sub>n" and "pure_universal \<xi>'"
          using Until_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) linear pure_universal_suffix_closed suffix_conc_fst suffix_conc_length suffix_conc_snd suffix_suffix)
    qed (simp; metis Until_ltln(2) not_less0 prefix_suffix)
next
  case (Release_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi>'")
      case False
        hence "\<xi> = false\<^sub>n" and "pure_eventual \<xi>'"
          using Release_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) le_iff_add add_diff_cancel_left' linear pure_eventual_left_append suffix_0 suffix_conc_fst suffix_conc_snd)
    qed (simp; metis Release_ltln(2) not_less0 prefix_suffix)
next
  case (WeakUntil_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi> \<and> suspendable \<xi>'")
      case False
        hence "\<xi>' = false\<^sub>n" and "pure_eventual \<xi>"
          using WeakUntil_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) le_iff_add add_diff_cancel_left' linear pure_eventual_left_append suffix_0 suffix_conc_fst suffix_conc_snd)
      qed (simp; metis (full_types) WeakUntil_ltln.IH prefix_suffix)
next
  case (StrongRelease_ltln \<xi> \<xi>')
    show ?case
    proof (cases "suspendable \<xi> \<and> suspendable \<xi>'")
      case False
        hence "\<xi>' = true\<^sub>n" and "pure_universal \<xi>"
          using StrongRelease_ltln by simp+
        thus ?thesis
          by (simp; metis (no_types) linear pure_universal_suffix_closed suffix_conc_fst suffix_conc_length suffix_conc_snd suffix_suffix)
    qed (simp; metis (full_types) StrongRelease_ltln.IH(1) StrongRelease_ltln.IH(2) prefix_suffix)
qed (simp_all, metis prefix_suffix)

theorem pure_eventual_until_simp:
  assumes "pure_eventual \<mu>"
  shows "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<mu> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<mu>"
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<mu>"
    using pure_eventual_left_append[OF assms] prefix_suffix by metis
  thus ?thesis
    by force
qed

theorem pure_universal_release_simp:
  assumes "pure_universal \<nu>"
  shows "w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<nu> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<nu>"
proof -
  have "\<And>i. w \<Turnstile>\<^sub>n \<nu> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<nu>"
    using pure_universal_suffix_closed[OF assms] prefix_suffix by metis
  thus ?thesis
    by force
qed

theorem pure_universal_weak_until_simp:
  assumes "pure_universal \<phi>" and "pure_universal \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> W\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
proof -
  have "\<And>i. w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> suffix i w \<Turnstile>\<^sub>n \<psi>"
    using assms pure_universal_suffix_closed prefix_suffix by metis+
  thus ?thesis
    by force
qed

theorem pure_eventual_strong_release_simp:
  assumes "pure_eventual \<phi>" and "pure_eventual \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> and\<^sub>n \<psi>"
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. suffix i w \<Turnstile>\<^sub>n \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi>"
    using assms pure_eventual_left_append prefix_suffix by metis+
  thus ?thesis
    by force
qed

theorem suspendable_formula_simp:
  assumes "suspendable \<xi>"
  shows "w \<Turnstile>\<^sub>n X\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t1)
    and "w \<Turnstile>\<^sub>n \<phi> U\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t2)
    and "w \<Turnstile>\<^sub>n \<phi> R\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>" (is ?t3)
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<xi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<xi>"
    using suspendable_prefix_invariant[OF assms] prefix_suffix by metis
  thus ?t1 ?t2 ?t3
    by force+
qed

theorem suspendable_formula_simp2:
  assumes "suspendable \<phi>" and "suspendable \<psi>"
  shows "w \<Turnstile>\<^sub>n \<phi> W\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>" (is ?t1)
    and "w \<Turnstile>\<^sub>n \<phi> M\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi> and\<^sub>n \<psi>" (is ?t2)
proof -
  have "\<And>i. suffix i w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>" and "\<And>i. suffix i w \<Turnstile>\<^sub>n \<psi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<psi>"
    using assms suspendable_prefix_invariant prefix_suffix by metis+
  thus ?t1 ?t2
    by force+
qed

fun rewrite_modal :: "'a ltln \<Rightarrow> 'a ltln"
where
  "rewrite_modal true\<^sub>n = true\<^sub>n"
| "rewrite_modal false\<^sub>n = false\<^sub>n"
| "rewrite_modal (\<phi> and\<^sub>n \<psi>) = (rewrite_modal \<phi> and\<^sub>n rewrite_modal \<psi>)"
| "rewrite_modal (\<phi> or\<^sub>n \<psi>) = (rewrite_modal \<phi> or\<^sub>n rewrite_modal \<psi>)"
| "rewrite_modal (\<phi> U\<^sub>n \<psi>) = (if pure_eventual \<psi> \<or> suspendable \<psi> then rewrite_modal \<psi> else (rewrite_modal \<phi> U\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> R\<^sub>n \<psi>) = (if pure_universal \<psi> \<or> suspendable \<psi> then rewrite_modal \<psi> else (rewrite_modal \<phi> R\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> W\<^sub>n \<psi>) = (if pure_universal \<phi> \<and> pure_universal \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi> then (rewrite_modal \<phi> or\<^sub>n rewrite_modal \<psi>) else (rewrite_modal \<phi> W\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (\<phi> M\<^sub>n \<psi>) = (if pure_eventual \<phi> \<and> pure_eventual \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi> then (rewrite_modal \<phi> and\<^sub>n rewrite_modal \<psi>) else (rewrite_modal \<phi> M\<^sub>n rewrite_modal \<psi>))"
| "rewrite_modal (X\<^sub>n \<phi>) = (if suspendable \<phi> then rewrite_modal \<phi> else X\<^sub>n (rewrite_modal \<phi>))"
| "rewrite_modal \<phi> = \<phi>"

lemma rewrite_modal_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_modal \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (Until_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_eventual \<psi> \<or> suspendable \<psi>")
      apply (insert pure_eventual_until_simp[of \<psi>] suspendable_formula_simp[of \<psi>])
      apply fastforce+
      done
next
  case (Release_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_universal \<psi> \<or> suspendable \<psi>")
      apply (insert pure_universal_release_simp[of \<psi>] suspendable_formula_simp[of \<psi>])
      apply fastforce+
      done
next
  case (WeakUntil_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_universal \<phi> \<and> pure_universal \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi>")
      apply (insert pure_universal_weak_until_simp[of \<phi> \<psi>] suspendable_formula_simp2[of \<phi> \<psi>])
      apply fastforce+
      done
next
  case (StrongRelease_ltln \<phi> \<psi>)
    thus ?case
      apply (cases "pure_eventual \<phi> \<and> pure_eventual \<psi> \<or> suspendable \<phi> \<and> suspendable \<psi>")
      apply (insert pure_eventual_strong_release_simp[of \<phi> \<psi>] suspendable_formula_simp2[of \<phi> \<psi>])
      apply fastforce+
      done
next
  case (Next_ltln \<phi>)
    thus ?case
      apply (cases "suspendable \<phi>")
      apply (insert suspendable_formula_simp[of \<phi>])
      apply fastforce+
      done
qed auto

lemma rewrite_modal_size:
  "size (rewrite_modal \<phi>) \<le> size \<phi>"
  by (induction \<phi>) auto

subsection \<open>Syntactical Implication Based Simplification\<close>

inductive syntactical_implies :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" ("_ \<turnstile>\<^sub>s _" [80, 80])
where
  "_ \<turnstile>\<^sub>s true\<^sub>n"
| "false\<^sub>n \<turnstile>\<^sub>s _"
| "\<phi> = \<phi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s \<phi>"

| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> and\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> and\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> and\<^sub>n \<chi>)"

| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> or\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> or\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> or\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"

| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<phi> \<turnstile>\<^sub>s (\<psi> U\<^sub>n \<chi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> (\<phi> U\<^sub>n \<psi>) \<turnstile>\<^sub>s \<chi>"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<nu> \<Longrightarrow> (\<phi> U\<^sub>n \<psi>) \<turnstile>\<^sub>s (\<chi> U\<^sub>n \<nu>)"

| "\<chi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> (\<psi> R\<^sub>n \<chi>) \<turnstile>\<^sub>s \<phi>"
| "\<chi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> \<chi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<chi> \<turnstile>\<^sub>s (\<phi> R\<^sub>n \<psi>)"
| "\<phi> \<turnstile>\<^sub>s \<chi> \<Longrightarrow> \<psi> \<turnstile>\<^sub>s \<nu> \<Longrightarrow> (\<phi> R\<^sub>n \<psi>) \<turnstile>\<^sub>s (\<chi> R\<^sub>n \<nu>)"

| "(false\<^sub>n R\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<Longrightarrow> (false\<^sub>n R\<^sub>n \<phi>) \<turnstile>\<^sub>s X\<^sub>n \<psi>"
| "\<phi> \<turnstile>\<^sub>s (true\<^sub>n U\<^sub>n \<psi>) \<Longrightarrow> (X\<^sub>n \<phi>) \<turnstile>\<^sub>s (true\<^sub>n U\<^sub>n \<psi>)"
| "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> (X\<^sub>n \<phi>) \<turnstile>\<^sub>s (X\<^sub>n \<psi>)"

lemma syntactical_implies_correct:
  "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<Longrightarrow> w \<Turnstile>\<^sub>n \<psi>"
  by (induction arbitrary: w rule: syntactical_implies.induct; auto; force)

fun rewrite_syn_imp
where
  "rewrite_syn_imp (\<phi> and\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<phi>
    else if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<psi>
    else if \<phi> \<turnstile>\<^sub>s (not\<^sub>n \<psi>) \<or> \<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>) then
      false\<^sub>n
    else
      mk_and (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> or\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<psi>
    else if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<phi>
    else if (not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<or> (not\<^sub>n \<psi>) \<turnstile>\<^sub>s \<phi> then
      true\<^sub>n
    else
      mk_or (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> U\<^sub>n \<psi>) = (
    if \<phi> \<turnstile>\<^sub>s \<psi> then
      rewrite_syn_imp \<psi>
    else if (not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> then
      mk_finally (rewrite_syn_imp \<psi>)
    else
      mk_until (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (\<phi> R\<^sub>n \<psi>) = (
    if \<psi> \<turnstile>\<^sub>s \<phi> then
      rewrite_syn_imp \<psi>
    else if \<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>) then
      mk_globally (rewrite_syn_imp \<psi>)
    else
      mk_release (rewrite_syn_imp \<phi>) (rewrite_syn_imp \<psi>))"
| "rewrite_syn_imp (X\<^sub>n \<phi>) = mk_next (rewrite_syn_imp \<phi>)"
| "rewrite_syn_imp \<phi> = \<phi>"

lemma rewrite_syn_imp_sound:
  "w \<Turnstile>\<^sub>n rewrite_syn_imp \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case And_ltln
    thus ?case
      by (simp add: Let_def; metis syntactical_implies_correct not\<^sub>n_semantics)
next
  case (Or_ltln \<phi> \<psi>)
    moreover
    have "(not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi> \<Longrightarrow> \<forall>w. w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
      by (auto intro: syntactical_implies_correct[of "not\<^sub>n \<phi>"])
    moreover
    have "(not\<^sub>n \<psi>) \<turnstile>\<^sub>s \<phi> \<Longrightarrow> \<forall>w. w \<Turnstile>\<^sub>n \<phi> or\<^sub>n \<psi>"
      by (auto intro: syntactical_implies_correct[of "not\<^sub>n \<psi>"])
    ultimately
    show ?case
      by (auto intro: syntactical_implies_correct)
next
  case (Until_ltln \<phi> \<psi>)
    moreover
    have "\<phi> \<turnstile>\<^sub>s \<psi> \<Longrightarrow> ?case"
      by (force simp add: Until_ltln dest: syntactical_implies_correct)
    moreover
    {
      assume A: "(not\<^sub>n \<phi>) \<turnstile>\<^sub>s \<psi>" and B: "\<not> \<phi> \<turnstile>\<^sub>s \<psi>"
      hence [simp]: "rewrite_syn_imp (\<phi> U\<^sub>n \<psi>) = mk_finally (rewrite_syn_imp \<psi>)"
        by simp
      {
        assume "\<exists>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
        moreover
        define i where "i \<equiv> LEAST i. suffix i w \<Turnstile>\<^sub>n \<psi>"
        ultimately
        have "\<forall>j < i. \<not>suffix j w \<Turnstile>\<^sub>n \<psi>" and "suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (blast dest: not_less_Least , metis LeastI \<open>\<exists>i. suffix i w \<Turnstile>\<^sub>n \<psi>\<close> i_def)
        hence "\<forall>j < i. suffix j w \<Turnstile>\<^sub>n \<phi>" and "suffix i w \<Turnstile>\<^sub>n \<psi>"
          using syntactical_implies_correct[OF A] by auto
      }
      hence ?case
        by (simp del: rewrite_syn_imp.simps; unfold Until_ltln(2)) blast
    }
    ultimately
    show ?case
      by fastforce
next
  case (Release_ltln \<phi> \<psi>)
    moreover
    have "\<psi> \<turnstile>\<^sub>s \<phi> \<Longrightarrow> ?case"
      by (force simp add: Release_ltln dest: syntactical_implies_correct)
    moreover
    {
      assume A: "\<psi> \<turnstile>\<^sub>s (not\<^sub>n \<phi>)" and B: "\<not> \<psi> \<turnstile>\<^sub>s \<phi>"
      hence [simp]: "rewrite_syn_imp (\<phi> R\<^sub>n \<psi>) = mk_globally (rewrite_syn_imp \<psi>)"
        by simp
      {
        assume "\<exists>i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>"
        moreover
        define i where "i \<equiv> LEAST i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>"
        ultimately
        have "\<forall>j < i. suffix j w \<Turnstile>\<^sub>n \<psi>" and "\<not> suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (blast dest: not_less_Least , metis LeastI \<open>\<exists>i. \<not>suffix i w \<Turnstile>\<^sub>n \<psi>\<close> i_def)
        hence "\<forall>j < i. \<not>suffix j w \<Turnstile>\<^sub>n \<phi>" and "\<not> suffix i w \<Turnstile>\<^sub>n \<psi>"
          using syntactical_implies_correct[OF A] by auto
      }
      hence ?case
        by (simp del: rewrite_syn_imp.simps; unfold Release_ltln(2)) blast
    }
    ultimately
    show ?case
      by fastforce
qed auto

subsection \<open>Iterated Rewriting\<close>

fun iterate
where
  "iterate f x 0 = x"
| "iterate f x (Suc n) = (let x' = f x in if x = x' then x else iterate f x' n)"

definition
  "rewrite_iter_fast \<phi> \<equiv> iterate (rewrite_modal o rewrite_X) \<phi> (size \<phi>)"

definition
  "rewrite_iter_slow \<phi> \<equiv> iterate (rewrite_syn_imp o rewrite_modal o rewrite_X) \<phi> (size \<phi>)"

text \<open>The rewriting functions defined in the previous subsections can be used as-is. However, in the
  most cases one wants to iterate these rules until the formula cannot be simplified further.
  @{const rewrite_iter_fast} pulls X operators up in the syntax tree and the uses the
  "modal" simplification rules. @{const rewrite_iter_slow} additionally tries to simplify the
  formula using syntactic implication checking.\<close>

lemma iterate_sound:
  assumes "\<And>\<phi>. w \<Turnstile>\<^sub>n f \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  shows "w \<Turnstile>\<^sub>n iterate f \<phi> n \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (induction n arbitrary: \<phi>; simp add: assms Let_def)

theorem rewrite_iter_fast_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_iter_fast \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using iterate_sound[of _ "rewrite_modal o rewrite_X"]
  unfolding comp_def rewrite_modal_sound rewrite_X_sound rewrite_iter_fast_def
  by blast

theorem rewrite_iter_slow_sound [simp]:
  "w \<Turnstile>\<^sub>n rewrite_iter_slow \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using iterate_sound[of _ "rewrite_syn_imp o rewrite_modal o rewrite_X"]
  unfolding comp_def rewrite_modal_sound rewrite_X_sound rewrite_syn_imp_sound rewrite_iter_slow_def
  by blast

subsection \<open>Preservation of atoms\<close>

lemma iterate_atoms:
  assumes
    "\<And>\<phi>. atoms_ltln (f \<phi>) \<subseteq> atoms_ltln \<phi>"
  shows
    "atoms_ltln (iterate f \<phi> n) \<subseteq> atoms_ltln \<phi>"
  by (induction n arbitrary: \<phi>) (auto, metis (mono_tags, lifting) assms in_mono)

lemma rewrite_modal_atoms:
  "atoms_ltln (rewrite_modal \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma mk_and_atoms:
  "atoms_ltln (mk_and \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_and_def split: ltln.splits)

lemma mk_or_atoms:
  "atoms_ltln (mk_or \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_or_def split: ltln.splits)

lemma remove_strong_ops_atoms:
  "atoms_ltln (remove_strong_ops \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma remove_weak_ops_atoms:
  "atoms_ltln (remove_weak_ops \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma mk_globally_atoms:
  "atoms_ltln (mk_globally \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (auto simp: mk_globally_def split: ltln.splits) (insert remove_weak_ops_atoms, fast+)

lemma mk_until_atoms:
  "atoms_ltln (mk_until \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_until_def split: ltln.splits) (insert mk_finally_atoms, fastforce+)

lemma mk_release_atoms:
  "atoms_ltln (mk_release \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_release_def split: ltln.splits) (insert mk_globally_atoms, fastforce+)

lemma mk_weak_until_atoms:
  "atoms_ltln (mk_weak_until \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_weak_until_def split: ltln.splits) (insert mk_globally_atoms, fastforce+)

lemma mk_strong_release_atoms:
  "atoms_ltln (mk_strong_release \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  by (auto simp: mk_strong_release_def split: ltln.splits) (insert mk_finally_atoms, fastforce+)

lemma mk_next_atoms:
  "atoms_ltln (mk_next \<phi>) = atoms_ltln \<phi>"
  by (auto simp: mk_next_def split: ltln.splits)

lemma mk_next_pow_atoms:
  "atoms_ltln (mk_next_pow n \<phi>) = atoms_ltln \<phi>"
  by (induction n) (auto simp: mk_next_pow_def split: ltln.splits)

lemma combine_atoms:
  assumes
    "\<And>\<phi> \<psi>. atoms_ltln (f \<phi> \<psi>) \<subseteq> atoms_ltln \<phi> \<union> atoms_ltln \<psi>"
  shows
    "atoms_ltln (fst (combine f x y)) \<subseteq> atoms_ltln (fst x) \<union> atoms_ltln (fst y)"
  by (metis assms fst_combine mk_next_pow_atoms prod.collapse)

lemmas combine_mk_atoms =
  combine_atoms[OF mk_and_atoms]
  combine_atoms[OF mk_or_atoms]
  combine_atoms[OF mk_until_atoms]
  combine_atoms[OF mk_release_atoms]
  combine_atoms[OF mk_weak_until_atoms]
  combine_atoms[OF mk_strong_release_atoms]

lemma rewrite_X_enat_atoms:
  "atoms_ltln (fst (rewrite_X_enat \<phi>)) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) (simp_all add: case_prod_beta, insert combine_mk_atoms, fast+)

lemma rewrite_X_atoms:
  "atoms_ltln (rewrite_X \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (induction \<phi>) (simp_all add: rewrite_X_def mk_next_pow_atoms case_prod_beta, insert combine_mk_atoms, fast+)

lemma rewrite_syn_imp_atoms:
  "atoms_ltln (rewrite_syn_imp \<phi>) \<subseteq> atoms_ltln \<phi>"
proof (induction \<phi>)
  case (And_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_and_atoms by simp fast
next
  case (Or_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_or_atoms by simp fast
next
  case (Next_ltln \<phi>)
  then show ?case
    using mk_next_atoms by simp fast
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_finally_atoms mk_until_atoms by simp fast
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    using mk_globally_atoms mk_release_atoms by simp fast
qed simp_all

lemma rewrite_iter_fast_atoms:
  "atoms_ltln (rewrite_iter_fast \<phi>) \<subseteq> atoms_ltln \<phi>"
proof -
  have 1: "\<And>\<phi>. atoms_ltln (rewrite_modal (rewrite_X \<phi>)) \<subseteq> atoms_ltln \<phi>"
    using rewrite_modal_atoms rewrite_X_atoms by force

  show ?thesis
    by (simp add: rewrite_iter_fast_def 1 iterate_atoms)
qed

lemma rewrite_iter_slow_atoms:
  "atoms_ltln (rewrite_iter_slow \<phi>) \<subseteq> atoms_ltln \<phi>"
proof -
  have 1: "\<And>\<phi>. atoms_ltln (rewrite_syn_imp (rewrite_modal (rewrite_X \<phi>))) \<subseteq> atoms_ltln \<phi>"
    using rewrite_syn_imp_atoms rewrite_modal_atoms rewrite_X_atoms by force

  show ?thesis
    by (simp add: rewrite_iter_slow_def 1 iterate_atoms)
qed

subsection \<open>Simplifier\<close>

text \<open>We now define a convenience wrapper for the rewriting engine\<close>

datatype mode = Nop | Fast | Slow

fun simplify :: "mode \<Rightarrow> 'a ltln \<Rightarrow> 'a ltln"
where
  "simplify Nop = id"
| "simplify Fast = rewrite_iter_fast"
| "simplify Slow = rewrite_iter_slow"

theorem simplify_correct:
  "w \<Turnstile>\<^sub>n simplify m \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (cases m) simp+

lemma simplify_atoms:
  "atoms_ltln (simplify m \<phi>) \<subseteq> atoms_ltln \<phi>"
  by (cases m) (insert rewrite_iter_fast_atoms rewrite_iter_slow_atoms, fastforce+)

subsection \<open>Code Generation\<close>

code_pred syntactical_implies .

export_code simplify checking

lemma "rewrite_iter_fast (F\<^sub>n (G\<^sub>n (X\<^sub>n prop\<^sub>n(''a'')))) = (F\<^sub>n (G\<^sub>n prop\<^sub>n(''a'')))"
  by eval

lemma "rewrite_iter_fast (X\<^sub>n prop\<^sub>n(''a'') U\<^sub>n (X\<^sub>n nprop\<^sub>n(''a''))) = X\<^sub>n (prop\<^sub>n(''a'') U\<^sub>n nprop\<^sub>n(''a''))"
  by eval

lemma "rewrite_iter_slow (X\<^sub>n prop\<^sub>n(''a'') U\<^sub>n (X\<^sub>n nprop\<^sub>n(''a''))) = X\<^sub>n (F\<^sub>n nprop\<^sub>n(''a''))"
  by eval

end


section "Tries via Search Trees"

theory Trie_Map
imports
  RBT_Map
  Trie_Fun
begin

text \<open>An implementation of tries based on maps implemented by red-black trees.
Works for any kind of search tree.\<close>

text \<open>Implementation of map:\<close>

type_synonym 'a mapi = "'a rbt"

datatype 'a trie_map = Nd bool "('a * 'a trie_map) mapi"

text \<open>In principle one should be able to given an implementation of tries
once and for all for any map implementation and not just for a specific one (RBT) as done here.
But because the map (@{typ "'a rbt"}) is used in a datatype, the HOL type system does not support this.

However, the development below works verbatim for any map implementation, eg \<open>Tree_Map\<close>,
and not just \<open>RBT_Map\<close>, except for the termination lemma \<open>lookup_size\<close>.\<close>
term size_tree
lemma lookup_size[termination_simp]:
  fixes t :: "('a::linorder * 'a trie_map) rbt"
  shows "lookup t a = Some b \<Longrightarrow> size b < Suc (size_tree (\<lambda>ab. Suc(Suc (size (snd(fst ab))))) t)"
apply(induction t a rule: lookup.induct)
apply(auto split: if_splits)
done

definition empty :: "'a trie_map" where
[simp]: "empty = Nd False Leaf"

fun isin :: "('a::linorder) trie_map \<Rightarrow> 'a list \<Rightarrow> bool" where
"isin (Nd b m) [] = b" |
"isin (Nd b m) (x # xs) = (case lookup m x of None \<Rightarrow> False | Some t \<Rightarrow> isin t xs)"

fun insert :: "('a::linorder) list \<Rightarrow> 'a trie_map \<Rightarrow> 'a trie_map" where
"insert [] (Nd b m) = Nd True m" |
"insert (x#xs) (Nd b m) =
  Nd b (update x (insert xs (case lookup m x of None \<Rightarrow> empty | Some t \<Rightarrow> t)) m)"

fun delete :: "('a::linorder) list \<Rightarrow> 'a trie_map \<Rightarrow> 'a trie_map" where
"delete [] (Nd b m) = Nd False m" |
"delete (x#xs) (Nd b m) = Nd b
   (case lookup m x of
      None \<Rightarrow> m |
      Some t \<Rightarrow> update x (delete xs t) m)"

subsection "Correctness"

text \<open>Proof by stepwise refinement. First abstract to type @{typ "'a trie"}.\<close>

fun abs :: "'a::linorder trie_map \<Rightarrow> 'a trie" where
"abs (Nd b t) = Trie_Fun.Nd b (\<lambda>a. map_option abs (lookup t a))"

fun invar :: "('a::linorder)trie_map \<Rightarrow> bool" where
"invar (Nd b m) = (M.invar m \<and> (\<forall>a t. lookup m a = Some t \<longrightarrow> invar t))"

lemma isin_abs: "isin t xs = Trie_Fun.isin (abs t) xs"
apply(induction t xs rule: isin.induct)
apply(auto split: option.split)
done

lemma abs_insert: "invar t \<Longrightarrow> abs(insert xs t) = Trie_Fun.insert xs (abs t)"
apply(induction xs t rule: insert.induct)
apply(auto simp: M.map_specs RBT_Set.empty_def[symmetric] split: option.split)
done

lemma abs_delete: "invar t \<Longrightarrow> abs(delete xs t) = Trie_Fun.delete xs (abs t)"
apply(induction xs t rule: delete.induct)
apply(auto simp: M.map_specs split: option.split)
done

lemma invar_insert: "invar t \<Longrightarrow> invar (insert xs t)"
apply(induction xs t rule: insert.induct)
apply(auto simp: M.map_specs RBT_Set.empty_def[symmetric] split: option.split)
done

lemma invar_delete: "invar t \<Longrightarrow> invar (delete xs t)"
apply(induction xs t rule: delete.induct)
apply(auto simp: M.map_specs split: option.split)
done

text \<open>Overall correctness w.r.t. the \<open>Set\<close> ADT:\<close>

interpretation S2: Set
where empty = empty and isin = isin and insert = insert and delete = delete
and set = "set o abs" and invar = invar
proof (standard, goal_cases)
  case 1 show ?case by (simp add: isin_case split: list.split)
next
  case 2 thus ?case by (simp add: isin_abs)
next
  case 3 thus ?case by (simp add: set_insert abs_insert del: set_def)
next
  case 4 thus ?case by (simp add: set_delete abs_delete del: set_def)
next
  case 5 thus ?case by (simp add: M.map_specs RBT_Set.empty_def[symmetric])
next
  case 6 thus ?case by (simp add: invar_insert)
next
  case 7 thus ?case by (simp add: invar_delete)
qed

end