section \<open>Implementation\<close>

theory HMM_Implementation
  imports
    Hidden_Markov_Model
    "Monad_Memo_DP.State_Main"
begin

subsection \<open>The Forward Algorithm\<close>

locale HMM4 = HMM3 _ _ _ \<O>\<^sub>s \<K> for \<O>\<^sub>s :: "'t set" and \<K> :: "'s \<Rightarrow> 's pmf" +
  assumes states_distinct: "distinct state_list"

context HMM3_defs
begin

context
  fixes os :: "'t iarray"
begin

text \<open>
  Alternative definition using indices into the list of states.
  The list of states is implemented as an immutable array for better performance.
\<close>

function forward_ix_rec where
  "forward_ix_rec s t_end n = (if n \<ge> IArray.length os then indicator {t_end} s else
    (\<Sum>t \<leftarrow> state_list.
      ennreal (pmf (\<O> t) (os !! n)) * ennreal (pmf (\<K> s) t) * forward_ix_rec t t_end (n + 1)))
  "
  by auto
termination
  by (relation "Wellfounded.measure (\<lambda>(_,_,n). IArray.length os - n)") auto

text \<open>Memoization\<close>

memoize_fun forward_ix\<^sub>m: forward_ix_rec
  with_memory dp_consistency_mapping
  monadifies (state) forward_ix_rec.simps[unfolded Let_def]
  term forward_ix\<^sub>m'
memoize_correct
  by memoize_prover

text \<open>The main theorems generated by memoization.\<close>
context
  includes state_monad_syntax
begin
thm forward_ix\<^sub>m'.simps forward_ix\<^sub>m_def
thm forward_ix\<^sub>m.memoized_correct
end

end (* Fixed IArray *)

definition
  "forward_ix os = forward_ix_rec (IArray os)"

definition
  "likelihood_compute s os \<equiv>
    if s \<in> set state_list then Some (\<Sum>t \<leftarrow> state_list. forward s t os) else None"

end (* HMM3 Defs *)

text \<open>Correctness of the alternative definition.\<close>

lemma (in HMM3) forward_ix_drop_one:
  "forward_ix (o # os) s t (n + 1) = forward_ix os s t n"
  by (induction "length os - n" arbitrary: s n; simp add: forward_ix_def)

lemma (in HMM4) forward_ix_forward:
  "forward_ix os s t 0 = forward s t os"
  unfolding forward_ix_def
proof (induction os arbitrary: s)
  case Nil
  then show ?case
    by simp
next
  case (Cons o os)
  show ?case
    using forward_ix_drop_one[unfolded forward_ix_def] states_distinct
    by (subst forward.simps, subst forward_ix_rec.simps)
       (simp add: Cons.IH state_list_\<S> sum_list_distinct_conv_sum_set
             del: forward_ix_rec.simps forward.simps
       )
qed

text \<open>
  Instructs the code generator to use this equation instead to execute \<open>forward\<close>.
  Uses the memoized version of \<open>forward_ix\<close>.
\<close>
lemma (in HMM4) forward_code [code]:
  "forward s t os = fst (run_state (forward_ix\<^sub>m' (IArray os) s t 0) Mapping.empty)"
  by (simp only:
      forward_ix_def forward_ix\<^sub>m.memoized_correct forward_ix_forward[symmetric]
      states_distinct
     )

theorem (in HMM4) likelihood_compute:
  "likelihood_compute s os = Some x \<longleftrightarrow> s \<in> \<S> \<and> x = likelihood s os"
  unfolding likelihood_compute_def
  by (auto simp: states_distinct state_list_\<S> sum_list_distinct_conv_sum_set likelihood_forward)

subsection \<open>The Viterbi Algorithm\<close>

context HMM3_defs
begin

context
  fixes os :: "'t iarray"
begin

text \<open>
  Alternative definition using indices into the list of states.
  The list of states is implemented as an immutable array for better performance.
\<close>

function viterbi_ix_rec where
  "viterbi_ix_rec s t_end n = (if n \<ge> IArray.length os then ([], indicator {t_end} s) else
  fst (
    argmax snd (map
      (\<lambda>t. let (xs, v) = viterbi_ix_rec t t_end (n + 1) in
        (t # xs, ennreal (pmf (\<O> t) (os !! n) * pmf (\<K> s) t) * v))
    state_list)))
  "
  by pat_completeness auto
termination
  by (relation "Wellfounded.measure (\<lambda>(_,_,n). IArray.length os - n)") auto

text \<open>Memoization\<close>

memoize_fun viterbi_ix\<^sub>m: viterbi_ix_rec
  with_memory dp_consistency_mapping
  monadifies (state) viterbi_ix_rec.simps[unfolded Let_def]

memoize_correct
  by memoize_prover

text \<open>The main theorems generated by memoization.\<close>
context
  includes state_monad_syntax
begin
thm viterbi_ix\<^sub>m'.simps viterbi_ix\<^sub>m_def
thm viterbi_ix\<^sub>m.memoized_correct
end

end (* Fixed IArray *)

definition
  "viterbi_ix os = viterbi_ix_rec (IArray os)"

end (* HMM3 Defs *)

context HMM3
begin

lemma viterbi_ix_drop_one:
  "viterbi_ix (o # os) s t (n + 1) = viterbi_ix os s t n"
  by (induction "length os - n" arbitrary: s n; simp add: viterbi_ix_def)

lemma viterbi_ix_viterbi:
  "viterbi_ix os s t 0 = viterbi s t os"
  unfolding viterbi_ix_def
proof (induction os arbitrary: s)
  case Nil
  then show ?case
    by simp
next
  case (Cons o os)
  show ?case
    using viterbi_ix_drop_one[unfolded viterbi_ix_def]
    by (subst viterbi.simps, subst viterbi_ix_rec.simps)
       (simp add: Cons.IH del: viterbi_ix_rec.simps viterbi.simps)
qed

lemma viterbi_code [code]:
  "viterbi s t os = fst (run_state (viterbi_ix\<^sub>m' (IArray os) s t 0) Mapping.empty)"
  by (simp only: viterbi_ix_def viterbi_ix\<^sub>m.memoized_correct viterbi_ix_viterbi[symmetric])

end (* Hidden Markov Model 3 *)

subsection \<open>Misc\<close>

lemma pmf_of_alist_support_aux_1:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
  shows "(0 :: real) \<le> (case map_of \<mu> x of None \<Rightarrow> 0 | Some p \<Rightarrow> p)"
  using assms by (auto split: option.split dest: map_of_SomeD)

lemma pmf_of_alist_support_aux_2:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
    and "sum_list (map snd \<mu>) = 1"
    and "distinct (map fst \<mu>)"
  shows "\<integral>\<^sup>+ x. ennreal (case map_of \<mu> x of None \<Rightarrow> 0 | Some p \<Rightarrow> p) \<partial>count_space UNIV = 1"
  using assms
  apply (subst nn_integral_count_space)
  subgoal
    by (rule finite_subset[where B = "fst ` set \<mu>"];
        force split: option.split_asm simp: image_iff dest: map_of_SomeD)
  apply (subst sum.mono_neutral_left[where T = "fst ` set \<mu>"])
     apply blast
  subgoal
    by (smt ennreal_less_zero_iff map_of_eq_None_iff mem_Collect_eq option.case(1) subsetI)
  subgoal
    by auto
  subgoal premises prems
  proof -
    have "(\<Sum>x = 0..<length \<mu>. snd (\<mu> ! x))
      = sum (\<lambda> x. case map_of \<mu> x of None \<Rightarrow> 0 | Some v \<Rightarrow> v) (fst ` set \<mu>)"
      apply (rule sym)
      apply (rule sum.reindex_cong[where l = "\<lambda> i. fst (\<mu> ! i)"])
        apply (auto split: option.split)
      subgoal
        using prems(3) by (intro inj_onI, auto simp: distinct_conv_nth)
      subgoal
        by (auto simp: in_set_conv_nth rev_image_eqI)
      subgoal
        by (simp add: map_of_eq_None_iff)
      subgoal
        using map_of_eq_Some_iff[OF prems(3)]
        by (metis fst_conv nth_mem option.inject prod_eqI snd_conv)
      done
    with prems(2) show ?thesis
      by (smt pmf_of_alist_support_aux_1[OF assms(1)] atLeastLessThan_iff ennreal_1
          length_map nth_map sum.cong sum_ennreal sum_list_sum_nth
          )
  qed
  done

lemma pmf_of_alist_support:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
    and "sum_list (map snd \<mu>) = 1"
    and "distinct (map fst \<mu>)"
  shows "set_pmf (pmf_of_alist \<mu>) \<subseteq> fst ` set \<mu>"
  unfolding pmf_of_alist_def
  apply (subst set_embed_pmf)
  subgoal for x
    using assms(1) by (auto split: option.split dest: map_of_SomeD)
  subgoal
    using pmf_of_alist_support_aux_2[OF assms] .
  apply (force split: option.split_asm simp: image_iff dest: map_of_SomeD)+
  done

text \<open>Defining a Markov kernel from an association list.\<close>
locale Closed_Kernel_From =
  fixes K :: "('s \<times> ('t \<times> real) list) list"
    and S :: "'t list"
  assumes wellformed: "S \<noteq> []"
      and closed: "\<forall> (s, \<mu>) \<in> set K. \<forall> (t, _) \<in> set \<mu>. t \<in> set S"
      and is_pmf:
        "\<forall> (_, \<mu>) \<in> set K. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set K. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set K. sum_list (map snd \<mu>) = 1"
      and is_unique:
        "distinct (map fst K)"
begin

definition
  "K' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) K) s of
  None \<Rightarrow> return_pmf (hd S) |
  Some s \<Rightarrow> s"

sublocale Closed_Kernel K' "set S"
  using wellformed closed is_pmf pmf_of_alist_support
  unfolding K'_def by - (standard; fastforce split: option.split_asm dest: map_of_SomeD)

definition [code]:
  "K1 = map_of (map (\<lambda> (s, \<mu>). (s, map_of \<mu>)) K)"

lemma pmf_of_alist_aux:
  assumes "(s, \<mu>) \<in> set K"
  shows
    "pmf (pmf_of_alist \<mu>) t = (case map_of \<mu> t of
      None \<Rightarrow> 0
    | Some p \<Rightarrow> p)"
  using assms is_pmf unfolding pmf_of_alist_def
  by (intro pmf_embed_pmf pmf_of_alist_support_aux_2)
     (auto 4 3 split: option.split dest: map_of_SomeD)

lemma (in -) map_of_NoneD:
  "x \<notin> fst ` set M" if "map_of M x = None"
  using that by (auto dest: weak_map_of_SomeI)

lemma K'_code [code_post]:
  "pmf (K' s) t = (case K1 s of
      None \<Rightarrow> (if t = hd S then 1 else 0)
    | Some \<mu> \<Rightarrow> case \<mu> t of
        None \<Rightarrow> 0
      | Some p \<Rightarrow> p
  )"
  unfolding K'_def K1_def
  apply (clarsimp split: option.split, safe)
                 apply (drule map_of_SomeD, drule map_of_NoneD, force)+
         apply (fastforce dest: unique map_of_SomeD simp: pmf_of_alist_aux)+
  done

end

subsection \<open>Executing Concrete HMMs\<close>

locale Concrete_HMM_defs =
  fixes \<K> :: "('s \<times> ('s \<times> real) list) list"
    and \<O> :: "('s \<times> ('t \<times> real) list) list"
    and \<O>\<^sub>s :: "'t list"
    and \<K>\<^sub>s :: "'s list"
begin

definition
  "\<K>' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) \<K>) s of
    None \<Rightarrow> return_pmf (hd \<K>\<^sub>s) |
    Some s \<Rightarrow> s"

definition
  "\<O>' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) \<O>) s of
    None \<Rightarrow> return_pmf (hd \<O>\<^sub>s) |
    Some s \<Rightarrow> s"

end

locale Concrete_HMM = Concrete_HMM_defs +
  assumes observations_wellformed': "\<O>\<^sub>s \<noteq> []"
      and observations_closed': "\<forall> (s, \<mu>) \<in> set \<O>. \<forall> (t, _) \<in> set \<mu>. t \<in> set \<O>\<^sub>s"
      and observations_form_pmf':
        "\<forall> (_, \<mu>) \<in> set \<O>. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set \<O>. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set \<O>. sum_list (map snd \<mu>) = 1"
      and observations_unique:
        "distinct (map fst \<O>)"
  assumes states_wellformed: "\<K>\<^sub>s \<noteq> []"
      and states_closed: "\<forall> (s, \<mu>) \<in> set \<K>. \<forall> (t, _) \<in> set \<mu>. t \<in> set \<K>\<^sub>s"
      and states_form_pmf:
        "\<forall> (_, \<mu>) \<in> set \<K>. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set \<K>. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set \<K>. sum_list (map snd \<mu>) = 1"
      and states_unique:
        "distinct (map fst \<K>)" "distinct \<K>\<^sub>s"
begin

interpretation O: Closed_Kernel_From \<O> \<O>\<^sub>s
  rewrites "O.K' = \<O>'"
proof -
  show \<open>Closed_Kernel_From \<O> \<O>\<^sub>s\<close>
    using observations_wellformed' observations_closed' observations_form_pmf' observations_unique
    by unfold_locales auto
  show \<open>Closed_Kernel_From.K' \<O> \<O>\<^sub>s = \<O>'\<close>
    unfolding Closed_Kernel_From.K'_def[OF \<open>Closed_Kernel_From \<O> \<O>\<^sub>s\<close>] \<O>'_def
    by auto
qed

interpretation K: Closed_Kernel_From \<K> \<K>\<^sub>s
  rewrites "K.K' = \<K>'"
proof -
  show \<open>Closed_Kernel_From \<K> \<K>\<^sub>s\<close>
    using states_wellformed states_closed states_form_pmf states_unique by unfold_locales auto
  show \<open>Closed_Kernel_From.K' \<K> \<K>\<^sub>s = \<K>'\<close>
    unfolding Closed_Kernel_From.K'_def[OF \<open>Closed_Kernel_From \<K> \<K>\<^sub>s\<close>] \<K>'_def
    by auto
qed

lemmas O_code = O.K'_code O.K1_def
lemmas K_code = K.K'_code K.K1_def

sublocale HMM_interp: HMM4 \<O>' "set \<K>\<^sub>s" \<K>\<^sub>s "set \<O>\<^sub>s" \<K>'
  using O.Closed_Kernel_axioms K.Closed_Kernel_axioms states_unique(2)
  by (intro_locales; intro HMM4_axioms.intro HMM3_axioms.intro HOL.refl)

end (* Concrete HMM *)

end


theory ShortestPathNeg

(*
  This theory uses the graph library and
  several lemmas that were proven in the
  shortest path theory
*)
imports ShortestPath

begin
section \<open>Shortest Path (with general edge costs)\<close>
(*
  In this locale we assume we are given a
  wellformed directed graph $G = (V,E)$ with
  finite $V$ and $E$ (this is the assumption
  $graphG$). Moreover, a source vertex $s$ in
  $V$ . In addition, a cost function c, a function
 $num:V\to \Nat$, $parent\dash edge:V\to E \cup $*)
locale shortest_paths_locale_step1 =
  fixes G :: "('a, 'b) pre_digraph" (structure)
  fixes s :: "'a"
  fixes c :: "'b \<Rightarrow> real"
  fixes num :: "'a \<Rightarrow> nat"
  fixes parent_edge :: "'a \<Rightarrow> 'b option"
  fixes dist :: "'a  \<Rightarrow> ereal"
  assumes graphG: "fin_digraph G"
  assumes s_assms:
    "s \<in> verts G"
    "dist s \<noteq> \<infinity>"
    "parent_edge s = None"
    "num s = 0"
  assumes  parent_num_assms:
    "\<And>v.  \<lbrakk>v \<in> verts G; v \<noteq> s; dist v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
    (\<exists>e \<in> arcs G. parent_edge v = Some e \<and>
    head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
    num v  = num (tail G e) + 1)"
  assumes noPedge: "\<And>e. e\<in>arcs G \<Longrightarrow>
    dist (tail G e) \<noteq> \<infinity> \<Longrightarrow> dist (head G e) \<noteq> \<infinity>"

sublocale shortest_paths_locale_step1 \<subseteq> fin_digraph G
  using graphG by auto

definition (in shortest_paths_locale_step1) enum :: "'a \<Rightarrow> enat" where
  "enum v = (if (dist v = \<infinity> \<or> dist v = - \<infinity>) then \<infinity> else num v)"

locale shortest_paths_locale_step2 =
  shortest_paths_locale_step1 +
  basic_just_sp G dist c s enum +
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"

function (in shortest_paths_locale_step1) pwalk :: "'a \<Rightarrow> 'b list"
where
  "pwalk v =
    (if (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G)
      then []
      else pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]
    )"
by auto
termination (in shortest_paths_locale_step1)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in shortest_paths_locale_step1) pwalk_simps:
  "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G \<Longrightarrow> pwalk v = []"
  "v \<noteq> s \<Longrightarrow> dist v \<noteq> \<infinity> \<Longrightarrow> v \<in> verts G \<Longrightarrow>
    pwalk v = pwalk (tail G (the (parent_edge v))) @ [the (parent_edge v)]"
by auto

definition (in shortest_paths_locale_step1) pwalk_verts :: "'a  \<Rightarrow> 'a set" where
  "pwalk_verts v = {u. u \<in> set (awalk_verts s (pwalk v))}"

locale shortest_paths_locale_step3 =
  shortest_paths_locale_step2 +
  fixes C :: "('a \<times>('b awalk)) set"
  assumes C_se:
    "C \<subseteq> {(u, p). dist u \<noteq> \<infinity> \<and> awalk u p u \<and> awalk_cost c p < 0}"
  assumes int_neg_cyc:
    "\<And>v. v \<in> verts G \<Longrightarrow> dist v = -\<infinity> \<Longrightarrow>
      (fst ` C) \<inter> pwalk_verts v  \<noteq> {}"

locale shortest_paths_locale_step2_pred =
  shortest_paths_locale_step1 +
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes bj: "basic_just_sp_pred G dist c s enum pred"
  assumes source_val: "(\<exists>v \<in> verts G. enum v \<noteq> \<infinity>) \<Longrightarrow> dist s = 0"
  assumes no_edge_Vm_Vf:
    "\<And>e. e \<in> arcs G \<Longrightarrow> dist (tail G e) = - \<infinity> \<Longrightarrow> \<forall> r. dist (head G e) \<noteq> ereal r"
(*
sublocale shortest_paths_locale_step2_pred \<subseteq> shortest_paths_locale_step2
using shortest_paths_locale_step2_pred_axioms
unfolding shortest_paths_locale_step2_pred_def
   shortest_paths_locale_step2_pred_axioms_def
   shortest_paths_locale_step2_def
   shortest_paths_locale_step2_axioms_def
try0
*)

lemma (in shortest_paths_locale_step1) num_s_is_min:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows "num v > 0"
     using parent_num_assms[OF assms] by fastforce

lemma (in shortest_paths_locale_step1) path_from_root_Vr_ex:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "dist v \<noteq> \<infinity>"
  shows  "\<exists>e. s \<rightarrow>\<^sup>* tail G e \<and>
          e \<in> arcs G \<and> head G e = v \<and> dist (tail G e) \<noteq> \<infinity> \<and>
          parent_edge v = Some e \<and> num v = num (tail G e) + 1"
using assms
proof(induct "num v - 1" arbitrary : v)
case 0
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF 0(2-4)] by fast
  have "tail G e = s"
    using num_s_is_min[OF tail_in_verts [OF ee(1)] _ ee(3)]
    ee(5) 0(1) by auto
  then show ?case using ee by auto
next
case (Suc n')
  obtain e where ee:
    "e \<in> arcs G" "head G e = v" "dist (tail G e) \<noteq> \<infinity>"
    "parent_edge v = Some e" "num v = num (tail G e) + 1"
    using parent_num_assms[OF Suc(3-5)] by fast
  then have ss: "tail G e \<noteq> s"
    using num_s_is_min tail_in_verts
    Suc(2) s_assms(4) by force
  have nst: "n' = num (tail G e) - 1"
    using ee(5) Suc(2) by presburger
  obtain e' where reach: "s \<rightarrow>\<^sup>* tail G e'" and
    e': "e' \<in> arcs G" "head G e' = tail G e" "dist (tail G e') \<noteq> \<infinity>"
    using Suc(1)[OF nst tail_in_verts[OF ee(1)] ss ee(3)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e"
    by (metis arc_implies_awalk reachable_awalk reachable_trans)
  then show ?case using e' ee by auto
qed

lemma (in shortest_paths_locale_step1) path_from_root_Vr:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "s \<rightarrow>\<^sup>* v"
proof(cases "v = s")
case True thus ?thesis using assms by simp
next
case False
  obtain e where "s \<rightarrow>\<^sup>* tail G e" "e \<in> arcs G" "head G e = v"
      using path_from_root_Vr_ex[OF assms(1) False assms(2)] by blast
  then have "s \<rightarrow>\<^sup>* tail G e" "tail G e \<rightarrow> v"
    by (auto intro: in_arcs_imp_in_arcs_ends)
  then show ?thesis by (rule reachable_adj_trans)
qed

lemma (in shortest_paths_locale_step1) \<mu>_V_less_inf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "\<mu> c s v \<noteq> \<infinity>"
  using assms path_from_root_Vr \<mu>_reach_conv by force

lemma (in shortest_paths_locale_step2) enum_not0:
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "enum v \<noteq> \<infinity>"
  shows "enum v \<noteq> enat 0"
     using parent_num_assms[OF assms(1,2)] assms unfolding enum_def by auto

lemma (in shortest_paths_locale_step2) dist_Vf_\<mu>:
  fixes v :: 'a
  assumes vG: "v \<in> verts G"
  assumes "\<exists>r. dist v = ereal r"
  shows "dist v = \<mu> c s v"
proof -
  have ds: "dist s =  0"
    using assms source_val unfolding enum_def by force
  have ews:"awalk s [] s"
    using s_assms(1) unfolding awalk_def by simp
  have mu: "\<mu> c s s = ereal 0"
    using min_cost_le_walk_cost[OF ews, where c=c]
    awalk_cost_Nil ds  dist_le_\<mu>[OF s_assms(1)] zero_ereal_def
    by simp
  thus ?thesis
    using ds assms dist_le_\<mu>[OF vG]
    dist_ge_\<mu>[OF vG _ _ mu ds enum_not0]
    unfolding enum_def by fastforce
qed

lemma (in shortest_paths_locale_step1) pwalk_awalk:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v \<noteq> \<infinity>"
  shows "awalk s (pwalk v) v"
proof (cases "v=s")
case True
  thus ?thesis
    using assms pwalk.simps[where v=v]
    awalk_Nil_iff by presburger
next
case False
  from assms show ?thesis
  proof (induct rule: pwalk.induct)
    fix v
    let ?e = "the (parent_edge v)"
    let ?u = "tail G ?e"
    assume ewu: "\<not> (v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G) \<Longrightarrow>
                 ?u \<in> verts G \<Longrightarrow> dist ?u \<noteq> \<infinity> \<Longrightarrow>
                 awalk s (pwalk ?u) ?u"
    assume vG: "v \<in> verts G"
    assume dv: "dist v \<noteq> \<infinity>"
    thus "awalk s (pwalk v) v "
    proof (cases "v = s \<or> dist v = \<infinity> \<or> v \<notin> verts G")
    case True
      thus ?thesis
        using pwalk.simps vG dv
        awalk_Nil_iff by fastforce
    next
    case False
      obtain e  where ee:
        "e \<in>arcs G"
        "parent_edge v = Some e"
        "head G e = v"
        "dist (tail G e) \<noteq> \<infinity>"
        using parent_num_assms False by blast
      hence "awalk s (pwalk ?u) ?u"
        using ewu[OF False] tail_in_verts by simp
      hence "awalk s (pwalk (tail G e) @ [e]) v"
        using ee(1-3) vG
        by (auto simp: awalk_simps simp del: pwalk.simps)
      also have "pwalk (tail G e) @ [e] = pwalk v"
        using False ee(2) unfolding pwalk.simps[where v=v] by auto
      finally show ?thesis .
    qed
  qed
qed

lemma (in shortest_paths_locale_step3) \<mu>_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "dist v = - \<infinity>"
  shows "\<mu> c s v = - \<infinity>"
proof -
  have "awalk s (pwalk v) v"
    using pwalk_awalk assms by force
moreover
  obtain w where ww: "w \<in> fst ` C \<inter> pwalk_verts v"
    using int_neg_cyc[OF assms] by blast
  then obtain q where
     "awalk w q w"
     "awalk_cost c q < 0"
     using C_se by auto
moreover
  have "w \<in> set (awalk_verts s (pwalk v))"
    using ww unfolding pwalk_verts_def by fast
ultimately
  show ?thesis using  neg_cycle_imp_inf_\<mu> by force
qed

lemma (in shortest_paths_locale_step3) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
proof(cases "dist v")
show " \<And>r. dist v = ereal r \<Longrightarrow> dist v = \<mu> c s v"
  using dist_Vf_\<mu>[OF assms] by simp
next
show "dist v = \<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_V_less_inf[OF assms]
  dist_le_\<mu>[OF assms] by simp
next
show "dist v = -\<infinity> \<Longrightarrow> dist v = \<mu> c s v"
  using \<mu>_ninf[OF assms] by simp
qed

end


theory Float_Misc imports
  Main
  "HOL-Library.Float"
  "Affine_Arithmetic.Optimize_Float"
begin

abbreviation
  float_of_nat :: "nat \<Rightarrow> float"
where
  "float_of_nat \<equiv> of_nat"

abbreviation
  float_of_int :: "int \<Rightarrow> float"
where
  "float_of_int \<equiv> of_int"

definition rat_of_float::"float \<Rightarrow> rat" where
  "rat_of_float f = (let e=exponent f;m=mantissa f in
    if e\<ge>0 then rat_of_int(m*2^nat e) else Fract m (2^nat (- e)))"

lemma real_of_rat_of_float[simp]:
  "real_of_rat (rat_of_float f) = real_of_float f"
  unfolding rat_of_float_def
  by (auto simp add:Let_def mantissa_exponent of_rat_mult of_rat_power of_rat_divide
    powr_real_of_int field_simps of_rat_rat)

lemma rat_of_float_of_int[simp]:
  "rat_of_float (float_of_int x) = rat_of_int x"
  by (metis of_rat_eq_iff of_rat_of_int_eq real_of_float_of_int_eq real_of_rat_of_float)

lemma rat_of_float_0[simp]: "rat_of_float 0 = 0"
  using rat_of_float_def by auto

lemma rat_of_float_1[simp]: "rat_of_float 1 = 1"
  by (simp add: exponent_1 mantissa_1 rat_of_float_def)

lemma rat_of_float_add: "rat_of_float (x + y) = rat_of_float x + rat_of_float y"
proof -
  have "real_of_rat (rat_of_float (x + y)) = real_of_rat (rat_of_float x + rat_of_float y)"
    by (simp add: of_rat_add)
  then show ?thesis using of_rat_eq_iff by blast
qed

lemma rat_of_float_mult: "rat_of_float (x * y) = rat_of_float x * rat_of_float y"
proof -
  have "real_of_rat (rat_of_float (x * y)) = real_of_rat (rat_of_float x * rat_of_float y)"
    by (simp add: of_rat_mult)
  then show ?thesis using of_rat_eq_iff by blast
qed

end


theory Referencing
imports
  Main
  "List-Index.List_Index"
begin

datatype ltype=
  Unit | Fun ltype ltype (infixr "\<rightarrow>"  225) | Ref ltype

datatype lterm=
  LVar nat
| LApp lterm lterm
| LAbs ltype lterm
| unit
| ref lterm
| deref lterm ("!(_)" [180]220)
| assign lterm lterm ("(_)::=(_)" [100,195] 220)
| L nat

fun shift_L :: "int \<Rightarrow> nat \<Rightarrow> lterm \<Rightarrow> lterm" where
 "shift_L d c (ref t) = ref (shift_L d c t)"|
 "shift_L d c (t1::=t2) = (shift_L d c t1)::=(shift_L d c t2)"|
 "shift_L d c (LVar k)    = LVar (if k < c then k else nat (int k + d))" |
 "shift_L d c (LApp t t1) = LApp (shift_L d c t) (shift_L d c t1)" |
 "shift_L d c (LAbs T t)  = LAbs T (shift_L d (Suc c) t)" |
 "shift_L d c (!t) =!(shift_L d c t)" |
 "shift_L d c unit = unit" |
 "shift_L d c (L v) = L v"

fun subst_L :: "nat \<Rightarrow> lterm \<Rightarrow> lterm \<Rightarrow> lterm" where
  "subst_L j s (ref t) = ref (subst_L j s t)"|
  "subst_L j s (t1::=t2) = (subst_L j s t1)::=(subst_L j s t2)"|
  "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)" |
  "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
  "subst_L j s (LAbs T t) = LAbs T (subst_L (Suc j) (shift_L 1 0 s) t)"|
  "subst_L j s unit = unit" |
  "subst_L j s (L n) = L n" |
  "subst_L j s (!t) = !(subst_L j s t)"

fun FV ::"lterm \<Rightarrow> nat set" where
  "FV (LVar k) = {k}"|
  "FV (LApp t1 t2) = FV t1 \<union> FV t2"|
  "FV (LAbs T t) =  image (\<lambda>x. x - 1) (FV t - {0})" |
  "FV (t1::=t2) = FV t1 \<union> FV t2"|
  "FV (ref t) = FV t"|
  "FV (!t) = FV t"|
  "FV _ = {}"

inductive is_value_L:: "lterm \<Rightarrow> bool" where
  "is_value_L unit"
| "is_value_L (L n)"
| "is_value_L (LAbs T t)"

type_synonym lstore   = "lterm list"

abbreviation consS :: "lstore \<Rightarrow> lterm \<Rightarrow> lstore" (infixl "|\<leftarrow>|" 200) where
  "\<mu>|\<leftarrow>|v \<equiv> \<mu>@[v]"

inductive eval1_L :: "lterm \<Rightarrow> lstore \<Rightarrow> lterm \<Rightarrow> lstore \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 \<mu> t1' \<mu>' \<Longrightarrow> eval1_L (LApp t1 t2) \<mu> (LApp t1' t2) \<mu>'" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 \<mu> t2' \<mu>'\<Longrightarrow> eval1_L (LApp v1 t2) \<mu> (LApp v1 t2') \<mu>'" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T' t12) v2) \<mu>
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12)) \<mu>" |
  eval1_LRefV:
    "is_value_L v \<Longrightarrow> eval1_L (ref v) \<mu> (L (length \<mu>)) (\<mu>|\<leftarrow>|v)" |
  eval1_LRef:
    "eval1_L t1 \<mu> t1' \<mu>' \<Longrightarrow> eval1_L (ref t1) \<mu> (ref t1') \<mu>'" |
  eval1_LDerefLoc:
    "n<length \<mu> \<Longrightarrow>  eval1_L (!(L n)) \<mu> (\<mu>!n) \<mu>" |
  eval1_LDeref:
    "eval1_L t1 \<mu> t1' \<mu>' \<Longrightarrow> eval1_L (!t1) \<mu> (!t1') \<mu>'" |
  eval1_LAssignLoc:
    "is_value_L v \<Longrightarrow> eval1_L (L n::=v) \<mu> unit (\<mu>[n:=v])"|
  eval1_LAssign1:
    "eval1_L t1 \<mu> t1' \<mu>' \<Longrightarrow> eval1_L (t1::=t2) \<mu> (t1'::=t2) \<mu>'" |
  eval1_LAssign2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 \<mu> t2' \<mu>'\<Longrightarrow> eval1_L (v1::=t2) \<mu> (v1::=t2') \<mu>'"

inductive_cases eval1_LAppE: "eval1_L (LApp t1 t2) \<mu> t' \<mu>'"

type_synonym lcontext = "ltype list"
type_synonym loc_ctx   = "ltype list"

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T' \<equiv> T' # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

abbreviation consLoc :: "loc_ctx \<Rightarrow> ltype \<Rightarrow> loc_ctx" (infixl "|,|\<^sub>l" 200) where
  "\<Sigma> |,|\<^sub>l T' \<equiv> \<Sigma>@[T']"
abbreviation elemLoc :: "(nat \<times> ltype) \<Rightarrow> loc_ctx \<Rightarrow> bool" (infix "|\<in>\<^sub>l|" 200) where
  "elemLoc p \<Sigma> \<equiv> fst p < length \<Sigma> \<and> snd p = nth \<Sigma> (fst p)"

text{*  For the typing rule of letbinder, we require to replace the type
        of the variable by the expected type
    *}

inductive has_type_L :: "lcontext \<Rightarrow> loc_ctx \<Rightarrow> lterm \<Rightarrow> ltype \<Rightarrow> bool" ("((_)|;|(_)/ \<turnstile> (_)/ |:| (_))" [150,150, 150] 150) where
  \<comment> \<open>Rules relating to the type of Unit\<close>
  has_type_Lunit:
    "\<Gamma>|;|\<Sigma> \<turnstile> unit |:| Unit"|
  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LVar:
    "(x, T') |\<in>| \<Gamma> \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> LVar x |:| (T')" |
  has_type_LAbs:
    "(\<Gamma> |,| T1)|;|\<Sigma> \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> LAbs T1 t2 |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma>|;|\<Sigma> \<turnstile> t1 |:| T11 \<rightarrow> T12 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> LApp t1 t2 |:| T12" |
  has_type_Loc:
    "(n,T1) |\<in>\<^sub>l| \<Sigma> \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> L n |:| Ref T1" |
  has_type_Ref:
    "\<Gamma>|;|\<Sigma> \<turnstile> t |:| T1 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> ref t |:| Ref T1"|
  has_type_Deref:
    "\<Gamma>|;|\<Sigma> \<turnstile> t |:| Ref T1 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> !t |:| T1"|
  has_type_Assign:
    "\<Gamma>|;|\<Sigma> \<turnstile> t1 |:| Ref T1 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> t2 |:| T1 \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> (t1::=t2) |:| Unit"

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> v |:| Unit \<Longrightarrow> v = unit"
  "is_value_L v \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
  "is_value_L v \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> v |:| Ref T1 \<Longrightarrow>\<exists>n. n<length \<Sigma> \<and> v = L n \<and> \<Sigma>!n=T1"
by (auto elim: has_type_L.cases is_value_L.cases)

abbreviation well_typed_store::"lcontext \<Rightarrow> loc_ctx \<Rightarrow> lstore \<Rightarrow> bool" ("(_)|;|(_) \<Turnstile> (_)" [150,150,190] 200) where
"\<Gamma>|;|\<Sigma> \<Turnstile> \<mu> \<equiv> (length \<Sigma> = length \<mu>) \<and> (\<forall>i<length \<Sigma>. \<Gamma>|;|\<Sigma> \<turnstile> (\<mu>!i) |:| (\<Sigma>!i))"

lemma gr_Suc_conv: "Suc x \<le> n \<longleftrightarrow> (\<exists>m. n = Suc m \<and> x \<le> m)"
  by (cases n) auto

lemma FV_shift:
  "FV (shift_L (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV t)"
proof (induction t arbitrary: c rule: lterm.induct)
  case (LAbs T t)
  thus ?case  by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemmas int_1 = of_nat_1[where 'a=int]

lemma FV_subst:
  "FV (subst_L n t u) = (if n \<in> FV u then (FV u - {n}) \<union> FV t else FV u)"
proof (induction u arbitrary: n t rule: lterm.induct)
  case (LAbs T u)
  thus ?case
    by (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1],
        (metis DiffI One_nat_def UnCI diff_Suc_1 empty_iff imageI insert_iff nat.distinct(1))+)
qed (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1])

lemma weakening:
  "\<Gamma> |;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> |;|\<Sigma> \<turnstile> shift_L 1 n t |:| T"
proof (induction \<Gamma> \<Sigma> t T arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t2 T2)
    from has_type_LAbs.prems has_type_LAbs.hyps
      has_type_LAbs.IH[where n="Suc n"]
    show ?case
      by (auto intro: has_type_L.intros)
qed (auto simp: nth_append min_def intro: has_type_L.intros)

lemma substitution:
  "\<Gamma> |;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow>  \<Gamma>|;|\<Sigma> \<turnstile> LVar n |:| S \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> s |:| S \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> subst_L n s t |:| T"
proof (induction \<Gamma> \<Sigma>  t T arbitrary: s n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 \<Sigma> t T2)
  thus ?case
    using weakening[where n=0, unfolded insert_nth_def nat.rec]
    by (force intro!: has_type_L.intros simp: has_type_L.simps[of _ _ "LVar _" _, simplified])
qed (auto intro!: has_type_L.intros simp: has_type_L.simps[of _ _ "LVar _" _, simplified])

lemma store_updt:
  "\<Gamma> |;|\<Sigma> \<Turnstile> \<mu> \<Longrightarrow> i<length \<Sigma> \<Longrightarrow> \<Sigma>!i = T \<Longrightarrow> \<Gamma> |;|\<Sigma> \<turnstile> v |:| T \<Longrightarrow> \<Gamma> |;|\<Sigma> \<Turnstile> (\<mu>[i:=v])"
by (simp, metis  nth_list_update_eq nth_list_update_neq)

lemma store_weakening:
  "\<Gamma> |;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow> \<Gamma>|;|(\<Sigma>@\<Sigma>1) \<turnstile> t |:| T"
by (induction \<Gamma> \<Sigma>  t T arbitrary: \<Sigma>1 rule: has_type_L.induct)
   (auto intro!: has_type_L.intros
         simp: has_type_L.simps[of _ _ "LVar _" _, simplified] nth_append)

lemma progress:
  "\<Gamma>|;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow> \<Gamma>=\<emptyset> \<Longrightarrow> is_value_L t \<or> (\<forall>\<mu>. \<Gamma>|;|\<Sigma> \<Turnstile> \<mu> \<longrightarrow> (\<exists>t' \<mu>'. eval1_L t \<mu> t' \<mu>'))"
proof (induction t T rule: has_type_L.induct)
  case (has_type_LApp \<Gamma> \<Sigma> t1 T11 T12 t2)
    note hyps=this
    show ?case
      using hyps(3-4)[OF hyps(5)]
      by (metis eval1_L.intros(1-3) canonical_forms(2)[OF _ hyps(1)])
next
  case (has_type_Ref \<Gamma> \<Sigma> t T1)
    note hyps=this
    show ?case
      using hyps(2)[OF hyps(3)]
            eval1_L.intros(4,5)
      by meson
next
  case (has_type_Deref \<Gamma> \<Sigma> t T1)
    note hyps=this
    show ?case
      using hyps(2)[OF hyps(3)] canonical_forms(3)[OF _ hyps(1)]
            eval1_L.intros(6,7)
      by metis
next
  case (has_type_Assign \<Gamma> \<Sigma> t1 T1 t2)
    note hyps=this
    show ?case
      using hyps(3,4)[OF hyps(5)]
            canonical_forms(3)[OF _ hyps(1)] eval1_L.intros(8-10)
      by metis
qed (simp_all add: is_value_L.intros)

lemma shift_down:
  "insert_nth n U \<Gamma>|;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> \<Gamma>|;|\<Sigma> \<turnstile> shift_L (- 1) n t |:| T"
proof (induction "insert_nth n U \<Gamma>" \<Sigma> t T arbitrary: \<Gamma> n rule: has_type_L.induct)
  case (has_type_LAbs V t T)
    from this(1,3,4) show ?case
      by (fastforce intro: has_type_L.intros has_type_LAbs.hyps(2)[where n="Suc n"])+
qed (fastforce intro: has_type_L.intros simp: nth_append min_def)+

lemma preservation:
  "\<Gamma> |;|\<Sigma> \<turnstile> t |:| T \<Longrightarrow> \<Gamma> |;|\<Sigma> \<Turnstile> \<mu> \<Longrightarrow> eval1_L t \<mu> t' \<mu>' \<Longrightarrow>
    \<exists>\<Sigma>1. \<Gamma> |;| (\<Sigma>@\<Sigma>1) \<Turnstile> \<mu>' \<and> \<Gamma> |;|(\<Sigma>@\<Sigma>1) \<turnstile> t' |:| T"
proof (induction \<Gamma> \<Sigma> t T arbitrary: \<mu>' t' rule: has_type_L.induct)
  case (has_type_LApp \<Gamma> \<Sigma> t1 T11 T12 t2)
    note hyps = this and has_T_Abs= has_type_L.simps[of _ _ "LAbs _ _", simplified]

    have 1:"(\<exists>t1'. t' = LApp t1' t2 \<and> eval1_L t1 \<mu> t1' \<mu>') \<Longrightarrow> ?case"
      using has_type_L.intros(4) eval1_L.intros(1)
            hyps(2) store_weakening[of \<Gamma> \<Sigma>] hyps(3)[OF hyps(5)]
      by meson

    have 2:"\<exists>t2'. t' = LApp t1 t2' \<and> is_value_L t1 \<and> eval1_L t2 \<mu> t2' \<mu>' \<Longrightarrow> ?case"
      using has_type_L.intros(4) eval1_L.intros(2)
            hyps(1) store_weakening[of \<Gamma> \<Sigma>] hyps(4)[OF hyps(5)]
      by meson

    have 3: "\<exists>T' t12.
        t1 = LAbs T' t12 \<and> t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t12) \<and> \<mu>' = \<mu> \<and> is_value_L t2
        \<Longrightarrow> ?case"
      proof -
        assume P:"\<exists>T' t12. t1 = LAbs T' t12 \<and> t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t12) \<and>
                            \<mu>' = \<mu> \<and> is_value_L t2"
        then obtain T' t1' where H: "t1 = LAbs T' t1'" "t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t1')"
                                       "\<mu>'= \<mu>" "is_value_L t2"
          by fastforce

        have H':"\<Gamma> |,| T'|;|\<Sigma> \<turnstile> t1' |:| T12" "T'=T11"
          using  hyps(1)[unfolded H(1) has_type_L.simps[of _ _ "LAbs _ _", simplified]]
          by fast+

        have FV_after_subst:"(\<And>x. x \<in> FV (subst_L 0 (shift_L 1 0 t2) t1') \<Longrightarrow> x \<noteq> 0)"
          using FV_subst[of 0 "shift_L 1 0 t2" t1', unfolded FV_shift[of 1 0 t2, simplified]]
          by (cases "0\<in>FV t1'") (fastforce, metis)

        show ?thesis
          using substitution[OF H'(1), of 0 T11 "shift_L 1 0 t2", unfolded H'(2)]
                weakening[OF hyps(2),of 0 T', unfolded insert_nth_def nat.rec H'(2), simplified]
                hyps(5)[unfolded H(3)[symmetric]]
                shift_down[ of 0 T11 \<Gamma> \<Sigma> "subst_L 0 (shift_L 1 0 t2) t1'" T12,
                            OF _  _ FV_after_subst,
                            unfolded insert_nth_def nat.rec H(2)[symmetric], simplified]
                has_type_L.simps[of "\<Gamma>|,|T11" \<Sigma> "LVar 0", simplified]
          by simp
      qed
    show ?case
      using  hyps(6)[unfolded eval1_L.simps[of "LApp t1 t2" \<mu>, simplified]]
             1 2 3
      by force
next
  case (has_type_Ref \<Gamma> \<Sigma> t T1)
    note hyps=this
    have 1:" t' = L (length \<mu>) \<and> \<mu>' = \<mu> |\<leftarrow>| t \<and> is_value_L t \<Longrightarrow> ?case"
      using hyps(1) has_type_L.intros(5)[of "length \<mu>" T1 "\<Sigma>|,|\<^sub>lT1" \<Gamma>, simplified]
            hyps(3) store_weakening
      by (metis length_append_singleton less_Suc_eq nth_append nth_append_length)
    have "(\<exists>t1'. t' = ref t1' \<and> eval1_L t \<mu> t1' \<mu>') \<Longrightarrow> ?case"
      using hyps(2)[OF hyps(3), of _ \<mu>']
            has_type_L.intros(6)[of \<Gamma> "\<Sigma> @ _" _ T1]
      by meson
    with 1 show ?case
      using hyps(4)[unfolded eval1_L.simps[of "ref _",simplified]]
      by fast
next
  case (has_type_Deref \<Gamma> \<Sigma> t T1)
    note hyps=this
    have 1:"(\<exists>n. t = L n \<and> t' = \<mu> ! n \<and> \<mu>' = \<mu> \<and> n < length \<mu>) \<Longrightarrow> ?case"
      using hyps(3) hyps(1) has_type_L.simps[of \<Gamma> \<Sigma> "L _" "Ref T1", simplified]
      by fastforce

    have "(\<exists>t1'. t' = !t1' \<and> eval1_L t \<mu> t1' \<mu>') \<Longrightarrow> ?case"
      using hyps(2)[OF hyps(3), of _ \<mu>']
            has_type_L.intros(7)[of \<Gamma> "\<Sigma>@_" _ T1]
      by meson

    with 1 show ?case
      using hyps(4)[unfolded eval1_L.simps[of "!t",simplified]]
      by blast
next
  case (has_type_Assign \<Gamma> \<Sigma> t1 T1 t2)
    note hyps=this

    have 1: "\<exists>n. t1 = L n \<and> t' = unit \<and> \<mu>' = \<mu>[n := t2] \<and> is_value_L t2 \<Longrightarrow> ?case"
      using has_type_L.simps[of \<Gamma> \<Sigma> "L _" "Ref T1", simplified] hyps(1)
            store_updt[OF hyps(5) _ _ hyps(2)]
            has_type_Lunit
      by fastforce

    have 2: "\<exists>t1'. t' = t1'::=t2 \<and> eval1_L t1 \<mu> t1' \<mu>' \<Longrightarrow> ?case"
      using hyps(3)[OF hyps(5), of _ \<mu>']
            has_type_L.intros(8)[OF _ store_weakening[OF hyps(2)]]
      by meson

    have "\<exists>t2'. t' = t1::=t2' \<and> is_value_L t1 \<and> eval1_L t2 \<mu> t2' \<mu>' \<Longrightarrow> ?case"
      using hyps(4)[OF hyps(5), of _ \<mu>']
            has_type_L.intros(8)[OF store_weakening[OF hyps(1)]]
      by meson

    with 1 2 show ?case
      using hyps(6)[unfolded eval1_L.simps[of "t1::=t2", simplified]]
      by blast
qed (auto elim: eval1_L.cases)

end


(*  Title:      HOL/ex/Unification.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Author:     Konrad Slind, TUM & Cambridge University Computer Laboratory
    Author:     Alexander Krauss, TUM
*)

section \<open>Substitution and Unification\<close>

theory Unification
imports Main
begin

text \<open>
  Implements Manna \& Waldinger's formalization, with Paulson's
  simplifications, and some new simplifications by Slind and Krauss.

  Z Manna \& R Waldinger, Deductive Synthesis of the Unification
  Algorithm.  SCP 1 (1981), 5-48

  L C Paulson, Verifying the Unification Algorithm in LCF. SCP 5
  (1985), 143-170

  K Slind, Reasoning about Terminating Functional Programs,
  Ph.D. thesis, TUM, 1999, Sect. 5.8

  A Krauss, Partial and Nested Recursive Function Definitions in
  Higher-Order Logic, JAR 44(4):303-336, 2010. Sect. 6.3
\<close>

subsection \<open>Terms\<close>

text \<open>Binary trees with leaves that are constants or variables.\<close>

datatype 'a trm =
  Var 'a
  | Const 'a
  | Comb "'a trm" "'a trm" (infix "\<cdot>" 60)

primrec vars_of :: "'a trm \<Rightarrow> 'a set"
where
  "vars_of (Var v) = {v}"
| "vars_of (Const c) = {}"
| "vars_of (M \<cdot> N) = vars_of M \<union> vars_of N"

fun occs :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" (infixl "\<prec>" 54)
where
  "u \<prec> Var v \<longleftrightarrow> False"
| "u \<prec> Const c \<longleftrightarrow> False"
| "u \<prec> M \<cdot> N \<longleftrightarrow> u = M \<or> u = N \<or> u \<prec> M \<or> u \<prec> N"

lemma finite_vars_of[intro]: "finite (vars_of t)"
  by (induct t) simp_all

lemma vars_iff_occseq: "x \<in> vars_of t \<longleftrightarrow> Var x \<prec> t \<or> Var x = t"
  by (induct t) auto

lemma occs_vars_subset: "M \<prec> N \<Longrightarrow> vars_of M \<subseteq> vars_of N"
  by (induct N) auto

lemma size_less_size_if_occs: "t \<prec> u \<Longrightarrow> size t < size u"
proof (induction u arbitrary: t)
  case (Comb u1 u2)
  thus ?case by fastforce
qed simp_all

corollary neq_if_occs: "t \<prec> u \<Longrightarrow> t \<noteq> u"
  using size_less_size_if_occs by auto

subsection \<open>Substitutions\<close>

type_synonym 'a subst = "('a \<times> 'a trm) list"

fun assoc :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b"
where
  "assoc x d [] = d"
| "assoc x d ((p,q)#t) = (if x = p then q else assoc x d t)"

primrec subst :: "'a trm \<Rightarrow> 'a subst \<Rightarrow> 'a trm" (infixl "\<lhd>" 55)
where
  "(Var v) \<lhd> s = assoc v (Var v) s"
| "(Const c) \<lhd> s = (Const c)"
| "(M \<cdot> N) \<lhd> s = (M \<lhd> s) \<cdot> (N \<lhd> s)"

definition subst_eq (infixr "\<doteq>" 52)
where
  "s1 \<doteq> s2 \<longleftrightarrow> (\<forall>t. t \<lhd> s1 = t \<lhd> s2)"

fun comp :: "'a subst \<Rightarrow> 'a subst \<Rightarrow> 'a subst" (infixl "\<lozenge>" 56)
where
  "[] \<lozenge> bl = bl"
| "((a,b) # al) \<lozenge> bl = (a, b \<lhd> bl) # (al \<lozenge> bl)"

lemma subst_Nil[simp]: "t \<lhd> [] = t"
by (induct t) auto

lemma subst_mono: "t \<prec> u \<Longrightarrow> t \<lhd> s \<prec> u \<lhd> s"
by (induct u) auto

lemma agreement: "(t \<lhd> r = t \<lhd> s) \<longleftrightarrow> (\<forall>v \<in> vars_of t. Var v \<lhd> r = Var v \<lhd> s)"
by (induct t) auto

lemma repl_invariance: "v \<notin> vars_of t \<Longrightarrow> t \<lhd> (v,u) # s = t \<lhd> s"
by (simp add: agreement)

lemma remove_var: "v \<notin> vars_of s \<Longrightarrow> v \<notin> vars_of (t \<lhd> [(v, s)])"
by (induct t) simp_all

lemma subst_refl[iff]: "s \<doteq> s"
  by (auto simp:subst_eq_def)

lemma subst_sym[sym]: "\<lbrakk>s1 \<doteq> s2\<rbrakk> \<Longrightarrow> s2 \<doteq> s1"
  by (auto simp:subst_eq_def)

lemma subst_trans[trans]: "\<lbrakk>s1 \<doteq> s2; s2 \<doteq> s3\<rbrakk> \<Longrightarrow> s1 \<doteq> s3"
  by (auto simp:subst_eq_def)

lemma subst_no_occs: "\<not> Var v \<prec> t \<Longrightarrow> Var v \<noteq> t
  \<Longrightarrow> t \<lhd> [(v,s)] = t"
by (induct t) auto

lemma comp_Nil[simp]: "\<sigma> \<lozenge> [] = \<sigma>"
by (induct \<sigma>) auto

lemma subst_comp[simp]: "t \<lhd> (r \<lozenge> s) = t \<lhd> r \<lhd> s"
proof (induct t)
  case (Var v) thus ?case
    by (induct r) auto
qed auto

lemma subst_eq_intro[intro]: "(\<And>t. t \<lhd> \<sigma> = t \<lhd> \<theta>) \<Longrightarrow> \<sigma> \<doteq> \<theta>"
  by (auto simp:subst_eq_def)

lemma subst_eq_dest[dest]: "s1 \<doteq> s2 \<Longrightarrow> t \<lhd> s1 = t \<lhd> s2"
  by (auto simp:subst_eq_def)

lemma comp_assoc: "(a \<lozenge> b) \<lozenge> c \<doteq> a \<lozenge> (b \<lozenge> c)"
  by auto

lemma subst_cong: "\<lbrakk>\<sigma> \<doteq> \<sigma>'; \<theta> \<doteq> \<theta>'\<rbrakk> \<Longrightarrow> (\<sigma> \<lozenge> \<theta>) \<doteq> (\<sigma>' \<lozenge> \<theta>')"
  by (auto simp: subst_eq_def)

lemma var_self: "[(v, Var v)] \<doteq> []"
proof
  fix t show "t \<lhd> [(v, Var v)] = t \<lhd> []"
    by (induct t) simp_all
qed

lemma var_same[simp]: "[(v, t)] \<doteq> [] \<longleftrightarrow> t = Var v"
by (metis assoc.simps(2) subst.simps(1) subst_eq_def var_self)

lemma vars_of_subst_conv_Union: "vars_of (t \<lhd> \<eta>) = \<Union>(vars_of ` (\<lambda>x. Var x \<lhd> \<eta>) ` vars_of t)"
  by (induction t) simp_all

lemma domain_comp: "fst ` set (\<sigma> \<lozenge> \<theta>) = fst ` (set \<sigma> \<union> set \<theta>)"
  by (induction \<sigma> \<theta> rule: comp.induct) auto

subsection \<open>Unifiers and Most General Unifiers\<close>

definition Unifier :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool"
  where "Unifier \<sigma> t u \<longleftrightarrow> (t \<lhd> \<sigma> = u \<lhd> \<sigma>)"

lemma not_occs_if_Unifier:
  assumes "Unifier \<sigma> t u"
  shows "\<not> (t \<prec> u) \<and> \<not> (u \<prec> t)"
proof -
  from assms have "t \<lhd> \<sigma> = u \<lhd> \<sigma>"
    unfolding Unifier_def by simp
  thus ?thesis
    using neq_if_occs subst_mono by metis
qed

definition MGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "MGU \<sigma> t u \<longleftrightarrow>
   Unifier \<sigma> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> (\<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>))"

lemma MGUI[intro]:
  "\<lbrakk>t \<lhd> \<sigma> = u \<lhd> \<sigma>; \<And>\<theta>. t \<lhd> \<theta> = u \<lhd> \<theta> \<Longrightarrow> \<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>\<rbrakk>
  \<Longrightarrow> MGU \<sigma> t u"
  by (simp only:Unifier_def MGU_def, auto)

lemma MGU_sym[sym]:
  "MGU \<sigma> s t \<Longrightarrow> MGU \<sigma> t s"
  by (auto simp:MGU_def Unifier_def)

lemma MGU_is_Unifier: "MGU \<sigma> t u \<Longrightarrow> Unifier \<sigma> t u"
unfolding MGU_def by (rule conjunct1)

lemma MGU_Var:
  assumes "\<not> Var v \<prec> t"
  shows "MGU [(v,t)] (Var v) t"
proof (intro MGUI exI)
  show "Var v \<lhd> [(v,t)] = t \<lhd> [(v,t)]" using assms
    by (metis assoc.simps(2) repl_invariance subst.simps(1) subst_Nil vars_iff_occseq)
next
  fix \<theta> assume th: "Var v \<lhd> \<theta> = t \<lhd> \<theta>"
  show "\<theta> \<doteq> [(v,t)] \<lozenge> \<theta>"
  proof
    fix s show "s \<lhd> \<theta> = s \<lhd> [(v,t)] \<lozenge> \<theta>" using th
      by (induct s) auto
  qed
qed

lemma MGU_Const: "MGU [] (Const c) (Const d) \<longleftrightarrow> c = d"
  by (auto simp: MGU_def Unifier_def)

subsection \<open>The unification algorithm\<close>

function unify :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> 'a subst option"
where
  "unify (Const c) (M \<cdot> N)   = None"
| "unify (M \<cdot> N)   (Const c) = None"
| "unify (Const c) (Var v)   = Some [(v, Const c)]"
| "unify (M \<cdot> N)   (Var v)   = (if Var v \<prec> M \<cdot> N
                                        then None
                                        else Some [(v, M \<cdot> N)])"
| "unify (Var v)   M         = (if Var v \<prec> M
                                        then None
                                        else Some [(v, M)])"
| "unify (Const c) (Const d) = (if c=d then Some [] else None)"
| "unify (M \<cdot> N) (M' \<cdot> N') = (case unify M M' of
                                    None \<Rightarrow> None |
                                    Some \<theta> \<Rightarrow> (case unify (N \<lhd> \<theta>) (N' \<lhd> \<theta>)
                                      of None \<Rightarrow> None |
                                         Some \<sigma> \<Rightarrow> Some (\<theta> \<lozenge> \<sigma>)))"
  by pat_completeness auto

subsection \<open>Properties used in termination proof\<close>

text \<open>Elimination of variables by a substitution:\<close>

definition
  "elim \<sigma> v \<equiv> \<forall>t. v \<notin> vars_of (t \<lhd> \<sigma>)"

lemma elim_intro[intro]: "(\<And>t. v \<notin> vars_of (t \<lhd> \<sigma>)) \<Longrightarrow> elim \<sigma> v"
  by (auto simp:elim_def)

lemma elim_dest[dest]: "elim \<sigma> v \<Longrightarrow> v \<notin> vars_of (t \<lhd> \<sigma>)"
  by (auto simp:elim_def)

lemma elim_eq: "\<sigma> \<doteq> \<theta> \<Longrightarrow> elim \<sigma> x = elim \<theta> x"
  by (auto simp:elim_def subst_eq_def)

lemma occs_elim: "\<not> Var v \<prec> t
  \<Longrightarrow> elim [(v,t)] v \<or> [(v,t)] \<doteq> []"
by (metis elim_intro remove_var var_same vars_iff_occseq)

text \<open>The result of a unification never introduces new variables:\<close>

declare unify.psimps[simp]

lemma unify_vars:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "vars_of (t \<lhd> \<sigma>) \<subseteq> vars_of M \<union> vars_of N \<union> vars_of t"
  (is "?P M N \<sigma> t")
using assms
proof (induct M N arbitrary:\<sigma> t)
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]" by simp
  thus ?case by (induct t) auto
next
  case (4 M N v)
  hence "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  thus ?case by (induct t) auto
next
  case (5 v M)
  hence "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  thus ?case by (induct t) auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "\<And>t. ?P M M' \<theta>1 t"
    and ih2: "\<And>t. ?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2 t"
    by (auto split:option.split_asm)

  show ?case
  proof
    fix v assume a: "v \<in> vars_of (t \<lhd> \<sigma>)"

    show "v \<in> vars_of (M \<cdot> N) \<union> vars_of (M' \<cdot> N') \<union> vars_of t"
    proof (cases "v \<notin> vars_of M \<and> v \<notin> vars_of M'
        \<and> v \<notin> vars_of N \<and> v \<notin> vars_of N'")
      case True
      with ih1 have l:"\<And>t. v \<in> vars_of (t \<lhd> \<theta>1) \<Longrightarrow> v \<in> vars_of t"
        by auto

      from a and ih2[where t="t \<lhd> \<theta>1"]
      have "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)
        \<or> v \<in> vars_of (t \<lhd> \<theta>1)" unfolding \<sigma>
        by auto
      hence "v \<in> vars_of t"
      proof
        assume "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
        with True show ?thesis by (auto dest:l)
      next
        assume "v \<in> vars_of (t \<lhd> \<theta>1)"
        thus ?thesis by (rule l)
      qed

      thus ?thesis by auto
    qed auto
  qed
qed (auto split: if_split_asm)

text \<open>The result of a unification is either the identity
substitution or it eliminates a variable from one of the terms:\<close>

lemma unify_eliminates:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "(\<exists>v\<in>vars_of M \<union> vars_of N. elim \<sigma> v) \<or> \<sigma> \<doteq> []"
  (is "?P M N \<sigma>")
using assms
proof (induct M N arbitrary:\<sigma>)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 c v)
  have no_occs: "\<not> Var v \<prec> Const c" by simp
  with 3 have "\<sigma> = [(v, Const c)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (4 M N v)
  hence no_occs: "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (5 v M)
  hence no_occs: "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (6 c d) thus ?case
    by (cases "c = d") auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "?P M M' \<theta>1"
    and ih2: "?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2"
    by (auto split:option.split_asm)

  from \<open>unify_dom (M \<cdot> N, M' \<cdot> N')\<close>
  have "unify_dom (M, M')"
    by (rule accp_downward) (rule unify_rel.intros)
  hence no_new_vars:
    "\<And>t. vars_of (t \<lhd> \<theta>1) \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of t"
    by (rule unify_vars) (rule \<open>unify M M' = Some \<theta>1\<close>)

  from ih2 show ?case
  proof
    assume "\<exists>v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1). elim \<theta>2 v"
    then obtain v
      where "v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
      and el: "elim \<theta>2 v" by auto
    with no_new_vars show ?thesis unfolding \<sigma>
      by (auto simp:elim_def)
  next
    assume empty[simp]: "\<theta>2 \<doteq> []"

    have "\<sigma> \<doteq> (\<theta>1 \<lozenge> [])" unfolding \<sigma>
      by (rule subst_cong) auto
    also have "\<dots> \<doteq> \<theta>1" by auto
    finally have "\<sigma> \<doteq> \<theta>1" .

    from ih1 show ?thesis
    proof
      assume "\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta>1 v"
      with elim_eq[OF \<open>\<sigma> \<doteq> \<theta>1\<close>]
      show ?thesis by auto
    next
      note \<open>\<sigma> \<doteq> \<theta>1\<close>
      also assume "\<theta>1 \<doteq> []"
      finally show ?thesis ..
    qed
  qed
qed

declare unify.psimps[simp del]

subsection \<open>Termination proof\<close>

termination unify
proof
  let ?R = "measures [\<lambda>(M,N). card (vars_of M \<union> vars_of N),
                           \<lambda>(M, N). size M]"
  show "wf ?R" by simp

  fix M N M' N' :: "'a trm"
  show "((M, M'), (M \<cdot> N, M' \<cdot> N')) \<in> ?R" \<comment> \<open>Inner call\<close>
    by (rule measures_lesseq) (auto intro: card_mono)

  fix \<theta>                                   \<comment> \<open>Outer call\<close>
  assume inner: "unify_dom (M, M')"
    "unify M M' = Some \<theta>"

  from unify_eliminates[OF inner]
  show "((N \<lhd> \<theta>, N' \<lhd> \<theta>), (M \<cdot> N, M' \<cdot> N')) \<in>?R"
  proof
    \<comment> \<open>Either a variable is eliminated \ldots\<close>
    assume "(\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta> v)"
    then obtain v
      where "elim \<theta> v"
      and "v\<in>vars_of M \<union> vars_of M'" by auto
    with unify_vars[OF inner]
    have "vars_of (N\<lhd>\<theta>) \<union> vars_of (N'\<lhd>\<theta>)
      \<subset> vars_of (M\<cdot>N) \<union> vars_of (M'\<cdot>N')"
      by auto

    thus ?thesis
      by (auto intro!: measures_less intro: psubset_card_mono)
  next
    \<comment> \<open>Or the substitution is empty\<close>
    assume "\<theta> \<doteq> []"
    hence "N \<lhd> \<theta> = N"
      and "N' \<lhd> \<theta> = N'" by auto
    thus ?thesis
       by (auto intro!: measures_less intro: psubset_card_mono)
  qed
qed

subsection \<open>Unification returns a Most General Unifier\<close>

lemma unify_computes_MGU:
  "unify M N = Some \<sigma> \<Longrightarrow> MGU \<sigma> M N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M N M' N' \<sigma>) \<comment> \<open>The interesting case\<close>

  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and MGU_inner: "MGU \<theta>1 M M'"
    and MGU_outer: "MGU \<theta>2 (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (auto split:option.split_asm)

  show ?case
  proof
    from MGU_inner and MGU_outer
    have "M \<lhd> \<theta>1 = M' \<lhd> \<theta>1"
      and "N \<lhd> \<theta>1 \<lhd> \<theta>2 = N' \<lhd> \<theta>1 \<lhd> \<theta>2"
      unfolding MGU_def Unifier_def
      by auto
    thus "M \<cdot> N \<lhd> \<sigma> = M' \<cdot> N' \<lhd> \<sigma>" unfolding \<sigma>
      by simp
  next
    fix \<sigma>' assume "M \<cdot> N \<lhd> \<sigma>' = M' \<cdot> N' \<lhd> \<sigma>'"
    hence "M \<lhd> \<sigma>' = M' \<lhd> \<sigma>'"
      and Ns: "N \<lhd> \<sigma>' = N' \<lhd> \<sigma>'" by auto

    with MGU_inner obtain \<delta>
      where eqv: "\<sigma>' \<doteq> \<theta>1 \<lozenge> \<delta>"
      unfolding MGU_def Unifier_def
      by auto

    from Ns have "N \<lhd> \<theta>1 \<lhd> \<delta> = N' \<lhd> \<theta>1 \<lhd> \<delta>"
      by (simp add:subst_eq_dest[OF eqv])

    with MGU_outer obtain \<rho>
      where eqv2: "\<delta> \<doteq> \<theta>2 \<lozenge> \<rho>"
      unfolding MGU_def Unifier_def
      by auto

    have "\<sigma>' \<doteq> \<sigma> \<lozenge> \<rho>" unfolding \<sigma>
      by (rule subst_eq_intro, auto simp:subst_eq_dest[OF eqv] subst_eq_dest[OF eqv2])
    thus "\<exists>\<gamma>. \<sigma>' \<doteq> \<sigma> \<lozenge> \<gamma>" ..
  qed
qed (auto simp: MGU_Const intro: MGU_Var MGU_Var[symmetric] split: if_split_asm)

subsection \<open>Unification returns Idempotent Substitution\<close>

definition Idem :: "'a subst \<Rightarrow> bool"
where "Idem s \<longleftrightarrow> (s \<lozenge> s) \<doteq> s"

lemma Idem_Nil [iff]: "Idem []"
  by (simp add: Idem_def)

lemma Var_Idem:
  assumes "~ (Var v \<prec> t)" shows "Idem [(v,t)]"
  unfolding Idem_def
proof
  from assms have [simp]: "t \<lhd> [(v, t)] = t"
    by (metis assoc.simps(2) subst.simps(1) subst_no_occs)

  fix s show "s \<lhd> [(v, t)] \<lozenge> [(v, t)] = s \<lhd> [(v, t)]"
    by (induct s) auto
qed

lemma Unifier_Idem_subst:
  "Idem(r) \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
    Unifier (r \<lozenge> s) (t \<lhd> r) (u \<lhd> r)"
by (simp add: Idem_def Unifier_def subst_eq_def)

lemma Idem_comp:
  "Idem r \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
      (!!q. Unifier q (t \<lhd> r) (u \<lhd> r) \<Longrightarrow> s \<lozenge> q \<doteq> q) \<Longrightarrow>
    Idem (r \<lozenge> s)"
  apply (frule Unifier_Idem_subst, blast)
  apply (force simp add: Idem_def subst_eq_def)
  done

theorem unify_gives_Idem:
  "unify M N  = Some \<sigma> \<Longrightarrow> Idem \<sigma>"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M M' N N' \<sigma>)

  then obtain \<theta>1 \<theta>2
    where "unify M N = Some \<theta>1"
    and \<theta>2: "unify (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and "Idem \<theta>1"
    and "Idem \<theta>2"
    by (auto split: option.split_asm)

  from \<theta>2 have "Unifier \<theta>2 (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (rule unify_computes_MGU[THEN MGU_is_Unifier])

  with \<open>Idem \<theta>1\<close>
  show "Idem \<sigma>" unfolding \<sigma>
  proof (rule Idem_comp)
    fix \<sigma> assume "Unifier \<sigma> (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    with \<theta>2 obtain \<gamma> where \<sigma>: "\<sigma> \<doteq> \<theta>2 \<lozenge> \<gamma>"
      using unify_computes_MGU MGU_def by blast

    have "\<theta>2 \<lozenge> \<sigma> \<doteq> \<theta>2 \<lozenge> (\<theta>2 \<lozenge> \<gamma>)" by (rule subst_cong) (auto simp: \<sigma>)
    also have "... \<doteq> (\<theta>2 \<lozenge> \<theta>2) \<lozenge> \<gamma>" by (rule comp_assoc[symmetric])
    also have "... \<doteq> \<theta>2 \<lozenge> \<gamma>" by (rule subst_cong) (auto simp: \<open>Idem \<theta>2\<close>[unfolded Idem_def])
    also have "... \<doteq> \<sigma>" by (rule \<sigma>[symmetric])
    finally show "\<theta>2 \<lozenge> \<sigma> \<doteq> \<sigma>" .
  qed
qed (auto intro!: Var_Idem split: option.splits if_splits)

subsection \<open>Unification Returns Substitution With Minimal Domain And Range\<close>

definition range_vars where
  "range_vars \<sigma> = \<Union> {vars_of (Var x \<lhd> \<sigma>) |x. Var x \<lhd> \<sigma> \<noteq> Var x}"

lemma vars_of_subst_subset: "vars_of (N \<lhd> \<sigma>) \<subseteq> vars_of N \<union> range_vars \<sigma>"
proof (rule subsetI)
  fix x assume "x \<in> vars_of (N \<lhd> \<sigma>)"
  thus "x \<in> vars_of N \<union> range_vars \<sigma>"
  proof (induction N)
    case (Var y)
    thus ?case
      unfolding range_vars_def vars_of.simps by force
  next
    case (Const y)
    thus ?case
      by simp
  next
    case (Comb N1 N2)
    thus ?case
      by auto
  qed
qed

lemma range_vars_comp_subset: "range_vars (\<sigma>\<^sub>1 \<lozenge> \<sigma>\<^sub>2) \<subseteq> range_vars \<sigma>\<^sub>1 \<union> range_vars \<sigma>\<^sub>2"
proof (rule subsetI)
  fix x assume "x \<in> range_vars (\<sigma>\<^sub>1 \<lozenge> \<sigma>\<^sub>2)"
  then obtain x' where
    x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2: "Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2 \<noteq> Var x'" and x_in: "x \<in> vars_of (Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2)"
    unfolding range_vars_def by auto

  show "x \<in> range_vars \<sigma>\<^sub>1 \<union> range_vars \<sigma>\<^sub>2"
  proof (cases "Var x' \<lhd> \<sigma>\<^sub>1 = Var x'")
    case True
    with x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2 x_in show ?thesis
      unfolding range_vars_def by auto
  next
    case x'_\<sigma>\<^sub>1_neq: False
    show ?thesis
    proof (cases "Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2 = Var x' \<lhd> \<sigma>\<^sub>1")
      case True
      with x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2 x_in x'_\<sigma>\<^sub>1_neq show ?thesis
        unfolding range_vars_def by auto
    next
      case False
      with x_in obtain y where "y \<in> vars_of (Var x' \<lhd> \<sigma>\<^sub>1)" and "x \<in> vars_of (Var y \<lhd> \<sigma>\<^sub>2)"
        by (smt (verit, best) UN_iff image_iff vars_of_subst_conv_Union)
      with x'_\<sigma>\<^sub>1_neq show ?thesis
        unfolding range_vars_def by force
    qed
  qed
qed

theorem unify_gives_minimal_range:
  "unify M N  = Some \<sigma> \<Longrightarrow> range_vars \<sigma> \<subseteq> vars_of M \<union> vars_of N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (1 c M N)
  thus ?case by simp
next
  case (2 M N c)
  thus ?case by simp
next
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]"
    by simp
  thus ?case
    by (simp add: range_vars_def)
next
  case (4 M N v)
  hence "\<sigma> = [(v, M \<cdot> N)]"
    by (metis option.discI option.sel unify.simps(4))
  thus ?case
    by (auto simp: range_vars_def)
next
  case (5 v M)
  hence "\<sigma> = [(v, M)]"
    by (metis option.discI option.inject unify.simps(5))
  thus ?case
    by (auto simp: range_vars_def)
next
  case (6 c d)
  hence "\<sigma> = []"
    by (metis option.distinct(1) option.sel unify.simps(6))
  thus ?case
    by (simp add: range_vars_def)
next
  case (7 M N M' N')
  from "7.prems" obtain \<theta>\<^sub>1 \<theta>\<^sub>2 where
    "unify M M' = Some \<theta>\<^sub>1" and "unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2" and "\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2"
    apply simp
    by (metis (no_types, lifting) option.case_eq_if option.collapse option.discI option.sel)

  from "7.hyps"(1) have range_\<theta>\<^sub>1: "range_vars \<theta>\<^sub>1 \<subseteq> vars_of M \<union> vars_of M'"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> by simp

  from "7.hyps"(2) have "range_vars \<theta>\<^sub>2 \<subseteq> vars_of (N \<lhd> \<theta>\<^sub>1) \<union> vars_of (N' \<lhd> \<theta>\<^sub>1)"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> \<open>unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2\<close> by simp
  hence range_\<theta>\<^sub>2: "range_vars \<theta>\<^sub>2 \<subseteq> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using vars_of_subst_subset[of _ \<theta>\<^sub>1] by auto

  have "range_vars \<sigma> = range_vars (\<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2)"
    unfolding \<open>\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2\<close> by simp
  also have "... \<subseteq> range_vars \<theta>\<^sub>1 \<union> range_vars \<theta>\<^sub>2"
    by (rule range_vars_comp_subset)
  also have "... \<subseteq> range_vars \<theta>\<^sub>1 \<union> vars_of N \<union> vars_of N'"
    using range_\<theta>\<^sub>2 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N'"
    using range_\<theta>\<^sub>1 by auto
  finally show ?case
    by auto
qed

theorem unify_gives_minimal_domain:
  "unify M N  = Some \<sigma> \<Longrightarrow> fst ` set \<sigma> \<subseteq> vars_of M \<union> vars_of N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (1 c M N)
  thus ?case
    by simp
next
  case (2 M N c)
  thus ?case
    by simp
next
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]"
    by simp
  thus ?case
    by (simp add: dom_def)
next
  case (4 M N v)
  hence "\<sigma> = [(v, M \<cdot> N)]"
    by (metis option.distinct(1) option.inject unify.simps(4))
  thus ?case
    by (simp add: dom_def)
next
  case (5 v M)
  hence "\<sigma> = [(v, M)]"
    by (metis option.distinct(1) option.inject unify.simps(5))
  thus ?case
    by (simp add: dom_def)
next
  case (6 c d)
  hence "\<sigma> = []"
    by (metis option.distinct(1) option.sel unify.simps(6))
  thus ?case
    by simp
next
  case (7 M N M' N')
  from "7.prems" obtain \<theta>\<^sub>1 \<theta>\<^sub>2 where
    "unify M M' = Some \<theta>\<^sub>1" and "unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2" and "\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2"
    apply simp
    by (metis (no_types, lifting) option.case_eq_if option.collapse option.discI option.sel)

  from "7.hyps"(1) have dom_\<theta>\<^sub>1: "fst ` set \<theta>\<^sub>1 \<subseteq> vars_of M \<union> vars_of M'"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> by simp

  from "7.hyps"(2) have "fst ` set \<theta>\<^sub>2 \<subseteq> vars_of (N \<lhd> \<theta>\<^sub>1) \<union> vars_of (N' \<lhd> \<theta>\<^sub>1)"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> \<open>unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2\<close> by simp
  hence dom_\<theta>\<^sub>2: "fst ` set \<theta>\<^sub>2 \<subseteq> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using vars_of_subst_subset[of _ \<theta>\<^sub>1] by auto

  have "fst ` set \<sigma> = fst ` set (\<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2)"
    unfolding \<open>\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2\<close> by simp
  also have "... = fst ` set \<theta>\<^sub>1 \<union> fst ` set \<theta>\<^sub>2"
    by (auto simp: domain_comp)
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> fst ` set \<theta>\<^sub>2"
    using dom_\<theta>\<^sub>1 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using dom_\<theta>\<^sub>2 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N'"
    using unify_gives_minimal_range[OF \<open>unify M M' = Some \<theta>\<^sub>1\<close>] by auto
  finally show ?case
    by auto
qed

subsection \<open>Idempotent Most General Unifier\<close>

definition IMGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "IMGU \<mu> t u \<longleftrightarrow> Unifier \<mu> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> \<theta> \<doteq> \<mu> \<lozenge> \<theta>)"

lemma IMGU_iff_Idem_and_MGU: "IMGU \<mu> t u \<longleftrightarrow> Idem \<mu> \<and> MGU \<mu> t u"
  unfolding IMGU_def Idem_def MGU_def
  by (smt (verit, best) subst_comp subst_eq_def)

lemma unify_computes_IMGU:
  "unify M N = Some \<sigma> \<Longrightarrow> IMGU \<sigma> M N"
  by (simp add: IMGU_iff_Idem_and_MGU unify_computes_MGU unify_gives_Idem)

subsection \<open>Unification is complete\<close>

lemma unify_eq_Some_if_Unifier:
  assumes "Unifier \<sigma> t u"
  shows "\<exists>\<tau>. unify t u = Some \<tau>"
  using assms
proof (induction t u rule: unify.induct)
  case (1 c M N)
  thus ?case
    by (simp add: Unifier_def)
next
  case (2 M N c)
  thus ?case
    by (simp add: Unifier_def)
next
  case (3 c v)
  thus ?case
    by simp
next
  case (4 M N v)
  hence "\<not> (Var v \<prec> M \<cdot> N)"
    by (auto dest: not_occs_if_Unifier)
  thus ?case
    by simp
next
  case (5 v M)
  thus ?case
    by (auto dest: not_occs_if_Unifier)
next
  case (6 c d)
  thus ?case
    by (simp add: Unifier_def)
next
  case (7 M N M' N')
  from "7.prems" have "Unifier \<sigma> M M'"
    by (simp add: Unifier_def)
  with "7.IH"(1) obtain \<tau> where "unify M M' = Some \<tau>"
    by auto
  moreover have "Unifier \<sigma> (N \<lhd> \<tau>) (N' \<lhd> \<tau>)"
    by (smt (verit, ccfv_threshold) "7.prems" IMGU_def Unifier_def calculation subst.simps(3)
        subst_comp subst_eq_def trm.inject(3) unify_computes_IMGU)
  ultimately show ?case
    using "7.IH"(2) by auto
qed

definition subst_domain where
  "subst_domain \<sigma> = {x. Var x \<lhd> \<sigma> \<noteq> Var x}"

lemma subst_domain_subset_list_domain: "subst_domain \<sigma> \<subseteq> fst ` set \<sigma>"
proof (rule Set.subsetI)
  fix x assume "x \<in> subst_domain \<sigma>"
  hence "Var x \<lhd> \<sigma> \<noteq> Var x"
    by (simp add: subst_domain_def)
  then show "x \<in> fst ` set \<sigma>"
  proof (induction \<sigma>)
    case Nil
    thus ?case
      by simp
  next
    case (Cons p \<sigma>)
    show ?case
    proof (cases "x = fst p")
      case True
      thus ?thesis
        by simp
    next
      case False
      with Cons.IH Cons.prems show ?thesis
        by (cases p) simp
    qed
  qed
qed

lemma subst_apply_eq_Var:
  assumes "s \<lhd> \<sigma> = Var x"
  obtains y where "s = Var y" and "Var y \<lhd> \<sigma> = Var x"
  using assms by (induct s) auto

lemma mem_range_varsI:
  assumes "Var x \<lhd> \<sigma> = Var y" and "x \<noteq> y"
  shows "y \<in> range_vars \<sigma>"
  using assms unfolding range_vars_def
  by (metis (mono_tags, lifting) UnionI mem_Collect_eq trm.inject(1) vars_iff_occseq)

lemma IMGU_subst_domain_subset:
  assumes "IMGU \<mu> t u"
  shows "subst_domain \<mu> \<subseteq> vars_of t \<union> vars_of u"
proof (rule Set.subsetI)
  from assms have "Unifier \<mu> t u"
    by (simp add: IMGU_def)
  then obtain \<upsilon> where "unify t u = Some \<upsilon>"
    using unify_eq_Some_if_Unifier by metis
  hence "Unifier \<upsilon> t u"
    using MGU_def unify_computes_MGU by blast
  with assms have "\<upsilon> \<doteq> \<mu> \<lozenge> \<upsilon>"
    by (simp add: IMGU_def)

  fix x assume "x \<in> subst_domain \<mu>"
  hence "Var x \<lhd> \<mu> \<noteq> Var x"
    by (simp add: subst_domain_def)

  show "x \<in> vars_of t \<union> vars_of u"
  proof (cases "x \<in> subst_domain \<upsilon>")
    case True
    hence "x \<in> fst ` set \<upsilon>"
      using subst_domain_subset_list_domain by fast
    thus ?thesis
      using unify_gives_minimal_domain[OF \<open>unify t u = Some \<upsilon>\<close>] by auto
  next
    case False
    hence "Var x \<lhd> \<upsilon> = Var x"
      by (simp add: subst_domain_def)
    hence "Var x \<lhd> \<mu> \<lhd> \<upsilon> = Var x"
      using \<open>\<upsilon> \<doteq> \<mu> \<lozenge> \<upsilon>\<close>
      by (metis subst_comp subst_eq_dest)
    then show ?thesis
      apply (rule subst_apply_eq_Var)
      using \<open>Var x \<lhd> \<mu> \<noteq> Var x\<close>
      using unify_gives_minimal_range[OF \<open>unify t u = Some \<upsilon>\<close>]
      using mem_range_varsI
      by force
  qed
qed

lemma IMGU_range_vars_subset:
  assumes "IMGU \<mu> t u"
  shows "range_vars \<mu> \<subseteq> vars_of t \<union> vars_of u"
proof (rule Set.subsetI)
  from assms have "Unifier \<mu> t u"
    by (simp add: IMGU_def)
  then obtain \<upsilon> where "unify t u = Some \<upsilon>"
    using unify_eq_Some_if_Unifier by metis
  hence "Unifier \<upsilon> t u"
    using MGU_def unify_computes_MGU by blast
  with assms have "\<upsilon> \<doteq> \<mu> \<lozenge> \<upsilon>"
    by (simp add: IMGU_def)

  have ball_subst_dom: "\<forall>x \<in> subst_domain \<upsilon>. vars_of (Var x \<lhd> \<upsilon>) \<subseteq> vars_of t \<union> vars_of u"
    using unify_gives_minimal_range[OF \<open>unify t u = Some \<upsilon>\<close>]
    using range_vars_def subst_domain_def by fastforce

  fix x assume "x \<in> range_vars \<mu>"
  then obtain y where "x \<in> vars_of (Var y \<lhd> \<mu>)" and "Var y \<lhd> \<mu> \<noteq> Var y"
    by (auto simp: range_vars_def)

  have vars_of_y_\<upsilon>: "vars_of (Var y \<lhd> \<upsilon>) \<subseteq> vars_of t \<union> vars_of u"
    using ball_subst_dom
    by (metis (mono_tags, lifting) IMGU_subst_domain_subset \<open>Var y \<lhd> \<mu> \<noteq> Var y\<close> assms empty_iff
        insert_iff mem_Collect_eq subset_eq subst_domain_def vars_of.simps(1))

  show "x \<in> vars_of t \<union> vars_of u"
  proof (rule ccontr)
    assume "x \<notin> vars_of t \<union> vars_of u"
    hence "x \<notin> vars_of (Var y \<lhd> \<upsilon>)"
      using vars_of_y_\<upsilon> by blast
    moreover have "x \<in> vars_of (Var y \<lhd> \<mu> \<lhd> \<upsilon>)"
    proof -
      have "Var x \<lhd> \<upsilon> = Var x"
        using \<open>x \<notin> vars_of t \<union> vars_of u\<close>
        using IMGU_subst_domain_subset \<open>unify t u = Some \<upsilon>\<close> subst_domain_def unify_computes_IMGU
        by fastforce
      thus ?thesis
        by (metis \<open>x \<in> vars_of (Var y \<lhd> \<mu>)\<close> subst_mono vars_iff_occseq)
    qed
    ultimately show False
      using \<open>\<upsilon> \<doteq> \<mu> \<lozenge> \<upsilon>\<close>
      by (metis subst_comp subst_eq_dest)
  qed
qed

end