(*
    File:        FinBnd.thy
    Time-stamp:  <2015-12-16T10:57:10Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory FinBnd imports MonoInj begin

definition FinExt :: "[i,i=>i,i]=>i" where
"FinExt(D, h, X) == {0} Un {x: Pow(D). EX z: X. x <= h(z)}"

definition fin_bnd :: "[i, i=>i]=>o" where
"fin_bnd(x, h) == EX n: nat. x <= nat_rec(n, 0, %n r. h(r))"

definition fin_bnd_set :: "[i, i=>i]=>i" where
"fin_bnd_set(D, h) == {x: Pow(D). fin_bnd(x, h)}"

definition bnd_cont :: "[i, i=>i]=>o" where
    "bnd_cont(D, h) ==   h(D) <= D &
                       (ALL X:Pow(Pow(D)). X ~= 0 -->
                                 h(Union(X)) = (UN x: X. h(x)))"

(** bnd_cont(D, h) : h is bound by D and is continuous **)
lemma bnd_contI:
  "[| !!X. [| X <= Pow(D); X ~= 0 |] ==> h(Union(X)) = (UN x: X. h(x));
      h(D) <= D |] ==> bnd_cont(D, h)"
apply (unfold bnd_cont_def)
apply blast
done

lemma bnd_contD1:
    "bnd_cont(D, h) ==> h(D) <= D"
apply (unfold bnd_cont_def)
apply blast
done

lemma bnd_contD2:
    "[| bnd_cont(D, h); X <= Pow(D); X ~= 0 |] ==>
          h(Union(X)) = (UN x: X. h(x))"
apply (unfold bnd_cont_def)
apply blast
done

lemma bnd_cont_upair:
  "[| bnd_cont(D, h); X <= D; Y <= D |] ==> h(X Un Y) = h(X) Un h(Y)"
apply (unfold Un_def)
apply (erule bnd_contD2 [THEN ssubst])
apply (rule subsetI)
apply (rule PowI)
apply (erule UpairE)
apply simp
apply simp
apply (rule not_emptyI)
apply (rule UpairI1)
apply (rule equalityI)
apply (rule Union_mono)
apply (rule subsetI)
apply (erule RepFunE)
apply (erule UpairE)
apply simp
apply simp
apply (rule Union_mono)
apply (rule subsetI)
apply (erule UpairE)
apply hypsubst
apply (rule RepFunI)
apply (rule UpairI1)
apply hypsubst
apply (rule RepFunI)
apply (rule UpairI2)
done

lemma bnd_cont_bnd_mono:
    "bnd_cont(D, h) ==> bnd_mono(D,h)"
apply (rule bnd_monoI)
apply (erule bnd_contD1)
apply (erule_tac P="%x. h(W) <= h(x)" in subset_Un_iff [THEN iffD1, THEN subst])
apply (erule_tac P="%x. h(W) <= x" in bnd_cont_upair [THEN ssubst])
apply (assumption | (rule Un_upper1))+
done

(** fin_bnd(x, h) : x is finitely bound by h **)
lemma fin_bnd_0:
  "fin_bnd(0, h)"
apply (unfold fin_bnd_def)
apply blast
done

lemma fin_bnd_induct:
  assumes major: "fin_bnd(a, h)"
  and P_0: "P(0)"
  and indstep: "!! x y. [| fin_bnd(x,h); y <= h(x); P(x)|]  ==> P(y)"
  shows "P(a)"
apply (rule major [unfolded fin_bnd_def, THEN bexE])
apply (erule_tac P="a <= nat_rec(x, 0, % n r. h(r))" in rev_mp)
apply (rule allE)
prefer 2 apply assumption
apply (erule nat_induct)
apply (rule allI)
apply (rule nat_rec_0 [THEN ssubst])
apply (rule impI)
apply (drule subset_empty_iff [THEN iffD1])
apply (erule ssubst)
apply (rule P_0)
apply (rule allI)
apply (rule nat_rec_succ [THEN ssubst])
apply assumption
apply (rule impI)
apply (rule indstep [unfolded fin_bnd_def])
prefer 2 apply assumption
apply (rule bexI)
apply (rule subset_refl)
apply assumption
apply (erule allE)
apply (erule mp)
apply (rule subset_refl)
done

lemma fin_bnd_lemma1:
  "[| bnd_mono(D, h); n: nat |] ==> nat_rec(n, 0, %n r. h(r)) <= D"
apply (erule nat_induct)
apply (rule nat_rec_0 [THEN ssubst])
apply (rule empty_subsetI)
apply (erule nat_rec_succ [THEN ssubst])
apply (erule bnd_mono_subset)
apply assumption
done

lemma fin_bnd_lemma2:
  assumes hmono: "bnd_mono(D, h)"
  shows "n: nat ==>
    nat_rec(n, 0, %l r. h(r)) <= nat_rec(succ(n), 0, %l r. h(r))"
apply (erule nat_induct)
apply (rule nat_rec_0 [THEN ssubst])
apply (rule empty_subsetI)
apply (simp only: nat_rec_succ)
apply (rule hmono [THEN bnd_monoD2])
apply assumption
apply (rule hmono [THEN bnd_mono_subset])
apply (rule hmono [THEN fin_bnd_lemma1])
apply assumption
done

lemma fin_bnd_lemma3 [rule_format]:
 assumes hmono: "bnd_mono(D,h)"
 shows "ALL m: nat. ALL n: nat. n le m -->
        nat_rec(n, 0, %l r. h(r)) <= nat_rec(m, 0, %l r. h(r))"
apply (rule ballI)
apply (erule nat_induct)
apply (intro impI ballI)
apply (drule le_imp_subset)
apply (drule subset_empty_iff [THEN iffD1])
apply hypsubst
apply (rule subset_refl)
apply (intro impI ballI)
apply (drule le_succ_iff [THEN iffD1])
apply (erule disjE)
apply (rule hmono [THEN fin_bnd_lemma2, THEN [2] subset_trans])
prefer 2 apply assumption
apply (erule ballE)
apply (erule mp)
apply assumption
apply (erule notE)
apply assumption
apply (erule conjE)
apply hypsubst
apply (rule subset_refl)
done

lemma fin_bnd_domain:
    "[| bnd_mono(D, h); fin_bnd(x, h) |] ==> x <= D"
apply (unfold fin_bnd_def)
apply (erule bexE)
apply (erule subset_trans)
apply (erule fin_bnd_lemma1)
apply assumption
done

lemma fin_bnd_succ:
  "[| bnd_mono(D,h); fin_bnd(x, h); y <= h(x) |] ==> fin_bnd(y, h)"
apply (unfold fin_bnd_def)
apply (erule bexE)
apply (rule bexI)
apply (rule nat_rec_succ [THEN ssubst])
apply assumption
apply (erule subset_trans)
apply (rule_tac h="h" in bnd_monoD2)
apply (assumption | (rule nat_succI fin_bnd_lemma1))+
done

lemma fin_bnd_subset:
  "[| bnd_mono(D, h); fin_bnd(x, h); y <= x |] ==> fin_bnd(y, h)"
apply (unfold fin_bnd_def)
apply (elim bexE)
apply (rule bexI)
apply (erule subset_trans)
apply assumption+
done

lemma fin_bnd_Un:
    assumes hmono: "bnd_mono(D, h)"
    shows "[| fin_bnd(x, h); fin_bnd(y, h) |] ==>
                fin_bnd(x Un y, h)"
apply (unfold fin_bnd_def)
apply (elim bexE)
apply (rename_tac m)
apply (rule_tac i="n" and j="m" in Ord_linear_le)
apply (erule nat_into_Ord)+
apply (rule bexI)
apply (rule Un_least)
apply (erule subset_trans)
apply (erule_tac [2] subset_trans)
apply (rule hmono [THEN fin_bnd_lemma3])
prefer 3 apply assumption
apply (rule_tac [3] hmono [THEN fin_bnd_lemma3])
apply (assumption | (rule le_refl) | (erule nat_into_Ord))+
apply (rule bexI)
apply (rule Un_least)
apply (erule subset_trans)
apply (erule_tac [2] subset_trans)
apply (rule hmono [THEN fin_bnd_lemma3])
apply (rule_tac [4] hmono [THEN fin_bnd_lemma3])
prefer 6 apply assumption
apply (assumption | (rule le_refl) | (erule nat_into_Ord))+
done

lemma fin_bnd_bound:
  assumes hmono: "bnd_mono(D, h)"
  and fb_a: "fin_bnd(a, h)"
  and fb_z: "!!z. [| a <= h(z); z <= D; fin_bnd(h(z), h) |] ==> P"
  shows "P"
apply (rule fb_a [unfolded fin_bnd_def, THEN bexE])
apply (rule fb_z [unfolded fin_bnd_def])
apply (erule subset_trans)
apply (rule hmono [THEN fin_bnd_lemma2, THEN subset_trans])
apply assumption
apply (simp only: nat_rec_succ)
apply (rule subset_refl)
apply (rule hmono [THEN fin_bnd_lemma1])
apply assumption
apply (rule_tac x="succ(x)" in bexI)
apply (simp only: nat_rec_succ)
apply (rule subset_refl)
apply (rule nat_succI)
apply assumption
done

lemma fin_bnd_bound2:
  assumes hmono: "bnd_mono(D, h)"
  and fb_a: "fin_bnd(a, h)"
  and fb_z: "!!z. [| a <= z; z <= h(z); z <= D;
               fin_bnd(z, h); fin_bnd(h(z), h) |] ==> P"
  shows "P"
apply (rule fb_a [unfolded fin_bnd_def, THEN bexE])
apply (rule fb_z [unfolded fin_bnd_def])
apply (rule_tac [2]  hmono [THEN fin_bnd_lemma2, THEN subset_trans])
prefer 2 apply assumption
prefer 2 apply (simp only: nat_rec_succ)
apply (rule subset_refl)
apply assumption
apply (rule hmono [THEN fin_bnd_lemma1])
apply assumption
apply (rule_tac x="x" in bexI)
apply (rule subset_refl)
apply assumption
apply (rule_tac x="succ(x)" in bexI)
apply (simp only: nat_rec_succ)
apply (rule subset_refl)
apply (rule nat_succI)
apply assumption
done

(** FinExt(D, h) : the finite extension of h **)
lemma FinExt_bnd_cont:
    "bnd_cont(Pow(D), FinExt(D,h))"
apply (rule bnd_contI)
apply (unfold FinExt_def)
prefer 2 apply blast
apply (rule equalityI)
apply (rule subsetI)
apply (rule_tac [2] subsetI)
apply (erule UnE)
apply (erule not_emptyE)
apply blast
apply (erule CollectE)
apply (erule bexE)
apply (erule UnionE)
apply (erule UN_I)
apply (rule UnI2)
apply (erule CollectI)
apply (erule bexI)
apply assumption
apply (erule UN_E)
apply (erule UnE)
apply (erule UnI1)
apply (rule UnI2)
apply (erule CollectE)
apply (erule bexE)
apply (erule CollectI)
apply (erule bexI)
apply (erule UnionI)
apply assumption
done

lemma FinExt_bnd_mono:
  "bnd_mono(Pow(D), FinExt(D,h))"
apply (rule FinExt_bnd_cont [THEN bnd_cont_bnd_mono])
done

lemma FinExt_lower_Pow_lfp:
  assumes hmono: "bnd_mono(D,h)"
  shows "FinExt(D, h, Pow(lfp(D,h))) <= Pow(lfp(D,h))"
apply (unfold FinExt_def)
apply (rule Un_subset_iff [THEN iffD2])
apply (rule conjI)
apply blast
apply (rule subsetI)
apply (erule CollectE)
apply (erule bexE)
apply ((drule PowD) | (rule PowI))+
apply (erule subset_trans)
apply (rule hmono [THEN lfp_lemma2, THEN [2] subset_trans])
apply (erule hmono [THEN bnd_monoD2])
apply (rule lfp_subset)
done

lemma FinExt_another_def:
  assumes hmono: "bnd_mono(D,h)"
  and dom_X: "X <= Pow(D)"
  shows "FinExt(D, h, X) = {0} Un (UN z: X. Pow(h(z)))"
apply (unfold FinExt_def)
apply (rule equalityI)
apply (rule_tac [2] subset_refl [THEN Un_mono])
apply (rule_tac [1] subset_refl [THEN Un_mono])
apply (rule_tac [2] subsetI)
apply (rule subsetI)
apply (elim CollectE bexE)
apply (erule UN_I)
apply (erule PowI)
apply (erule UN_E)
apply (rule CollectI)
apply (drule dom_X [THEN subsetD])
apply (drule_tac [2] PowD)
apply (drule PowD)+
apply (rule PowI)
apply (erule subset_trans)
apply (erule hmono [THEN bnd_mono_subset])
apply (erule bexI)
apply assumption
done

(** fin_bnd_set and FinExt **)
lemma fin_bnd_set_domain:
    "fin_bnd_set(D, h) <= Pow(D)"
apply (unfold fin_bnd_set_def)
apply (rule Collect_subset)
done

lemma fin_bnd_set_0I:
    "0: fin_bnd_set(D, h)"
apply (unfold fin_bnd_set_def)
apply (rule CollectI)
apply (rule empty_subsetI [THEN PowI])
apply (rule fin_bnd_0)
done

lemma fin_bnd_setI:
  "[| a <= D; fin_bnd(a, h) |] ==> a: fin_bnd_set(D, h)"
apply (unfold fin_bnd_set_def)
apply (erule PowI [THEN CollectI])
apply assumption
done

lemma fin_bnd_setI2:
  "[| bnd_mono(D, h); fin_bnd(a, h) |] ==> a: fin_bnd_set(D, h)"
apply (unfold fin_bnd_set_def)
apply (rule fin_bnd_domain [THEN PowI, THEN CollectI])
apply assumption+
done

lemma fin_bnd_setD1:
    "a: fin_bnd_set(D, h) ==> a <= D"
apply (unfold fin_bnd_set_def)
apply blast
done

lemma fin_bnd_setD2:
    "a: fin_bnd_set(D, h) ==> fin_bnd(a, h)"
apply (unfold fin_bnd_set_def)
apply blast
done

lemma fin_bnd_setE:
    "[| a: fin_bnd_set(D, h);
        [| a <= D; fin_bnd(a, h)|] ==> P |] ==> P"
apply (unfold fin_bnd_set_def)
apply blast
done

lemma fin_bnd_set_subset_lfp_FinExt:
  assumes hmono: "bnd_mono(D,h)"
  shows "fin_bnd_set(D, h) <= lfp(Pow(D), FinExt(D, h))"
apply (unfold fin_bnd_set_def)
apply (rule subsetI)
apply (erule CollectE)
apply (erule fin_bnd_induct)
apply (rule FinExt_bnd_mono [THEN lfp_lemma2, THEN subsetD])
apply (subst hmono [THEN FinExt_another_def])
apply (rule lfp_subset)
apply (rule UnI1)
apply (rule singletonI)
apply (rule FinExt_bnd_mono [THEN lfp_lemma2, THEN subsetD])
apply (subst hmono [THEN FinExt_another_def])
apply (rule lfp_subset)
apply (rule UnI2)
apply (rule UN_I)
apply (rule_tac [2] PowI)
prefer 2 apply assumption
apply assumption
done

lemma fin_bnd_set_pre_fixedpt:
  assumes hmono: "bnd_mono(D, h)"
  shows "FinExt(D, h, fin_bnd_set(D, h)) <= fin_bnd_set(D, h)"
apply (unfold fin_bnd_set_def)
apply (rule Collect_subset
       [THEN hmono
            [THEN FinExt_another_def, THEN ssubst]])
apply (rule subsetI)
apply (erule UnE)
apply (erule singletonE)
apply hypsubst
apply (rule CollectI)
apply (rule empty_subsetI [THEN PowI])
apply (rule fin_bnd_0)
apply (erule UN_E)
apply (erule CollectE)
apply (rule CollectI)
apply (drule PowD)+
apply (rule PowI)
apply (rule hmono [THEN bnd_monoD1, THEN [2] subset_trans])
apply (erule subset_trans)
apply (erule hmono [THEN bnd_monoD2])
apply (rule subset_refl)
apply (drule PowD)+
apply (erule hmono [THEN fin_bnd_succ])
apply assumption
done

lemma fin_bnd_set_lfp_eq:
  assumes hmono: "bnd_mono(D, h)"
  shows "fin_bnd_set(D, h) = lfp(Pow(D), FinExt(D, h))"
apply (rule equalityI)
apply (rule hmono [THEN fin_bnd_set_subset_lfp_FinExt])
apply (rule lfp_lowerbound)
apply (rule hmono [THEN fin_bnd_set_pre_fixedpt])
apply (rule fin_bnd_set_domain)
done

lemma fin_bnd_set_Pow_lfp_lowerbound:
  assumes hmono: "bnd_mono(D,h)"
  shows "fin_bnd_set(D, h) <= Pow(lfp(D,h))"
apply (unfold fin_bnd_set_def)
apply (rule subsetI)
apply (erule CollectE)
apply (rule PowI)
apply (drule PowD)
apply (erule fin_bnd_induct)
apply (rule empty_subsetI)
apply (rule hmono [THEN lfp_lemma2, THEN [2] subset_trans])
apply (erule subset_trans)
apply (erule hmono [THEN bnd_monoD2])
apply (rule lfp_subset)
done

lemma Union_fin_bnd_set_pre_fixedpt:
  assumes hcont: "bnd_cont(D, h)"
  shows "h(Union(fin_bnd_set(D, h))) <= Union(fin_bnd_set(D, h))"
apply (rule_tac P="%y. y <= Union(fin_bnd_set(D,h))" in
        hcont [THEN bnd_contD2, THEN ssubst])
apply (rule_tac [2] not_emptyI)
apply (rule_tac [2] fin_bnd_set_0I)
apply (unfold fin_bnd_set_def)
apply (rule Collect_subset)
apply (rule subsetI)
apply (erule UN_E)
apply (erule CollectE)
apply (rule UnionI)
apply (rule CollectI)
prefer 3 apply assumption
apply (drule PowD)
apply (rule PowI)
apply (erule hcont [THEN bnd_cont_bnd_mono, THEN bnd_mono_subset])
apply (erule hcont [THEN bnd_cont_bnd_mono, THEN fin_bnd_succ])
apply (rule subset_refl)
done

lemma Union_fin_bnd_set_lfp_eq:
  assumes hcont: "bnd_cont(D, h)"
  shows "Union(fin_bnd_set(D, h)) = lfp(D, h)"
apply (rule equalityI)
apply (rule_tac P="%x. Union(fin_bnd_set(D, h)) <= x" in
        Union_Pow_eq [THEN subst])
apply (rule hcont [THEN bnd_cont_bnd_mono,
                   THEN fin_bnd_set_Pow_lfp_lowerbound,
                   THEN Union_mono])
apply (rule lfp_lowerbound)
apply (rule hcont [THEN Union_fin_bnd_set_pre_fixedpt])
apply (rule_tac P="%x. Union(fin_bnd_set(D, h)) <= x" in
        Union_Pow_eq [THEN subst])
apply (rule fin_bnd_set_domain [THEN Union_mono])
done

lemma fin_bnd_set_upper_Fin_lfp:
  assumes hcont: "bnd_cont(D, h)"
  shows "Fin(lfp(D, h)) <= fin_bnd_set(D, h)"
apply (rule subsetI)
apply (erule Fin_induct)
apply (rule fin_bnd_set_0I)
apply (rename_tac v y)
apply (drule_tac P="%x. v: x" in
  hcont [THEN Union_fin_bnd_set_lfp_eq, THEN ssubst])
apply (erule UnionE)
apply (unfold fin_bnd_set_def)
apply (elim CollectE)
apply (drule PowD)+
apply (rule CollectI)
apply blast
apply (rule hcont [THEN bnd_cont_bnd_mono, THEN fin_bnd_subset])
apply (rule_tac x="B" and y="y" in
        hcont [THEN bnd_cont_bnd_mono, THEN fin_bnd_Un])
apply assumption+
apply (rule cons_eq [THEN subst])
apply (rule Un_mono)
apply (erule singleton_subsetI)
apply (rule subset_refl)
done

(** Induction principles on finitely bound set **)
lemma fin_bnd_set_Collect_is_pre_fixedpt:
  assumes hinj: "mono_inj_pair(D,F,G)"
  and hinjp: "mono_inj_pair(F(D),Fp, Gp)"
  and FG0: "F(G(0)) = 0"
  and hmono: "bnd_mono(D,h)"
  and indstep: "!!x. x : FinExt(F(D), %x. F(h(G(x))),
                       {x: fin_bnd_set(F(D), %x. F(h(G(x)))).
                        (ALL y: Pow(Fp(F(G(x)))). P(Gp(y)))}) ==> P(x)"
  shows "FinExt(F(D), %x. F(h(G(x))),
                       {x: fin_bnd_set(F(D), %x. F(h(G(x)))).
                        (ALL y: Pow(Fp(F(G(x)))). P(Gp(y)))})
             <= {x: fin_bnd_set(F(D), %x. F(h(G(x)))).
                        (ALL y: Pow(Fp(F(G(x)))). P(Gp(y)))}"
apply (rule subsetI)
apply (rule CollectI)
apply (rule hmono [THEN hinj [THEN mono_inj_pair_bnd_mono],
                   THEN fin_bnd_set_pre_fixedpt [THEN subsetD]])
apply (rule FinExt_bnd_mono [THEN bnd_monoD2, THEN subsetD])
apply (rule_tac [2] fin_bnd_set_domain)
prefer 2 apply assumption
apply (rule Collect_subset)
apply (rule ballI)
apply (drule PowD)
apply (rule indstep)
apply (unfold FinExt_def)
apply (erule UnE)
apply (erule singletonE)
apply hypsubst
apply (rule UnI1)
apply (simp only: FG0)
apply (drule hinjp [THEN mono_inj_pairD3])
apply (rule hinjp [THEN mono_inj_pairD2])
apply (rule empty_subsetI)
apply (rule subset_refl)
apply (subst (asm) hinjp [THEN mono_inj_pairD1])
apply (rule empty_subsetI)
apply (drule subset_empty_iff [THEN iffD1])
apply (erule ssubst)
apply (rule singletonI)
apply (elim CollectE bexE)
apply (subgoal_tac "F(G(x)) <= F(D)" "h(G(z)) <= D")
apply (rule UnI2)
apply (rule CollectI)
apply (rule_tac [2] bexI)
apply (rule_tac [3] CollectI)
apply (rule_tac [4] ballI)
apply (erule_tac [4] bspec)
prefer 4 apply assumption
apply (rule PowI)
apply (drule PowD)
apply (rule subset_trans)
apply (rule hinjp [THEN mono_inj_pairD3])
apply assumption
apply (rule hinjp [THEN mono_inj_pairD2])
apply assumption
apply (rule subset_refl)
apply (subst hinjp [THEN mono_inj_pairD1])
apply assumption
apply (rule subset_trans)
apply (rule hinjp [THEN mono_inj_pairD3])
apply assumption
apply (rule hinjp [THEN mono_inj_pairD2])
apply assumption
apply (rule subset_refl)
apply (subst hinjp [THEN mono_inj_pairD1])
apply assumption
apply (rule subset_trans)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hinj [THEN mono_inj_pairD3])
apply assumption
apply (rule hinj [THEN mono_inj_pairD2])
apply assumption
apply (rule subset_refl)
apply (subst hinj [THEN mono_inj_pairD1])
apply assumption
apply (subst hinj [THEN mono_inj_pairD1])
apply assumption
apply (rule subset_refl)
apply assumption
apply (rule hmono [THEN bnd_mono_subset])
apply (rule_tac P="%x. G(z) <= x" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (erule fin_bnd_set_domain [THEN subsetD, THEN PowD])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule_tac P="%y. G(x) <= y" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (erule PowD)
apply (rule subset_refl)+
done

lemma fin_bnd_set_induct_lemma1:
  assumes hinj: "mono_inj_pair(D,F,G)"
  and hinjp: "mono_inj_pair(F(D),Fp, Gp)"
  and FG0: "F(G(0)) = 0"
  and hmono: "bnd_mono(D,h)"
  and P0: "P(0)"
  and indstep: "!!x. [| x <= F(D); EX z: fin_bnd_set(F(D), %x. F(h(G(x)))).
                  x <= F(h(G(z))) &
                  (ALL y. y <= Fp(F(G(z))) --> P(Gp(y)))
                |] ==> P(x)"
  shows "fin_bnd_set(F(D), %x. F(h(G(x)))) <=
                    {x: fin_bnd_set(F(D), %x. F(h(G(x)))).
                                     ALL y: Pow(Fp(F(G(x)))). P(Gp(y))}"
apply (rule_tac P="%z. z <= {x: fin_bnd_set(F(D), %x. F(h(G(x)))).
                                     ALL y: Pow(Fp(F(G(x)))). P(Gp(y))}"
          in mono_inj_pair_bnd_mono [OF hinj hmono,
                THEN fin_bnd_set_lfp_eq, THEN ssubst])
apply (rule lfp_lowerbound)
apply (rule_tac [2] Collect_subset [THEN subset_trans])
apply (rule_tac [2] fin_bnd_set_domain)
apply (rule fin_bnd_set_Collect_is_pre_fixedpt
          [OF hinj hinjp FG0 hmono])
apply (unfold FinExt_def)
apply (rule indstep)
apply (erule_tac [2] UnE)
apply (erule UnE)
apply blast
prefer 2 apply (erule singletonE)
apply hypsubst
apply (rule_tac x="0" in bexI)
apply (rule conjI)
apply (rule empty_subsetI)
apply (intro allI impI)
apply (rule ssubst)
apply (rule_tac [2] P0)
apply (subst (asm) FG0)
apply (drule hinjp [THEN mono_inj_pairD3])
apply (rule hinjp [THEN mono_inj_pairD2])
apply (rule empty_subsetI)
apply (rule subset_refl)
apply (subst (asm) hinjp [THEN mono_inj_pairD1])
apply (rule empty_subsetI)
apply (erule subset_empty_iff [THEN iffD1])
apply (rule fin_bnd_set_0I)
apply (elim CollectE bexE)
apply (erule PowD)
apply (elim CollectE bexE)
apply blast
done

lemma mono_inj_pair_fin_bnd_set_induct:
  assumes hinj: "mono_inj_pair(D,F,G)"
  and hinjp: "mono_inj_pair(F(D),Fp, Gp)"
  and FG0: "F(G(0)) = 0"
  and hmono: "bnd_mono(D,h)"
  and a_in_fb: "a: fin_bnd_set(F(D), %x. F(h(G(x))))"
  and P0: "P(0)"
  and indstep:
   "!!x. [| x <= F(D); EX z: fin_bnd_set(F(D), %x. F(h(G(x)))).
               x <= F(h(G(z))) &
          (ALL y. y <= Fp(F(G(z))) --> P(Gp(y)))
    |] ==> P(x)"
  shows "P(a)"
apply (rule hinjp [THEN mono_inj_pairD1, THEN subst])
apply (rule a_in_fb [THEN fin_bnd_set_domain [THEN subsetD], THEN PowD])
apply (rule mono_inj_pair_bnd_mono [THEN fin_bnd_bound,
        OF hinj hmono a_in_fb[unfolded fin_bnd_set_def, THEN CollectD2]])
apply (subgoal_tac "h(G(z)) <= D")
prefer 2
apply (rule hmono [THEN bnd_mono_subset])
apply (rule_tac P="%x. G(z) <= x" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (erule hinj [THEN mono_inj_pairD3])
apply (rule subset_refl)
apply (rule fin_bnd_set_induct_lemma1 [OF hinj hinjp FG0 hmono,
        THEN subsetD, THEN CollectD2, THEN bspec])
apply (rule P0)
prefer 2 apply (rule fin_bnd_setI)
prefer 2 apply assumption
apply (rule mono_inj_pair_bnd_mono [OF hinj hmono, THEN bnd_mono_subset])
apply assumption
prefer 2 apply (rule PowI)
apply (rule hinjp [THEN mono_inj_pairD2])
apply (subst hinj [THEN mono_inj_pairD1])
apply assumption+
apply (subst hinj [THEN mono_inj_pairD1])
apply assumption
apply (rule mono_inj_pair_bnd_mono [OF hinj hmono, THEN bnd_mono_subset])
apply assumption
apply (rule indstep)
apply assumption+
done

lemmas fin_bnd_set_induct = mono_inj_pair_fin_bnd_set_induct
  [OF trivial_mono_inj_pair trivial_mono_inj_pair refl, rule_format]

lemma mono_inj_pair_fin_bnd_lemma:
  assumes hinj: "mono_inj_pair(D, F, G)"
  and hmono: "bnd_mono(D, h)"
  and prem: "fin_bnd(z, %x. F(h(G(x))))"
  shows "fin_bnd(F(G(z)), %x. F(h(G(x))))"
apply (rule fin_bnd_bound2 [OF mono_inj_pair_bnd_mono [OF hinj hmono] prem])
apply (rename_tac v)
apply (subgoal_tac "h(G(v)) <= D")
apply (rule mono_inj_pair_bnd_mono [OF hinj hmono, THEN fin_bnd_succ])
apply (rule_tac [2]  hinj [THEN mono_inj_pairD2])
apply (rule_tac [2] P="%x. G(z) <= x" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule_tac [3] hinj [THEN mono_inj_pairD3])
apply (erule_tac [3] subset_trans)
apply (rule_tac [4] hinj [THEN mono_inj_pairD2])
prefer 3 apply assumption
apply (assumption | (rule subset_refl))+
apply (rule hmono [THEN bnd_mono_subset])
apply (rule_tac P="%x. G(v) <= x" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule_tac [2] hinj [THEN mono_inj_pairD3])
apply (assumption | (rule subset_refl))+
done

lemma fin_bnd_set_succI:
  assumes hmono: "bnd_mono(D, h)"
  and major: "Y <= h(X)"
  and prem: "X: fin_bnd_set(D, h)"
  shows "Y: fin_bnd_set(D, h)"
apply (rule hmono [THEN fin_bnd_setI2])
apply (rule fin_bnd_succ [OF hmono prem [THEN fin_bnd_setD2]])
apply (rule major)
done

lemma fin_bnd_set_UnI:
  assumes hmono: "bnd_mono(D, h)"
  and prem1: "X: fin_bnd_set(D,h)"
  and prem2: "Y: fin_bnd_set(D, h)"
  shows "X Un Y: fin_bnd_set(D, h)"
apply (rule hmono [THEN fin_bnd_setI2])
apply (rule hmono [THEN fin_bnd_Un])
apply (rule prem1 [THEN fin_bnd_setD2])
apply (rule prem2 [THEN fin_bnd_setD2])
done

lemma fin_bnd_set_subsetI:
  assumes hmono: "bnd_mono(D, h)"
  and major: "Y <= X"
  and prem: "X: fin_bnd_set(D,h)"
  shows "Y: fin_bnd_set(D, h)"
apply (rule hmono [THEN fin_bnd_setI2])
apply (rule fin_bnd_subset [OF hmono prem [THEN fin_bnd_setD2] major])
done

lemma fin_bnd_set_boundE:
  assumes hmono: "bnd_mono(D, h)"
  and major: "a: fin_bnd_set(D, h)"
  and prem: "!!z. [| a <= z; z <= h(z); z: fin_bnd_set(D, h);
               h(z): fin_bnd_set(D, h) |] ==> P"
  shows "P"
apply (rule fin_bnd_bound2 [OF hmono major [THEN fin_bnd_setD2]])
apply (rule prem)
apply (assumption | (rule hmono [THEN fin_bnd_setI2]))+
done

end


section \<open>Computation of distinguishing traces based on OFSM tables\<close>

text \<open>This theory implements an algorithm for finding minimal length distinguishing
      traces for observable minimal FSMs based on OFSM tables.\<close>

theory Distinguishability
  imports Minimisation HOL.List
begin

subsection \<open>Finding Diverging OFSM Tables\<close>

(* some k such that the class of state q does not change in any OFSM table after the k-th table *)
definition ofsm_table_fixpoint_value :: "('a,'b,'c) fsm \<Rightarrow> nat" where
  "ofsm_table_fixpoint_value M = (SOME k . (\<forall> q . q \<in> states M \<longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k q) \<and> (\<forall> q k' . q \<in> states M \<longrightarrow> k' \<ge> k \<longrightarrow> ofsm_table M (\<lambda>q . states M) k' q = ofsm_table M (\<lambda>q . states M) k q))"

(* find the minimal k such that states q1 and q2 fall in different classes in the k-th table *)
function find_first_distinct_ofsm_table_gt :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
  "find_first_distinct_ofsm_table_gt M q1 q2 k =
      (if q1 \<in> states M \<and> q2 \<in> states M \<and> ((ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2))
        then (if ofsm_table M (\<lambda>q . states M) k q1 \<noteq> ofsm_table M (\<lambda>q . states M) k q2
              then k
              else find_first_distinct_ofsm_table_gt M q1 q2 (Suc k))
        else 0)"
  using prod_cases4 by blast+
termination
proof -
  {
    fix M :: "('a,'b,'c) fsm"
    fix q1 q2 k
    assume "q1 \<in> FSM.states M \<and> q2 \<in> FSM.states M \<and> ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
           "ofsm_table M (\<lambda>q . states M) k q1 = ofsm_table M (\<lambda>q . states M) k q2"
    then have "q1 \<in> FSM.states M" and "q2 \<in> FSM.states M"
          and "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
      by force+

    let ?k = "ofsm_table_fixpoint_value M"
    obtain k' where "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k' q" and "\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> k' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) k' q"
      using ofsm_table_fix_length[of M "(\<lambda>q . states M)"]
      by blast
    then have "(\<forall> q . q \<in> states M \<longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k' q) \<and> (\<forall> q k'' . q \<in> states M \<longrightarrow> k'' \<ge> k' \<longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) k' q)"
      by blast
    then have *:"\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) ?k q"
          and **: "\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> ?k \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) ?k q"
      using some_eq_imp[of "\<lambda> k . (\<forall> q . q \<in> states M \<longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k q) \<and> (\<forall> q k' . q \<in> states M \<longrightarrow> k' \<ge> k \<longrightarrow> ofsm_table M (\<lambda>q . states M) k' q = ofsm_table M (\<lambda>q . states M) k q)" ?k k']
      unfolding ofsm_table_fixpoint_value_def
      by blast+

    have "?k > k"
      using *
            \<open>ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2\<close>
            \<open>ofsm_table M (\<lambda>q . states M) k q1 = ofsm_table M (\<lambda>q . states M) k q2\<close>
            **[OF \<open>q1 \<in> states M\<close>]
            **[OF \<open>q2 \<in> states M\<close>]
      by (metis \<open>q1 \<in> FSM.states M \<and> q2 \<in> FSM.states M \<and> ofsm_table_fix M (\<lambda>q. FSM.states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q. FSM.states M) 0 q2\<close> leI)
    then have "?k - Suc k < ?k - k"
      by simp
  } note t = this

  show ?thesis
    apply (relation "measure (\<lambda> (M, q1, q2, k) . ofsm_table_fixpoint_value M - k)")
      apply auto[1]
    apply (simp del: observable.simps ofsm_table_fix.simps)
    by (erule t)
qed

partial_function (tailrec) find_first_distinct_ofsm_table_no_check :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
  find_first_distinct_ofsm_table_no_check_def[code]:
    "find_first_distinct_ofsm_table_no_check M q1 q2 k =
      (if ofsm_table M (\<lambda>q . states M) k q1 \<noteq> ofsm_table M (\<lambda>q . states M) k q2
          then k
          else find_first_distinct_ofsm_table_no_check M q1 q2 (Suc k))"

(* a version of find_first_distinct_ofsm_table_gt that avoids repeating the same checks in each
  recursive step *)
fun find_first_distinct_ofsm_table_gt' :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
  "find_first_distinct_ofsm_table_gt' M q1 q2 k =
      (if q1 \<in> states M \<and> q2 \<in> states M \<and> ((q2 \<notin> ofsm_table_fix M (\<lambda>q . states M) 0 q1))
        then find_first_distinct_ofsm_table_no_check M q1 q2 k
        else 0)"

lemma find_first_distinct_ofsm_table_gt_code[code] :
  "find_first_distinct_ofsm_table_gt M q1 q2 k = find_first_distinct_ofsm_table_gt' M q1 q2 k"
proof (cases "q1 \<in> states M \<and> q2 \<in> states M \<and> ((ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2))")
  case False
  have "find_first_distinct_ofsm_table_gt M q1 q2 k = 0"
    using False
    by (metis find_first_distinct_ofsm_table_gt.simps)
  moreover have "find_first_distinct_ofsm_table_gt' M q1 q2 k = 0"
  proof (cases "q1 \<in> states M \<and> q2 \<in> states M")
    case True
    then have "q1 \<in> FSM.states M" and "q2 \<in> FSM.states M"
          and "ofsm_table_fix M (\<lambda>q . states M) 0 q1 = ofsm_table_fix M (\<lambda>q . states M) 0 q2"
      using False by force+
    then have "q2 \<in> ofsm_table_fix M (\<lambda>q . states M) 0 q1"
      using ofsm_table_fix_eq_if_elem[of q1 M q2]
      using minimise_initial_partition
      by blast
    then show ?thesis
      by (metis find_first_distinct_ofsm_table_gt'.simps)
  next
    case False
    then show ?thesis by (meson find_first_distinct_ofsm_table_gt'.simps)
  qed
  ultimately show ?thesis
    by simp
next
  case True
  then have "q1 \<in> FSM.states M" and "q2 \<in> FSM.states M"
        and "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
    by force+
  then have "q2 \<notin> ofsm_table_fix M (\<lambda>q . states M) 0 q1"
      using ofsm_table_fix_eq_if_elem[of q1 M q2]
      using minimise_initial_partition
      by blast

  obtain k' where "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k' q" and "\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> k' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) k' q"
    using ofsm_table_fix_length[of M "(\<lambda>q . states M) "]
    by blast

  have f1: "find_first_distinct_ofsm_table_gt M q1 q2 =
              (\<lambda>x. if ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2
                then x
                else find_first_distinct_ofsm_table_gt M q1 q2 (Suc x))"
    using find_first_distinct_ofsm_table_gt.simps[of M q1 q2]
    using True
    by meson

  have f2: "find_first_distinct_ofsm_table_no_check M q1 q2 =
              (\<lambda>x. if ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2
                then x
                else find_first_distinct_ofsm_table_no_check M q1 q2 (Suc x))"
    using True find_first_distinct_ofsm_table_no_check.simps[of M q1 q2]
    by meson

  have "(\<And>x. k' \<le> x \<Longrightarrow> ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2)"
    using \<open>\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> k' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) k' q\<close> \<open>q1 \<in> FSM.states M\<close> \<open>q2 \<in> FSM.states M\<close>
    by (metis True \<open>\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) k' q\<close>)

  have "find_first_distinct_ofsm_table_gt' M q1 q2 k = find_first_distinct_ofsm_table_no_check M q1 q2 k"
    using True \<open>q2 \<notin> ofsm_table_fix M (\<lambda>q . states M) 0 q1\<close> find_first_distinct_ofsm_table_gt'.simps[of M]
    by meson
  then show ?thesis
    using recursion_renaming_helper[OF f1 f2 \<open>(\<And>x. k' \<le> x \<Longrightarrow> ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2)\<close>, of k']
    by simp
qed

lemma find_first_distinct_ofsm_table_gt_is_first_gt :
  assumes "q1 \<in> FSM.states M"
      and "q2 \<in> FSM.states M"
      and "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
shows "ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table_gt M q1 q2 k) q1 \<noteq> ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table_gt M q1 q2 k) q2"
  and "k \<le> k' \<Longrightarrow> k' < (find_first_distinct_ofsm_table_gt M q1 q2 k) \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k' q1 = ofsm_table M (\<lambda>q . states M) k' q2"
proof -

  have f: "find_first_distinct_ofsm_table_gt M q1 q2 =
              (\<lambda>x. if ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2
                then x
                else find_first_distinct_ofsm_table_gt M q1 q2 (Suc x))"
    using assms find_first_distinct_ofsm_table_gt.simps[of M]
    by meson

  obtain kx where "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) kx q" and "\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> kx \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) kx q"
    using ofsm_table_fix_length[of M "(\<lambda>q . states M)"]
    by blast
  have P: "(\<And>x. kx \<le> x \<Longrightarrow> ofsm_table M (\<lambda>q . states M) x q1 \<noteq> ofsm_table M (\<lambda>q . states M) x q2)"
    using \<open>\<And> q k'' . q \<in> states M \<Longrightarrow> k'' \<ge> kx \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k'' q = ofsm_table M (\<lambda>q . states M) kx q\<close> \<open>q1 \<in> FSM.states M\<close> \<open>q2 \<in> FSM.states M\<close>
    by (metis assms \<open>\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M (\<lambda>q . states M) 0 q = ofsm_table M (\<lambda>q . states M) kx q\<close>)

  show "ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table_gt M q1 q2 k) q1 \<noteq> ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table_gt M q1 q2 k) q2"
    using minimal_fixpoint_helper(1)[OF f P, of kx k] .

  show "k \<le> k' \<Longrightarrow> k' < (find_first_distinct_ofsm_table_gt M q1 q2 k) \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k' q1 = ofsm_table M (\<lambda>q . states M) k' q2"
    using minimal_fixpoint_helper(2)[OF f P, of kx k k']
    by auto
qed

abbreviation(input) "find_first_distinct_ofsm_table M q1 q2 \<equiv> find_first_distinct_ofsm_table_gt M q1 q2 0"

lemma find_first_distinct_ofsm_table_is_first :
  assumes "q1 \<in> FSM.states M"
      and "q2 \<in> FSM.states M"
      and "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
shows "ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table M q1 q2) q1 \<noteq> ofsm_table M (\<lambda>q . states M) (find_first_distinct_ofsm_table M q1 q2) q2"
  and "k' < (find_first_distinct_ofsm_table M q1 q2) \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k' q1 = ofsm_table M (\<lambda>q . states M) k' q2"
  using find_first_distinct_ofsm_table_gt_is_first_gt[OF assms, of 0] by blast+

(* find IO pair (x,y) such that q1 and q2 are immediately distinguishable by it or
   the states reached by this IO pair reach from q1 and q2 respectively reach distinct
   classes in the (k-1)-th table *)
fun select_diverging_ofsm_table_io :: "('a,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('b \<times> 'c) \<times> ('a option \<times> 'a option)" where
  "select_diverging_ofsm_table_io M q1 q2 k = (let
      ins = inputs_as_list M;
      outs = outputs_as_list M;
      table = ofsm_table M (\<lambda>q . states M) (k-1);
      f = (\<lambda> (x,y) . case (h_obs M q1 x y, h_obs M q2 x y)
                   of
                      (Some q1', Some q2')  \<Rightarrow> if table q1' \<noteq> table q2'
                                                  then Some ((x,y),(Some q1', Some q2'))
                                                  else None |
                      (None,None)           \<Rightarrow> None |
                      (Some q1', None)      \<Rightarrow> Some ((x,y),(Some q1', None)) |
                      (None, Some q2')      \<Rightarrow> Some ((x,y),(None, Some q2')))
      in
        hd (List.map_filter f (List.product ins outs)))"

lemma select_diverging_ofsm_table_io_Some :
  assumes "observable M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "ofsm_table M (\<lambda>q . states M) (Suc k) q1 \<noteq> ofsm_table M (\<lambda>q . states M) (Suc k) q2"
obtains x y
  where "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
    and "\<And> q1' q2' . h_obs M q1 x y = Some q1' \<Longrightarrow> h_obs M q2 x y = Some q2' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
    and "h_obs M q1 x y \<noteq> None \<or> h_obs M q2 x y \<noteq> None"
proof -

  let ?res = "select_diverging_ofsm_table_io M q1 q2 (Suc k)"

  define f where f: "f = (\<lambda> (x,y) . case (h_obs M q1 x y, h_obs M q2 x y)
                                of
                                  (Some q1', Some q2') \<Rightarrow> if ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'
                                                            then Some ((x,y),(Some q1', Some q2'))
                                                            else None |
                                  (None,None) \<Rightarrow> None |
                                  (Some q1', None) \<Rightarrow> Some ((x,y),(Some q1', None)) |
                                  (None, Some q2') \<Rightarrow> Some ((x,y),(None, Some q2')))"

  have f1: "\<And> x y . f (x,y) \<noteq> None \<Longrightarrow> f (x,y) = Some ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
  proof -
    fix x y assume "f (x,y) \<noteq> None"
    then show "f (x,y) = Some ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
      unfolding f by (cases "h_obs M q1 x y"; cases "h_obs M q2 x y"; auto)
  qed

  have f2 : "\<And> q1' q2' x y . f (x,y) = Some ((x,y),(Some q1', Some q2')) \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
  proof -
    fix q1' q2' x y assume *: "f (x,y) = Some ((x,y),(Some q1', Some q2'))"
    then have **: "f (x,y) = Some ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
      using f1 by auto
    show "ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
      using * ** unfolding f by (cases "h_obs M q1 x y"; cases "h_obs M q2 x y"; auto)
  qed

  have f3: "\<And> x y . f (x,y) \<noteq> None \<Longrightarrow> h_obs M q1 x y \<noteq> None \<or> h_obs M q2 x y \<noteq> None"
  proof -
    fix x y assume "f (x,y) \<noteq> None"
    then show "h_obs M q1 x y \<noteq> None \<or> h_obs M q2 x y \<noteq> None"
      unfolding f by (cases "h_obs M q1 x y"; cases "h_obs M q2 x y"; auto)
  qed

  have *: "select_diverging_ofsm_table_io M q1 q2 (Suc k) = hd (List.map_filter f (List.product (inputs_as_list M) (outputs_as_list M)))"
    unfolding f select_diverging_ofsm_table_io.simps Let_def
    using diff_Suc_1 by presburger

  let ?P = "\<forall> x y . x \<in> inputs M \<longrightarrow> y \<in> outputs M \<longrightarrow> (h_obs M q1 x y = None \<longleftrightarrow> h_obs M q2 x y = None)"
  show ?thesis proof (cases ?P)
    case False
    then obtain x y where "x \<in> inputs M" and "y \<in> outputs M" and "\<not> (h_obs M q1 x y = None \<longleftrightarrow> h_obs M q2 x y = None)"
      by blast
    then consider "h_obs M q1 x y = None \<and> (\<exists> q2' . h_obs M q2 x y = Some q2')" |
                  "h_obs M q2 x y = None \<and> (\<exists> q1' . h_obs M q1 x y = Some q1')"
      by fastforce
    then show ?thesis proof cases
      case 1
      then obtain q2' where "h_obs M q1 x y = None" and "h_obs M q2 x y = Some q2'" by blast
      then have "f (x,y) = Some ((x,y),(None, Some q2'))"
        unfolding f by force
      moreover have "(x,y) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
        using \<open>y \<in> outputs M\<close> outputs_as_list_set[of M]
        using \<open>x \<in> inputs M\<close> inputs_as_list_set[of M]
        using image_iff by fastforce
      ultimately have "(List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M))) \<noteq> []"
        unfolding List.map_filter_def
        by (metis (mono_tags, lifting) Nil_is_map_conv filter_empty_conv option.discI)
      then have **: "?res \<in> set (List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M)))"
        unfolding * using hd_in_set by simp

      obtain xR yR where "(xR,yR) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
                     and res: "f (xR,yR) = Some ?res"
        using map_filter_elem[OF **]
        by (metis prod.exhaust_sel)

      have p1: "?res = ((xR,yR),(h_obs M q1 xR yR, h_obs M q2 xR yR))"
        using res f1
        by (metis option.distinct(1) option.sel)
      then have p2: "\<And> q1' q2' . h_obs M q1 xR yR = Some q1' \<Longrightarrow> h_obs M q2 xR yR = Some q2' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
        using res f1 f2 by auto
      have p3: "h_obs M q1 xR yR \<noteq> None \<or> h_obs M q2 xR yR \<noteq> None"
        using res f3 by blast

      show ?thesis using that p1 p2 p3 by blast
    next
      case 2
      then obtain q1' where "h_obs M q2 x y = None" and "h_obs M q1 x y = Some q1'" by blast
      then have "f (x,y) = Some ((x,y),(Some q1', None))"
        unfolding f by force
      moreover have "(x,y) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
        using \<open>y \<in> outputs M\<close> outputs_as_list_set[of M]
        using \<open>x \<in> inputs M\<close> inputs_as_list_set[of M]
        using image_iff by fastforce
      ultimately have "(List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M))) \<noteq> []"
        unfolding List.map_filter_def
        by (metis (mono_tags, lifting) Nil_is_map_conv filter_empty_conv option.discI)
      then have **: "?res \<in> set (List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M)))"
        unfolding * using hd_in_set by simp

      obtain xR yR where "(xR,yR) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
                     and res: "f (xR,yR) = Some ?res"
        using map_filter_elem[OF **]
        by (metis prod.exhaust_sel)

      have p1: "?res = ((xR,yR),(h_obs M q1 xR yR, h_obs M q2 xR yR))"
        using res f1
        by (metis option.distinct(1) option.sel)
      then have p2: "\<And> q1' q2' . h_obs M q1 xR yR = Some q1' \<Longrightarrow> h_obs M q2 xR yR = Some q2' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
        using res f1 f2 by auto
      have p3: "h_obs M q1 xR yR \<noteq> None \<or> h_obs M q2 xR yR \<noteq> None"
        using res f3 by blast

      show ?thesis using that p1 p2 p3 by blast
    qed
  next
    case True

    obtain io where "length io \<le> Suc k" and "io \<in> LS M q1 \<union> LS M q2" and "io \<notin> LS M q1 \<inter> LS M q2"
      using \<open>ofsm_table M (\<lambda>q . states M) (Suc k) q1 \<noteq> ofsm_table M (\<lambda>q . states M) (Suc k) q2\<close>
      unfolding ofsm_table_set[OF assms(2) minimise_initial_partition] ofsm_table_set[OF assms(3) minimise_initial_partition]
      unfolding is_in_language_iff[OF assms(1,2)] is_in_language_iff[OF assms(1,3)]
      by blast
    then have "io \<noteq> []"
      using assms(2) assms(3) by auto
    then have "io = [hd io] @ tl io"
      by (metis append.left_neutral append_Cons list.exhaust_sel)
    then obtain x y where "hd io = (x,y)"
      by (meson prod.exhaust_sel)

    have "[(x,y)] \<in> LS M q1 \<inter> LS M q2"
    proof -
      have "[(x,y)] \<in> LS M q1 \<union> LS M q2"
        using \<open>io \<in> LS M q1 \<union> LS M q2\<close> language_prefix \<open>hd io = (x,y)\<close> \<open>io = [hd io] @ tl io\<close>
        by (metis Un_iff)
      then have "x \<in> inputs M" and "y \<in> outputs M"
        by auto

      consider "[(x,y)] \<in> LS M q1" | "[(x,y)] \<in> LS M q2"
        using \<open>[(x,y)] \<in> LS M q1 \<union> LS M q2\<close> by blast
      then show ?thesis
      proof cases
        case 1
        then have "h_obs M q1 x y \<noteq> None"
          using h_obs_None[OF \<open>observable M\<close>] unfolding LS_single_transition by auto
        then have "h_obs M q2 x y \<noteq> None"
          using True \<open>x \<in> inputs M\<close> \<open>y \<in> outputs M\<close> by meson
        then show ?thesis
          using 1 h_obs_None[OF \<open>observable M\<close>]
          by (metis IntI LS_single_transition fst_conv snd_conv)
      next
        case 2
        then have "h_obs M q2 x y \<noteq> None"
          using h_obs_None[OF \<open>observable M\<close>] unfolding LS_single_transition by auto
        then have "h_obs M q1 x y \<noteq> None"
          using True \<open>x \<in> inputs M\<close> \<open>y \<in> outputs M\<close> by meson
        then show ?thesis
          using 2 h_obs_None[OF \<open>observable M\<close>]
          by (metis IntI LS_single_transition fst_conv snd_conv)
      qed
    qed
    then obtain q1' q2' where "(q1,x,y,q1') \<in> transitions M"
                          and "(q2,x,y,q2') \<in> transitions M"
      using LS_single_transition by force
    then have "q1' \<in> states M" and "q2' \<in> states M" using fsm_transition_target by auto

    have "tl io \<in> LS M q1' \<union> LS M q2'"
      using observable_language_transition_target[OF \<open>observable M\<close> \<open>(q1,x,y,q1') \<in> transitions M\<close>]
            observable_language_transition_target[OF \<open>observable M\<close> \<open>(q2,x,y,q2') \<in> transitions M\<close>]
            \<open>io \<in> LS M q1 \<union> LS M q2\<close>
      unfolding fst_conv snd_conv
      by (metis Un_iff \<open>hd io = (x, y)\<close> \<open>io = [hd io] @ tl io\<close> append_Cons append_Nil)
    moreover have "tl io \<notin> LS M q1' \<inter> LS M q2'"
      using observable_language_transition_target[OF \<open>observable M\<close> \<open>(q1,x,y,q1') \<in> transitions M\<close>]
            observable_language_transition_target[OF \<open>observable M\<close> \<open>(q2,x,y,q2') \<in> transitions M\<close>]
            \<open>io \<in> LS M q1 \<union> LS M q2\<close>
      unfolding fst_conv snd_conv
      by (metis Int_iff LS_prepend_transition \<open>(q1, x, y, q1') \<in> FSM.transitions M\<close> \<open>(q2, x, y, q2') \<in> FSM.transitions M\<close> \<open>hd io = (x, y)\<close> \<open>io \<noteq> []\<close> \<open>io \<notin> LS M q1 \<inter> LS M q2\<close> fst_conv list.collapse snd_conv)
    moreover have "length (tl io) \<le> k"
      using \<open>length io \<le> Suc k\<close> by auto
    ultimately have "ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
      unfolding ofsm_table_set_observable[OF assms(1) \<open>q1' \<in> states M\<close> minimise_initial_partition]  ofsm_table_set_observable[OF assms(1) \<open>q2' \<in> states M\<close> minimise_initial_partition]
      using \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> after_is_state[OF assms(1)]
      by blast
    moreover have "h_obs M q1 x y = Some q1'"
      using \<open>(q1,x,y,q1') \<in> transitions M\<close> \<open>observable M\<close> unfolding h_obs_Some[OF \<open>observable M\<close>] observable_alt_def by auto
    moreover have "h_obs M q2 x y = Some q2'"
      using \<open>(q2,x,y,q2') \<in> transitions M\<close> \<open>observable M\<close> unfolding h_obs_Some[OF \<open>observable M\<close>] observable_alt_def by auto
    ultimately have "f (x,y) = Some ((x,y),(Some q1', Some q2'))"
      unfolding f by force

    moreover have "(x,y) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
      using fsm_transition_output[OF \<open>(q1,x,y,q1') \<in> transitions M\<close>] outputs_as_list_set[of M]
      using fsm_transition_input[OF \<open>(q1,x,y,q1') \<in> transitions M\<close>] inputs_as_list_set[of M]
      using image_iff by fastforce
    ultimately have "(List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M))) \<noteq> []"
      unfolding List.map_filter_def
      by (metis (mono_tags, lifting) Nil_is_map_conv filter_empty_conv option.discI)
    then have **: "?res \<in> set (List.map_filter f (List.product(inputs_as_list M) (outputs_as_list M)))"
      unfolding * using hd_in_set by simp

    obtain xR yR where "(xR,yR) \<in> set (List.product(inputs_as_list M) (outputs_as_list M))"
                   and res: "f (xR,yR) = Some ?res"
      using map_filter_elem[OF **]
      by (metis prod.exhaust_sel)

    have p1: "?res = ((xR,yR),(h_obs M q1 xR yR, h_obs M q2 xR yR))"
      using res f1
      by (metis option.distinct(1) option.sel)
    then have p2: "\<And> q1' q2' . h_obs M q1 xR yR = Some q1' \<Longrightarrow> h_obs M q2 xR yR = Some q2' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
      using res f1 f2 by auto
    have p3: "h_obs M q1 xR yR \<noteq> None \<or> h_obs M q2 xR yR \<noteq> None"
      using res f3 by blast
    show ?thesis using that p1 p2 p3 by blast
  qed
qed

subsection \<open>Assembling Distinguishing Traces\<close>

(* assembles a distinguishing sequence for q1 and q2 that reside in distinct classes in the
   (k+1)-th table by recursively appending IO pairs that distinguish the current states
   or lead to distinct classes in the next lower table *)
fun assemble_distinguishing_sequence_from_ofsm_table :: "('a,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('b \<times> 'c) list" where
  "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 0 = []" |
  "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = (case
      select_diverging_ofsm_table_io M q1 q2 (Suc k)
    of
      ((x,y),(Some q1',Some q2')) \<Rightarrow> (x,y) # (assemble_distinguishing_sequence_from_ofsm_table M q1' q2' k) |
      ((x,y),_)                   \<Rightarrow> [(x,y)])"

lemma assemble_distinguishing_sequence_from_ofsm_table_distinguishes :
  assumes "observable M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "ofsm_table M (\<lambda>q . states M) k q1 \<noteq> ofsm_table M (\<lambda>q . states M) k q2"
shows "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<in> LS M q1 \<union> LS M q2"
and   "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<notin> LS M q1 \<inter> LS M q2"
and   "butlast (assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k) \<in> LS M q1 \<inter> LS M q2"
proof -
  have "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<in> LS M q1 \<union> LS M q2
        \<and> assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<notin> LS M q1 \<inter> LS M q2
        \<and> butlast (assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k) \<in> LS M q1 \<inter> LS M q2"
    using assms(2,3,4)
  proof (induction k arbitrary: q1 q2)
    case 0
    then show ?case by auto
  next
    case (Suc k)

    obtain x y where s1: "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
                 and s2: "\<And> q1' q2' . h_obs M q1 x y = Some q1' \<Longrightarrow> h_obs M q2 x y = Some q2' \<Longrightarrow> ofsm_table M (\<lambda>q . states M) k q1' \<noteq> ofsm_table M (\<lambda>q . states M) k q2'"
                 and s3: "h_obs M q1 x y \<noteq> None \<or> h_obs M q2 x y \<noteq> None"
      using select_diverging_ofsm_table_io_Some[OF assms(1) Suc.prems]
      by blast

    consider (a) "h_obs M q1 x y = None \<and> h_obs M q2 x y \<noteq> None" |
             (b) "h_obs M q1 x y \<noteq> None \<and> h_obs M q2 x y = None" |
             (c) "h_obs M q1 x y \<noteq> None \<and> h_obs M q2 x y \<noteq> None"
      using s3 by blast
    then show ?case proof cases
      case a
      then obtain q2' where "h_obs M q1 x y = None" and "h_obs M q2 x y = Some q2'"
        by blast
      then have "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(None, Some q2'))"
        using s1 by auto
      then have *:"assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = [(x,y)]"
        by auto

      have "[(x,y)] \<in> LS M q1 \<union> LS M q2"
        using \<open>h_obs M q2 x y = Some q2'\<close> LS_single_transition[of x y M]
        by (metis UnI2 h_obs_None[OF \<open>observable M\<close>] a fst_conv snd_conv)
      moreover have "[(x,y)] \<notin> LS M q1 \<inter> LS M q2"
        using \<open>h_obs M q1 x y = None\<close> LS_single_transition[of x y M]
        unfolding h_obs_None[OF \<open>observable M\<close>] by force
      moreover have "butlast [(x,y)] \<in> LS M q1 \<inter> LS M q2"
        using Suc.prems(1,2) by auto
      ultimately show ?thesis
        unfolding * by simp
    next
      case b
      then obtain q1' where "h_obs M q2 x y = None" and "h_obs M q1 x y = Some q1'"
        by blast
      then have "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(Some q1',None))"
        using s1 by auto
      then have *:"assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = [(x,y)]"
        by auto

      have "[(x,y)] \<in> LS M q1 \<union> LS M q2"
        using \<open>h_obs M q1 x y = Some q1'\<close> LS_single_transition[of x y M]
        by (metis UnI1 assms(1) b fst_conv h_obs_None snd_conv)
      moreover have "[(x,y)] \<notin> LS M q1 \<inter> LS M q2"
        using \<open>h_obs M q2 x y = None\<close> LS_single_transition[of x y M]
        unfolding h_obs_None[OF \<open>observable M\<close>] by force
      moreover have "butlast [(x,y)] \<in> LS M q1 \<inter> LS M q2"
        using Suc.prems(1,2) by auto
      ultimately show ?thesis
        unfolding * by simp
    next
      case c
      then obtain q1' q2' where "h_obs M q1 x y = Some q1'" and "h_obs M q2 x y = Some q2'"
        by blast
      then have "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(Some q1', Some q2'))"
        using s1 by auto
      then have "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = (x,y) # (assemble_distinguishing_sequence_from_ofsm_table M q1' q2' k)"
        by auto
      moreover define subseq where subseq: "subseq = (assemble_distinguishing_sequence_from_ofsm_table M q1' q2' k)"
      ultimately have *:"assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = (x,y) # subseq"
        by auto

      have "(q1,x,y,q1') \<in> transitions M"
        using \<open>h_obs M q1 x y = Some q1'\<close> h_obs_Some[OF \<open>observable M\<close>] by blast
      then have "q1' \<in> states M"
        using fsm_transition_target by auto
      have "(q2,x,y,q2') \<in> transitions M"
        using \<open>h_obs M q2 x y = Some q2'\<close> h_obs_Some[OF \<open>observable M\<close>] by blast
      then have "q2' \<in> states M"
        using fsm_transition_target by auto

      have i1: "subseq \<in> LS M q1' \<union> LS M q2'"
      and  i2: "subseq \<notin> LS M q1' \<inter> LS M q2'"
      and  i3: "butlast subseq \<in> LS M q1' \<inter> LS M q2'"
        using Suc.IH[OF \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> s2[OF \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close>]]
        unfolding subseq by blast+

      have "(x,y) # subseq \<in> LS M q1 \<union> LS M q2"
        using i1 \<open>(q1,x,y,q1') \<in> transitions M\<close> \<open>(q2,x,y,q2') \<in> transitions M\<close>
        by (metis LS_prepend_transition Un_iff fst_conv snd_conv)
      moreover have "(x,y) # subseq \<notin> LS M q1 \<inter> LS M q2"
        using observable_language_transition_target[OF \<open>observable M\<close> \<open>(q1,x,y,q1') \<in> transitions M\<close>, of subseq]
              observable_language_transition_target[OF \<open>observable M\<close> \<open>(q2,x,y,q2') \<in> transitions M\<close>, of subseq]
              i2
        unfolding fst_conv snd_conv
        by blast
      moreover have "butlast ((x,y) # subseq) \<in> LS M q1 \<inter> LS M q2"
        using i3 \<open>(q1,x,y,q1') \<in> transitions M\<close> \<open>(q2,x,y,q2') \<in> transitions M\<close>
        by (metis Int_iff LS_prepend_transition LS_single_transition append_butlast_last_id butlast.simps(2) fst_conv language_prefix snd_conv)
       ultimately show ?thesis
        unfolding * by simp
    qed
  qed

  then show "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<in> LS M q1 \<union> LS M q2"
       and  "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k \<notin> LS M q1 \<inter> LS M q2"
       and  "butlast (assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k) \<in> LS M q1 \<inter> LS M q2"
    by blast+
qed

lemma assemble_distinguishing_sequence_from_ofsm_table_length :
  "length (assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k) \<le> k"
proof (induction k arbitrary: q1 q2)
  case 0
  then show ?case by auto
next
  case (Suc k)
  obtain x y A B where *:"select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),A,B)"
    using prod.exhaust by metis

  show ?case proof (cases A)
    case None
    then have "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = [(x,y)]"
      unfolding assemble_distinguishing_sequence_from_ofsm_table.simps * case_prod_conv by auto
    then show ?thesis
      by (metis Suc_le_length_iff length_Cons list.distinct(1) not_less_eq_eq)
  next
    case (Some q1')
    show ?thesis proof (cases B)
      case None
      then have "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = [(x,y)]"
        unfolding assemble_distinguishing_sequence_from_ofsm_table.simps * case_prod_conv Some by auto
      then show ?thesis
        by (metis Suc_le_length_iff length_Cons list.distinct(1) not_less_eq_eq)
    next
      case (Some q2')
      show ?thesis
        unfolding assemble_distinguishing_sequence_from_ofsm_table.simps * \<open>A = Some q1'\<close> Some case_prod_conv
        using Suc.IH[of q1' q2']
        by simp
    qed
  qed
qed

lemma ofsm_table_fix_partition_fixpoint_trivial_partition :
  assumes "q \<in> states M"
shows "ofsm_table_fix M (\<lambda>q. FSM.states M) 0 q = ofsm_table M (\<lambda>q. FSM.states M) (size M - 1) q"
proof -
  have "((\<lambda>q. FSM.states M) ` FSM.states M) = {states M}"
    using fsm_initial[of M]
    by auto
  then have *:"card ((\<lambda>q. FSM.states M) ` FSM.states M) = 1"
    by auto

  show ?thesis
    using ofsm_table_fix_partition_fixpoint[OF minimise_initial_partition _ assms, of "size M"]
    unfolding *
    by blast
qed

fun get_distinguishing_sequence_from_ofsm_tables :: "('a,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list" where
  "get_distinguishing_sequence_from_ofsm_tables M q1 q2 = (let
      k = find_first_distinct_ofsm_table M q1 q2
  in assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k)"

lemma get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace :
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "q1 \<noteq> q2"
shows "get_distinguishing_sequence_from_ofsm_tables M q1 q2 \<in> LS M q1 \<union> LS M q2"
and   "get_distinguishing_sequence_from_ofsm_tables M q1 q2 \<notin> LS M q1 \<inter> LS M q2"
and   "butlast (get_distinguishing_sequence_from_ofsm_tables M q1 q2) \<in> LS M q1 \<inter> LS M q2"
proof -
  have "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
    using \<open>minimal M\<close> unfolding minimal_observable_code[OF assms(1)]
    using assms(3,4,5) by blast

  let ?k = "find_first_distinct_ofsm_table_gt M q1 q2 0"
  have "ofsm_table M (\<lambda>q . states M) ?k q1 \<noteq> ofsm_table M (\<lambda>q . states M) ?k q2"
    using find_first_distinct_ofsm_table_is_first(1)[OF assms(3,4) \<open>ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2\<close>] .

  have *:"get_distinguishing_sequence_from_ofsm_tables M q1 q2 = assemble_distinguishing_sequence_from_ofsm_table M q1 q2 ?k"
    by auto

  show "get_distinguishing_sequence_from_ofsm_tables M q1 q2 \<in> LS M q1 \<union> LS M q2"
  and  "get_distinguishing_sequence_from_ofsm_tables M q1 q2 \<notin> LS M q1 \<inter> LS M q2"
  and  "butlast (get_distinguishing_sequence_from_ofsm_tables M q1 q2) \<in> LS M q1 \<inter> LS M q2"
    using assemble_distinguishing_sequence_from_ofsm_table_distinguishes[OF assms(1,3,4) \<open>ofsm_table M (\<lambda>q . states M) ?k q1 \<noteq> ofsm_table M (\<lambda>q . states M) ?k q2\<close>]
    unfolding *
    by blast+
qed

lemma get_distinguishing_sequence_from_ofsm_tables_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "q1 \<noteq> q2"
shows "distinguishes M q1 q2 (get_distinguishing_sequence_from_ofsm_tables M q1 q2)"
  using get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms]
  unfolding distinguishes_def
  by blast

subsection \<open>Minimal Distinguishing Traces\<close>

lemma get_distinguishing_sequence_from_ofsm_tables_is_minimally_distinguishing :
  fixes M :: "('a,'b::linorder,'c::linorder) fsm"
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "q1 \<noteq> q2"
shows "minimally_distinguishes M q1 q2 (get_distinguishing_sequence_from_ofsm_tables M q1 q2)"
proof -

  have *:"ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
    using \<open>minimal M\<close> unfolding minimal_observable_code[OF assms(1)]
    using assms(3,4,5) by blast

  obtain k where "k = find_first_distinct_ofsm_table M q1 q2"
             and "get_distinguishing_sequence_from_ofsm_tables M q1 q2 = assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k"
    by auto
  then have "length (get_distinguishing_sequence_from_ofsm_tables M q1 q2) \<le> k"
    using assemble_distinguishing_sequence_from_ofsm_table_length
    by metis
  moreover have "\<And> io . length io < k \<Longrightarrow> \<not>distinguishes M q1 q2 io"
  proof -
    fix io :: "('b \<times> 'c) list"
    assume "length io < k"
    then have "ofsm_table M (\<lambda>q. FSM.states M) (length io) q1 = ofsm_table M (\<lambda>q. FSM.states M) (length io) q2"
      using find_first_distinct_ofsm_table_is_first[OF assms(3,4) *]
      unfolding \<open>k = find_first_distinct_ofsm_table M q1 q2\<close>
      by blast
    then show "\<not>distinguishes M q1 q2 io"
      using ofsm_table_set_observable[OF assms(1,3) minimise_initial_partition]
      using ofsm_table_set_observable[OF assms(1,4) minimise_initial_partition]
      unfolding distinguishes_def
      by (metis (mono_tags, lifting) Int_iff Un_iff assms(3) le_refl mem_Collect_eq ofsm_table_containment)
  qed
  ultimately show ?thesis
    using get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms]
    unfolding minimally_distinguishes_def distinguishes_def
    using le_neq_implies_less not_le_imp_less
    by blast
qed

lemma minimally_distinguishes_length :
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "q1 \<noteq> q2"
  and     "minimally_distinguishes M q1 q2 io"
shows "length io \<le> size M - 1"
proof -

  have "ofsm_table_fix M (\<lambda>q . states M) 0 q1 \<noteq> ofsm_table_fix M (\<lambda>q . states M) 0 q2"
    using \<open>minimal M\<close> unfolding minimal_observable_code[OF assms(1)]
    using assms(3,4,5) by blast
  then have "ofsm_table M (\<lambda>q. FSM.states M) (FSM.size M - 1) q1 \<noteq> ofsm_table M (\<lambda>q. FSM.states M) (FSM.size M - 1) q2"
    using ofsm_table_fix_partition_fixpoint_trivial_partition assms(3,4)
    by metis
  then obtain io' where "distinguishes M q1 q2 io'" and "length io' \<le> size M - 1"
    unfolding ofsm_table_set_observable[OF assms(1,3) minimise_initial_partition]
    unfolding ofsm_table_set_observable[OF assms(1,4) minimise_initial_partition]
    unfolding distinguishes_def
    by blast
  then show ?thesis
    using assms(6) unfolding minimally_distinguishes_def
    using dual_order.trans by blast
qed

end


theory Acceptance
imports Sequence_LTL
begin

  type_synonym 'a pred = "'a \<Rightarrow> bool"
  type_synonym 'a rabin = "'a pred \<times> 'a pred"
  type_synonym 'a gen = "'a list"

  definition rabin :: "'a rabin \<Rightarrow> 'a stream pred" where
    "rabin \<equiv> \<lambda> (I, F) w. infs I w \<and> fins F w"

  lemma rabin[intro]:
    assumes "IF = (I, F)" "infs I w" "fins F w"
    shows "rabin IF w"
    using assms unfolding rabin_def by auto
  lemma rabin_elim[elim]:
    assumes "rabin IF w"
    obtains I F
    where "IF = (I, F)" "infs I w" "fins F w"
    using assms unfolding rabin_def by auto

  definition gen :: "('a \<Rightarrow> 'b pred) \<Rightarrow> ('a gen \<Rightarrow> 'b pred)" where
    "gen P cs w \<equiv> \<forall> c \<in> set cs. P c w"

  lemma gen[intro]:
    assumes "\<And> c. c \<in> set cs \<Longrightarrow> P c w"
    shows "gen P cs w"
    using assms unfolding gen_def by auto
  lemma gen_elim[elim]:
    assumes "gen P cs w"
    obtains "\<And> c. c \<in> set cs \<Longrightarrow> P c w"
    using assms unfolding gen_def by auto

  definition cogen :: "('a \<Rightarrow> 'b pred) \<Rightarrow> ('a gen \<Rightarrow> 'b pred)" where
    "cogen P cs w \<equiv> \<exists> c \<in> set cs. P c w"

  lemma cogen[intro]:
    assumes "c \<in> set cs" "P c w"
    shows "cogen P cs w"
    using assms unfolding cogen_def by auto
  lemma cogen_elim[elim]:
    assumes "cogen P cs w"
    obtains c
    where "c \<in> set cs" "P c w"
    using assms unfolding cogen_def by auto

  lemma cogen_alt_def: "cogen P cs w \<longleftrightarrow> \<not> gen (\<lambda> c w. Not (P c w)) cs w" by auto

end


subsection "Negative Infinity"
theory NegInfinity
  imports "HOL-Analysis.Poly_Roots" VSAlgos
begin

lemma freeIn_allzero : "freeIn var (allZero p var)"
  by (simp add: not_in_isovarspar freeIn_list_conj)

lemma allzero_eval :
  assumes lLength : "var < length L"
  shows"(\<exists>x. \<forall>y<x. aEval (Eq p) (list_update L var y) ) = (\<forall>x. eval (allZero p var) (list_update L var x))"
proof-
  define n where "n = MPoly_Type.degree p var"
  define k where "k i x =((insertion (nth_default 0(list_update L var x)) (isolate_variable_sparse p var i)))" for i x
  {fix x
    have "(eval (allZero p var) (list_update L var x)) =
        (\<forall>i\<in>{0..<(MPoly_Type.degree p var)+1}. aEval (Eq(isolate_variable_sparse p var i)) (list_update L var x))"
      by (simp add: eval_list_conj atLeast0_lessThan_Suc)
    also have "... = (\<forall>i\<in>{0..<(MPoly_Type.degree p var)+1}. (insertion (nth_default 0(list_update L var x)) (isolate_variable_sparse p var i))=0)"
      by simp
    also have "... = (\<forall>i\<le>(MPoly_Type.degree p var). (insertion (nth_default 0(list_update L var x)) (isolate_variable_sparse p var i))=0)"
      by fastforce
    also have "... = (\<forall>y. (\<Sum>i\<le>(MPoly_Type.degree p var). ((insertion (nth_default 0(list_update L var x)) (isolate_variable_sparse p var i)) * y ^ i))=0)"
      using polyfun_eq_const[where n="MPoly_Type.degree p var", where k="0", where c="\<lambda>i. (insertion (nth_default 0(list_update L var x)) (isolate_variable_sparse p var i))"]
      by (metis (no_types, lifting) le_add2 le_add_same_cancel2)
    also have "... = (\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0)"
      using k_def n_def by simp
    finally have  "(eval (allZero p var) (list_update L var x)) = (\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0)"
      by simp
  }
  then have h1 : "(\<forall>x. (eval (allZero p var) (list_update L var x))) = (\<forall>x.(\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0))"
    by simp

  have "(\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0) = (\<exists>y. \<forall>x<y. (\<Sum>i\<le>(MPoly_Type.degree p var). (insertion (nth_default 0 (list_update L var x))(isolate_variable_sparse p var i))* x^i)= 0)"
    using k_def n_def by simp
  also have "... = (\<exists>y. \<forall>x<y. insertion (nth_default 0 (list_update L var x)) (\<Sum>i\<le>(MPoly_Type.degree p var). (isolate_variable_sparse p var i)* Var var^i)= 0)"
    by(simp add: insertion_sum' insertion_mult insertion_pow insertion_var lLength)
  also have "... = (\<exists>y. \<forall>x<y. insertion (nth_default 0 (list_update L var x)) p = 0)"
    using sum_over_zero  by simp
  also have "... = (\<exists>y. \<forall>x<y. aEval (Eq p) (list_update L var x))"
    by simp
  finally have h2 : "(\<exists>y. \<forall>x<y. aEval (Eq p) (list_update L var x)) = (\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0)"
    by simp

  have k_all : "\<forall>x y i. k i x = k i y"
    unfolding k_def
    by (simp add: insertion_isovarspars_free)
  have h3a : "(\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0) \<Longrightarrow> (\<forall>x.(\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0))"
  proof-
    assume h : "(\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0)"
    {fix z y
      assume h : "(\<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0)"
      have "\<forall>x<y.\<forall>i\<le>n. k i x = k i z"
        unfolding k_def
        using insertion_isovarspars_free by blast
      then have * : "\<forall>x<y.\<forall>i\<le>n. k i x * x ^ i = k i z * x^i"
        by auto
      then have "\<forall>x<y. (\<Sum>i\<le>n. k i x * x ^ i) = (\<Sum>i\<le>n. k i z * x ^ i)"
        by (metis (no_types, lifting) k_all sum.cong)
      then have "\<forall>x<y. (\<Sum>i\<le>n. (k i z)* x^i)= 0"
        using h  by simp
      then have "\<not>(finite {x. (\<Sum>i\<le>n. k i z * x ^ i) = 0})"
        using infinite_Iio[where a="y"]  Inf_many_def[where P="\<lambda>x. (\<Sum>i\<le>n. k i z * x ^ i) = 0"]
        by (smt INFM_iff_infinite frequently_mono lessThan_def)
      then have "\<forall>i\<le>n. k i z = 0"
        using  polyfun_rootbound[where n="n",  where c = "\<lambda>i. k i z" ]
        by blast
    }
    then have "\<forall>x.\<forall>i\<le>n. k i x = 0"
      using h
      by (meson gt_ex)
    then show ?thesis by simp
  qed
  have h3b : "(\<forall>x.(\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0)) \<Longrightarrow> (\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0)"
  proof-
    assume h : "(\<forall>x.(\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0))"
    {fix z y x
      have "(\<Sum>i\<le>n. (k i z)* x^i)= 0"
        using h k_all by blast
      then have "\<forall>i\<le>n. k i z = 0"
        using polyfun_eq_const[where k="0", where c = "\<lambda>i. k i z", where n="n"]
        by (metis h)
    }
    then have "\<forall>x.\<forall>i\<le>n. k i x = 0"
      by (meson gt_ex)
    then show ?thesis by simp
  qed
  have h3 : "(\<exists>y. \<forall>x<y. (\<Sum>i\<le>n. (k i x)* x^i)= 0) = (\<forall>x.(\<forall>y. (\<Sum>i\<le>n. (k i x) * y ^ i)=0))"
    using h3a h3b by auto
  show ?thesis using h1 h2 h3 by simp
qed

lemma freeIn_altNegInf : "freeIn var (alternateNegInfinity p var)"
proof-
  have h1 : "\<forall>i. var \<notin> (vars (if (i::nat) mod 2 = 0 then (Const(1)::real mpoly) else (Const(-1)::real mpoly)))"
    using var_not_in_Const[where var = "var", where x="1"] var_not_in_Const[where var = "var", where x="-1"]
    by simp
  define g where "g = (\<lambda>F.\<lambda>i.
    let a_n = isolate_variable_sparse p var i in
    let exp = (if i mod 2 = 0 then Const(1) else Const(-1)) in
      or (Atom(Less (exp * a_n)))
        (and (Atom (Eq a_n)) F)
    )"
  have h3 : "\<forall>i. \<forall>F. (freeIn var F \<longrightarrow> freeIn var (g F i))"
    using g_def h1
    by (smt PolyAtoms.and_def not_in_isovarspar PolyAtoms.or_def freeIn.simps(1) freeIn.simps(2) freeIn.simps(7) freeIn.simps(8) not_in_mult)
  define L where "L = ([0..<((MPoly_Type.degree p var)+1)])"
  have "\<forall>F. freeIn var F \<longrightarrow> freeIn var (foldl (g::atom fm \<Rightarrow> nat \<Rightarrow> atom fm) F (L::nat list))"
  proof(induction L)
    case Nil
    then show ?case by simp
  next
    case (Cons a L)
    then show ?case using h3 by simp
  qed
  then have "freeIn var (foldl g FalseF L)"
    using freeIn.simps(6) by blast
  then show ?thesis using g_def L_def by simp
qed

theorem freeIn_substNegInfinity : "freeIn var (substNegInfinity var A)"
  apply(cases A) using freeIn_altNegInf freeIn_allzero by simp_all

end


header {* Lazy list monad *}

theory Lazy_List_Monad
imports Monad_Zero_Plus
begin

text {* To illustrate the general process of defining a new type
constructor, we formalize the datatype of lazy lists. Below are the
Haskell datatype definition and class instances. *}

text_raw {*
\begin{verbatim}
data List a = Nil | Cons a (List a)

instance Functor List where
  fmap f Nil = Nil
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Monad List where
  return x        = Cons x Nil
  Nil       >>= k = Nil
  Cons x xs >>= k = mplus (k x) (xs >>= k)

instance MonadZero List where
  mzero = Nil

instance MonadPlus List where
  mplus Nil         ys = ys
  mplus (Cons x xs) ys = Cons x (mplus xs ys)
\end{verbatim}
*}

subsection {* Type definition *}

text {* The first step is to register the datatype definition with
@{text tycondef}. *}

tycondef 'a\<cdot>llist = LNil | LCons (lazy "'a") (lazy "'a\<cdot>llist")

text {* The @{text tycondef} command generates lots of theorems
automatically, but there are a few more involving @{text coerce} and
@{text fmapU} that we still need to prove manually. These proofs could
be automated in a later version of @{text tycondef}. *}

lemma coerce_llist_abs [simp]: "coerce\<cdot>(llist_abs\<cdot>x) = llist_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: llist_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_llist)
done

lemma coerce_LNil [simp]: "coerce\<cdot>LNil = LNil"
unfolding LNil_def by simp

lemma coerce_LCons [simp]: "coerce\<cdot>(LCons\<cdot>x\<cdot>xs) = LCons\<cdot>(coerce\<cdot>x)\<cdot>(coerce\<cdot>xs)"
unfolding LCons_def by simp

lemma fmapU_llist_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>llist) = \<bottom>"
  "fmapU\<cdot>f\<cdot>LNil = LNil"
  "fmapU\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs) = LCons\<cdot>(f\<cdot>x)\<cdot>(fmapU\<cdot>f\<cdot>xs)"
unfolding fmapU_llist_def llist_map_def
apply (subst fix_eq, simp)
apply (subst fix_eq, simp add: LNil_def)
apply (subst fix_eq, simp add: LCons_def)
done

subsection {* Class instances *}

text {* The @{text tycondef} command defines @{text fmapU} for us and
proves a @{text prefunctor} class instance automatically. For the
@{text functor} instance we only need to prove the composition law,
which we can do by induction. *}

instance llist :: "functor"
proof
  fix f g and xs :: "udom\<cdot>llist"
  show "fmapU\<cdot>f\<cdot>(fmapU\<cdot>g\<cdot>xs) = fmapU\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
    by (induct xs rule: llist.induct) simp_all
qed

text {* For the other class instances, we need to provide definitions
for a few constants: @{text returnU}, @{text bindU} @{text zeroU}, and
@{text plusU}. We can use ordinary commands like @{text definition}
and @{text fixrec} for this purpose. Finally we prove the class
axioms, along with a few helper lemmas, using ordinary proof
procedures like induction. *}

instantiation llist :: monad_zero_plus
begin

fixrec plusU_llist :: "udom\<cdot>llist \<rightarrow> udom\<cdot>llist \<rightarrow> udom\<cdot>llist"
  where "plusU_llist\<cdot>LNil\<cdot>ys = ys"
  | "plusU_llist\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>ys = LCons\<cdot>x\<cdot>(plusU_llist\<cdot>xs\<cdot>ys)"

lemma plusU_llist_strict [simp]: "plusU\<cdot>\<bottom>\<cdot>ys = (\<bottom>::udom\<cdot>llist)"
by fixrec_simp

fixrec bindU_llist :: "udom\<cdot>llist \<rightarrow> (udom \<rightarrow> udom\<cdot>llist) \<rightarrow> udom\<cdot>llist"
  where "bindU_llist\<cdot>LNil\<cdot>k = LNil"
  | "bindU_llist\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>k = plusU\<cdot>(k\<cdot>x)\<cdot>(bindU_llist\<cdot>xs\<cdot>k)"

lemma bindU_llist_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>llist)"
by fixrec_simp

definition zeroU_llist_def:
  "zeroU = LNil"

definition returnU_llist_def:
  "returnU = (\<Lambda> x. LCons\<cdot>x\<cdot>LNil)"

lemma plusU_LNil_right: "plusU\<cdot>xs\<cdot>LNil = xs"
by (induct xs rule: llist.induct) simp_all

lemma plusU_llist_assoc:
  fixes xs ys zs :: "udom\<cdot>llist"
  shows "plusU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>zs = plusU\<cdot>xs\<cdot>(plusU\<cdot>ys\<cdot>zs)"
by (induct xs rule: llist.induct) simp_all

lemma bindU_plusU_llist:
  fixes xs ys :: "udom\<cdot>llist" shows
  "bindU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>f = plusU\<cdot>(bindU\<cdot>xs\<cdot>f)\<cdot>(bindU\<cdot>ys\<cdot>f)"
by (induct xs rule: llist.induct) (simp_all add: plusU_llist_assoc)

instance proof
  fix x :: "udom"
  fix f :: "udom \<rightarrow> udom"
  fix h k :: "udom \<rightarrow> udom\<cdot>llist"
  fix xs ys zs :: "udom\<cdot>llist"
  show "fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct xs rule: llist.induct, simp_all add: returnU_llist_def)
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>k = k\<cdot>x"
    by (simp add: returnU_llist_def plusU_LNil_right)
  show "bindU\<cdot>(bindU\<cdot>xs\<cdot>h)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(h\<cdot>x)\<cdot>k)"
    by (induct xs rule: llist.induct)
       (simp_all add: bindU_plusU_llist)
  show "bindU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>k = plusU\<cdot>(bindU\<cdot>xs\<cdot>k)\<cdot>(bindU\<cdot>ys\<cdot>k)"
    by (induct xs rule: llist.induct)
       (simp_all add: plusU_llist_assoc)
  show "plusU\<cdot>(plusU\<cdot>xs\<cdot>ys)\<cdot>zs = plusU\<cdot>xs\<cdot>(plusU\<cdot>ys\<cdot>zs)"
    by (rule plusU_llist_assoc)
  show "bindU\<cdot>zeroU\<cdot>k = zeroU"
    by (simp add: zeroU_llist_def)
  show "fmapU\<cdot>f\<cdot>(plusU\<cdot>xs\<cdot>ys) = plusU\<cdot>(fmapU\<cdot>f\<cdot>xs)\<cdot>(fmapU\<cdot>f\<cdot>ys)"
    by (induct xs rule: llist.induct) simp_all
  show "fmapU\<cdot>f\<cdot>zeroU = (zeroU :: udom\<cdot>llist)"
    by (simp add: zeroU_llist_def)
  show "plusU\<cdot>zeroU\<cdot>xs = xs"
    by (simp add: zeroU_llist_def)
  show "plusU\<cdot>xs\<cdot>zeroU = xs"
    by (simp add: zeroU_llist_def plusU_LNil_right)
qed

end

subsection {* Transfer properties to polymorphic versions *}

text {* After proving the class instances, there is still one more
step: We must transfer all the list-specific lemmas about the
monomorphic constants (e.g., @{text fmapU} and @{text bindU}) to the
corresponding polymorphic constants (@{text fmap} and @{text bind}).
These lemmas primarily consist of the defining equations for each
constant. The polymorphic constants are defined using @{text coerce},
so the proofs proceed by unfolding the definitions and simplifying
with the @{text coerce_simp} rules. *}

lemma fmap_llist_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>llist) = \<bottom>"
  "fmap\<cdot>f\<cdot>LNil = LNil"
  "fmap\<cdot>f\<cdot>(LCons\<cdot>x\<cdot>xs) = LCons\<cdot>(f\<cdot>x)\<cdot>(fmap\<cdot>f\<cdot>xs)"
unfolding fmap_def by simp_all

lemma mplus_llist_simps [simp]:
  "mplus\<cdot>(\<bottom>::'a\<cdot>llist)\<cdot>ys = \<bottom>"
  "mplus\<cdot>LNil\<cdot>ys = ys"
  "mplus\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>ys = LCons\<cdot>x\<cdot>(mplus\<cdot>xs\<cdot>ys)"
unfolding mplus_def by simp_all

lemma bind_llist_simps [simp]:
  "bind\<cdot>(\<bottom>::'a\<cdot>llist)\<cdot>f = \<bottom>"
  "bind\<cdot>LNil\<cdot>f = LNil"
  "bind\<cdot>(LCons\<cdot>x\<cdot>xs)\<cdot>f = mplus\<cdot>(f\<cdot>x)\<cdot>(bind\<cdot>xs\<cdot>f)"
unfolding bind_def mplus_def
by (simp_all add: coerce_simp)

lemma return_llist_def:
  "return = (\<Lambda> x. LCons\<cdot>x\<cdot>LNil)"
unfolding return_def returnU_llist_def
by (simp add: coerce_simp)

lemma mzero_llist_def:
  "mzero = LNil"
unfolding mzero_def zeroU_llist_def
by simp

lemma join_llist_simps [simp]:
  "join\<cdot>(\<bottom>::'a\<cdot>llist\<cdot>llist) = \<bottom>"
  "join\<cdot>LNil = LNil"
  "join\<cdot>(LCons\<cdot>xs\<cdot>xss) = mplus\<cdot>xs\<cdot>(join\<cdot>xss)"
unfolding join_def by simp_all

end


theory DataRefinement
imports NREST
begin

subsection \<open>Data Refinement\<close>

lemma "{(1,2),(2,4)}``{1,2}={2,4}" by auto

definition conc_fun ("\<Down>") where
  "conc_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT | REST X \<Rightarrow> REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"
                                                                  (* ^- not so sure here *)
definition abs_fun ("\<Up>") where
  "abs_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT
    | REST X \<Rightarrow> if dom X\<subseteq>Domain R then REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R}) else FAILT"
                                                (* ^- not so sure here *)
lemma
  conc_fun_FAIL[simp]: "\<Down>R FAILT = FAILT" and
  conc_fun_RES: "\<Down>R (REST X) = REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"
  unfolding conc_fun_def by (auto split: nrest.split)

(*
lemma conc_fun_RES_sv: "single_valued R \<Longrightarrow>
  \<Down>R (REST X) = REST (\<lambda>c. if c\<in>Dom R then Some (X Sup {X a| a. (c,a)\<in>R})"
*)

lemma nrest_Rel_mono: "A \<le> B \<Longrightarrow> \<Down> R A \<le> \<Down> R B"
  unfolding conc_fun_def
  apply (auto split: nrest.split simp: le_fun_def)
  by (smt Sup_mono mem_Collect_eq)

subsubsection \<open>Examples\<close>

definition Rset where "Rset = { (c,a)| c a. set c = a}"

lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
  unfolding conc_fun_def RETURNT_def Rset_def
  apply simp unfolding le_fun_def by auto

lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
  unfolding conc_fun_def RETURNT_def Rset_def
  apply simp unfolding le_fun_def by auto

definition Reven where "Reven = { (c,a)| c a. even c = a}"

lemma "RETURNT 3 \<le> \<Down>Reven (RETURNT False)"
  unfolding conc_fun_def RETURNT_def Reven_def
  apply simp unfolding le_fun_def by auto

lemma "m \<le> \<Down>Id m"
  unfolding conc_fun_def RETURNT_def
  apply (cases m) by auto

lemma "m \<le> \<Down>{} m \<longleftrightarrow> (m=FAILT \<or> m = SPECT bot)"
  unfolding conc_fun_def RETURNT_def
  apply (cases m) apply auto by (metis bot.extremum dual_order.antisym le_funI)

lemma abs_fun_simps[simp]:
  "\<Up>R FAILT = FAILT"
  "dom X\<subseteq>Domain R \<Longrightarrow> \<Up>R (REST X) = REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R})"
  "\<not>(dom X\<subseteq>Domain R) \<Longrightarrow> \<Up>R (REST X) = FAILT"
  unfolding abs_fun_def by (auto  split: nrest.split)

term single_valued

context fixes R assumes SV: "single_valued R" begin

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Sup_sv: "(c, a') \<in> R \<Longrightarrow>  Sup {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma indomD: " M c = Some y \<Longrightarrow> dom M \<subseteq> Domain R \<Longrightarrow> (\<exists>a. (c,a)\<in>R)"
  by auto

lemma conc_abs_swap: "m' \<le> \<Down>R m \<longleftrightarrow> \<Up>R m' \<le> m"
  apply rule
  subgoal (* <-- *)
  unfolding conc_fun_def abs_fun_def using SV
  apply (auto split: nrest.splits)
  subgoal for M M'
    apply (auto simp add: le_fun_def)
    by (smt Sup_least antisym le_cases mem_Collect_eq single_valuedD)
  subgoal
    by (smt Collect_cong Domain.DomainI domI domIff empty_Sup empty_def le_map_dom_mono set_rev_mp)
  done

  subgoal (* \<longrightarrow> *)
    unfolding conc_fun_def abs_fun_def using SV
    apply(auto split: nrest.splits if_splits)
    apply (auto simp add: le_fun_def)
    subgoal for M M' c
      apply(cases "M c = None")
       apply auto apply(frule indomD) apply simp
      apply(auto)
      apply(simp only: Sup_sv)

      by (metis (mono_tags, lifting) Sup_le_iff mem_Collect_eq)
    done
  done

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Inf_sv: "(c, a') \<in> R \<Longrightarrow>  Inf {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma ac_galois: "galois_connection (\<Up>R) (\<Down>R)"
  apply (unfold_locales)
  by (rule conc_abs_swap)

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Sup_some_svD: "Sup {m a |a. (c, a) \<in> R} = Some t' \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> m a = Some t')"
  using SV by (smt Sup_le_iff dual_order.antisym less_eq_option_Some_None mem_Collect_eq order_refl single_valued_def)

end

lemma pw_abs_nofail[refine_pw_simps]:
  "nofailT (\<Up>R M) \<longleftrightarrow> (nofailT M \<and> (\<forall>x. (\<exists>t. inresT M x t) \<longrightarrow> x\<in>Domain R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_simps abs_fun_def)
  by (metis zero_enat_def zero_le)

(*
lemma pw_abs_inres[refine_pw_simps]:
  "(\<exists>t. inresT (\<Up>R M) a t) \<longleftrightarrow> (nofailT (\<Up>R M) \<longrightarrow> (\<exists>c. (\<exists>t. inresT M c t) \<and> (c,a)\<in>R))"
  apply (cases M)
   apply simp
  apply rule
  subgoal for m
    apply (auto simp: abs_fun_def) (*    *)
    sorry
  subgoal for m
    sorry
  done
*)

lemma pw_conc_nofail[refine_pw_simps]:
  "nofailT (\<Down>R S) = nofailT S"
  by (cases S) (auto simp: conc_fun_RES)

lemma "single_valued A \<Longrightarrow> single_valued B \<Longrightarrow> single_valued (A O B)"
  by (simp add: single_valued_relcomp)

lemma Sup_enatoption_less2: " Sup X = Some \<infinity> \<Longrightarrow> (\<exists>x. Some x \<in> X \<and> enat t < x)"
  using Sup_enat_less2
  by (metis Sup_option_def in_these_eq option.distinct(1) option.sel)

lemma pw_conc_inres[refine_pw_simps]:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> ((\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t) \<comment> \<open> \<and> (\<forall>s' t'. (s,s')\<in>R \<longrightarrow> inresT S' s' t' \<longrightarrow> t' \<le> t )\<close> ))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES  )
      subgoal for t'
        apply(cases t')
         apply auto
        subgoal for n apply(auto dest!: Sup_finite_enat)
          subgoal for a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x="enat n"]) by auto
          done
        subgoal apply(drule Sup_enatoption_less2[where t=t])
          apply auto subgoal for x a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x=x]) by auto
          done
        done
      done
    subgoal
      apply (auto simp: conc_fun_RES)
      by (smt Sup_upper dual_order.trans le_some_optE mem_Collect_eq)
    done
  done
(*
lemma pw_conc_inres_sv:
  "single_valued R \<Longrightarrow> inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> (\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      by (auto simp: conc_fun_RES dest!: Sup_some_svD)
    subgoal
      by (auto simp: conc_fun_RES Sup_sv )
    done
  done *)

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows
  "single_valued R \<Longrightarrow> Sup {m a| a. (c,a) \<in> R} = None \<longleftrightarrow> c \<notin> Domain R"
  apply rule
  subgoal oops

(*
lemma pw_abs_inre:
  "inresT (\<Up>R M) a t \<longleftrightarrow> (nofailT (\<Up>R M) \<longrightarrow> (\<exists>c. inresT M c t \<and> (c,a)\<in>R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_def)
  done*)

(*
lemma pw_conc_inres:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> (\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    done
  oops *)

lemma sv_the: "single_valued R \<Longrightarrow> (c,a) \<in> R \<Longrightarrow> (THE a. (c, a) \<in> R) = a"
  by (simp add: single_valued_def the_equality)

lemma
  conc_fun_RES_sv:
  assumes SV: "single_valued R"
  shows "\<Down>R (REST X) = REST (\<lambda>c. if c\<in>Domain R then X (THE a. (c,a)\<in>R) else None )"
  unfolding conc_fun_def
  apply(auto split: nrest.split)
  apply(rule ext)
  apply auto
  subgoal using  SV  by (auto simp: Sup_sv sv_the)
  subgoal by (smt Collect_cong Domain.DomainI empty_Sup empty_def)
  done

lemma conc_fun_mono[simp, intro!]:
  shows "mono (\<Down>R)"
  apply rule
  apply (simp add: pw_le_iff)
  by (auto simp: refine_pw_simps)

lemma conc_fun_R_mono:
  assumes "R \<subseteq> R'"
  shows "\<Down>R M \<le> \<Down>R' M"
  using assms
  by (auto simp: pw_le_iff refine_pw_simps)

lemma SupSup_2: "Sup {m a |a. (c, a) \<in> R O S} =  Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R }"
proof -
  have i: "\<And>a. (c,a) \<in> R O S \<longleftrightarrow> (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)" by auto
  have "Sup {m a |a. (c, a) \<in> R O S} = Sup {m a |a. (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)}"
      unfolding i by auto
    also have "...  = Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R}" by auto
    finally show ?thesis .
  qed

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows SupSup: "Sup {Sup {m aa |aa. P a aa c} |a. Q a c} = Sup {m aa |a aa. P a aa c \<and> Q a c}"
  apply(rule antisym)
   subgoal apply(rule Sup_least)
     by (auto intro: Sup_subset_mono)
   subgoal
     unfolding Sup_le_iff apply auto
     by (smt Sup_upper Sup_upper2 mem_Collect_eq)
   done

lemma
  fixes m :: "'a \<Rightarrow> enat option"
  shows
    SupSup_1: "Sup {Sup {m aa |aa. (a, aa) \<in> S} |a. (c, a) \<in> R} = Sup {m aa |a aa. (a,aa)\<in>S \<and> (c,a)\<in>R}"
  by(rule SupSup)

lemma conc_fun_chain:
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  apply(simp only: conc_fun_RES)
  apply auto apply (rule ext)  unfolding SupSup_1 SupSup_2 by meson

lemma conc_fun_chain_sv:
  assumes SVR: "single_valued R" and SVS: "single_valued S"
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  using SVS apply(simp only: conc_fun_RES_sv)
  using SVR apply(simp only: conc_fun_RES_sv)
  using single_valued_relcomp[OF SVR SVS] apply(simp only: conc_fun_RES_sv)
  apply (auto split: nrest.split)
  apply (rule ext) apply auto
    apply(auto simp add: sv_the)
  apply(subst sv_the) by auto

lemma conc_Id[simp]: "\<Down>Id = id"
  unfolding conc_fun_def [abs_def] by (auto split: nrest.split)

lemma conc_fun_fail_iff[simp]:
  "\<Down>R S = FAILT \<longleftrightarrow> S=FAILT"
  "FAILT = \<Down>R S \<longleftrightarrow> S=FAILT"
  by (auto simp add: pw_eq_iff refine_pw_simps)

lemma conc_trans[trans]:
  assumes A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

lemma conc_trans_sv:
  assumes SV: "single_valued R" "single_valued R'"
    and A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

text \<open>WARNING: The order of the single statements is important here!\<close>
lemma conc_trans_additional[trans]:
  assumes "single_valued R"
  shows
  "\<And>A B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>R  C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>A B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>\<Down>R  C"

  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  "\<And>A B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>    C"
  "\<And>A B C. A\<le>    B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  using assms conc_trans[where R=R and R'=Id]
  by (auto intro: order_trans)

lemma RETURNT_refine:
  assumes "(x,x')\<in>R"
  shows "RETURNT x \<le> \<Down>R (RETURNT x')"
  using assms
  by (auto simp: RETURNT_def conc_fun_RES le_fun_def Sup_upper)

lemma bindT_refine':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'; inresT M x t; inresT M' x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_le_iff refine_pw_simps)
  by blast
thm refine_pw_simps
lemma bindT_refine:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x'. \<lbrakk> (x,x')\<in>R' \<rbrakk>
    \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bind M' (\<lambda>x'. f' x'))"
  apply (rule bindT_refine') using assms by auto

subsection \<open>WHILET refine\<close>

lemma RECT_refine:
  assumes M: "mono2 body"
  assumes R0: "(x,x')\<in>R"
  assumes RS: "\<And>f f' x x'. \<lbrakk> \<And>x x'. (x,x')\<in>R \<Longrightarrow> f x \<le>\<Down>S (f' x'); (x,x')\<in>R \<rbrakk>
    \<Longrightarrow> body f x \<le>\<Down>S (body' f' x')"
  shows "RECT (\<lambda>f x. body f x) x \<le>\<Down>S (RECT (\<lambda>f' x'. body' f' x') x')"
  unfolding RECT_flat_gfp_def
  apply (clarsimp simp add: M)
  apply (rule flatf_fixp_transfer[where
        fp'="flatf_gfp body"
    and B'=body
    and P="\<lambda>x x'. (x',x)\<in>R",
    OF _ _ flatf_ord.fixp_unfold[OF M[THEN trimonoD_flatf_ge]] R0])
  apply simp
  apply (simp add: trimonoD_flatf_ge)
  by (rule RS)

lemma WHILET_refine:
  assumes R0: "(x,x')\<in>R"
  assumes COND_REF: "\<And>x x'. \<lbrakk> (x,x')\<in>R \<rbrakk> \<Longrightarrow> b x = b' x'"
  assumes STEP_REF:
    "\<And>x x'. \<lbrakk> (x,x')\<in>R; b x; b' x' \<rbrakk> \<Longrightarrow> f x \<le> \<Down>R (f' x')"
  shows "whileT b f x \<le> \<Down>R (whileT b' f' x')"
  unfolding whileT_def apply(rule RECT_refine)
    subgoal by(refine_mono)
     apply (fact R0)
    by(auto simp: COND_REF STEP_REF RETURNT_refine intro: bindT_refine[where R'=R])

lemma
  assumes a: "\<And>m n c a. c\<in>Domain R \<Longrightarrow> \<exists>a. SPECT (n c) \<le>  SPECT (m a)"
  shows "(SPECT n) \<le> \<Down> R (SPECT m)"
  using a  apply auto
    unfolding conc_fun_def apply (auto split: nrest.split)
      unfolding le_fun_def apply auto
    proof -
      fix c
      assume "(\<And>c n m. c \<in> Domain R \<Longrightarrow> \<exists>a. \<forall>x. n c x \<le> m a x)"
      oops

lemma SPECT_refines_conc_fun':
  assumes a: "\<And>m c.  M = SPECT m
          \<Longrightarrow> c \<in> dom n \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R M"
proof -
  show ?thesis
    unfolding conc_fun_def apply (auto split: nrest.split)
    subgoal for m unfolding le_fun_def apply auto
    proof -
      fix c
      assume m: "M = SPECT m"
      show "n c \<le> Sup {m a |a. (c, a) \<in> R} "
      proof (cases "c \<in> dom n")
        case True
        with m a obtain a where k: "(c,a)\<in>R" "n c \<le> m a" by blast
        show ?thesis apply(rule  Sup_upper2) using k by auto
      next
        case False
        then show ?thesis
          by (simp add: domIff)
      qed
    qed
    done
qed

lemma SPECT_refines_conc_fun:
  assumes a: "\<And>m c. (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a by auto

lemma SPECT_refines_conc_fun_sv:
  assumes "single_valued R"
    and a: "dom n \<subseteq> Domain R"
    and "\<And>c. c \<in> dom n \<Longrightarrow> n c \<le> (THE a. (c,a)\<in>R)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a
  using indomD[OF assms(1) _ a] domIff
  oops

lemma conc_fun_br: "\<Down> (br \<alpha> I1) (SPECT (emb I2 t))
        = (SPECT (emb (\<lambda>x. I1 x \<and> I2 (\<alpha> x)) t))"
  unfolding conc_fun_RES  apply auto apply(rule ext)
    using Sup_Some by (auto simp: emb'_def br_def bot_option_def Sup_option_def)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_16
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 y (nil2)) = y"
| "last (cons2 y (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((xs = (nil2)) ==> ((last (cons2 x xs)) = x))"
  find_proof DInd
  apply (induct)
   apply auto
  done

end