(*  Title:      HOL/Library/Code_Target_Int.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Implementation of integer numbers by target-language integers\<close>

theory Code_Target_Int
imports Main
begin

code_datatype int_of_integer

declare [[code drop: integer_of_int]]

context
includes integer.lifting
begin

lemma [code]:
  "Int.Pos = int_of_integer \<circ> integer_of_num"
  by transfer (simp add: fun_eq_iff)

lemma [code]:
  "Int.Neg = int_of_integer \<circ> uminus \<circ> integer_of_num"
  by transfer (simp add: fun_eq_iff)

lemma [code_abbrev]:
  "int_of_integer (numeral k) = Int.Pos k"
  by transfer simp

lemma [code_abbrev]:
  "int_of_integer (- numeral k) = Int.Neg k"
  by transfer simp

context
begin

qualified definition positive :: "num \<Rightarrow> int"
  where [simp]: "positive = numeral"

qualified definition negative :: "num \<Rightarrow> int"
  where [simp]: "negative = uminus \<circ> numeral"

lemma [code_computation_unfold]:
  "numeral = positive"
  "Int.Pos = positive"
  "Int.Neg = negative"
  by (simp_all add: fun_eq_iff)

end

lemma [code, symmetric, code_post]:
  "0 = int_of_integer 0"
  by transfer simp

lemma [code, symmetric, code_post]:
  "1 = int_of_integer 1"
  by transfer simp

lemma [code_post]:
  "int_of_integer (- 1) = - 1"
  by simp

lemma [code]:
  "k + l = int_of_integer (of_int k + of_int l)"
  by transfer simp

lemma [code]:
  "- k = int_of_integer (- of_int k)"
  by transfer simp

lemma [code]:
  "k - l = int_of_integer (of_int k - of_int l)"
  by transfer simp

lemma [code]:
  "Int.dup k = int_of_integer (Code_Numeral.dup (of_int k))"
  by transfer simp

declare [[code drop: Int.sub]]

lemma [code]:
  "k * l = int_of_integer (of_int k * of_int l)"
  by simp

lemma [code]:
  "k div l = int_of_integer (of_int k div of_int l)"
  by simp

lemma [code]:
  "k mod l = int_of_integer (of_int k mod of_int l)"
  by simp

lemma [code]:
  "divmod m n = map_prod int_of_integer int_of_integer (divmod m n)"
  unfolding prod_eq_iff divmod_def map_prod_def case_prod_beta fst_conv snd_conv
  by transfer simp

lemma [code]:
  "HOL.equal k l = HOL.equal (of_int k :: integer) (of_int l)"
  by transfer (simp add: equal)

lemma [code]:
  "k \<le> l \<longleftrightarrow> (of_int k :: integer) \<le> of_int l"
  by transfer rule

lemma [code]:
  "k < l \<longleftrightarrow> (of_int k :: integer) < of_int l"
  by transfer rule

declare [[code drop: "gcd :: int \<Rightarrow> _" "lcm :: int \<Rightarrow> _"]]

lemma gcd_int_of_integer [code]:
  "gcd (int_of_integer x) (int_of_integer y) = int_of_integer (gcd x y)"
  by transfer rule

lemma lcm_int_of_integer [code]:
  "lcm (int_of_integer x) (int_of_integer y) = int_of_integer (lcm x y)"
  by transfer rule

end

lemma (in ring_1) of_int_code_if:
  "of_int k = (if k = 0 then 0
     else if k < 0 then - of_int (- k)
     else let
       l = 2 * of_int (k div 2);
       j = k mod 2
     in if j = 0 then l else l + 1)"
proof -
  from div_mult_mod_eq have *: "of_int k = of_int (k div 2 * 2 + k mod 2)" by simp
  show ?thesis
    by (simp add: Let_def of_int_add [symmetric]) (simp add: * mult.commute)
qed

declare of_int_code_if [code]

lemma [code]:
  "nat = nat_of_integer \<circ> of_int"
  including integer.lifting by transfer (simp add: fun_eq_iff)

definition char_of_int :: "int \<Rightarrow> char"
  where [code_abbrev]: "char_of_int = char_of"

definition int_of_char :: "char \<Rightarrow> int"
  where [code_abbrev]: "int_of_char = of_char"

lemma [code]:
  "char_of_int = char_of_integer \<circ> integer_of_int"
  including integer.lifting unfolding char_of_integer_def char_of_int_def
  by transfer (simp add: fun_eq_iff)

lemma [code]:
  "int_of_char = int_of_integer \<circ> integer_of_char"
  including integer.lifting unfolding integer_of_char_def int_of_char_def
  by transfer (simp add: fun_eq_iff)

context
  includes integer.lifting bit_operations_syntax
begin

declare [[code drop: \<open>bit :: int \<Rightarrow> _\<close> \<open>not :: int \<Rightarrow> _\<close>
  \<open>and :: int \<Rightarrow> _\<close> \<open>or :: int \<Rightarrow> _\<close> \<open>xor :: int \<Rightarrow> _\<close>
  \<open>push_bit :: _ \<Rightarrow> _ \<Rightarrow> int\<close> \<open>drop_bit :: _ \<Rightarrow> _ \<Rightarrow> int\<close> \<open>take_bit :: _ \<Rightarrow> _ \<Rightarrow> int\<close>]]

lemma [code]:
  \<open>bit (int_of_integer k) n \<longleftrightarrow> bit k n\<close>
  by transfer rule

lemma [code]:
  \<open>NOT (int_of_integer k) = int_of_integer (NOT k)\<close>
  by transfer rule

lemma [code]:
  \<open>int_of_integer k AND int_of_integer l = int_of_integer (k AND l)\<close>
  by transfer rule

lemma [code]:
  \<open>int_of_integer k OR int_of_integer l = int_of_integer (k OR l)\<close>
  by transfer rule

lemma [code]:
  \<open>int_of_integer k XOR int_of_integer l = int_of_integer (k XOR l)\<close>
  by transfer rule

lemma [code]:
  \<open>push_bit n (int_of_integer k) = int_of_integer (push_bit n k)\<close>
  by transfer rule

lemma [code]:
  \<open>drop_bit n (int_of_integer k) = int_of_integer (drop_bit n k)\<close>
  by transfer rule

lemma [code]:
  \<open>take_bit n (int_of_integer k) = int_of_integer (take_bit n k)\<close>
  by transfer rule

lemma [code]:
  \<open>mask n = int_of_integer (mask n)\<close>
  by transfer rule

lemma [code]:
  \<open>set_bit n (int_of_integer k) = int_of_integer (set_bit n k)\<close>
  by transfer rule

lemma [code]:
  \<open>unset_bit n (int_of_integer k) = int_of_integer (unset_bit n k)\<close>
  by transfer rule

lemma [code]:
  \<open>flip_bit n (int_of_integer k) = int_of_integer (flip_bit n k)\<close>
  by transfer rule

end

code_identifier
  code_module Code_Target_Int \<rightharpoonup>
    (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


(*  Title:       Verification components with Kleene Algebras
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Verification components with Kleene Algebras \<close>

text \<open> We create verification rules based on various Kleene Algebras. \<close>

theory VC_diffKAD_KA
  imports
  KAT_and_DRA.PHL_KAT
  "KAD.Modal_Kleene_Algebra"
  "Transformer_Semantics.Kleisli_Quantale"

begin

subsection \<open> Hoare logic and refinement in KAT \<close>

text \<open> Here we derive the rules of Hoare Logic and a refinement calculus in
Kleene algebra with tests. \<close>

notation t ("\<tt>\<tt>")

hide_const t

no_notation ars_r ("r")
        and if_then_else ("if _ then _ else _ fi" [64,64,64] 63)
        and while ("while _ do _ od" [64,64] 63)

context kat (* mostly by Victor Gomes, Georg Struth *)
begin

\<comment> \<open> Definitions of Hoare Triple \<close>

definition Hoare :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("H") where
  "H p x q \<longleftrightarrow> \<tt>\<tt> p \<cdot> x \<le> x \<cdot> \<tt>\<tt> q"

lemma H_consl: "\<tt>\<tt> p \<le> \<tt>\<tt> p' \<Longrightarrow> H p' x q \<Longrightarrow> H p x q"
  using Hoare_def phl_cons1 by blast

lemma H_consr: "\<tt>\<tt> q' \<le> \<tt>\<tt> q \<Longrightarrow> H p x q' \<Longrightarrow> H p x q"
  using Hoare_def phl_cons2 by blast

lemma H_cons: "\<tt>\<tt> p \<le> \<tt>\<tt> p' \<Longrightarrow> \<tt>\<tt> q' \<le> \<tt>\<tt> q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (simp add: H_consl H_consr)

\<comment> \<open> Skip program \<close>

lemma H_skip:  "H p 1 p"
  by (simp add: Hoare_def)

\<comment> \<open> Sequential composition \<close>

lemma H_seq: "H p x r \<Longrightarrow> H r y q \<Longrightarrow> H p (x \<cdot> y) q"
  by (simp add: Hoare_def phl_seq)

\<comment> \<open> Conditional statement \<close>

definition kat_cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = (\<tt>\<tt> p \<cdot> x + n p \<cdot> y)"

lemma H_var: "H p x q \<longleftrightarrow> \<tt>\<tt> p \<cdot> x \<cdot> n q = 0"
  by (metis Hoare_def n_kat_3 t_n_closed)

lemma H_cond_iff: "H p (if r then x else y fi) q \<longleftrightarrow> H (\<tt>\<tt> p \<cdot> \<tt>\<tt> r) x q \<and> H (\<tt>\<tt> p \<cdot> n r) y q"
proof -
  have "H p (if r then x else y fi) q \<longleftrightarrow> \<tt>\<tt> p \<cdot> (\<tt>\<tt> r \<cdot> x + n r \<cdot> y) \<cdot> n q = 0"
    by (simp add: H_var kat_cond_def)
  also have "... \<longleftrightarrow> \<tt>\<tt> p \<cdot> \<tt>\<tt> r \<cdot> x \<cdot> n q + \<tt>\<tt> p \<cdot> n r \<cdot> y \<cdot> n q = 0"
    by (simp add: distrib_left mult_assoc)
  also have "... \<longleftrightarrow> \<tt>\<tt> p \<cdot> \<tt>\<tt> r \<cdot> x \<cdot> n q = 0 \<and> \<tt>\<tt> p \<cdot> n r \<cdot> y \<cdot> n q = 0"
    by (metis add_0_left no_trivial_inverse)
  finally show ?thesis
    by (metis H_var test_mult)
qed

lemma H_cond: "H (\<tt>\<tt> p \<cdot> \<tt>\<tt> r) x q \<Longrightarrow> H (\<tt>\<tt> p \<cdot> n r) y q \<Longrightarrow> H p (if r then x else y fi) q"
  by (simp add: H_cond_iff)

\<comment> \<open> While loop \<close>

definition kat_while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while b do x od = (\<tt>\<tt> b \<cdot> x)\<^sup>\<star> \<cdot> n b"

definition kat_while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_exp1: "H (\<tt>\<tt> p \<cdot> \<tt>\<tt> r) x q \<Longrightarrow> H p (\<tt>\<tt> r \<cdot> x) q"
  using Hoare_def n_de_morgan_var2 phl.ht_at_phl_export1 by auto

lemma H_while: "H (\<tt>\<tt> p \<cdot> \<tt>\<tt> r) x p \<Longrightarrow> H p (while r do x od) (\<tt>\<tt> p \<cdot> n r)"
proof -
  assume a1: "H (\<tt>\<tt> p \<cdot> \<tt>\<tt> r) x p"
  have "\<tt>\<tt> (\<tt>\<tt> p \<cdot> n r) = n r \<cdot> \<tt>\<tt> p \<cdot> n r"
    using n_preserve test_mult by presburger
  then show ?thesis
    using a1 Hoare_def H_exp1 conway.phl.it_simr phl_export2 kat_while_def by auto
qed

lemma H_while_inv: "\<tt>\<tt> p \<le> \<tt>\<tt> i \<Longrightarrow> \<tt>\<tt> i \<cdot> n r \<le> \<tt>\<tt> q \<Longrightarrow> H (\<tt>\<tt> i \<cdot> \<tt>\<tt> r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  by (metis H_cons H_while test_mult kat_while_inv_def)

\<comment> \<open> Finite iteration \<close>

lemma H_star: "H i x i \<Longrightarrow> H i (x\<^sup>\<star>) i"
  unfolding Hoare_def using star_sim2 by blast

lemma H_star_inv:
  assumes "\<tt>\<tt> p \<le> \<tt>\<tt> i" and "H i x i" and "(\<tt>\<tt> i) \<le> (\<tt>\<tt> q)"
  shows "H p (x\<^sup>\<star>) q"
proof-
  have "H i (x\<^sup>\<star>) i"
    using assms(2) H_star by blast
  hence "H p (x\<^sup>\<star>) i"
    unfolding Hoare_def using assms(1) phl_cons1 by blast
  thus ?thesis
    unfolding Hoare_def using assms(3) phl_cons2 by blast
qed

definition kat_loop_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("loop _ inv _ " [64,64] 63)
  where "loop x inv i = x\<^sup>\<star>"

lemma H_loop: "H p x p \<Longrightarrow> H p (loop x inv i) p"
  unfolding kat_loop_inv_def by (rule H_star)

lemma H_loop_inv: "\<tt>\<tt> p \<le> \<tt>\<tt> i \<Longrightarrow> H i x i \<Longrightarrow> \<tt>\<tt> i \<le> \<tt>\<tt> q \<Longrightarrow> H p (loop x inv i) q"
  unfolding kat_loop_inv_def using H_star_inv by blast

\<comment> \<open> Invariants \<close>

lemma H_inv: "\<tt>\<tt> p \<le> \<tt>\<tt> i \<Longrightarrow> \<tt>\<tt> i \<le> \<tt>\<tt> q \<Longrightarrow> H i x i \<Longrightarrow> H p x q"
  by (rule_tac p'=i and q'=i in H_cons)

lemma H_inv_plus: "\<tt>\<tt> i = i \<Longrightarrow> \<tt>\<tt> j = j \<Longrightarrow> H i x i \<Longrightarrow>  H j x j \<Longrightarrow>  H (i + j) x (i + j)"
  unfolding Hoare_def using combine_common_factor
  by (smt add_commute add.left_commute distrib_left join.sup.absorb_iff1 t_add_closed)

lemma H_inv_mult: "\<tt>\<tt> i = i \<Longrightarrow> \<tt>\<tt> j = j \<Longrightarrow> H i x i \<Longrightarrow>  H j x j \<Longrightarrow>  H (i \<cdot> j) x (i \<cdot> j)"
  unfolding Hoare_def by (smt n_kat_2 n_mult_comm t_mult_closure mult_assoc)

end

subsection \<open> refinement KAT \<close>

class rkat = kat +
  fixes Ref :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes spec_def:  "x \<le> Ref p q \<longleftrightarrow> H p x q"

begin (* mostly by Victor Gomes, Georg Struth *)

lemma R1: "H p (Ref p q) q"
  using spec_def by blast

lemma R2: "H p x q \<Longrightarrow> x \<le> Ref p q"
  by (simp add: spec_def)

lemma R_cons: "\<tt>\<tt> p \<le> \<tt>\<tt> p' \<Longrightarrow> \<tt>\<tt> q' \<le> \<tt>\<tt> q \<Longrightarrow> Ref p' q' \<le> Ref p q"
proof -
  assume h1: "\<tt>\<tt> p \<le> \<tt>\<tt> p'" and h2: "\<tt>\<tt> q' \<le> \<tt>\<tt> q"
  have "H p' (Ref p' q') q'"
    by (simp add: R1)
  hence "H p (Ref p' q') q"
    using h1 h2 H_consl H_consr by blast
  thus ?thesis
    by (rule R2)
qed

\<comment> \<open> Abort and skip programs \<close>

lemma R_skip: "1 \<le> Ref p p"
proof -
  have "H p 1 p"
    by (simp add: H_skip)
  thus ?thesis
    by (rule R2)
qed

lemma R_zero_one: "x \<le> Ref 0 1"
proof -
  have "H 0 x 1"
    by (simp add: Hoare_def)
  thus ?thesis
    by (rule R2)
qed

lemma R_one_zero: "Ref 1 0 = 0"
proof -
  have "H 1 (Ref 1 0) 0"
    by (simp add: R1)
  thus ?thesis
    by (simp add: Hoare_def join.le_bot)
qed

\<comment> \<open> Sequential composition \<close>

lemma R_seq: "(Ref p r) \<cdot> (Ref r q) \<le> Ref p q"
proof -
  have "H p (Ref p r) r" and "H r (Ref r q) q"
    by (simp add: R1)+
  hence "H p ((Ref p r) \<cdot> (Ref r q)) q"
    by (rule H_seq)
  thus ?thesis
    by (rule R2)
qed

\<comment> \<open> Conditional statement \<close>

lemma R_cond: "if v then (Ref (\<tt>\<tt> v \<cdot> \<tt>\<tt> p) q) else (Ref (n v \<cdot> \<tt>\<tt> p) q) fi \<le> Ref p q"
proof -
  have "H (\<tt>\<tt> v \<cdot> \<tt>\<tt> p) (Ref (\<tt>\<tt> v \<cdot> \<tt>\<tt> p) q) q" and "H (n v \<cdot> \<tt>\<tt> p) (Ref (n v \<cdot> \<tt>\<tt> p) q) q"
    by (simp add: R1)+
  hence "H p (if v then (Ref (\<tt>\<tt> v \<cdot> \<tt>\<tt> p) q) else (Ref (n v \<cdot> \<tt>\<tt> p) q) fi) q"
    by (simp add: H_cond n_mult_comm)
 thus ?thesis
    by (rule R2)
qed

\<comment> \<open> While loop \<close>

lemma R_while: "while q do (Ref (\<tt>\<tt> p \<cdot> \<tt>\<tt> q) p) od \<le> Ref p (\<tt>\<tt> p \<cdot> n q)"
proof -
  have "H (\<tt>\<tt> p \<cdot> \<tt>\<tt> q) (Ref (\<tt>\<tt> p \<cdot> \<tt>\<tt> q) p)  p"
    by (simp_all add: R1)
  hence "H p (while q do (Ref (\<tt>\<tt> p \<cdot> \<tt>\<tt> q) p) od) (\<tt>\<tt> p \<cdot> n q)"
    by (simp add: H_while)
  thus ?thesis
    by (rule R2)
qed

\<comment> \<open> Finite iteration \<close>

lemma R_star: "(Ref i i)\<^sup>\<star> \<le> Ref i i"
proof -
  have "H i (Ref i i) i"
    using R1 by blast
  hence "H i ((Ref i i)\<^sup>\<star>) i"
    using H_star by blast
  thus "Ref i i\<^sup>\<star> \<le> Ref i i"
    by (rule R2)
qed

lemma R_loop: "loop (Ref p p) inv i \<le> Ref p p"
  unfolding kat_loop_inv_def by (rule R_star)

\<comment> \<open> Invariants \<close>

lemma R_inv: "\<tt>\<tt> p \<le> \<tt>\<tt> i \<Longrightarrow> \<tt>\<tt> i \<le> \<tt>\<tt> q \<Longrightarrow> Ref i i \<le> Ref p q"
  using R_cons by force

end

no_notation kat_cond ("if _ then _ else _ fi" [64,64,64] 63)
        and kat_while ("while _ do _ od" [64,64] 63)
        and kat_while_inv ("while _ inv _ do _ od" [64,64,64] 63)
        and kat_loop_inv ("loop _ inv _ " [64,64] 63)

subsection \<open> Verification in AKA (KAD) \<close>

text \<open>Here we derive verification components with weakest liberal preconditions based on
antidomain Kleene algebra (or Kleene algebra with domain) \<close>

context antidomain_kleene_algebra
begin

\<comment> \<open> Sequential composition \<close>

declare fbox_mult [simp]

\<comment> \<open> Conditional statement \<close>

definition aka_cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63)
  where "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

lemma fbox_export1: "ad p + |x] q = |d p \<cdot> x] q"
  using a_d_add_closure addual.ars_r_def fbox_def fbox_mult by auto

lemma fbox_cond [simp]: "|if p then x else y fi] q = (ad p + |x] q) \<cdot> (d p + |y] q)"
  using aka_cond_def a_closure' ads_d_def ans_d_def fbox_add2 fbox_export1 by auto

\<comment> \<open> Finite iteration \<close>

definition aka_loop_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("loop _ inv _ " [64,64] 63)
  where "loop x inv i = x\<^sup>\<star>"

lemma fbox_stari: "d p \<le> d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> d p \<le> |x\<^sup>\<star>] q"
  by (meson dual_order.trans fbox_iso fbox_star_induct_var)

lemma fbox_loopi: "d p \<le> d i \<Longrightarrow> d i \<le> |x] i \<Longrightarrow> d i \<le> d q \<Longrightarrow> d p \<le> |loop x inv i] q"
  unfolding aka_loop_inv_def using fbox_stari by blast

\<comment> \<open> Invariants \<close>

lemma fbox_frame: "d p \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d q \<le> |x] r \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d r)"
  using dual.mult_isol_var fbox_add1 fbox_demodalisation3 fbox_simp by auto

lemma plus_inv: "i \<le> |x] i \<Longrightarrow> j \<le> |x] j \<Longrightarrow> (i + j) \<le> |x] (i + j)"
  by (metis ads_d_def dka.dsr5 fbox_simp fbox_subdist join.sup_mono order_trans)

lemma mult_inv: "d i \<le> |x] d i \<Longrightarrow> d j \<le> |x] d j \<Longrightarrow> (d i \<cdot> d j) \<le> |x] (d i \<cdot> d j)"
  using fbox_demodalisation3 fbox_frame fbox_simp by auto

end

subsection \<open> Relational model \<close>

text \<open>We show that relations form Kleene Algebras (KAT and AKA). \<close>

interpretation rel_uq: unital_quantale Id "(O)" "\<Inter>" "\<Union>" "(\<inter>)" "(\<subseteq>)" "(\<subset>)" "(\<union>)" "{}" UNIV
  by (unfold_locales, auto)

lemma power_is_relpow: "rel_uq.power X m = X ^^ m" for X::"'a rel"
proof (induct m)
  case 0 show ?case
    by (metis rel_uq.power_0 relpow.simps(1))
  case Suc thus ?case
    by (metis rel_uq.power_Suc2 relpow.simps(2))
qed

lemma rel_star_def: "X^* = (\<Union>m. rel_uq.power X m)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X O Y^* = (\<Union>m. X O rel_uq.power Y m)"
by (metis rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* O Y = (\<Union>m. (rel_uq.power X m) O Y)"
  by (metis rel_star_def relcomp_UNION_distrib2)

interpretation rel_ka: kleene_algebra "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl
proof
  fix x y z :: "'a rel"
  show "Id \<union> x O x\<^sup>* \<subseteq> x\<^sup>*"
    by (metis order_refl r_comp_rtrancl_eq rtrancl_unfold)
next
  fix x y z :: "'a rel"
  assume "z \<union> x O y \<subseteq> y"
  thus "x\<^sup>* O z \<subseteq> y"
    by (simp only: rel_star_contr, metis (lifting) SUP_le_iff rel_uq.power_inductl)
next
  fix x y z :: "'a rel"
  assume "z \<union> y O x \<subseteq> y"
  thus "z O x\<^sup>* \<subseteq> y"
    by (simp only: rel_star_contl, metis (lifting) SUP_le_iff rel_uq.power_inductr)
qed

interpretation rel_tests: test_semiring "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" "\<lambda>x. Id \<inter> ( - x)"
  by (standard, auto)

interpretation rel_kat: kat "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl "\<lambda>x. Id \<inter> ( - x)"
  by (unfold_locales)

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_kat.Hoare P X Q}"

interpretation rel_rkat: rkat "(\<union>)" "(;)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl "(\<lambda>X. Id \<inter> - X)" rel_R
  by (standard, auto simp: rel_R_def rel_kat.Hoare_def)

lemma RdL_is_rRKAT: "(\<forall>x. {(x,x)}; R1 \<subseteq> {(x,x)}; R2) = (R1 \<subseteq> R2)" (* Refinement in dL is that of rKAT *)
  by auto

definition rel_ad :: "'a rel \<Rightarrow> 'a rel" where
  "rel_ad R = {(x,x) | x. \<not> (\<exists>y. (x,y) \<in> R)}"

interpretation rel_aka: antidomain_kleene_algebra rel_ad "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl
  by  unfold_locales (auto simp: rel_ad_def)

subsection \<open> State transformer model \<close>

text \<open>We show that state transformers form Kleene Algebras (KAT and AKA). \<close>

notation Abs_nd_fun ("_\<^sup>\<bullet>" [101] 100)
     and Rep_nd_fun ("_\<^sub>\<bullet>" [101] 100)

declare Abs_nd_fun_inverse [simp]

lemma nd_fun_ext: "(\<And>x. (f\<^sub>\<bullet>) x = (g\<^sub>\<bullet>) x) \<Longrightarrow> f = g"
  apply(subgoal_tac "Rep_nd_fun f = Rep_nd_fun g")
  using Rep_nd_fun_inject
   apply blast
  by(rule ext, simp)

lemma nd_fun_eq_iff: "(f = g) = (\<forall>x. (f\<^sub>\<bullet>) x = (g\<^sub>\<bullet>) x)"
  by (auto simp: nd_fun_ext)

instantiation nd_fun :: (type) kleene_algebra
begin

definition "0 = \<zeta>\<^sup>\<bullet>"

definition "star_nd_fun f = qstar f" for f::"'a nd_fun"

definition "f + g = ((f\<^sub>\<bullet>) \<squnion> (g\<^sub>\<bullet>))\<^sup>\<bullet>"

named_theorems nd_fun_aka "antidomain kleene algebra properties for nondeterministic functions."

lemma nd_fun_plus_assoc[nd_fun_aka]: "x + y + z = x + (y + z)"
  and nd_fun_plus_comm[nd_fun_aka]: "x + y = y + x"
  and nd_fun_plus_idem[nd_fun_aka]: "x + x = x" for x::"'a nd_fun"
  unfolding plus_nd_fun_def by (simp add: ksup_assoc, simp_all add: ksup_comm)

lemma nd_fun_distr[nd_fun_aka]: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and nd_fun_distl[nd_fun_aka]: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z" for x::"'a nd_fun"
  unfolding plus_nd_fun_def times_nd_fun_def by (simp_all add: kcomp_distr kcomp_distl)

lemma nd_fun_plus_zerol[nd_fun_aka]: "0 + x = x"
  and nd_fun_mult_zerol[nd_fun_aka]: "0 \<cdot> x = 0"
  and nd_fun_mult_zeror[nd_fun_aka]: "x \<cdot> 0 = 0" for x::"'a nd_fun"
  unfolding plus_nd_fun_def zero_nd_fun_def times_nd_fun_def by auto

lemma nd_fun_leq[nd_fun_aka]: "(x \<le> y) = (x + y = y)"
  and nd_fun_less[nd_fun_aka]: "(x < y) = (x + y = y \<and> x \<noteq> y)"
  and nd_fun_leq_add[nd_fun_aka]: "z \<cdot> x \<le> z \<cdot> (x + y)" for x::"'a nd_fun"
  unfolding less_eq_nd_fun_def less_nd_fun_def plus_nd_fun_def times_nd_fun_def sup_fun_def
  by (unfold nd_fun_eq_iff le_fun_def, auto simp: kcomp_def)

lemma nd_star_one[nd_fun_aka]: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and nd_star_unfoldl[nd_fun_aka]: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and nd_star_unfoldr[nd_fun_aka]: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y" for x::"'a nd_fun"
  unfolding plus_nd_fun_def star_nd_fun_def
    apply(simp_all add: fun_star_inductl sup_nd_fun.rep_eq fun_star_inductr)
  by (metis order_refl sup_nd_fun.rep_eq uwqlka.conway.dagger_unfoldl_eq)

instance
  apply intro_classes
  using nd_fun_aka by simp_all

end

instantiation nd_fun :: (type) kat
begin

definition "n f = (\<lambda>x. if ((f\<^sub>\<bullet>) x = {}) then {x} else {})\<^sup>\<bullet>"

lemma nd_fun_n_op_one[nd_fun_aka]: "n (n (1::'a nd_fun)) = 1"
  and nd_fun_n_op_mult[nd_fun_aka]: "n (n (n x \<cdot> n y)) = n x \<cdot> n y"
  and nd_fun_n_op_mult_comp[nd_fun_aka]: "n x \<cdot> n (n x) = 0"
  and nd_fun_n_op_de_morgan[nd_fun_aka]: "n (n (n x) \<cdot> n (n y)) = n x + n y" for x::"'a nd_fun"
  unfolding n_op_nd_fun_def one_nd_fun_def times_nd_fun_def plus_nd_fun_def zero_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def)

instance
  by (intro_classes, auto simp: nd_fun_aka)

end

instantiation nd_fun :: (type) rkat
begin

definition "Ref_nd_fun P Q \<equiv> (\<lambda>s. \<Union>{(f\<^sub>\<bullet>) s|f. Hoare P f Q})\<^sup>\<bullet>"

instance
  apply(intro_classes)
  by (unfold Hoare_def n_op_nd_fun_def Ref_nd_fun_def times_nd_fun_def)
    (auto simp: kcomp_def le_fun_def less_eq_nd_fun_def)

end

instantiation nd_fun :: (type) antidomain_kleene_algebra
begin

definition "ad f = (\<lambda>x. if ((f\<^sub>\<bullet>) x = {}) then {x} else {})\<^sup>\<bullet>"

lemma nd_fun_ad_zero[nd_fun_aka]: "ad x \<cdot> x = 0"
  and nd_fun_ad[nd_fun_aka]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and nd_fun_ad_one[nd_fun_aka]: "ad (ad x) + ad x = 1" for x::"'a nd_fun"
  unfolding antidomain_op_nd_fun_def times_nd_fun_def plus_nd_fun_def zero_nd_fun_def
  by (auto simp: nd_fun_eq_iff kcomp_def one_nd_fun_def)

instance
  apply intro_classes
  using nd_fun_aka by simp_all

end

end


chapter \<open>Sigma-Formulas and Theorem 2.5\<close>

theory Sigma
imports Predicates
begin

section\<open>Ground Terms and Formulas\<close>

definition ground_aux :: "tm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

abbreviation ground :: "tm \<Rightarrow> bool"
  where "ground t \<equiv> ground_aux t {}"

definition ground_fm_aux :: "fm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_fm_aux A S \<equiv> (supp A \<subseteq> S)"

abbreviation ground_fm :: "fm \<Rightarrow> bool"
  where "ground_fm A \<equiv> ground_fm_aux A {}"

lemma ground_aux_simps[simp]:
  "ground_aux Zero S = True"
  "ground_aux (Var k) S = (if atom k \<in> S then True else False)"
  "ground_aux (Eats t u) S = (ground_aux t S \<and> ground_aux u S)"
unfolding ground_aux_def
by (simp_all add: supp_at_base)

lemma ground_fm_aux_simps[simp]:
  "ground_fm_aux Fls S = True"
  "ground_fm_aux (t IN u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (A OR B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A AND B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A IFF B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (Neg A) S =  (ground_fm_aux A S)"
  "ground_fm_aux (Ex x A) S = (ground_fm_aux A (S \<union> {atom x}))"
by (auto simp: ground_fm_aux_def ground_aux_def supp_conv_fresh)

lemma ground_fresh[simp]:
  "ground t \<Longrightarrow> atom i \<sharp> t"
  "ground_fm A \<Longrightarrow> atom i \<sharp> A"
unfolding ground_aux_def ground_fm_aux_def fresh_def
by simp_all

section\<open>Sigma Formulas\<close>

text\<open>Section 2 material\<close>

subsection \<open>Strict Sigma Formulas\<close>

text\<open>Definition 2.1\<close>
inductive ss_fm :: "fm \<Rightarrow> bool" where
    MemI:  "ss_fm (Var i IN Var j)"
  | DisjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A OR B)"
  | ConjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A AND B)"
  | ExI:   "ss_fm A \<Longrightarrow> ss_fm (Ex i A)"
  | All2I: "ss_fm A \<Longrightarrow> atom j \<sharp> (i,A) \<Longrightarrow> ss_fm (All2 i (Var j) A)"

equivariance ss_fm

nominal_inductive ss_fm
  avoids ExI: "i" | All2I: "i"
by (simp_all add: fresh_star_def)

declare ss_fm.intros [intro]

definition Sigma_fm :: "fm \<Rightarrow> bool"
  where "Sigma_fm A \<longleftrightarrow> (\<exists>B. ss_fm B \<and> supp B \<subseteq> supp A \<and> {} \<turnstile> A IFF B)"

lemma Sigma_fm_Iff: "\<lbrakk>{} \<turnstile> B IFF A; supp A \<subseteq> supp B; Sigma_fm A\<rbrakk> \<Longrightarrow> Sigma_fm B"
  by (metis Sigma_fm_def Iff_trans order_trans)

lemma ss_fm_imp_Sigma_fm [intro]: "ss_fm A \<Longrightarrow> Sigma_fm A"
  by (metis Iff_refl Sigma_fm_def order_refl)

lemma Sigma_fm_Fls [iff]: "Sigma_fm Fls"
  by (rule Sigma_fm_Iff [of _ "Ex i (Var i IN Var i)"]) auto

subsection\<open>Closure properties for Sigma-formulas\<close>

lemma
  assumes "Sigma_fm A" "Sigma_fm B"
    shows Sigma_fm_AND [intro!]: "Sigma_fm (A AND B)"
      and Sigma_fm_OR [intro!]:  "Sigma_fm (A OR B)"
      and Sigma_fm_Ex [intro!]:  "Sigma_fm (Ex i A)"
proof -
  obtain SA SB where "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
                 and "ss_fm SB" "{} \<turnstile> B IFF SB" "supp SB \<subseteq> supp B"
    using assms by (auto simp add: Sigma_fm_def)
  then show "Sigma_fm (A AND B)"  "Sigma_fm (A OR B)"  "Sigma_fm (Ex i A)"
    apply (auto simp: Sigma_fm_def)
    apply (metis ss_fm.ConjI Conj_cong Un_mono supp_Conj)
    apply (metis ss_fm.DisjI Disj_cong Un_mono fm.supp(3))
    apply (rule exI [where x = "Ex i SA"])
    apply (auto intro!: Ex_cong)
    done
qed

lemma Sigma_fm_All2_Var:
  assumes H0: "Sigma_fm A" and ij: "atom j \<sharp> (i,A)"
  shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain SA where SA: "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
    using H0 by (auto simp add: Sigma_fm_def)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [of _ "All2 i (Var j) SA"])
    apply (metis All2_cong Refl SA(2) emptyE)
    using SA ij
    apply (auto simp: supp_conv_fresh subset_iff)
    apply (metis ss_fm.All2I fresh_Pair ss_fm_imp_Sigma_fm)
    done
qed

section\<open>Lemma 2.2: Atomic formulas are Sigma-formulas\<close>

lemma Eq_Eats_Iff:
   assumes [unfolded fresh_Pair, simp]: "atom i \<sharp> (z,x,y)"
   shows "{} \<turnstile> z EQ Eats x y IFF (All2 i z (Var i IN x OR Var i EQ y)) AND x SUBS z AND y IN z"
proof (rule Iff_I, auto)
  have "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN Eats x y"
    by (metis Assume Iff_MP_left Iff_sym Mem_cong Refl)
  then show "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN x OR Var i EQ y"
    by (metis Iff_MP_same Mem_Eats_Iff)
next
  show "{z EQ Eats x y} \<turnstile> x SUBS z"
    by (metis Iff_MP2_same Subset_cong [OF Refl Assume] Subset_Eats_I)
next
  show "{z EQ Eats x y} \<turnstile> y IN z"
    by (metis Iff_MP2_same Mem_cong Assume Refl Mem_Eats_I2)
next
  show "{x SUBS z, y IN z, All2 i z (Var i IN x OR Var i EQ y)} \<turnstile> z EQ Eats x y"
       (is "{_, _, ?allHyp} \<turnstile> _")
    apply (rule Eq_Eats_iff [OF assms, THEN Iff_MP2_same], auto)
    apply (rule Ex_I [where x="Var i"])
    apply (auto intro: Subset_D  Mem_cong [OF Assume Refl, THEN Iff_MP2_same])
    done
qed

lemma Subset_Zero_sf: "Sigma_fm (Var i SUBS Zero)"
proof -
  obtain j::name where j: "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Subset_Zero_Iff: "{} \<turnstile> Var i SUBS Zero IFF (All2 j (Var i) Fls)"
    by (auto intro!: Subset_I [of j] intro: Eq_Zero_D Subset_Zero_D All2_E [THEN rotate2])
  thus ?thesis using j
    by (auto simp: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF Subset_Zero_Iff] Sigma_fm_All2_Var)
qed

lemma Eq_Zero_sf: "Sigma_fm (Var i EQ Zero)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  thus ?thesis
    by (auto simp add: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF _ _ Subset_Zero_sf] Subset_Zero_D EQ_imp_SUBS)
qed

lemma theorem_sf: assumes "{} \<turnstile> A" shows "Sigma_fm A"
proof -
  obtain i::name and j::name
    where ij: "atom i \<sharp> (j,A)" "atom j \<sharp> A"
    by (metis obtain_fresh)
  show ?thesis
    apply (rule Sigma_fm_Iff [where A = "Ex i (Ex j (Var i IN Var j))"])
    using ij
    apply (auto simp: )
    apply (rule Ex_I [where x=Zero], simp)
    apply (rule Ex_I [where x="Eats Zero Zero"])
    apply (auto intro: Mem_Eats_I2 assms thin0)
    done
qed

text \<open>The subset relation\<close>
lemma Var_Subset_sf: "Sigma_fm (Var i SUBS Var j)"
proof -
  obtain k::name where k: "atom (k::name) \<sharp> (i,j)"
    by (metis obtain_fresh)
  thus ?thesis
  proof (cases "i=j")
    case True thus ?thesis using k
      by (auto intro!: theorem_sf Subset_I [where i=k])
  next
    case False thus ?thesis using k
      by (auto simp: ss_fm_imp_Sigma_fm Subset.simps [of k] ss_fm.intros)
  qed
qed

lemma Zero_Mem_sf: "Sigma_fm (Zero IN Var i)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Zero_Mem_Iff: "{} \<turnstile> Zero IN Var i IFF (Ex j (Var j  EQ Zero AND Var j  IN Var i))"
    by (auto intro: Ex_I [where x = Zero]  Mem_cong [OF Assume Refl, THEN Iff_MP_same])
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF Zero_Mem_Iff] Eq_Zero_sf)
qed

lemma ijk: "i + k < Suc (i + j + k)"
  by arith

lemma All2_term_Iff_fresh: "i\<noteq>j \<Longrightarrow> atom j' \<sharp> (i,j,A) \<Longrightarrow>
   {} \<turnstile> (All2 i (Var j) A) IFF Ex j' (Var j EQ Var j' AND All2 i (Var j') A)"
apply auto
apply (rule Ex_I [where x="Var j"], auto)
apply (rule Ex_I [where x="Var i"], auto intro: ContraProve Mem_cong [THEN Iff_MP_same])
done

lemma Sigma_fm_All2_fresh:
  assumes "Sigma_fm A" "i\<noteq>j"
    shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain j'::name where j': "atom j' \<sharp> (i,j,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff_fresh [OF _ j']])
    using assms j'
    apply (auto simp: supp_conv_fresh Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Subset_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j IN t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i SUBS Eats t u)"
proof -
  obtain k::name where k: "atom k \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i SUBS Eats t u IFF All2 k (Var i) (Var k IN t OR Var k EQ u)"
    apply (auto simp: fresh_Pair intro: Set_MP Disj_I1 Disj_I2)
    apply (force intro!: Subset_I [where i=k] intro: All2_E' [OF Hyp] Mem_Eats_I1 Mem_Eats_I2)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    using k
    apply (auto intro!: Sigma_fm_All2_fresh simp add: assms fresh_Pair supp_conv_fresh fresh_at_base)
    done
qed

lemma Eq_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i EQ Eats t u)"
proof -
  obtain j::name and k::name and l::name
    where atoms: "atom j \<sharp> (t,u,i)" "atom k \<sharp> (t,u,i,j)" "atom l \<sharp> (t,u,i,j,k)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i EQ Eats t u IFF
              Ex j (Ex k (Var i EQ Eats (Var j) (Var k) AND Var j EQ t AND Var k EQ u))"
    apply auto
    apply (rule Ex_I [where x=t], simp)
    apply (rule Ex_I [where x=u], auto intro: Trans Eats_cong)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    apply (auto simp: assms supp_at_base)
    apply (rule Sigma_fm_Iff [OF Eq_Eats_Iff [of l]])
    using atoms
    apply (auto simp: supp_conv_fresh fresh_at_base Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Eats_Mem_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Eats t u IN Var i)"
proof -
  obtain j::name where j: "atom j \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Eats t u IN Var i IFF
              Ex j (Var j IN Var i AND Var j EQ Eats t u)"
    apply (auto simp: fresh_Pair intro: Ex_I [where x="Eats t u"])
    apply (metis Assume Mem_cong [OF _ Refl, THEN Iff_MP_same] rotate2)
    done
  thus ?thesis
    by (rule Sigma_fm_Iff) (auto simp: assms supp_conv_fresh Eq_Eats_sf)
qed

lemma Subset_Mem_sf_lemma:
  "size t + size u < n \<Longrightarrow> Sigma_fm (t SUBS u) \<and> Sigma_fm (t IN u)"
proof (induction n arbitrary: t u rule: less_induct)
  case (less n t u)
  show ?case
  proof
    show "Sigma_fm (t SUBS u)"
      proof (cases t rule: tm.exhaust)
        case Zero thus ?thesis
          by (auto intro: theorem_sf)
      next
        case (Var i) thus ?thesis using less.prems
          apply (cases u rule: tm.exhaust)
          apply (auto simp: Subset_Zero_sf Var_Subset_sf)
          apply (force simp: supp_conv_fresh less.IH
                       intro: Subset_Eats_sf Sigma_fm_Iff [OF Extensionality])
          done
      next
        case (Eats t1 t2) thus ?thesis using less.IH [OF _ ijk] less.prems
          by (auto intro!: Sigma_fm_Iff [OF Eats_Subset_Iff]  simp: supp_conv_fresh)
             (metis add.commute)
      qed
  next
    show "Sigma_fm (t IN u)"
      proof (cases u rule: tm.exhaust)
        case Zero show ?thesis
          by (rule Sigma_fm_Iff [where A=Fls]) (auto simp: supp_conv_fresh Zero)
      next
        case (Var i) show ?thesis
        proof (cases t rule: tm.exhaust)
          case Zero thus ?thesis using \<open>u = Var i\<close>
            by (auto intro: Zero_Mem_sf)
        next
          case (Var j)
          thus ?thesis using \<open>u = Var i\<close>
            by auto
        next
          case (Eats t1 t2) thus ?thesis using \<open>u = Var i\<close> less.prems
            by (force intro: Eats_Mem_sf Sigma_fm_Iff [OF Extensionality _ _]
                      simp: supp_conv_fresh less.IH [THEN conjunct1])
        qed
      next
        case (Eats t1 t2) thus ?thesis  using  less.prems
          by (force intro: Sigma_fm_Iff [OF Mem_Eats_Iff] Sigma_fm_Iff [OF Extensionality _ _]
                    simp: supp_conv_fresh less.IH)
      qed
  qed
qed

lemma Subset_sf [iff]: "Sigma_fm (t SUBS u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

lemma Mem_sf [iff]: "Sigma_fm (t IN u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

text \<open>The equality relation is a Sigma-Formula\<close>
lemma Equality_sf [iff]: "Sigma_fm (t EQ u)"
  by (auto intro: Sigma_fm_Iff [OF Extensionality] simp: supp_conv_fresh)

section\<open>Universal Quantification Bounded by an Arbitrary Term\<close>

lemma All2_term_Iff: "atom i \<sharp> t \<Longrightarrow> atom j \<sharp> (i,t,A) \<Longrightarrow>
                  {} \<turnstile> (All2 i t A) IFF Ex j (Var j EQ t AND All2 i (Var j) A)"
apply auto
apply (rule Ex_I [where x=t], auto)
apply (rule Ex_I [where x="Var i"])
apply (auto intro: ContraProve Mem_cong [THEN Iff_MP2_same])
done

lemma Sigma_fm_All2 [intro!]:
  assumes "Sigma_fm A" "atom i \<sharp> t"
    shows "Sigma_fm (All2 i t A)"
proof -
  obtain j::name where j: "atom j \<sharp> (i,t,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i t A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff [of i t j]])
    using assms j
    apply (auto simp: supp_conv_fresh Sigma_fm_All2_Var)
    done
qed

section \<open>Lemma 2.3: Sequence-related concepts are Sigma-formulas\<close>

lemma OrdP_sf [iff]: "Sigma_fm (OrdP t)"
proof -
  obtain z::name and y::name where "atom z \<sharp> t" "atom y \<sharp> (t, z)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: OrdP.simps)
qed

lemma OrdNotEqP_sf [iff]: "Sigma_fm (OrdNotEqP t u)"
  by (auto simp: OrdNotEqP.simps)

lemma HDomain_Incl_sf [iff]: "Sigma_fm (HDomain_Incl t u)"
proof -
  obtain x::name and y::name and z::name
    where "atom x \<sharp> (t,u,y,z)" "atom y \<sharp> (t,u,z)" "atom z \<sharp> (t,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma HFun_Sigma_Iff:
  assumes "atom z \<sharp> (r,z',x,y,x',y')"  "atom z' \<sharp> (r,x,y,x',y')"
       "atom x \<sharp> (r,y,x',y')"  "atom y \<sharp> (r,x',y')"
       "atom x' \<sharp> (r,y')"  "atom y' \<sharp> (r)"
  shows
  "{} \<turnstile>HFun_Sigma r IFF
         All2 z r (All2 z' r (Ex x (Ex y (Ex x' (Ex y'
             (Var z EQ HPair (Var x) (Var y) AND Var z' EQ HPair (Var x') (Var y')
              AND OrdP (Var x) AND OrdP (Var x') AND
              ((Var x NEQ Var x') OR (Var y EQ Var y'))))))))"
  apply (simp add: HFun_Sigma.simps [OF assms])
  apply (rule Iff_refl All_cong Imp_cong Ex_cong)+
  apply (rule Conj_cong [OF Iff_refl])
  apply (rule Conj_cong [OF Iff_refl], auto)
  apply (blast intro: Disj_I1 Neg_D OrdNotEqP_I)
  apply (blast intro: Disj_I2)
  apply (blast intro: OrdNotEqP_E rotate2)
  done

lemma HFun_Sigma_sf [iff]: "Sigma_fm (HFun_Sigma t)"
proof -
  obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
    where atoms: "atom z \<sharp> (t,z',x,y,x',y')"  "atom z' \<sharp> (t,x,y,x',y')"
       "atom x \<sharp> (t,y,x',y')"  "atom y \<sharp> (t,x',y')"
       "atom x' \<sharp> (t,y')"  "atom y' \<sharp> (t)"
    by (metis obtain_fresh)
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF HFun_Sigma_Iff [OF atoms]] simp: supp_conv_fresh atoms)
qed

lemma LstSeqP_sf [iff]: "Sigma_fm (LstSeqP t u v)"
  by (auto simp: LstSeqP.simps)

section \<open>A Key Result: Theorem 2.5\<close>

subsection \<open>Sigma-Eats Formulas\<close>

inductive se_fm :: "fm \<Rightarrow> bool" where
    MemI:  "se_fm (t IN u)"
  | DisjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A OR B)"
  | ConjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A AND B)"
  | ExI:   "se_fm A \<Longrightarrow> se_fm (Ex i A)"
  | All2I: "se_fm A \<Longrightarrow> atom i \<sharp> t \<Longrightarrow> se_fm (All2 i t A)"

equivariance se_fm

nominal_inductive se_fm
  avoids ExI: "i" | All2I: "i"
by (simp_all add: fresh_star_def)

declare se_fm.intros [intro]

lemma subst_fm_in_se_fm: "se_fm A \<Longrightarrow> se_fm (A(k::=x))"
by (nominal_induct avoiding: k x rule: se_fm.strong_induct) (auto)

subsection\<open>Preparation\<close>
text\<open>To begin, we require some facts connecting quantification and ground terms.\<close>

lemma obtain_const_tm:  obtains t where "\<lbrakk>t\<rbrakk>e = x" "ground t"
proof (induct x rule: hf_induct)
  case 0 thus ?case
    by (metis ground_aux_simps(1) eval_tm.simps(1))
next
  case (hinsert y x) thus ?case
    by (metis ground_aux_simps(3) eval_tm.simps(3))
qed

text\<open>In a negative context, the formulation above is actually weaker than this one.\<close>
lemma ex_eval_fm_iff_exists_tm':
  "eval_fm e (Ex k A) \<longleftrightarrow> (\<exists>t. eval_fm e (A(k::=t)))"
by (auto simp: eval_subst_fm) (metis obtain_const_tm)

text\<open>A ground term defines a finite set of ground terms, its elements.\<close>
nominal_function elts :: "tm \<Rightarrow> tm set" where
   "elts Zero       = {}"
 | "elts (Var k)    = {}"
 | "elts (Eats t u) = insert u (elts t)"
by (auto simp: eqvt_def elts_graph_aux_def) (metis tm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma eval_fm_All2_Eats:
  "atom i \<sharp> (t,u) \<Longrightarrow>
   eval_fm e (All2 i (Eats t u) A) \<longleftrightarrow> eval_fm e (A(i::=u)) \<and> eval_fm e (All2 i t A)"
  by (simp only: ex_eval_fm_iff_exists_tm' eval_fm.simps) (auto simp: eval_subst_fm)

text\<open>The term @{term t} must be ground, since @{term elts} doesn't handle variables.\<close>
lemma eval_fm_All2_Iff_elts:
  "ground t \<Longrightarrow> eval_fm e (All2 i t A) \<longleftrightarrow> (\<forall>u \<in> elts t. eval_fm e (A(i::=u)))"
apply (induct t rule: tm.induct)
apply auto [2]
apply (simp add: eval_fm_All2_Eats del: eval_fm.simps)
done

lemma prove_elts_imp_prove_All2:
   "ground t \<Longrightarrow> (\<And>u. u \<in> elts t \<Longrightarrow> {} \<turnstile> A(i::=u)) \<Longrightarrow> {} \<turnstile> All2 i t A"
proof (induct t rule: tm.induct)
  case Zero thus ?case
    by auto
next
  case (Var i) thus ?case  \<comment> \<open>again: vacuously!\<close>
    by simp
next
  case (Eats t u)
  hence pt: "{} \<turnstile> All2 i t A" and pu: "{} \<turnstile> A(i::=u)"
    by auto
  have "{} \<turnstile> ((Var i IN t) IMP A)(i ::= Var i)"
    by (rule All_D [OF pt])
  hence "{} \<turnstile> ((Var i IN t) IMP A)"
    by simp
  thus ?case using pu
    by (auto intro: anti_deduction) (metis Iff_MP_same Var_Eq_subst_Iff thin1)
qed

subsection\<open>The base cases: ground atomic formulas\<close>

lemma ground_prove:
   "\<lbrakk>size t + size u < n; ground t; ground u\<rbrakk>
    \<Longrightarrow> (\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u) \<and> (\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u)"
proof (induction n arbitrary: t u rule: less_induct)
  case (less n t u)
  show ?case
  proof
    show "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u" using less
      by (cases t rule: tm.exhaust) auto
  next
    { fix y t u
      have "\<lbrakk>y < n; size t + size u < y; ground t; ground u; \<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e\<rbrakk>
           \<Longrightarrow> {} \<turnstile> t EQ u"
        by (metis Equality_I less.IH add.commute order_refl)
    }
    thus "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u" using less.prems
      by (cases u rule: tm.exhaust) (auto simp: Mem_Eats_I1 Mem_Eats_I2 less.IH)
  qed
qed

lemma
  assumes "ground t" "ground u"
    shows ground_prove_SUBS: "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t SUBS u"
      and ground_prove_IN:   "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t IN u"
      and ground_prove_EQ:   "\<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t EQ u"
  by (metis Equality_I assms ground_prove [OF lessI] order_refl)+

lemma ground_subst:
  "ground_aux tm (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_aux (subst i t tm) S"
  by (induct tm rule: tm.induct) (auto simp: ground_aux_def)

lemma ground_subst_fm:
  "ground_fm_aux A (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_fm_aux (A(i::=t)) S"
  apply (nominal_induct A avoiding: i arbitrary: S rule: fm.strong_induct)
  apply (auto simp: ground_subst Set.insert_commute)
  done

lemma elts_imp_ground: "u \<in> elts t \<Longrightarrow> ground_aux t S \<Longrightarrow> ground_aux u S"
  by (induct t rule: tm.induct) auto

lemma ground_se_fm_induction:
   "ground_fm \<alpha> \<Longrightarrow> size \<alpha> < n \<Longrightarrow> se_fm \<alpha> \<Longrightarrow> eval_fm e \<alpha> \<Longrightarrow> {} \<turnstile> \<alpha>"
proof (induction n arbitrary: \<alpha> rule: less_induct)
  case (less n \<alpha>)
  show ?case using \<open>se_fm \<alpha>\<close>
  proof (cases rule: se_fm.cases)
    case (MemI t u) thus "{} \<turnstile> \<alpha>" using less
      by (auto intro: ground_prove_IN)
  next
    case (DisjI A B) thus "{} \<turnstile> \<alpha>" using less
      by (auto intro: Disj_I1 Disj_I2)
  next
    case (ConjI A B) thus "{} \<turnstile> \<alpha>" using less
      by auto
  next
    case (ExI A i)
    thus "{} \<turnstile> \<alpha>" using less.prems
      apply (auto simp: ex_eval_fm_iff_exists_tm simp del: better_ex_eval_fm)
      apply (auto intro!: Ex_I less.IH subst_fm_in_se_fm ground_subst_fm)
      done
  next
    case (All2I A i t)
    hence t: "ground t" using less.prems
      by (auto simp: ground_aux_def fresh_def)
    hence "(\<forall>u\<in>elts t. eval_fm e (A(i::=u)))"
      by (metis All2I(1) t eval_fm_All2_Iff_elts less(5))
    thus "{} \<turnstile> \<alpha>" using less.prems All2I t
      apply (auto del: Neg_I intro!: prove_elts_imp_prove_All2 less.IH)
      apply (auto intro: subst_fm_in_se_fm ground_subst_fm elts_imp_ground)
      done
  qed
qed

lemma se_fm_imp_thm: "\<lbrakk>se_fm A; ground_fm A; eval_fm e A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
  by (metis ground_se_fm_induction lessI)

text\<open>Theorem 2.5\<close>
theorem Sigma_fm_imp_thm: "\<lbrakk>Sigma_fm A; ground_fm A; eval_fm e0 A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
  by (metis Iff_MP2_same ss_imp_se_fm empty_iff Sigma_fm_def eval_fm_Iff ground_fm_aux_def
            hfthm_sound se_fm_imp_thm subset_empty)

end


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

section \<open>A Proof of Higman's Lemma via Open Induction\<close>

theory Higman_OI
imports
  Open_Induction.Open_Induction
  Minimal_Elements
  Almost_Full
begin

subsection \<open>Some facts about the suffix relation\<close>

lemma wfp_on_strict_suffix:
  "wfp_on strict_suffix A"
by (rule wfp_on_mono [OF subset_refl, of _ _ "measure_on length A"])
   (auto simp: strict_suffix_def suffix_def)

lemma po_on_strict_suffix:
  "po_on strict_suffix A"
by (force simp: strict_suffix_def po_on_def transp_on_def irreflp_on_def)

subsection \<open>Lexicographic Order on Infinite Sequences\<close>

lemma antisymp_on_LEX:
  assumes "irreflp_on P A" and "antisymp_on P A"
  shows "antisymp_on (LEX P) (SEQ A)"
proof
  fix f g assume SEQ: "f \<in> SEQ A" "g \<in> SEQ A" and "LEX P f g" and "LEX P g f"
  then obtain i j where "P (f i) (g i)" and "P (g j) (f j)"
    and "\<forall>k<i. f k = g k" and "\<forall>k<j. g k = f k" by (auto simp: LEX_def)
  then have "P (f (min i j)) (f (min i j))"
    using assms(2) and SEQ by (cases "i = j") (auto simp: antisymp_on_def min_def, force)
  with assms(1) and SEQ show  "f = g" by (auto simp: irreflp_on_def)
qed

lemma LEX_trans:
  assumes "transp_on P A" and "f \<in> SEQ A" and "g \<in> SEQ A" and "h \<in> SEQ A"
    and "LEX P f g" and "LEX P g h"
  shows "LEX P f h"
using assms by (auto simp: LEX_def transp_on_def) (metis less_trans linorder_neqE_nat)

lemma qo_on_LEXEQ:
  "transp_on P A \<Longrightarrow> qo_on (LEXEQ P) (SEQ A)"
by (auto simp: qo_on_def reflp_on_def transp_on_def [of "LEXEQ P"] dest: LEX_trans)

context minimal_element
begin

lemma glb_LEX_lexmin:
  assumes "chain_on (LEX P) C (SEQ A)" and "C \<noteq> {}"
  shows "glb (LEX P) C (lexmin C)"
proof
  have "C \<subseteq> SEQ A" using assms by (auto simp: chain_on_def)
  then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
  note * = \<open>C \<subseteq> SEQ A\<close> \<open>C \<noteq> {}\<close>
  note lex = LEX_imp_less [folded irreflp_on_def, OF po [THEN po_on_imp_irreflp_on]]
  \<comment> \<open>\<open>lexmin C\<close> is a lower bound\<close>
  show "lb (LEX P) C (lexmin C)"
  proof
    fix f assume "f \<in> C"
    then show "LEXEQ P (lexmin C) f"
    proof (cases "f = lexmin C")
      define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
      case False
      then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
      from LeastI_ex [OF this, folded i_def]
        and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
      have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
      then have **: "f \<in> eq_upto C (lexmin C) i" "f i \<in> ith (eq_upto C (lexmin C) i) i"
        using \<open>f \<in> C\<close> by force+
      moreover from ** have "\<not> P (f i) (lexmin C i)"
        using lexmin_minimal [OF *, of "f i" i] and \<open>f \<in> C\<close> and \<open>C \<subseteq> SEQ A\<close> by blast
      moreover obtain g where "g \<in> eq_upto C (lexmin C) (Suc i)"
        using eq_upto_lexmin_non_empty [OF *] by blast
      ultimately have "P (lexmin C i) (f i)"
        using neq and \<open>C \<subseteq> SEQ A\<close> and assms(1) and lex [of g f i] and lex [of f g i]
        by (auto simp: eq_upto_def chain_on_def)
      with eq show ?thesis by (auto simp: LEX_def)
    qed simp
  qed

  \<comment> \<open>\<open>lexmin C\<close> is greater than or equal to any other lower bound\<close>
  fix f assume lb: "lb (LEX P) C f"
  then show "LEXEQ P f (lexmin C)"
  proof (cases "f = lexmin C")
    define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
    case False
    then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
    from LeastI_ex [OF this, folded i_def]
      and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
    have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
    obtain h where "h \<in> eq_upto C (lexmin C) (Suc i)" and "h \<in> C"
      using eq_upto_lexmin_non_empty [OF *] by (auto simp: eq_upto_def)
    then have [simp]: "\<And>j. j < Suc i \<Longrightarrow> h j = lexmin C j" by auto
    with lb and \<open>h \<in> C\<close> have "LEX P f h" using neq by (auto simp: lb_def)
    then have "P (f i) (h i)"
      using neq and eq and \<open>C \<subseteq> SEQ A\<close> and \<open>h \<in> C\<close> by (intro lex) auto
    with eq show ?thesis by (auto simp: LEX_def)
  qed simp
qed

lemma dc_on_LEXEQ:
  "dc_on (LEXEQ P) (SEQ A)"
proof
  fix C assume "chain_on (LEXEQ P) C (SEQ A)" and "C \<noteq> {}"
  then have chain: "chain_on (LEX P) C (SEQ A)" by (auto simp: chain_on_def)
  then have "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
  then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
  have "glb (LEX P) C (lexmin C)" by (rule glb_LEX_lexmin [OF chain \<open>C \<noteq> {}\<close>])
  then have "glb (LEXEQ P) C (lexmin C)" by (auto simp: glb_def lb_def)
  with \<open>lexmin C \<in> SEQ A\<close> show "\<exists>f \<in> SEQ A. glb (LEXEQ P) C f" by blast
qed

end

text \<open>
  Properties that only depend on finite initial segments of a sequence
  (i.e., which are open with respect to the product topology).
\<close>
definition "pt_open_on Q A \<longleftrightarrow> (\<forall>f\<in>A. Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g)))"

lemma pt_open_onD:
  "pt_open_on Q A \<Longrightarrow> Q f \<Longrightarrow> f \<in> A \<Longrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
  unfolding pt_open_on_def by blast

lemma pt_open_on_good:
  "pt_open_on (good Q) (SEQ A)"
proof (unfold pt_open_on_def, intro ballI)
  fix f assume f: "f \<in> SEQ A"
  show "good Q f = (\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g)"
  proof
    assume "good Q f"
    then obtain i and j where *: "i < j" "Q (f i) (f j)" by auto
    have "\<forall>g\<in>SEQ A. (\<forall>i<Suc j. g i = f i) \<longrightarrow> good Q g"
    proof (intro ballI impI)
      fix g assume "g \<in> SEQ A" and "\<forall>i<Suc j. g i = f i"
      then show "good Q g" using * by (force simp: good_def)
    qed
    then show "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g" ..
  next
    assume "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g"
    with f show "good Q f" by blast
  qed
qed

context minimal_element
begin

lemma pt_open_on_imp_open_on_LEXEQ:
  assumes "pt_open_on Q (SEQ A)"
  shows "open_on (LEXEQ P) Q (SEQ A)"
proof
  fix C assume chain: "chain_on (LEXEQ P) C (SEQ A)" and ne: "C \<noteq> {}"
    and "\<exists>g\<in>SEQ A. glb (LEXEQ P) C g \<and> Q g"
  then obtain g where g: "g \<in> SEQ A" and "glb (LEXEQ P) C g"
    and Q: "Q g" by blast
  then have glb: "glb (LEX P) C g" by (auto simp: glb_def lb_def)
  from chain have "chain_on (LEX P) C (SEQ A)" and C: "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
  note * = glb_LEX_lexmin [OF this(1) ne]
  have "lexmin C \<in> SEQ A" using ne and C by (intro lexmin_SEQ_mem)
  from glb_unique [OF _ g this glb *]
    and antisymp_on_LEX [OF po_on_imp_irreflp_on [OF po] po_on_imp_antisymp_on [OF po]]
  have [simp]: "lexmin C = g" by auto
  from assms [THEN pt_open_onD, OF Q g]
  obtain n :: nat where **: "\<And>h. h \<in> SEQ A \<Longrightarrow> (\<forall>i<n. h i = g i) \<longrightarrow> Q h" by blast
  from eq_upto_lexmin_non_empty [OF C ne, of n]
  obtain f where "f \<in> eq_upto C g n" by auto
  then have "f \<in> C" and "Q f" using ** [of f] and C by force+
  then show "\<exists>f\<in>C. Q f" by blast
qed

lemma open_on_good:
  "open_on (LEXEQ P) (good Q) (SEQ A)"
  by (intro pt_open_on_imp_open_on_LEXEQ pt_open_on_good)

end

lemma open_on_LEXEQ_imp_pt_open_on_counterexample:
  fixes a b :: "'a"
  defines "A \<equiv> {a, b}" and "P \<equiv> (\<lambda>x y. False)" and "Q \<equiv> (\<lambda>f. \<forall>i. f i = b)"
  assumes [simp]: "a \<noteq> b"
  shows "minimal_element P A" and "open_on (LEXEQ P) Q (SEQ A)"
    and "\<not> pt_open_on Q (SEQ A)"
proof -
  show "minimal_element P A"
    by standard (auto simp: P_def po_on_def irreflp_on_def transp_on_def wfp_on_def)
  show "open_on (LEXEQ P) Q (SEQ A)"
    by (auto simp: P_def open_on_def chain_on_def SEQ_def glb_def lb_def LEX_def)
  show "\<not> pt_open_on Q (SEQ A)"
  proof
    define f :: "nat \<Rightarrow> 'a" where "f \<equiv> (\<lambda>x. b)"
    have "f \<in> SEQ A" by (auto simp: A_def f_def)
    moreover assume "pt_open_on Q (SEQ A)"
    ultimately have "Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
      unfolding pt_open_on_def by blast
    moreover have "Q f" by (auto simp: Q_def f_def)
    moreover have "\<exists>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<and> \<not> Q g" for n
      by (intro bexI [of _ "f(n := a)"]) (auto simp: f_def Q_def A_def)
    ultimately show False by blast
  qed
qed

lemma higman:
  assumes "almost_full_on P A"
  shows "almost_full_on (list_emb P) (lists A)"
proof
  interpret minimal_element strict_suffix "lists A"
    by (unfold_locales) (intro po_on_strict_suffix wfp_on_strict_suffix)+
  fix f presume "f \<in> SEQ (lists A)"
  with qo_on_LEXEQ [OF po_on_imp_transp_on [OF po_on_strict_suffix]] and dc_on_LEXEQ and open_on_good
    show "good (list_emb P) f"
  proof (induct rule: open_induct_on)
    case (less f)
    define h where "h i = hd (f i)" for i
    show ?case
    proof (cases "\<exists>i. f i = []")
      case False
      then have ne: "\<forall>i. f i \<noteq> []" by auto
      with \<open>f \<in> SEQ (lists A)\<close> have "\<forall>i. h i \<in> A" by (auto simp: h_def ne_lists)
      from almost_full_on_imp_homogeneous_subseq [OF assms this]
      obtain \<phi> :: "nat \<Rightarrow> nat" where mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
        and P: "\<And>i j. i < j \<Longrightarrow> P (h (\<phi> i)) (h (\<phi> j))" by blast
      define f' where "f' i = (if i < \<phi> 0 then f i else tl (f (\<phi> (i - \<phi> 0))))" for i
      have f': "f' \<in> SEQ (lists A)" using ne and \<open>f \<in> SEQ (lists A)\<close>
        by (auto simp: f'_def dest: list.set_sel)
      have [simp]: "\<And>i. \<phi> 0 \<le> i \<Longrightarrow> h (\<phi> (i - \<phi> 0)) # f' i = f (\<phi> (i - \<phi> 0))"
        "\<And>i. i < \<phi> 0 \<Longrightarrow> f' i = f i" using ne by (auto simp: f'_def h_def)
      moreover have "strict_suffix (f' (\<phi> 0)) (f (\<phi> 0))" using ne by (auto simp: f'_def)
      ultimately have "LEX strict_suffix f' f" by (auto simp: LEX_def)
      with LEX_imp_not_LEX [OF this] have "strict (LEXEQ strict_suffix) f' f"
        using po_on_strict_suffix [of UNIV] unfolding po_on_def irreflp_on_def transp_on_def by blast
      from less(2) [OF f' this] have "good (list_emb P) f'" .
      then obtain i j where "i < j" and emb: "list_emb P (f' i) (f' j)" by (auto simp: good_def)
      consider "j < \<phi> 0" | "\<phi> 0 \<le> i" | "i < \<phi> 0" and "\<phi> 0 \<le> j" by arith
      then show ?thesis
      proof (cases)
        case 1 with \<open>i < j\<close> and emb show ?thesis by (auto simp: good_def)
      next
        case 2
        with \<open>i < j\<close> and P have "P (h (\<phi> (i - \<phi> 0))) (h (\<phi> (j - \<phi> 0)))" by auto
        with emb have "list_emb P (h (\<phi> (i - \<phi> 0)) # f' i) (h (\<phi> (j - \<phi> 0)) # f' j)" by auto
        then have "list_emb P (f (\<phi> (i - \<phi> 0))) (f (\<phi> (j - \<phi> 0)))" using 2 and \<open>i < j\<close> by auto
        moreover with 2 and \<open>i <j\<close> have "\<phi> (i - \<phi> 0) < \<phi> (j - \<phi> 0)" using mono by auto
        ultimately show ?thesis by (auto simp: good_def)
      next
        case 3
        with emb have "list_emb P (f i) (f' j)" by auto
        moreover have "f (\<phi> (j - \<phi> 0)) = h (\<phi> (j - \<phi> 0)) # f' j" using 3 by auto
        ultimately have "list_emb P (f i) (f (\<phi> (j - \<phi> 0)))" by auto
        moreover have "i < \<phi> (j - \<phi> 0)" using mono [of 0 "j - \<phi> 0"] and 3 by force
        ultimately show ?thesis by (auto simp: good_def)
      qed
    qed auto
  qed
qed blast

end