(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   A general calculus of refinement in Isabelle.
*)

chapter "Refinement"

theory Simulation
imports "~~/src/HOL/Main"
begin

text {*
  A data type is a collection of three functions on three basic types.
  The three basic types are the private state space @{typ 'a}, the observable
  state space @{typ 'b} and the operations @{typ 'j}.

  The three functions are the initialisation @{term "Init"} which (potentially
  nondeterministically) produces a private state space from an observable one,
  the finalisation @{term Fin} which projects the observable part of
  the state space out of the private one, and finally @{term Step} that gives
  the (potentially nondeterministic) transition relation on the private state
  space for each operation in @{typ 'j}.

  In the simple case, the private state space is something like a
  tuple @{typ "'a \<times> 'b"} fully containing the observable part such
  that @{term Fin} just becomes the projection @{term snd}, and @{term
  "Init s"} constructs an additional private part, e.g. just
  @{term "{(f x, x)}"}.

  Hoare triples on the system and refinement are defined over the observable
  part of the state.
*}

record ('a,'b,'j) data_type =
  Init :: "'b \<Rightarrow> 'a set"
  Fin :: "'a \<Rightarrow> 'b"
  Step :: "'j \<Rightarrow> ('a \<times> 'a) set"

text {*
  A sequence of operations over a transition relation @{term \<delta>} is executed
  by applying the relation repeatedly.
*}
definition
  steps :: "('j \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> 'a set \<Rightarrow> 'j list \<Rightarrow> 'a set" where
  "steps \<delta> \<equiv> foldl (\<lambda>S j. \<delta> j `` S)"

text {*
  The sequence of operations in the data type is then executed
  in an initial state by initialising the private state, executing
  the transition relation over this private state, and finally
  projecting back out the set of final, observable states.
*}
definition
   execution :: "('a,'b,'j) data_type \<Rightarrow> 'b \<Rightarrow> 'j list \<Rightarrow> 'b set" where
  "execution A s js \<equiv> Fin A ` steps (Step A) (Init A s) js"

text {*
  A Hoare triple over a list of operations in the data type is
  the usual: given a state in the pre-condition, all resulting states
  of the execution must be in the post-condition:
*}
definition
  hoare_triple :: "('a,'b,'j) data_type \<Rightarrow> 'b set \<Rightarrow> 'j list \<Rightarrow> 'b set \<Rightarrow> bool"
where
  "hoare_triple A P js Q \<equiv> \<forall>s \<in> P. execution A s js \<subseteq> Q"

text {*
  Refinement is defined by saying that all concrete behaviours are contained in
  their corresponding abstract ones. Only the private state spaces of the
  data type may differ.
*}
definition
  refines :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infix "\<sqsubseteq>" 60)
where
  "C \<sqsubseteq> A \<equiv> \<forall>js s. execution C s js \<subseteq> execution A s js"

text {*
  Alternatively, one may say that all Hoare triples proved on the abstract data
  type are true for the concrete one.
*}
lemma hoare_triple_refinement:
  "C \<sqsubseteq> A = (\<forall>P Q js. hoare_triple A P js Q \<longrightarrow> hoare_triple C P js Q)"
  by (simp add: refines_def hoare_triple_def) blast

-- "composing two relations"
definition
  rel_semi :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set" (infixl ";;;" 65)
where
  "A ;;; B \<equiv> A O B"

text {*
  Refinement is a global property over all executions and/or all
  hoare triples. As this is hard to show, we define the weaker concept
  of forward simulation.
*}
definition
  fw_sim :: "('a \<times> 'c) set \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool"
where
  "fw_sim R C A \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                  (\<forall>j. R ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                  (\<forall>s s'. (s,s') \<in> R \<longrightarrow> Fin C s' = Fin A s)"

definition
  fw_simulates :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infixl "\<sqsubseteq>\<^sub>F" 50)
where
  "C \<sqsubseteq>\<^sub>F A \<equiv> \<exists>R. fw_sim R C A"

lemma fw_sim_steps:
  assumes steps: "t' \<in> steps (Step C) S' js" "S' \<subseteq> R `` S"
  assumes sim: "fw_sim R C A"
  shows "\<exists>t \<in> steps (Step A) S js. (t,t') \<in> R" using steps
proof (induct js arbitrary: S' S)
  case Nil
  thus ?case by (simp add: steps_def) blast
next
  case (Cons j js)
  hence "t' \<in> steps (Step C) (Step C j `` S') js"
    by (clarsimp simp: steps_def)
  moreover {
    from Cons.prems
    have "S' \<subseteq> R `` S" by simp
    moreover
    from sim
    have "R ;;; Step C j \<subseteq> Step A j ;;; R" by (simp add: fw_sim_def)
    ultimately
    have "Step C j `` S' \<subseteq> R `` (Step A j `` S)"
      by (simp add: rel_semi_def) blast
  }
  ultimately
  show ?case using Cons.hyps
    by (auto simp: steps_def)
qed

lemma sim_imp_refines:
  "C \<sqsubseteq>\<^sub>F A \<Longrightarrow> C \<sqsubseteq> A"
  apply (clarsimp simp: refines_def execution_def fw_simulates_def)
  apply (rename_tac t)
  apply (drule fw_sim_steps)
    prefer 2
    apply assumption
   apply (simp add: fw_sim_def)
   apply blast
  apply clarsimp
  apply (erule rev_image_eqI)
  apply (simp add: fw_sim_def)
  done

text {*
  To further aid proofs, we define (private) invariants on data types.
  Private invariants are properties that are true throughout execution
  on the private state space of the state type. The purpose is to exploit
  these properties while showing forward simulation.
*}
definition
  invariant_holds :: "('a,'b,'j) data_type \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<Turnstile>" 60)
where
  "D \<Turnstile> I \<equiv> (\<forall>s. Init D s \<subseteq> I) \<and> (\<forall>j. Step D j `` I \<subseteq> I)"

lemma invariant_T [iff]: "D \<Turnstile> UNIV"
  by (simp add: invariant_holds_def)

lemma invariantI:
  "\<lbrakk> \<forall>s. Init D s \<subseteq> I; \<forall>j. Step D j `` I \<subseteq> I \<rbrakk> \<Longrightarrow> D \<Turnstile> I"
  by (simp add: invariant_holds_def)

lemma invariant_CollectI [intro?]:
  assumes init: "\<And>s a. s \<in> Init D a \<Longrightarrow> I s"
  assumes step: "\<And>j s s'. \<lbrakk> I s; (s,s') \<in> Step D j \<rbrakk> \<Longrightarrow> I s'"
  shows "D \<Turnstile> Collect I"
proof (rule invariantI)
  show "\<forall>a. Init D a \<subseteq> Collect I" by (fast intro: init)
next
  show "\<forall>j. Step D j `` Collect I \<subseteq> Collect I"
    by (auto simp add: Image_def intro: step)
qed

lemma invariant_conjI:
  "D \<Turnstile> P \<Longrightarrow> D \<Turnstile> Q  \<Longrightarrow> D \<Turnstile> P \<inter> Q"
  by (simp add: invariant_holds_def) blast

lemma invariant_conjI2:
  "\<lbrakk> D \<Turnstile> I; \<And>s. Init D s \<subseteq> I \<Longrightarrow> Init D s \<subseteq> J;
    \<forall>j. Step D j `` (I \<inter> J) \<subseteq> J \<rbrakk> \<Longrightarrow> D \<Turnstile> I \<inter> J"
  by (simp add: invariant_holds_def) blast

text {*
  We can now define forward simulation with an invariant. The proof
  obligation for the step and final case in the correspondence proof
  can now assume that the invariant holds. The invariant itself can be
  shown separately.
*}
definition
  LI :: "('a,'b,'j) data_type \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> bool"
where
  "LI A C R I \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                (\<forall>j. (R \<inter> I) ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                (\<forall>s s'. (s,s') \<in> R \<inter> I \<longrightarrow> Fin C s' = Fin A s)"

lemma LI_fw_sim:
  assumes  ia: "A \<Turnstile> I\<^sub>a" and ic: "C \<Turnstile> I\<^sub>c" and li: "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A"
proof -
  from li have
    init: "\<forall>s. Init C s \<subseteq> r `` Init A s" and
    step: "\<forall>j. (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) ;;; Step C j \<subseteq> Step A j ;;; r" and
    fin: "(\<forall>s s'. (s,s') \<in> r \<inter> (I\<^sub>a \<times> I\<^sub>c) \<longrightarrow> Fin C s' = Fin A s)"
    by (auto simp: LI_def)
  from ia have  "\<forall>s. (r \<inter> (UNIV \<times> I\<^sub>c) ) `` Init A s = (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  moreover from init ic have "\<forall>s. Init C s \<subseteq> (r \<inter> (UNIV \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  ultimately have initI: "\<forall>s. Init C s \<subseteq> (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s" by simp
  moreover {
    fix j
    from step have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r"..
    also
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) = ((UNIV \<times> I\<^sub>a) \<inter> Id) ;;; r ;;; ((I\<^sub>c \<times> UNIV) \<inter> Id)"
      (is "_ = ?I\<^sub>a ;;; r ;;; ?I\<^sub>c")
      by (simp add: rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j \<subseteq> ?I\<^sub>a ;;; Step A j ;;; r"
      by (simp add: rel_semi_def, blast)
    also
    from ia have "\<dots> \<subseteq> Step A j ;;; ?I\<^sub>a ;;; r"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;;  r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c \<subseteq>  Step A j ;;; ?I\<^sub>a ;;; r ;;; ?I\<^sub>c"
      by (simp add: rel_semi_def, blast)
    also
    from ic
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c =  ?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r \<inter> (I\<^sub>a \<times> I\<^sub>c)"
      by (simp add: rel_semi_def, blast)
  }
  ultimately show "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A" using fin
    by (simp add: fw_sim_def)
qed

lemma weaken_LI:
  assumes LI: "LI A C R I'" and weaker: "I \<subseteq> I'" shows "LI A C R I"
proof -
  from weaker have step: "\<And>j. R \<inter> I ;;; Step C j \<subseteq> R \<inter> I' ;;; Step C j"
    by (fastforce simp: rel_semi_def relcomp_def)
  from weaker have fin: "\<And>S. S \<in> R \<inter> I \<Longrightarrow> S \<in> R \<inter> I'" by fastforce
  from subset_trans[OF step] fin LI show ?thesis  by (clarsimp simp: LI_def)
qed

lemma fw_sim_eq_LI: "fw_sim r C A = LI A C r UNIV"
  by (simp add: fw_sim_def LI_def)

lemma fw_sim_LI: "fw_sim r C A \<Longrightarrow> LI A C r I"
  by (simp add: fw_sim_eq_LI weaken_LI[where I'=UNIV])

lemma L_invariantI:
  assumes  "A \<Turnstile> I\<^sub>a" and "C \<Turnstile> I\<^sub>c" and "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "C \<sqsubseteq>\<^sub>F A"
  using assms
  by (simp add: fw_simulates_def, rule_tac x="r \<inter> I\<^sub>a \<times> I\<^sub>c" in exI,
      simp add: LI_fw_sim)

lemma refinement_refl[simp]:
  "A \<sqsubseteq> A"
  by (simp add: refines_def)

lemma refinement_trans [trans]:
  "\<lbrakk>C \<sqsubseteq> B; B \<sqsubseteq> A\<rbrakk> \<Longrightarrow> C \<sqsubseteq> A"
  by (simp add: refines_def) blast

lemma fw_inv_transport:
  "\<lbrakk> A \<Turnstile> I\<^sub>a; C \<Turnstile> I\<^sub>c; LI A C R (I\<^sub>a \<times> I\<^sub>c) \<rbrakk> \<Longrightarrow> C \<Turnstile> {s'. \<exists>s. (s,s') \<in> R \<and> s \<in> I\<^sub>a \<and> s' \<in> I\<^sub>c}"
  apply (clarsimp simp: LI_def invariant_holds_def)
  apply (rule conjI)
   apply (rule allI)
   apply clarsimp
   apply (subgoal_tac "x \<in> (R `` Init A s)")
    prefer 2
    apply fastforce
   apply blast
  apply clarsimp
  apply (erule_tac x=j in allE)+
  apply (clarsimp simp: rel_semi_def)
  apply (subgoal_tac "(s,x) \<in> Step A j O R")
   prefer 2
   apply blast
  apply blast
  done

lemma fw_sim_refl:
  "fw_sim Id A A"
  apply (simp add: fw_sim_def rel_semi_def)
  done

lemma fw_simulates_refl[simp]:
  "A \<sqsubseteq>\<^sub>F A"
  apply (simp add: fw_simulates_def fw_sim_refl exI[where x="Id"])
  done

lemma fw_sim_trans:
  "\<lbrakk>fw_sim Q C B; fw_sim R B A\<rbrakk> \<Longrightarrow> fw_sim (R O Q) C A"
  apply (clarsimp simp: fw_sim_def)
  apply (intro conjI)
    apply clarsimp
    apply (rename_tac s x)
    apply (erule_tac x="s" in allE)
    apply (drule set_mp)
     apply assumption
    apply clarsimp
    apply (erule_tac x="s" in allE)
    apply (drule set_mp)
     apply assumption
    apply blast
   apply (clarsimp simp: rel_semi_def)
   apply (rename_tac j z' x y z)
   apply (erule_tac x="j" in allE)+
   apply (drule_tac x="(y, z')" in set_mp)
    apply blast
   apply clarsimp
   apply (rename_tac j x z x' y' z')
   apply (drule_tac x="(x, y')" in set_mp)
    apply auto
  done

lemma fw_simulates_trans:
  "\<lbrakk>C \<sqsubseteq>\<^sub>F B; B \<sqsubseteq>\<^sub>F A\<rbrakk> \<Longrightarrow> C \<sqsubseteq>\<^sub>F A"
  apply (auto simp: fw_simulates_def dest: fw_sim_trans)
  done

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Well-Quasi-Orders\<close>

theory Well_Quasi_Orders
imports Almost_Full_Relations
begin

subsection \<open>Basic Definitions\<close>

definition wqo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "wqo_on P A \<longleftrightarrow> transp_on P A \<and> almost_full_on P A"

lemma wqo_on_UNIV:
  "wqo_on (\<lambda>_ _. True) UNIV"
  using almost_full_on_UNIV by (auto simp: wqo_on_def transp_on_def)

lemma wqo_onI [Pure.intro]:
  "\<lbrakk>transp_on P A; almost_full_on P A\<rbrakk> \<Longrightarrow> wqo_on P A"
  unfolding wqo_on_def almost_full_on_def by blast

lemma wqo_on_imp_reflp_on:
  "wqo_on P A \<Longrightarrow> reflp_on P A"
  using almost_full_on_imp_reflp_on by (auto simp: wqo_on_def)

lemma wqo_on_imp_transp_on:
  "wqo_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: wqo_on_def)

lemma wqo_on_imp_almost_full_on:
  "wqo_on P A \<Longrightarrow> almost_full_on P A"
  by (auto simp: wqo_on_def)

lemma wqo_on_imp_qo_on:
  "wqo_on P A \<Longrightarrow> qo_on P A"
  by (metis qo_on_def wqo_on_imp_reflp_on wqo_on_imp_transp_on)

lemma wqo_on_imp_good:
  "wqo_on P A \<Longrightarrow> \<forall>i. f i \<in> A \<Longrightarrow> good P f"
  by (auto simp: wqo_on_def almost_full_on_def)

lemma wqo_on_subset:
  "A \<subseteq> B \<Longrightarrow> wqo_on P B \<Longrightarrow> wqo_on P A"
  using almost_full_on_subset [of A B P]
    and transp_on_subset [of A B P]
  unfolding wqo_on_def by blast

subsection \<open>Equivalent Definitions\<close>

text \<open>
  Given a quasi-order @{term P}, the following statements are equivalent:
  \begin{enumerate}
  \item @{term P} is a almost-full.
  \item @{term P} does neither allow decreasing chains nor antichains.
  \item Every quasi-order extending @{term P} is well-founded.
  \end{enumerate}
\<close>

lemma wqo_af_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> almost_full_on P A"
  using assms by (metis qo_on_def wqo_on_def)

lemma wqo_wf_and_no_antichain_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> wfp_on (strict P) A \<and> \<not> (\<exists>f. antichain_on P f A)"
  unfolding wqo_af_conv [OF assms]
  using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
    and almost_full_on_imp_no_antichain_on [of P A]
    and wf_and_no_antichain_imp_qo_extension_wf [of P A]
    and every_qo_extension_wf_imp_af [OF _ assms]
    by blast

lemma wqo_extensions_wf_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and> qo_on Q A \<longrightarrow> wfp_on (strict Q) A)"
  unfolding wqo_af_conv [OF assms]
  using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
    and almost_full_on_imp_no_antichain_on [of P A]
    and wf_and_no_antichain_imp_qo_extension_wf [of P A]
    and every_qo_extension_wf_imp_af [OF _ assms]
    by blast

lemma wqo_on_imp_wfp_on:
  "wqo_on P A \<Longrightarrow> wfp_on (strict P) A"
  by (metis (no_types) wqo_on_imp_qo_on wqo_wf_and_no_antichain_conv)

text \<open>
  The homomorphic image of a wqo set is wqo.
\<close>
lemma wqo_on_hom:
  assumes "transp_on Q (h ` A)"
    and "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q (h x) (h y)"
    and "wqo_on P A"
  shows "wqo_on Q (h ` A)"
  using assms and almost_full_on_hom [of A P Q h]
  unfolding wqo_on_def by blast

text \<open>
  The monomorphic preimage of a wqo set is wqo.
\<close>
lemma wqo_on_mon:
  assumes *: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longleftrightarrow> Q (h x) (h y)"
    and bij: "bij_betw h A B"
    and wqo: "wqo_on Q B"
  shows "wqo_on P A"
proof -
  have "transp_on P A"
  proof
    fix x y z assume [intro!]: "x \<in> A" "y \<in> A" "z \<in> A"
      and "P x y" and "P y z"
    with * have "Q (h x) (h y)" and "Q (h y) (h z)" by blast+
    with wqo_on_imp_transp_on [OF wqo] have "Q (h x) (h z)"
      using bij by (auto simp: bij_betw_def transp_on_def)
    with * show "P x z" by blast
  qed
  with assms and almost_full_on_mon [of A P Q h]
    show ?thesis unfolding wqo_on_def by blast
qed

subsection \<open>A Type Class for Well-Quasi-Orders\<close>

text \<open>
  In a well-quasi-order (wqo) every infinite sequence is good.
\<close>
class wqo = preorder +
  assumes good: "good (\<le>) f"

lemma wqo_on_UNIV_class_wqo [intro!]:
  "wqo_on P UNIV \<Longrightarrow> class.wqo P (strict P)"
  by (unfold_locales) (auto simp: wqo_on_def almost_full_on_def, unfold transp_on_def, blast)

text \<open>
  The following lemma converts between @{const wqo_on} (for the special case that the domain is the
  universe of a type) and the class predicate @{const class.wqo}.
\<close>
lemma wqo_on_UNIV_conv:
  "wqo_on P UNIV \<longleftrightarrow> class.wqo P (strict P)" (is "?lhs = ?rhs")
proof
  assume "?lhs" then show "?rhs" by auto
next
  assume "?rhs" then show "?lhs"
    unfolding class.wqo_def class.preorder_def class.wqo_axioms_def
    by (auto simp: wqo_on_def almost_full_on_def transp_on_def)
qed

text \<open>
  The strict part of a wqo is well-founded.
\<close>
lemma (in wqo) "wfP (<)"
proof -
  have "class.wqo (\<le>) (<)" ..
  hence "wqo_on (\<le>) UNIV"
    unfolding less_le_not_le [abs_def] wqo_on_UNIV_conv [symmetric] .
  from wqo_on_imp_wfp_on [OF this]
    show ?thesis unfolding less_le_not_le [abs_def] wfp_on_UNIV .
qed

lemma wqo_on_with_bot:
  assumes "wqo_on P A"
  shows "wqo_on (option_le P) A\<^sub>\<bottom>" (is "wqo_on ?P ?A")
proof -
  { from assms have trans [unfolded transp_on_def]: "transp_on P A"
      by (auto simp: wqo_on_def)
    have "transp_on ?P ?A"
      by (auto simp: transp_on_def elim!: with_bot_cases, insert trans) blast }
  moreover
  { from assms and almost_full_on_with_bot
      have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemma wqo_on_option_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on (option_le P) UNIV"
  using wqo_on_with_bot [of P UNIV] by simp

text \<open>
  When two sets are wqo, then their disjoint sum is wqo.
\<close>
lemma wqo_on_Plus:
  assumes "wqo_on P A" and "wqo_on Q B"
  shows "wqo_on (sum_le P Q) (A <+> B)" (is "wqo_on ?P ?A")
proof -
  { from assms have trans [unfolded transp_on_def]: "transp_on P A" "transp_on Q B"
      by (auto simp: wqo_on_def)
    have "transp_on ?P ?A"
      unfolding transp_on_def by (auto, insert trans) (blast+) }
  moreover
  { from assms and almost_full_on_Plus have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemma wqo_on_sum_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (sum_le P Q) UNIV"
  using wqo_on_Plus [of P UNIV Q UNIV] by simp

subsection \<open>Dickson's Lemma\<close>

lemma wqo_on_Sigma:
  fixes A1 :: "'a set" and A2 :: "'b set"
  assumes "wqo_on P1 A1" and "wqo_on P2 A2"
  shows "wqo_on (prod_le P1 P2) (A1 \<times> A2)" (is "wqo_on ?P ?A")
proof -
  { from assms have "transp_on P1 A1" and "transp_on P2 A2" by (auto simp: wqo_on_def)
    hence "transp_on ?P ?A" unfolding transp_on_def prod_le_def by blast }
  moreover
  { from assms and almost_full_on_Sigma [of P1 A1 P2 A2]
      have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemmas dickson = wqo_on_Sigma

lemma wqo_on_prod_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (prod_le P Q) UNIV"
  using wqo_on_Sigma [of P UNIV Q UNIV] by simp

subsection \<open>Higman's Lemma\<close>

lemma transp_on_list_emb:
  assumes "transp_on P A"
  shows "transp_on (list_emb P) (lists A)"
  using assms and list_emb_trans [of _ _ _ P]
    unfolding transp_on_def by blast

lemma wqo_on_lists:
  assumes "wqo_on P A" shows "wqo_on (list_emb P) (lists A)"
  using assms and almost_full_on_lists
    and transp_on_list_emb by (auto simp: wqo_on_def)

lemmas higman = wqo_on_lists

lemma wqo_on_list_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on (list_emb P) UNIV"
  using wqo_on_lists [of P UNIV] by simp

text \<open>
  Every reflexive and transitive relation on a finite set is a wqo.
\<close>
lemma finite_wqo_on:
  assumes "finite A" and refl: "reflp_on P A" and "transp_on P A"
  shows "wqo_on P A"
  using assms and finite_almost_full_on by (auto simp: wqo_on_def)

lemma finite_eq_wqo_on:
  assumes "finite A"
  shows "wqo_on (=) A"
  using finite_wqo_on [OF assms, of "(=)"]
  by (auto simp: reflp_on_def transp_on_def)

lemma wqo_on_lists_over_finite_sets:
  "wqo_on (list_emb (=)) (UNIV::('a::finite) list set)"
  using wqo_on_lists [OF finite_eq_wqo_on [OF finite [of "UNIV::('a::finite) set"]]] by simp

lemma wqo_on_map:
  fixes P and Q and h
  defines "P' \<equiv> \<lambda>x y. P x y \<and> Q (h x) (h y)"
  assumes "wqo_on P A"
    and "wqo_on Q B"
    and subset: "h ` A \<subseteq> B"
  shows "wqo_on P' A"
proof
  let ?Q = "\<lambda>x y. Q (h x) (h y)"
  from \<open>wqo_on P A\<close> have "transp_on P A"
    by (rule wqo_on_imp_transp_on)
  then show "transp_on P' A"
    using \<open>wqo_on Q B\<close> and subset
    unfolding wqo_on_def transp_on_def P'_def by blast

  from \<open>wqo_on P A\<close> have "almost_full_on P A"
    by (rule wqo_on_imp_almost_full_on)
  from \<open>wqo_on Q B\<close> have "almost_full_on Q B"
    by (rule wqo_on_imp_almost_full_on)

  show "almost_full_on P' A"
  proof
    fix f
    assume *: "\<forall>i::nat. f i \<in> A"
    from almost_full_on_imp_homogeneous_subseq [OF \<open>almost_full_on P A\<close> this]
      obtain g :: "nat \<Rightarrow> nat"
      where g: "\<And>i j. i < j \<Longrightarrow> g i < g j"
      and **: "\<forall>i. f (g i) \<in> A \<and> P (f (g i)) (f (g (Suc i)))"
      using * by auto
    from chain_transp_on_less [OF ** \<open>transp_on P A\<close>]
      have **: "\<And>i j. i < j \<Longrightarrow> P (f (g i)) (f (g j))" .
    let ?g = "\<lambda>i. h (f (g i))"
    from * and subset have B: "\<And>i. ?g i \<in> B" by auto
    with \<open>almost_full_on Q B\<close> [unfolded almost_full_on_def good_def, THEN bspec, of ?g]
      obtain i j :: nat
      where "i < j" and "Q (?g i) (?g j)" by blast
    with ** [OF \<open>i < j\<close>] have "P' (f (g i)) (f (g j))"
      by (auto simp: P'_def)
    with g [OF \<open>i < j\<close>] show "good P' f" by (auto simp: good_def)
  qed
qed

lemma wqo_on_UNIV_nat:
  "wqo_on (\<le>) (UNIV :: nat set)"
  unfolding wqo_on_def transp_on_def
  using almost_full_on_UNIV_nat by simp

end


theory Submission
  imports Defs
begin

inductive_set G :: "string set" where
empty: "[] \<in> G" |
pack: "w \<in> G \<Longrightarrow> (a#w@[b]) \<in> G"

lemma G_inv: "w \<in> G \<Longrightarrow> w = (a#w'@[b]) \<Longrightarrow> w' \<in> G"
  using G.cases by blast

theorem G_is_replicate:
  assumes "w \<in> G"
  shows "\<exists>n. w = replicate n a @ replicate n b"
using assms proof(induction rule: G.induct)
  case empty
  then show ?case
    by simp
next
  case (pack w)
  obtain n' where "w = replicate n' a @ replicate n' b"
    using pack.IH by blast
  then have "a # w @ [b] = a # replicate n' a @ replicate n' b @ [b]"
    by force
  then have "a # w @ [b] = replicate (n' + 1) a @ replicate (n' + 1) b"
    by (simp add: replicate_append_same)
  then show ?case
    by blast
qed

lemma rep_suc: "replicate (Suc n) a @ replicate (Suc n) b = a # replicate n a @ replicate n b @ [b]"
  by (simp add: replicate_append_same)

theorem replicate_G:
  assumes "w = replicate n a @ replicate n b"
  shows "w \<in> G"
  using assms proof(induction n arbitrary: w)
  case 0
  then show ?case
    by (simp add: G.empty)
next
  case (Suc n)
  from Suc.IH have w': "(replicate n a @ replicate n b) \<in> G"
    by blast
  from Suc.IH w' have "a # replicate n a @ replicate n b @ [b] \<in> G" using G.pack
    by fastforce
  then have "w \<in> G"
    using rep_suc Suc.prems by presburger
  thus ?case.
qed

corollary L_eq_G: "L = G"
  unfolding L_def using G_is_replicate replicate_G by auto

type_synonym rstate = "nat \<Rightarrow> int"

fun exec :: "instr \<Rightarrow> rstate \<Rightarrow> rstate"  where
  "exec (LDI i) s = s(0 := i)" |
  "exec (LD n) s = s(0 := s (n+1))" |
  "exec (ST n) s = s((n+1) := s 0)" |
  "exec (ADD n) s = s(0 := (s 0 + s (n+1)))"

fun execs :: "instr list \<Rightarrow> rstate \<Rightarrow> rstate"  where
  "execs [] s = s" |
  "execs (x#xs) s = execs xs (exec x s)"

theorem execs_append[simp]: "\<And>s. execs (xs @ ys) s = execs ys (execs xs s)"
  by(induction xs arbitrary: ys, auto)

fun cmp :: "expr \<Rightarrow> nat \<Rightarrow> instr list"  where
  "cmp (C i) _ = [LDI i]" |
  "cmp (V i) _ = [LD i]" |
  "cmp (A e1 e2) n = (cmp e1 n)@(ST (n))#(cmp e2 (n+1))@[ADD (n)]"

value "cmp (A (V 1) (V 2)) 10"

fun maxvar :: "expr \<Rightarrow> nat"  where
  "maxvar (C c) = 0" |
  "maxvar (V i) = i" |
  "maxvar (A e1 e2) = max (maxvar e1) (maxvar e2)"

theorem val_maxvar_same[simp]:
  "\<forall>n \<le> maxvar e. s n = s' n \<Longrightarrow> val e s = val e s'"
  by(induction e, auto)

lemma cmp_n_same[simp]: "\<forall>i \<le> n. 0 < i \<longrightarrow> execs (cmp e n) s i = s i"
  by(induction e n arbitrary: s rule: cmp.induct, auto)

lemma cmp_maxvar_same[simp]:
  "\<forall>n > maxvar e. \<forall>i \<le> maxvar e. 0 < i \<longrightarrow> execs (cmp e n) s i = s i"
  by(induction e arbitrary: s, auto)

lemma compiler_correct_free_reg: "\<forall>n > maxvar e. execs (cmp e n) s 0 = val e (s o Suc)"
  by(induction e arbitrary: s, auto)

theorem compiler_correct: "execs (cmp e (maxvar e + 1)) s 0 = val e (s o Suc)"
  using compiler_correct_free_reg less_add_one by blast

end


theory Submission
  imports Defs
begin

definition A\<^sub>0 :: "entry list"  where
  "A\<^sub>0 = [(V {}), (V {(1, 0)}), Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>1 :: "entry list"  where
  "A\<^sub>1 = [(V {}), Unchanged, (V {(1, 1)}), Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>2 :: "entry list"  where
  "A\<^sub>2 = [(V {}), Unchanged, Unchanged, (V {(1, 1)}), Unchanged, Unchanged, Unchanged, (V {(1, 1), (0, -1)}), Unchanged, Unchanged, Unchanged, Unchanged]"

definition A\<^sub>3 :: "entry list"  where
  "A\<^sub>3 = [(V {}), Unchanged, Unchanged, Unchanged, (V {(1, -1)}), Unchanged, Unchanged, Unchanged, (V {(1, -1), (0, -3)}), Unchanged, Unchanged, Unchanged]"

definition A\<^sub>4 :: "entry list"  where
  "A\<^sub>4 = [(V {}), Unchanged, Unchanged, Unchanged, Unchanged, (V {(0, -1)}), Unchanged, Unchanged, Unchanged, (V {(0, -1), (-3, -3)}), Unchanged, Unchanged]"

definition A\<^sub>5 :: "entry list"  where
  "A\<^sub>5 = [(V {}), Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, (V {(0, -1)}), Unchanged, Unchanged, Unchanged, (V {(0, -1), (-3, -3)}), Unchanged]"

definition A\<^sub>6 :: "entry list"  where
  "A\<^sub>6 = [(V {}), Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, Unchanged, (V {(-3, -3)})]"

(*
| x := 1 {A0};
| y := 1 {A1};
| {A2} LOOP
| y := y - 2; {A3}
| x := x + y {A4}
| {A5}
| UNTIL x < 0
| {A6}
*)

lemma hint:
  "\<lbrakk>continuous f; chain C\<rbrakk> \<Longrightarrow> f (\<Squnion> range C) = \<Squnion> (f `range C)"
proof-
  assume contf: "continuous f"
  assume chainC: "chain C"
  have "(\<forall>C. chain C \<longrightarrow> f (\<Squnion> (range C)) = \<Squnion> (f ` range C))"
    by (simp add: contf continuousD)
  then show "f (\<Squnion> range C) = \<Squnion> (f ` range C)"
    using chainC by blast
qed

lemma lift_chain: "chain C \<Longrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> C x \<le> C y)"
  by (simp add: Defs.chain_def lift_Suc_mono_le)

lemma chain_exists: "x \<le> y \<Longrightarrow> \<exists>C i j. (x = C i \<longrightarrow> y = C j \<longrightarrow> chain C)"
proof(rule ccontr)
  assume assms: "x \<le> y" "\<nexists>C i j. x = C i \<longrightarrow> y = C j \<longrightarrow> chain C"
  then obtain C i j where "C 0 = x \<and> C 1 = y \<and> chain C"
    using Defs.chain_def by fastforce
  with assms show "False"
    by simp
qed

lemma cont_imp_mono:
    fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  assumes "continuous f"
  shows "mono f"
proof
  fix x y :: "'a"
  assume "x \<le> y"
  let ?C = "(\<lambda>n::nat. if n = 0 then x else y)"
  have "\<forall>n. ?C n \<le> ?C (Suc n)"
    using \<open>x \<le> y\<close> by simp
  then have "chain ?C"
    by (simp add: Defs.chain_def)
  then have l: "f (\<Squnion> (range ?C)) = \<Squnion> (f ` range ?C)"
    using assms continuousD by blast
  have "x \<le> \<Squnion> (range ?C)"
    by simp
  then have "f x \<le> f (\<Squnion> (range ?C))"
    using l by auto
  moreover
  have "\<forall>v \<in> range ?C. v \<le> y"
    using \<open>x \<le> y\<close> by fastforce
  then have "y = \<Squnion> (range ?C)"
    using cSup_eq_maximum[of y "range ?C"] by force
  then have "f y = f (\<Squnion> (range ?C))"
    by presburger
  ultimately show "f x \<le> f y"
    by presburger
qed

thm mono_def monoI monoD

theorem kleene_lfp:
    fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes CONT: "continuous f"
  shows "lfp f = \<Squnion> (range (\<lambda>i. (f^^i) \<bottom>))"
proof -
  txt \<open> We propose a proof structure here, however, you may deviate from this
    and use your own proof structure: \<close>
  let ?C = "\<lambda>i. (f^^i) \<bottom>"
  note MONO=cont_imp_mono[OF CONT]
  have CHAIN: "chain ?C"
  proof-
    have "(\<forall>n. ?C n \<le> ?C (Suc n))"
      using MONO funpow_decreasing le_SucI by blast
    then show "chain ?C"
      using Defs.chain_def by blast
  qed

  have "mono f"
    by (simp add: MONO)

  show ?thesis
  proof (rule antisym)
    show "\<Squnion> (range ?C) \<le> lfp f"
      by (simp add: Kleene_iter_lpfp MONO SUP_le_iff lfp_greatest)
  next
    have supout: "f (\<Squnion> range ?C) = \<Squnion> (f ` range ?C)"
      using CONT CHAIN continuous_def by blast
    have "\<forall> x \<in> f ` range (\<lambda>i. (f ^^ i) \<bottom>). x \<in> range (\<lambda>i. (f ^^ i) \<bottom>)"
    proof
      fix x
      assume xdef: "x \<in> f ` range (\<lambda>i. (f ^^ i) \<bottom>)"
      then obtain b where bdef: "x = f b" "b \<in> range (\<lambda>i. (f ^^ i) \<bottom>)" by blast
      then obtain i where idef: "b = (f ^^ i) \<bottom>" by blast
      with bdef(1) have "x = f ((f ^^ i) \<bottom>)"
        by simp
      also have "... = (f ^^ (Suc i)) \<bottom>"
        by simp
      finally have "x = (f ^^ (Suc i)) \<bottom>"
        by simp
      then show "x \<in> range (\<lambda>i. (f ^^ i) \<bottom>)"
        by blast
    qed
    then have subset: "f ` range (\<lambda>i. (f ^^ i) \<bottom>) \<subseteq> range (\<lambda>i. (f ^^ i) \<bottom>)"
      by blast
    show "lfp f \<le> Sup (range ?C)"
      apply(rule lfp_lowerbound)
      apply(subst supout)
      apply(rule Sup_subset_mono)
      using subset by simp
    qed
qed

thm lfp_unfold lfp_lowerbound Sup_subset_mono range_eqI

end


theory Concrete_Semantics_7
  imports Main "~~/src/HOL/IMP/Com" "HOL-IMP.Star"
begin

(* "~~/src/HOL/IMP/Com" *)
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

schematic_goal ex : "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
  apply(rule Seq)
   apply(rule Assign)
  apply simp
  apply(rule Assign)
  done
thm ex[simplified]

code_pred big_step .

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"
values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"
values "{map t [''x'', ''y''] |t. (''x'' ::= N 2, \<lambda>_.0) \<Rightarrow> t}"

(* the following inverted rules(inductive cases) are needed to prove. *)
inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

declare big_step.intros [intro]
thm big_step.induct

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
  by blast

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
  shows "t = s"
proof-
  from assms show ?thesis
  proof cases
  case IfTrue
  then show ?thesis
    by auto
next
  case IfFalse
  then show ?thesis  by blast
qed
qed

lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
c1: "(c1, s) \<Rightarrow> s1" and
c2: "(c2, s1) \<Rightarrow> s2" and
c3: "(c3, s2) \<Rightarrow> s'"
    by blast
    from c2 c3 have "(c2;; c3, s1) \<Rightarrow> s'"
      using Seq by auto
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'"
    using Seq \<open>(c2;; c3, s1) \<Rightarrow> s'\<close> c1 by blast
next
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"

  then show  "(c1;; c2;; c3, s) \<Rightarrow> s'"
    by (meson Seq SeqE)
qed

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
  by blast

lemma unfold_while:
  "(WHILE b DO c)\<sim>(IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases
      case WhileFalse
      then show ?thesis
        by (simp add: IfFalse Skip)
    next
      case (WhileTrue s\<^sub>2)
      then show ?thesis
        using IfTrue Seq by auto
    qed
  qed
  moreover
  have  "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases
      case IfTrue
      then show ?thesis
        using WhileTrue by auto
    next
      case IfFalse
      then show ?thesis
        using WhileFalse by blast
    qed
  qed
  ultimately
  show ?thesis
    by blast
qed

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
  by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
  by blast

(* Q. What is big_step.induct[split_format(complete)]?
A. The proof of Lemma 7.6
requires the advanced form of rule induction described in Section 5.4.6 because
the big-step premise in the lemma involves not just variables but the
proper term WHILE b DO c.
 *)
lemma sim_while_cong_aux:
  "\<lbrakk>(WHILE b DO c,s) \<Rightarrow> t ; c \<sim> c'\<rbrakk> \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
  apply(induction "WHILE b DO c" s t arbitrary: b c rule:  big_step.induct[split_format(complete)])
   apply (simp add: WhileFalse)
  by blast

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
  using sim_while_cong_aux by auto

lemma sim_refl:  "c \<sim> c"
  by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)"
  by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''"
  by simp

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  apply(induction arbitrary:u rule: big_step.induct)
  apply (blast+)
  done

theorem "(c, s) \<Rightarrow> t \<Longrightarrow> (c, s) \<Rightarrow> t' \<Longrightarrow> t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  case (Skip s)
  then show ?case
    by auto
next
  case (Assign x a s)
  then show ?case
    by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case
    by blast
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then show ?case
    by blast
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then show ?case
    by blast
next
  case (WhileFalse b s c)
  then show ?case
    by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case
    by blast
qed


(* Author: Florian Haftmann, TU Muenchen *)

header {* A barebone conversion for discrete summation *}

theory Summation_Conversion
imports Factorials Summation
begin

named_theorems summation "rules for solving summation problems"

declare
  \<Sigma>_const [summation] \<Sigma>_add [summation]
  \<Sigma>_factor [summation] monomial_ffact [summation]

lemma intervall_simps [summation]:
  "(\<Sum>k\<Colon>nat = 0..0. f k) = f 0"
  "(\<Sum>k\<Colon>nat = 0..Suc n. f k) = f (Suc n) + (\<Sum>k\<Colon>nat = 0..n. f k)"
  by (simp_all add: add.commute)

lemma \<Delta>_ffact:
  "\<Delta> (ffact (Suc n)) k = of_nat (Suc n) * ffact n (of_int k)"
proof (induct n)
  case 0 then show ?case by (simp add: \<Delta>_def)
next
  case (Suc n)
  obtain m where "m = Suc n" by blast
  have "\<Delta> (ffact (Suc m)) k =
    ffact (Suc m) (of_int (k + 1)) - ffact (Suc m) (of_int k)"
    by (simp add: \<Delta>_def)
  also have "\<dots> = of_int (k + 1) * ffact m (of_int k)
    - (ffact m (of_int k) * (of_int k - of_nat m))"
    using ffact_Suc [of m "of_int k :: 'b"] by (simp add: mult.commute)
  also have "\<dots> = (of_int k + 1 - of_int k + of_nat m) * ffact m (of_int k)"
    by (simp add: algebra_simps)
  also have "\<dots> = of_nat (Suc m) * ffact m (of_int k)" by simp
  also have "\<dots> = of_nat (Suc m) * ffact (Suc m - 1) (of_int k)" by simp
  finally show ?case by (simp only: `m = Suc n` diff_Suc_1)
qed

lemma \<Sigma>_ffact_div [summation]:
  "\<Sigma> (ffact n) j l =
    (ffact (Suc n) (of_int l :: 'a :: {ring_div, semiring_char_0}) - ffact (Suc n) (of_int j)) div of_nat (Suc n)"
proof -
  have "ffact (Suc n) (of_int l :: 'a) - ffact (Suc n) (of_int j) =
    \<Sigma> (\<lambda>k. \<Delta> (ffact (Suc n)) k) j l"
    by (simp add: \<Sigma>_\<Delta>)
  also have "\<dots> = \<Sigma> (\<lambda>k. of_nat (Suc n) * ffact n (of_int k)) j l"
    by (simp add: \<Delta>_ffact)
  also have "\<dots> = of_nat (Suc n) * \<Sigma> (ffact n \<circ> of_int) j l"
    by (simp add: \<Sigma>_factor comp_def)
  finally show ?thesis by (simp only: \<Sigma>_comp_of_int div_mult_self1_is_id of_nat_eq_0_iff)
qed

lemma \<Sigma>_ffact_divide [summation]:
  "\<Sigma> (ffact n) j l =
    (ffact (Suc n) (of_int l :: 'a :: field_char_0) - ffact (Suc n) (of_int j)) / of_nat (Suc n)"
proof -
  have "ffact (Suc n) (of_int l :: 'a) - ffact (Suc n) (of_int j) =
    \<Sigma> (\<lambda>k. \<Delta> (ffact (Suc n)) k) j l"
    by (simp add: \<Sigma>_\<Delta>)
  also have "\<dots> = \<Sigma> (\<lambda>k. of_nat (Suc n) * ffact n (of_int k)) j l"
    by (simp add: \<Delta>_ffact)
  also have "\<dots> = of_nat (Suc n) * \<Sigma> (ffact n \<circ> of_int) j l"
    by (simp add: \<Sigma>_factor comp_def)
  finally show ?thesis by (simp only: \<Sigma>_comp_of_int nonzero_mult_divide_cancel_left of_nat_eq_0_iff)
qed

lemma of_int_coeff:
  "(of_int l :: 'a::comm_ring_1) * numeral k = of_int (l * numeral k)"
  by simp

lemmas nat_simps =
  add_0_left add_0_right add_Suc add_Suc_right
  mult_Suc mult_Suc_right mult_zero_left mult_zero_right
  One_nat_def of_nat_simps

lemmas of_int_pull_out =
   of_int_add [symmetric] of_int_diff [symmetric] of_int_mult [symmetric]
   of_int_coeff

lemmas of_int_pull_in =
  of_int_pull_out [symmetric] add_divide_distrib diff_divide_distrib of_int_power
  of_int_numeral of_int_neg_numeral times_divide_eq_left [symmetric]

ML {*
signature SUMMATION =
sig
  val conv: Proof.context -> conv
end

structure Summation : SUMMATION =
struct

val simps2 = @{thms Stirling.simps ffact.simps nat_simps};
val simpset3 =
  @{context}
  |> fold Simplifier.add_simp @{thms field_simps}
  |> Simplifier.simpset_of;
val simps4 = @{thms of_int_pull_out};
val simps6 = @{thms of_int_pull_in};

fun conv ctxt =
  let
    val ctxt1 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp (Named_Theorems.get ctxt @{named_theorems summation})
    val ctxt2 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps2
    val ctxt3 =
      ctxt
      |> put_simpset simpset3
    val ctxt4 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps4
    val semiring_conv = Conv.arg1_conv (Conv.arg_conv
       (Semiring_Normalizer.semiring_normalize_conv ctxt))
       (* an approximation: we assume @{term "of_int _ / _"} here *)
    val ctxt6 =
      ctxt
      |> put_simpset HOL_basic_ss
      |> fold Simplifier.add_simp simps6
  in
     Simplifier.rewrite ctxt1
     then_conv Simplifier.rewrite ctxt2
     then_conv Simplifier.rewrite ctxt3
     then_conv Simplifier.rewrite ctxt4
     then_conv semiring_conv
     then_conv Simplifier.rewrite ctxt6
  end

end
*}

hide_fact (open) nat_simps of_int_pull_out of_int_pull_in

end


(* Author: Fabian Immler, Alexander Maletzky *)

section \<open>Executable Representation of Polynomial Mappings as Association Lists\<close>

theory MPoly_Type_Class_FMap
  imports
    MPoly_Type_Class_Ordered
    Poly_Mapping_Finite_Map
begin

text \<open>In this theory, (type class) multivariate polynomials of type
  @{typ "('a, 'b) poly_mapping"} are represented as association lists.\<close>

text \<open>It is important to note that theory \<open>MPoly_Type_Class_OAlist\<close>, which represents polynomials as
  @{emph \<open>ordered\<close>} associative lists, is much better suited for doing actual computations. This
  theory is only included for being able to compare the two representations in terms of efficiency.\<close>

subsection \<open>Power Products\<close>

lemma compute_lcs_pp[code]:
  "lcs (Pm_fmap xs) (Pm_fmap ys) =
  Pm_fmap (fmmap_keys (\<lambda>k v. Orderings.max (lookup0 xs k) (lookup0 ys k)) (xs ++\<^sub>f ys))"
  by (rule poly_mapping_eqI)
    (auto simp add: fmlookup_default_fmmap_keys fmlookup_dom_iff fmdom'_notI
      lcs_poly_mapping.rep_eq fmdom'_notD)

lemma compute_deg_pp[code]:
  "deg_pm (Pm_fmap xs) = sum (the o fmlookup xs) (fmdom' xs)"
proof -
  have "deg_pm (Pm_fmap xs) = sum (lookup (Pm_fmap xs)) (keys (Pm_fmap xs))"
    by (rule deg_pm_superset) auto
  also have "\<dots> = sum (the o fmlookup xs) (fmdom' xs)"
    by (rule sum.mono_neutral_cong_left)
       (auto simp: fmlookup_dom'_iff fmdom'I in_keys_iff fmlookup_default_def
             split: option.splits)
  finally show ?thesis .
qed

definition adds_pp_add_linorder :: "('b \<Rightarrow>\<^sub>0 'a::add_linorder) \<Rightarrow> _ \<Rightarrow> bool"
  where [code_abbrev]: "adds_pp_add_linorder = (adds)"

lemma compute_adds_pp[code]:
  "adds_pp_add_linorder (Pm_fmap xs) (Pm_fmap ys) =
    (fmpred (\<lambda>k v. lookup0 xs k \<le> lookup0 ys k) (xs ++\<^sub>f ys))"
  for xs ys::"('a, 'b::add_linorder_min) fmap"
  unfolding adds_pp_add_linorder_def
  unfolding adds_poly_mapping
  using fmdom_notI
  by (force simp: fmlookup_dom_iff le_fun_def
      split: option.splits if_splits)

text\<open>Computing @{term lex} as below is certainly not the most efficient way, but it works.\<close>

lemma lex_pm_iff: "lex_pm s t = (\<forall>x. lookup s x \<le> lookup t x \<or> (\<exists>y<x. lookup s y \<noteq> lookup t y))"
proof -
  have "lex_pm s t = (\<not> lex_pm_strict t s)" by (simp add: lex_pm_strict_alt)
  also have "\<dots> = (\<forall>x. lookup s x \<le> lookup t x \<or> (\<exists>y<x. lookup s y \<noteq> lookup t y))"
    by (simp add: lex_pm_strict_def less_poly_mapping_def less_fun_def) (metis leD leI)
  finally show ?thesis .
qed

lemma compute_lex_pp[code]:
  "(lex_pm (Pm_fmap xs) (Pm_fmap (ys::(_, _::ordered_comm_monoid_add) fmap))) =
    (let zs = xs ++\<^sub>f ys in
      fmpred (\<lambda>x v.
        lookup0 xs x \<le> lookup0 ys x \<or>
        \<not> fmpred (\<lambda>y w. y \<ge> x \<or> lookup0 xs y = lookup0 ys y) zs) zs
    )"
  unfolding Let_def lex_pm_iff fmpred_iff Pm_fmap.rep_eq fmlookup_add fmlookup_dom_iff
  apply (intro iffI)
   apply (metis fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff leD)
  apply (metis eq_iff not_le fmdom'_notD fmlookup_default_if(2) fmlookup_dom'_iff)
  done

lemma compute_dord_pp[code]:
  "(dord_pm ord (Pm_fmap xs) (Pm_fmap (ys::('a::wellorder , 'b::ordered_comm_monoid_add) fmap))) =
    (let dx = deg_pm (Pm_fmap xs) in let dy = deg_pm (Pm_fmap ys) in
      dx < dy \<or> (dx = dy \<and> ord (Pm_fmap xs) (Pm_fmap ys))
    )"
  by (auto simp: Let_def deg_pm.rep_eq dord_fun_def dord_pm.rep_eq)
    (simp_all add: Pm_fmap.abs_eq)

subsubsection \<open>Computations\<close>

experiment begin

abbreviation "X \<equiv> 0::nat"
abbreviation "Y \<equiv> 1::nat"
abbreviation "Z \<equiv> 2::nat"

lemma
  "sparse\<^sub>0 [(X, 2::nat), (Z, 7)] + sparse\<^sub>0 [(Y, 3), (Z, 2)] = sparse\<^sub>0 [(X, 2), (Z, 9), (Y, 3)]"
  "dense\<^sub>0 [2, 0, 7::nat] + dense\<^sub>0 [0, 3, 2] = dense\<^sub>0 [2, 3, 9]"
  by eval+

lemma
  "sparse\<^sub>0 [(X, 2::nat), (Z, 7)] - sparse\<^sub>0 [(X, 2), (Z, 2)] = sparse\<^sub>0 [(Z, 5)]"
  by eval

lemma
  "lcs (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse\<^sub>0 [(Y, 3), (Z, 2)]) = sparse\<^sub>0 [(X, 2), (Y, 3), (Z, 7)]"
  by eval

lemma
  "(sparse\<^sub>0 [(X, 2::nat), (Z, 1)]) adds (sparse\<^sub>0 [(X, 3), (Y, 2), (Z, 1)])"
  by eval

lemma
  "lookup (sparse\<^sub>0 [(X, 2::nat), (Z, 3)]) X = 2"
  by eval

lemma
  "deg_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
  by eval

lemma
  "lex_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
by eval

lemma
  "lex_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
  by eval

lemma
  "\<not> (dlex_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)]))"
  by eval

lemma
  "dlex_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)])"
  by eval

lemma
  "\<not> (drlex_pm (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)]))"
  by eval

end

subsection \<open>Implementation of Multivariate Polynomials as Association Lists\<close>

subsubsection \<open>Unordered Power-Products\<close>

lemma compute_monomial [code]:
  "monomial c t = (if c = 0 then 0 else sparse\<^sub>0 [(t, c)])"
  by (auto intro!: poly_mapping_eqI simp: sparse\<^sub>0_def fmlookup_default_def lookup_single)

lemma compute_one_poly_mapping [code]: "1 = sparse\<^sub>0 [(0, 1)]"
  by (metis compute_monomial single_one zero_neq_one)

lemma compute_except_poly_mapping [code]:
  "except (Pm_fmap xs) S = Pm_fmap (fmfilter (\<lambda>k. k \<notin> S) xs)"
  by (auto simp: fmlookup_default_def lookup_except split: option.splits intro!: poly_mapping_eqI)

lemma lookup0_fmap_of_list_simps:
  "lookup0 (fmap_of_list ((x, y)#xs)) i = (if x = i then y else lookup0 (fmap_of_list xs) i)"
  "lookup0 (fmap_of_list []) i = 0"
  by (auto simp: fmlookup_default_def fmlookup_of_list split: if_splits option.splits)

lemma if_poly_mapping_eq_iff:
  "(if x = y then a else b) =
    (if (\<forall>i\<in>keys x \<union> keys y. lookup x i = lookup y i) then a else b)"
  by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)

lemma keys_add_eq: "keys (a + b) = keys a \<union> keys b - {x \<in> keys a \<inter> keys b. lookup a x + lookup b x = 0}"
  by (auto simp: in_keys_iff lookup_add add_eq_0_iff)

context term_powerprod
begin

context includes fmap.lifting begin

lift_definition shift_keys::"'a \<Rightarrow> ('t, 'b) fmap \<Rightarrow> ('t, 'b) fmap"
  is "\<lambda>t m x. if t adds\<^sub>p x then m (x \<ominus> t) else None"
proof -
  fix t and f::"'t \<Rightarrow> 'b option"
  assume "finite (dom f)"
  have "dom (\<lambda>x. if t adds\<^sub>p x then f (x \<ominus> t) else None) \<subseteq> (\<oplus>) t ` dom f"
    by (auto simp: adds_pp_alt domI term_simps split: if_splits)
  also have "finite \<dots>"
    using \<open>finite (dom f)\<close> by simp
  finally (finite_subset) show "finite (dom (\<lambda>x. if t adds\<^sub>p x then f (x \<ominus> t) else None))" .
qed

definition "shift_map_keys t f m = fmmap f (shift_keys t m)"

lemma compute_shift_map_keys[code]:
  "shift_map_keys t f (fmap_of_list xs) = fmap_of_list (map (\<lambda>(k, v). (t \<oplus> k, f v)) xs)"
  unfolding shift_map_keys_def
  apply transfer
  subgoal for f t xs
  proof -
    show ?thesis
      apply (rule ext)
      subgoal for x
        apply (cases "t adds\<^sub>p x")
        subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
        subgoal by (induction xs) (auto simp: adds_pp_alt term_simps)
        done
      done
  qed
  done

end

lemmas [simp] = compute_zero_pp[symmetric]

lemma compute_monom_mult_poly_mapping [code]:
  "monom_mult c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
  case True
  hence "monom_mult c t (Pm_fmap xs) = 0" using monom_mult_zero_left by simp
  thus ?thesis using True
    by simp
next
  case False
  thus ?thesis
    by (auto simp: simp: fmlookup_default_def shift_map_keys_def lookup_monom_mult
        adds_def group_eq_aux shift_keys.rep_eq
        intro!: poly_mapping_eqI split: option.splits)
qed

lemma compute_mult_scalar_poly_mapping [code]:
  "Pm_fmap (fmap_of_list xs) \<odot> q = (case xs of ((t, c) # ys) \<Rightarrow>
    (monom_mult c t q + except (Pm_fmap (fmap_of_list ys)) {t} \<odot> q) | _ \<Rightarrow>
    Pm_fmap fmempty)"
proof (split list.splits, simp, intro conjI impI allI, goal_cases)
  case (1 t c ys)
  have "Pm_fmap (fmupd t c (fmap_of_list ys)) = sparse\<^sub>0 [(t, c)] + except (sparse\<^sub>0 ys) {t}"
    by (auto simp: sparse\<^sub>0_def fmlookup_default_def lookup_add lookup_except
        split: option.splits intro!: poly_mapping_eqI)
  also have "sparse\<^sub>0 [(t, c)] = monomial c t"
    by (auto simp: sparse\<^sub>0_def lookup_single fmlookup_default_def intro!: poly_mapping_eqI)
  finally show ?case
    by (simp add: algebra_simps mult_scalar_monomial sparse\<^sub>0_def)
qed

end (* term_powerprod *)

subsubsection \<open>restore constructor view\<close>

named_theorems mpoly_simps

definition "monomial1 pp = monomial 1 pp"

lemma monomial1_Nil[mpoly_simps]: "monomial1 0 = 1"
  by (simp add: monomial1_def)

lemma monomial_mp: "monomial c (pp::'a\<Rightarrow>\<^sub>0nat) = Const\<^sub>0 c * monomial1 pp"
  for c::"'b::comm_semiring_1"
  by (auto intro!: poly_mapping_eqI simp: monomial1_def Const\<^sub>0_def mult_single)

lemma monomial1_add: "(monomial1 (a + b)::('a::monoid_add\<Rightarrow>\<^sub>0'b::comm_semiring_1)) = monomial1 a * monomial1 b"
  by (auto simp: monomial1_def mult_single)

lemma monomial1_monomial: "monomial1 (monomial n v) = (Var\<^sub>0 v::_\<Rightarrow>\<^sub>0('b::comm_semiring_1))^n"
  by (auto intro!: poly_mapping_eqI simp: monomial1_def Var\<^sub>0_power lookup_single when_def)

lemma Ball_True: "(\<forall>x\<in>X. True) \<longleftrightarrow> True" by auto
lemma Collect_False: "{x. False} = {}" by simp

lemma Pm_fmap_sum: "Pm_fmap f = (\<Sum>x \<in> fmdom' f. monomial (lookup0 f x) x)"
  including fmap.lifting
  by (auto intro!: poly_mapping_eqI sum.neutral
      simp: fmlookup_default_def lookup_sum lookup_single when_def fmdom'I
      split: option.splits)

lemma MPoly_numeral: "MPoly (numeral x) = numeral x"
  by (metis monom.abs_eq monom_numeral single_numeral)

lemma MPoly_power: "MPoly (x ^ n) = MPoly x ^ n"
  by (induction n) (auto simp: one_mpoly_def times_mpoly.abs_eq[symmetric])

lemmas [mpoly_simps] = Pm_fmap_sum
  add.assoc[symmetric] mult.assoc[symmetric]
  add_0 add_0_right mult_1 mult_1_right mult_zero_left mult_zero_right power_0 power_one_right
  fmdom'_fmap_of_list
  list.map fst_conv
  sum.insert_remove finite_insert finite.emptyI
  lookup0_fmap_of_list_simps
  num.simps rel_simps
  if_True if_False
  insert_Diff_if insert_iff empty_Diff empty_iff
  simp_thms
  sum.empty
  if_poly_mapping_eq_iff
  keys_zero keys_one
  keys_add_eq
  keys_single
  Un_insert_left Un_empty_left
  Int_insert_left Int_empty_left
  Collect_False
  lookup_add lookup_single lookup_zero lookup_one
  Set.ball_simps
  when_simps
  monomial_mp
  monomial1_add
  monomial1_monomial
  Const\<^sub>0_one Const\<^sub>0_zero Const\<^sub>0_numeral Const\<^sub>0_minus
  set_simps

text \<open>A simproc for postprocessing with \<open>mpoly_simps\<close> and not polluting \<open>[code_post]\<close>:\<close>

ML \<open>val mpoly_simproc = Simplifier.make_simproc @{context} "multivariate polynomials"
      {lhss = [@{term "Pm_fmap mpp::(_ \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 _"}],
       proc = (K (fn ctxt => fn ct =>
          SOME (Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps
            (Named_Theorems.get ctxt (\<^named_theorems>\<open>mpoly_simps\<close>))) ct)))}\<close>

(* The simproc slows down computations *a lot*, so it is deactivated by default. *)

(* setup \<open>Code_Preproc.map_post (fn ctxt => ctxt addsimprocs [mpoly_simproc])\<close> *)

subsubsection \<open>Ordered Power-Products\<close>

lemma foldl_assoc:
  assumes "\<And>x y z. f (f x y) z = f x (f y z)"
  shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
  fix a b
  show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
  fix a b x xs
  assume "\<And>a b. foldl f (f a b) xs = f a (foldl f b xs)"
  from assms[of a b x] this[of a "f b x"]
    show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
qed

context ordered_term
begin

definition list_max::"'t list \<Rightarrow> 't" where
  "list_max xs \<equiv> foldl ord_term_lin.max min_term xs"

lemma list_max_Cons: "list_max (x # xs) = ord_term_lin.max x (list_max xs)"
  unfolding list_max_def foldl_Cons
proof -
  have "foldl ord_term_lin.max (ord_term_lin.max x min_term) xs =
          ord_term_lin.max x (foldl ord_term_lin.max min_term xs)"
    by (rule foldl_assoc, rule ord_term_lin.max.assoc)
  from this ord_term_lin.max.commute[of min_term x]
    show "foldl ord_term_lin.max (ord_term_lin.max min_term x) xs =
            ord_term_lin.max x (foldl ord_term_lin.max min_term xs)" by simp
qed

lemma list_max_empty: "list_max [] = min_term"
  unfolding list_max_def by simp

lemma list_max_in_list:
  assumes "xs \<noteq> []"
  shows "list_max xs \<in> set xs"
  using assms
proof (induct xs, simp)
  fix x xs
  assume IH: "xs \<noteq> [] \<Longrightarrow> list_max xs \<in> set xs"
  show "list_max (x # xs) \<in> set (x # xs)"
  proof (cases "xs = []")
    case True
    hence "list_max (x # xs) = ord_term_lin.max min_term x" unfolding list_max_def by simp
    also have "\<dots> = x" unfolding ord_term_lin.max_def by (simp add: min_term_min)
    finally show ?thesis by simp
  next
    assume "xs \<noteq> []"
    show ?thesis
    proof (cases "x \<preceq>\<^sub>t list_max xs")
      case True
      hence "list_max (x # xs) = list_max xs"
        unfolding list_max_Cons ord_term_lin.max_def by simp
      thus ?thesis using IH[OF \<open>xs \<noteq> []\<close>] by simp
    next
      case False
      hence "list_max (x # xs) = x" unfolding list_max_Cons ord_term_lin.max_def by simp
      thus ?thesis by simp
    qed
  qed
qed

lemma list_max_maximum:
  assumes "a \<in> set xs"
  shows "a \<preceq>\<^sub>t (list_max xs)"
  using assms
proof (induct xs)
  assume "a \<in> set []"
  thus "a \<preceq>\<^sub>t list_max []" by simp
next
  fix x xs
  assume IH: "a \<in> set xs \<Longrightarrow> a \<preceq>\<^sub>t list_max xs" and a_in: "a \<in> set (x # xs)"
  from a_in have "a = x \<or> a \<in> set xs" by simp
  thus "a \<preceq>\<^sub>t list_max (x # xs)" unfolding list_max_Cons
  proof
    assume "a = x"
    thus "a \<preceq>\<^sub>t ord_term_lin.max x (list_max xs)" by simp
  next
    assume "a \<in> set xs"
    from IH[OF this] show "a \<preceq>\<^sub>t ord_term_lin.max x (list_max xs)"
      by (simp add: ord_term_lin.le_max_iff_disj)
  qed
qed

lemma list_max_nonempty:
  assumes "xs \<noteq> []"
  shows "list_max xs = ord_term_lin.Max (set xs)"
proof -
  have fin: "finite (set xs)" by simp
  have "ord_term_lin.Max (set xs) = list_max xs"
  proof (rule ord_term_lin.Max_eqI[OF fin, of "list_max xs"])
    fix y
    assume "y \<in> set xs"
    from list_max_maximum[OF this] show "y \<preceq>\<^sub>t list_max xs" .
  next
    from list_max_in_list[OF assms] show "list_max xs \<in> set xs" .
  qed
  thus ?thesis by simp
qed

lemma in_set_clearjunk_iff_map_of_eq_Some:
  "(a, b) \<in> set (AList.clearjunk xs) \<longleftrightarrow> map_of xs a = Some b"
  by (metis Some_eq_map_of_iff distinct_clearjunk map_of_clearjunk)

lemma Pm_fmap_of_list_eq_zero_iff:
  "Pm_fmap (fmap_of_list xs) = 0 \<longleftrightarrow> [(k, v)\<leftarrow>AList.clearjunk xs . v \<noteq> 0] = []"
  by (auto simp: poly_mapping_eq_iff fmlookup_default_def fun_eq_iff
    in_set_clearjunk_iff_map_of_eq_Some filter_empty_conv fmlookup_of_list split: option.splits)

lemma fmdom'_clearjunk0: "fmdom' (clearjunk0 xs) = fmdom' xs - {x. fmlookup xs x = Some 0}"
  by (metis (no_types, lifting) clearjunk0_def fmdom'_drop_set fmfilter_alt_defs(2) fmfilter_cong' mem_Collect_eq)

lemma compute_lt_poly_mapping[code]:
  "lt (Pm_fmap (fmap_of_list xs)) = list_max (map fst [(k, v) \<leftarrow> AList.clearjunk xs. v \<noteq> 0])"
proof -
  have "keys (Pm_fmap (fmap_of_list xs)) = fst ` {x \<in> set (AList.clearjunk xs). case x of (k, v) \<Rightarrow> v \<noteq> 0}"
    by (auto simp: compute_keys_pp fmdom'_clearjunk0 fmap_of_list.rep_eq
        in_set_clearjunk_iff_map_of_eq_Some fmdom'I image_iff fmlookup_dom'_iff)
  then show ?thesis
    unfolding lt_def
    by (auto simp: Pm_fmap_of_list_eq_zero_iff list_max_empty list_max_nonempty)
qed

lemma compute_higher_poly_mapping [code]:
  "higher (Pm_fmap xs) t = Pm_fmap (fmfilter (\<lambda>k. t \<prec>\<^sub>t k) xs)"
  unfolding higher_def compute_except_poly_mapping
  by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)

lemma compute_lower_poly_mapping [code]:
  "lower (Pm_fmap xs) t = Pm_fmap (fmfilter (\<lambda>k. k \<prec>\<^sub>t t) xs)"
  unfolding lower_def compute_except_poly_mapping
  by (metis mem_Collect_eq ord_term_lin.leD ord_term_lin.leI)

end (* ordered_term *)

lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting

subsection \<open>Computations\<close>

subsubsection \<open>Scalar Polynomials\<close>

type_synonym 'a mpoly_tc = "(nat \<Rightarrow>\<^sub>0 nat)\<Rightarrow>\<^sub>0'a"

definition "shift_map_keys_punit = term_powerprod.shift_map_keys to_pair_unit fst"

lemma compute_shift_map_keys_punit [code]:
  "shift_map_keys_punit t f (fmap_of_list xs) = fmap_of_list (map (\<lambda>(k, v). (t + k, f v)) xs)"
  by (simp add: punit.compute_shift_map_keys shift_map_keys_punit_def)

global_interpretation punit: term_powerprod to_pair_unit fst
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  defines monom_mult_punit = punit.monom_mult
  and mult_scalar_punit = punit.mult_scalar
  apply (fact MPoly_Type_Class.punit.term_powerprod_axioms)
  apply (fact MPoly_Type_Class.punit_adds_term)
  apply (fact MPoly_Type_Class.punit_pp_of_term)
  apply (fact MPoly_Type_Class.punit_component_of_term)
  done

lemma compute_monom_mult_punit [code]:
  "monom_mult_punit c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_punit t ((*) c) xs)"
  by (simp add: monom_mult_punit_def punit.compute_monom_mult_poly_mapping shift_map_keys_punit_def)

lemma compute_mult_scalar_punit [code]:
  "Pm_fmap (fmap_of_list xs) * q = (case xs of ((t, c) # ys) \<Rightarrow>
    (monom_mult_punit c t q + except (Pm_fmap (fmap_of_list ys)) {t} * q) | _ \<Rightarrow>
    Pm_fmap fmempty)"
  by (simp only: punit_mult_scalar[symmetric] punit.compute_mult_scalar_poly_mapping monom_mult_punit_def)

locale trivariate\<^sub>0_rat
begin

abbreviation X::"rat mpoly_tc" where "X \<equiv> Var\<^sub>0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y \<equiv> Var\<^sub>0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z \<equiv> Var\<^sub>0 (2::nat)"

end

locale trivariate
begin

abbreviation "X \<equiv> Var 0"
abbreviation "Y \<equiv> Var 1"
abbreviation "Z \<equiv> Var 2"

end

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "keys (X\<^sup>2 * Z ^ 3 + 2 * Y ^ 3 * Z\<^sup>2) =
    {monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
  by eval

lemma
  "keys (X\<^sup>2 * Z ^ 3 + 2 * Y ^ 3 * Z\<^sup>2) =
    {monomial 2 0 + monomial 3 2, monomial 3 1 + monomial 2 2}"
  by eval

lemma
  "- 1 * X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2 = - X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2"
  by eval

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 + X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 = X\<^sup>2 * Z ^ 7 + X\<^sup>2 * Z ^ 4"
  by eval

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 - X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 =
    X\<^sup>2 * Z ^ 7 - X\<^sup>2 * Z ^ 4"
  by eval

lemma
  "lookup (X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 + 2) (sparse\<^sub>0 [(0, 2), (2, 7)]) = 1"
  by eval

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 \<noteq>
   X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2"
  by eval

lemma
  "0 * X^2 * Z^7 + 0 * Y^3*Z\<^sup>2 = 0"
  by eval

lemma
  "monom_mult_punit 3 (sparse\<^sub>0 [(1, 2::nat)]) (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) =
    3 * Y\<^sup>2 * Z * X\<^sup>2 + 6 * Y ^ 5 * Z\<^sup>2"
  by eval

lemma
  "monomial (-4) (sparse\<^sub>0 [(0, 2::nat)]) = - 4 * X\<^sup>2"
  by eval

lemma "monomial (0::rat) (sparse\<^sub>0 [(0::nat, 2::nat)]) = 0"
  by eval

lemma
  "(X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) * (X\<^sup>2 * Z ^ 3 + - 2 * Y ^ 3 * Z\<^sup>2) =
    X ^ 4 * Z ^ 4 + - 2 * X\<^sup>2 * Z ^ 3 * Y ^ 3 +
 - 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X\<^sup>2"
  by eval

end

subsubsection \<open>Vector-Polynomials\<close>

type_synonym 'a vmpoly_tc = "((nat \<Rightarrow>\<^sub>0 nat) \<times> nat) \<Rightarrow>\<^sub>0 'a"

definition "shift_map_keys_pprod = pprod.shift_map_keys"

global_interpretation pprod: term_powerprod "\<lambda>x. x" "\<lambda>x. x"
  rewrites "pprod.pp_of_term = fst"
  and "pprod.component_of_term = snd"
  defines splus_pprod = pprod.splus
  and monom_mult_pprod = pprod.monom_mult
  and mult_scalar_pprod = pprod.mult_scalar
  and adds_term_pprod = pprod.adds_term
  apply (fact MPoly_Type_Class.pprod.term_powerprod_axioms)
  apply (fact MPoly_Type_Class.pprod_pp_of_term)
  apply (fact MPoly_Type_Class.pprod_component_of_term)
  done

lemma compute_adds_term_pprod [code_unfold]:
  "adds_term_pprod u v = (snd u = snd v \<and> adds_pp_add_linorder (fst u) (fst v))"
  by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)

lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
  by (simp add: splus_pprod_def pprod.splus_def)

lemma compute_shift_map_keys_pprod [code]:
  "shift_map_keys_pprod t f (fmap_of_list xs) = fmap_of_list (map (\<lambda>(k, v). (splus_pprod t k, f v)) xs)"
  by (simp add: pprod.compute_shift_map_keys shift_map_keys_pprod_def splus_pprod_def)

lemma compute_monom_mult_pprod [code]:
  "monom_mult_pprod c t (Pm_fmap xs) = Pm_fmap (if c = 0 then fmempty else shift_map_keys_pprod t ((*) c) xs)"
  by (simp add: monom_mult_pprod_def pprod.compute_monom_mult_poly_mapping shift_map_keys_pprod_def)

lemma compute_mult_scalar_pprod [code]:
  "mult_scalar_pprod (Pm_fmap (fmap_of_list xs)) q = (case xs of ((t, c) # ys) \<Rightarrow>
    (monom_mult_pprod c t q + mult_scalar_pprod (except (Pm_fmap (fmap_of_list ys)) {t}) q) | _ \<Rightarrow>
    Pm_fmap fmempty)"
  by (simp only: mult_scalar_pprod_def pprod.compute_mult_scalar_poly_mapping monom_mult_pprod_def)

definition Vec\<^sub>0 :: "nat \<Rightarrow> (('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) \<Rightarrow> (('a \<Rightarrow>\<^sub>0 nat) \<times> nat) \<Rightarrow>\<^sub>0 'b::semiring_1" where
  "Vec\<^sub>0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "keys (Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 3) + Vec\<^sub>0 1 (2 * Y ^ 3 * Z\<^sup>2)) =
    {(sparse\<^sub>0 [(0, 2), (2, 3)], 0), (sparse\<^sub>0 [(1, 3), (2, 2)], 1)}"
  by eval

lemma
  "keys (Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 3) + Vec\<^sub>0 2 (2 * Y ^ 3 * Z\<^sup>2)) =
    {(sparse\<^sub>0 [(0, 2), (2, 3)], 0), (sparse\<^sub>0 [(1, 3), (2, 2)], 2)}"
  by eval

lemma
  "Vec\<^sub>0 1 (X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2) + Vec\<^sub>0 3 (X\<^sup>2 * Z ^ 4) + Vec\<^sub>0 1 (- 2 * Y ^ 3 * Z\<^sup>2) =
    Vec\<^sub>0 1 (X\<^sup>2 * Z ^ 7) + Vec\<^sub>0 3 (X\<^sup>2 * Z ^ 4)"
  by eval

lemma
  "lookup (Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 7) + Vec\<^sub>0 1 (2 * Y ^ 3 * Z\<^sup>2 + 2)) (sparse\<^sub>0 [(0, 2), (2, 7)], 0) = 1"
  by eval

lemma
  "lookup (Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 7) + Vec\<^sub>0 1 (2 * Y ^ 3 * Z\<^sup>2 + 2)) (sparse\<^sub>0 [(0, 2), (2, 7)], 1) = 0"
  by eval

lemma
  "Vec\<^sub>0 0 (0 * X^2 * Z^7) + Vec\<^sub>0 1 (0 * Y^3*Z\<^sup>2) = 0"
  by eval

lemma
  "monom_mult_pprod 3 (sparse\<^sub>0 [(1, 2::nat)]) (Vec\<^sub>0 0 (X\<^sup>2 * Z) + Vec\<^sub>0 1 (2 * Y ^ 3 * Z\<^sup>2)) =
    Vec\<^sub>0 0 (3 * Y\<^sup>2 * Z * X\<^sup>2) + Vec\<^sub>0 1 (6 * Y ^ 5 * Z\<^sup>2)"
  by eval

end

subsection \<open>Code setup for type MPoly\<close>

text \<open>postprocessing from \<open>Var\<^sub>0, Const\<^sub>0\<close> to \<open>Var, Const\<close>.\<close>

lemmas [code_post] =
  plus_mpoly.abs_eq[symmetric]
  times_mpoly.abs_eq[symmetric]
  MPoly_numeral
  MPoly_power
  one_mpoly_def[symmetric]
  Var.abs_eq[symmetric]
  Const.abs_eq[symmetric]

instantiation mpoly::("{equal, zero}")equal begin

lift_definition equal_mpoly:: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> bool" is HOL.equal .

instance proof standard qed (transfer, rule equal_eq)

end

experiment begin interpretation trivariate .

lemmas [mpoly_simps] = plus_mpoly.abs_eq

lemma "content_primitive (4 * X * Y^2 * Z^3 + 6 * X\<^sup>2 * Y^4 + 8 * X\<^sup>2 * Y^5) =
    (2::int, 2 * X * Y\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y ^ 4 + 4 * X\<^sup>2 * Y ^ 5)"
  by eval

end

end (* theory *)