theory Kozen_Example
  imports SKAT_Tactics List
begin

(* Kozen and Angus's example *)

datatype kzp = f_kzp | g_kzp | P_kzp | bot_kzp | x_kzp

lemma kzp_UNIV: "UNIV = {P_kzp,f_kzp,g_kzp,bot_kzp,x_kzp}"
  by (auto, metis kzp.exhaust)

instantiation kzp :: ranked_alphabet
begin

  fun arity_kzp :: "kzp \<Rightarrow> nat" where
    "arity_kzp f_kzp = 1"
  | "arity_kzp g_kzp = 2"
  | "arity_kzp P_kzp = 1"
  | "arity_kzp bot_kzp = 0"
  | "arity_kzp x_kzp = 0"

  definition funs_kzp :: "kzp set" where "funs_kzp \<equiv> {f_kzp, g_kzp, bot_kzp, x_kzp}"

  definition rels_kzp :: "kzp set" where "rels_kzp \<equiv> {P_kzp}"

  definition NULL_kzp :: "kzp" where "NULL_kzp \<equiv> bot_kzp"

  declare funs_kzp_def [alphabet]
    and rels_kzp_def [alphabet]
    and NULL_kzp_def [alphabet]

  definition output_vars_kzp :: "kzp itself \<Rightarrow> nat set" where "output_vars_kzp x \<equiv> {0}"

  declare output_vars_kzp_def [alphabet]

  instance proof
    show "(funs :: kzp set) \<inter> rels = {}"
      by (simp add: funs_kzp_def rels_kzp_def)

    show "(funs :: kzp set) \<union> rels = UNIV"
      by (simp add: funs_kzp_def rels_kzp_def kzp_UNIV)

    show "(funs :: kzp set) \<noteq> {}"
      by (simp add: funs_kzp_def)

    show "(rels :: kzp set) \<noteq> {}"
      by (simp add: rels_kzp_def)

    show "NULL \<in> (funs :: kzp set)"
      by (simp add: NULL_kzp_def funs_kzp_def)

    show "arity (NULL::kzp) = 0"
      by (simp add: NULL_kzp_def)

    show "\<exists>x. x \<in> output_vars TYPE(kzp)"
      by (metis (mono_tags) insertI1 output_vars_kzp_def)

    show "finite (output_vars TYPE(kzp))"
      by (metis (hide_lams, mono_tags) atLeastLessThan0 finite_atLeastLessThan finite_insert output_vars_kzp_def)
  qed
end

definition f :: "kzp trm \<Rightarrow> kzp trm" where
  "f x \<equiv> App f_kzp [x]"

definition g :: "kzp trm \<Rightarrow> kzp trm \<Rightarrow> kzp trm" where
  "g x y \<equiv> App g_kzp [x, y]"

definition P :: "kzp trm \<Rightarrow> kzp skat" where
  "P x \<equiv> pred (Pred P_kzp [x])"

definition vx :: "kzp trm " where
  "vx \<equiv> App x_kzp []"

definition bot :: "kzp trm" where
  "bot \<equiv> App bot_kzp []"

declare f_def [skat_simp]
  and g_def [skat_simp]
  and bot_def [skat_simp]
  and P_def [skat_simp]
  and vx_def [skat_simp]

(* Sequences *)

abbreviation loop where "loop v \<equiv> skat_star (seq v)"

(* Useful lemmas *)

(* Sliding *)

lemma seq_slide:
  assumes xs_def: "xs = drop n ys"
  shows "seq xs\<cdot>(seq ys)\<^sup>\<star> = (seq (xs @ take n ys))\<^sup>\<star>\<cdot>seq xs"
proof -
  have "seq xs \<cdot> (seq (take n ys) \<cdot> seq xs)\<^sup>\<star> = (seq xs \<cdot> seq (take n ys))\<^sup>\<star> \<cdot> seq xs"
    by (simp add: ska.star_slide[simplified,symmetric])
  thus ?thesis
    by (metis append_take_drop_id assms seq_mult)
qed

(* Shorthand notation *)

definition a :: "nat \<Rightarrow> kzp skat" where
  "a i \<equiv> P (Var i)"

abbreviation a1 where "a1 \<equiv> a 1"
abbreviation a2 where "a2 \<equiv> a 2"
abbreviation a3 where "a3 \<equiv> a 3"
abbreviation a4 where "a4 \<equiv> a 4"

declare a_def [skat_simp]

lemma a_test [intro]: "a n \<in> carrier tests"
  by (simp add: a_def P_def, rule pred_closed)

lemma a_comm: "a n \<cdot> a m = a m \<cdot> a n"
  by skat_comm

lemma a_assign: "n \<noteq> m \<Longrightarrow> a n \<cdot> m := x = m := x \<cdot> a n"
  by skat_comm

definition b :: "nat \<Rightarrow> kzp skat" where
  "b i \<equiv> P (f (Var i))"

declare b_def [skat_simp]

definition c :: "nat \<Rightarrow> kzp skat" where
  "c i \<equiv> P (f (f (Var i)))"

abbreviation c2 where "c2 \<equiv> c 2"

declare c_def [skat_simp]

definition p :: "nat \<Rightarrow> nat \<Rightarrow> kzp skat" where
  "p i j \<equiv> i := f (Var j)"

declare p_def [skat_simp]

abbreviation p41 where "p41 \<equiv> p 4 1"
abbreviation p11 where "p11 \<equiv> p 1 1"
abbreviation p13 where "p13 \<equiv> p 1 3"
abbreviation p22 where "p22 \<equiv> p 2 2"

definition q :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> kzp skat" where
  "q i j k \<equiv> i := g (Var j) (Var k)"

abbreviation q214 where "q214 \<equiv> q 2 1 4"
abbreviation q311 where "q311 \<equiv> q 3 1 1"
abbreviation q211 where "q211 \<equiv> q 2 1 1"
abbreviation q222 where "q222 \<equiv> q 2 2 2"

declare q_def [skat_simp]

definition r :: "nat \<Rightarrow> nat \<Rightarrow> kzp skat" where
  "r i j \<equiv> i := f (f (Var j))"

abbreviation r13 where "r13 \<equiv> r 1 3"
abbreviation r12 where "r12 \<equiv> r 1 2"
abbreviation r22 where "r22 \<equiv> r 2 2"

declare r_def [skat_simp]

lemma p_to_r: "p n n \<cdot>p n n = r n n"
  by skat_simp (simp add: skat_assign3)

abbreviation x1 where "x1 \<equiv> 1 := vx"

definition s :: "nat \<Rightarrow> kzp skat" where
  "s i \<equiv> i := f vx"

abbreviation s1 where "s1 \<equiv> s 1"

abbreviation s2 where "s2 \<equiv> s 2"

declare s_def [skat_simp]

definition t :: "nat \<Rightarrow> kzp skat" where
  "t i \<equiv> i := g (f vx) (f vx)"

abbreviation t2 where "t2 \<equiv> t 2"

declare t_def [skat_simp]

definition u :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> kzp skat" where
  "u i j k \<equiv> i := g (f (f (Var j))) (f (f (Var k)))"

abbreviation "u222" where "u222 \<equiv> u 2 2 2"

declare u_def [skat_simp]

definition z :: "nat \<Rightarrow> kzp skat" where
  "z i \<equiv> 0 := Var i"

declare z_def [skat_simp]

abbreviation z2 where "z2 \<equiv> z 2"

definition y :: "nat \<Rightarrow> kzp skat" where
  "y i \<equiv> i := null"

declare y_def [skat_simp]

definition d :: "kzp skat" where
  "d \<equiv> P (f vx)"

declare d_def [skat_simp]

no_notation
  one_class.one ("1") and
  dioid.one ("1\<index>") and
  dioid.zero ("0\<index>") and
  zero_class.zero ("0") and
  plus_class.plus (infixl "+" 65)

abbreviation halt where "halt \<equiv> SKAT.halt [1,2,3,4]"

definition scheme1 where "scheme1 \<equiv>
  [ 1 := vx, 4 := f (Var 1), 1 := f (Var 1)
  , 2 := g (Var 1) (Var 4), 3 := g (Var 1) (Var 1)
  , loop
    [ !(P (Var 1)), 1 := f (Var 1)
    , 2 := g (Var 1) (Var 4), 3 := g (Var 1) (Var 1)
    ]
  , P (Var 1), 1 := f (Var 3)
  , loop
    [ !(P (Var 4)) + seq
      [ P (Var 4)
      , (!(P (Var 2)); 2 := f (Var 2))\<^sup>\<star>
      , P (Var 2), ! (P (Var 3))
      , 4 := f (Var 1), 1 := f (Var 1)
      ]
    , 2 := g (Var 1) (Var 4), 3 := g (Var 1) (Var 1)
    , loop
      [ !(P (Var 1)), 1 := f (Var 1)
      , 2 := g (Var 1) (Var 4), 3 := g (Var 1) (Var 1)
      ]
    , P (Var 1), 1 := f (Var 3)
    ]
  , P (Var 4)
  , (!(P (Var 2)) \<cdot> 2 := f (Var 2))\<^sup>\<star>
  , P (Var 2), P (Var 3), 0 := Var 2, halt
  ]"

definition scheme2 where "scheme2 \<equiv>
  [ 2 := f vx, P (Var 2)
  , 2 := g (Var 2) (Var 2)
  , loop
    [ !(P (Var 2))
    , 2 := f (f (Var 2))
    , P (Var 2)
    , 2 := g (Var 2) (Var 2)
    ]
  , P (Var 2), 0 := Var 2, halt
  ]"

declare Nat.One_nat_def [simp del]
declare foldr.simps[skat_simp]
declare o_def[skat_simp]
declare id_def[skat_simp]
declare halt.simps(1) [simp del]

lemma seq_merge: "seq (Vx#Vy#Vxs) = seq (Vx\<cdot>Vy#Vxs)"
  by (metis seq_cons skd.mult_assoc)

lemma kozen1: "p41\<cdot>p11 = p41\<cdot>p11\<cdot>(a1 iff a4)"
  by (subst bicon_comm) (auto simp add: pred_closed p_def a_def P_def f_def intro: eq_pred)

lemma kozen1_seq: "seq [p41,p11] = seq [p41,p11,(a1 iff a4)]"
  by (metis kozen1 seq_merge)

lemma kozen2: "p41\<cdot>p11\<cdot>q214 = p41\<cdot>p11\<cdot>q211"
proof -
  have "p41\<cdot>p11\<cdot>q214 = 4 := f (Var 1); 1 := f (Var 1); 2 := g (Var 1) (Var 4)"
    by (simp add: p_def q_def)
  also have "... = 1 := f (Var 1); 4 := Var 1; 2 := g (Var 1) (Var 4)"
    by (subst skat_assign1_var[symmetric]) (auto simp add: f_def)
  also have "... = 1 := f (Var 1); 4 := Var 1; 2 := g (Var 1) (Var 1)"
    by (simp add: g_def f_def skd.mult_assoc, subst skat_assign2_var, auto)
  also have "... = 4 := f (Var 1); 1 := f (Var 1); 2 := g (Var 1) (Var 1)"
    by (subst skat_assign1_var) (auto simp add: f_def)
  also have "... = p41\<cdot>p11\<cdot>q211"
    by (simp add: p_def q_def)
  finally show ?thesis .
qed

lemma kozen3: "p41\<cdot>p11\<cdot>q211\<cdot>q311\<cdot>a1\<cdot>a4 = p41\<cdot>p11\<cdot>q211\<cdot>q311\<cdot>a1"
proof -
  have "p41\<cdot>p11\<cdot>q211\<cdot>q311\<cdot>a1 = p41\<cdot>p11\<cdot>(a1 iff a4)\<cdot>q211\<cdot>q311\<cdot>a1"
    by (metis kozen1)
  also have "... = p41\<cdot>p11\<cdot>q211\<cdot>q311\<cdot>(a1 iff a4)\<cdot>a1"
    apply (subgoal_tac "(a1 iff a4)\<cdot>q211 = q211\<cdot>(a1 iff a4)" "(a1 iff a4)\<cdot>q311 = q311\<cdot>(a1 iff a4)")
    apply (smt skd.mult_assoc)
    by (skat_comm, auto)+
  also have "... = p41\<cdot>p11\<cdot>q211\<cdot>q311\<cdot>a1\<cdot>a4"
    apply (subgoal_tac "a1 iff a4 ; a1 = a1\<cdot>a4")
    apply (smt skd.mult_assoc)
    apply (subst bicon_comm)
    apply auto
    apply (subst bicon_conj1)
    apply auto
    by (rule a_comm)
  finally show ?thesis ..
qed

lemma kozen3_seq: "seq [p41,p11,q211,q311,a1,a4] = seq [p41,p11,q211,q311,a1]"
  by (simp add: seq_def skd.mult_onel kozen3)

lemma kozen4_seq: "seq [q211,q311,r13] = seq [q211,q311,r12]"
proof -
  have "q211\<cdot>q311\<cdot>r13 = 2 := g (Var 1) (Var 1); 3 := g (Var 1) (Var 1); 1 := f (f (Var 3))"
    by (simp add: q_def r_def)
  also have "... = 2 := g (Var 1) (Var 1); 3 := Var 2; 1 := f (f (Var 3))"
    by (subst skat_assign2_var[symmetric]) (auto simp add: g_def)
  also have "... = 2 := g (Var 1) (Var 1); 3 := Var 2; 1 := f (f (Var 2))"
    by (simp add: f_def g_def skd.mult_assoc, subst skat_assign2_var, auto)
  also have "... = 2 := g (Var 1) (Var 1); 3 := g (Var 1) (Var 1); 1 := f (f (Var 2))"
    by (subst skat_assign2_var) (auto simp add: g_def)
  finally show ?thesis
    by (simp add: q_def r_def seq_def skd.mult_onel)
qed

lemma kozen5': "q211\<cdot>q311 = q211\<cdot>q311\<cdot>(a2 iff a3)"
  by (auto simp add: pred_closed q_def a_def P_def g_def intro: eq_pred)

lemma kozen5_seq1: "seq [q211,q311,a3] = seq [q211,q311,a2]"
proof -
  have "q211\<cdot>q311\<cdot>a3 = q211\<cdot>q311\<cdot>(a2 iff a3)\<cdot>a3"
    by (metis kozen5')
  also have "... = q211\<cdot>q311\<cdot>a2\<cdot>a3"
    by (subgoal_tac "(a2 iff a3)\<cdot>a3 = a2\<cdot>a3") (auto simp add: skd.mult_assoc intro: bicon_conj1)
  also have "... = q211\<cdot>q311\<cdot>a3\<cdot>a2"
    by (metis skd.mult_assoc a_comm)
  also have "... = q211\<cdot>q311\<cdot>(a3 iff a2)\<cdot>a2"
    by (subgoal_tac "(a3 iff a2)\<cdot>a2 = a3\<cdot>a2") (auto simp add: skd.mult_assoc intro: bicon_conj1)
  also have "... = q211\<cdot>q311\<cdot>(a2 iff a3)\<cdot>a2"
    by (subst bicon_comm, auto)
  also have "... = q211\<cdot>q311\<cdot>a2"
    by (smt kozen5')
  finally show ?thesis
    by (simp add: seq_def skd.mult_onel)
qed

lemma kozen5_seq2: "seq [q211,q311,!a3] = seq [q211,q311,!a2]"
proof -
  have "q211\<cdot>q311\<cdot>!a3 = q211\<cdot>q311\<cdot>(!a2 iff !a3)\<cdot>!a3"
    by (subst kozen5', subst bicon_not, auto)
  also have "... = q211\<cdot>q311\<cdot>!a2\<cdot>!a3"
    by (subgoal_tac "(!a2 iff !a3)\<cdot>!a3 = !a2\<cdot>!a3") (auto simp add: skd.mult_assoc intro: bicon_conj1 not_closed)
  also have "... = q211\<cdot>q311\<cdot>!a3\<cdot>!a2"
    by (subgoal_tac "!a3\<cdot>!a2 = !a2\<cdot>!a3", smt skd.mult_assoc, skat_comm)
  also have "... = q211\<cdot>q311\<cdot>(!a3 iff !a2)\<cdot>!a2"
    by (subgoal_tac "(!a3 iff !a2)\<cdot>!a2 = !a3\<cdot>!a2") (auto simp add: skd.mult_assoc intro: bicon_conj1 not_closed)
  also have "... = q211\<cdot>q311\<cdot>(!a2 iff !a3)\<cdot>!a2"
    by (subst bicon_comm) (auto intro: not_closed)
  also have "... = q211\<cdot>q311\<cdot>!a2"
    by (subst bicon_not[symmetric], auto, smt kozen5')
  finally show ?thesis
    by (simp add: seq_def skd.mult_onel)
qed

lemma plus_indiv: "\<lbrakk>vx1 = x2; y1 = y2\<rbrakk> \<Longrightarrow> (vx1::kzp skat) + y1 = x2 + y2"
  by auto

lemma lemma41: "r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>!a2 = \<zero>"
proof -
  have "r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>!a2 \<sqsubseteq> r12\<cdot>a1\<cdot>p22\<cdot>(a2 + !a2)\<cdot>p22\<cdot>!a2"
    by (smt skat_order_def skd.add_assoc skd.add_comm skd.add_idem skd.distl skd.distr)
  also have "... = r12\<cdot>a1\<cdot>p22\<cdot>p22\<cdot>!a2"
    by (subst complement_one) (auto simp add: mult_oner)
  also have "... = r12\<cdot>a1\<cdot>r22\<cdot>!a2"
    by (metis p_to_r skd.mult_assoc)
  also have "... = r12\<cdot>r22\<cdot>a1\<cdot>!a2"
    by (subgoal_tac "a1\<cdot>r22 = r22\<cdot>a1", metis skd.mult_assoc, skat_comm)
  also have "... = r12\<cdot>r22\<cdot>(a1 iff a2)\<cdot>a1\<cdot>!a2"
    by (subgoal_tac "r12\<cdot>r22 = r12\<cdot>r22\<cdot>(a1 iff a2)") (auto simp add: r_def a_def P_def f_def intro: eq_pred)
  also have "... = \<zero>"
    apply (subgoal_tac "a1 iff a2; a1; !a2 = \<zero>")
    apply (metis skd.mult_assoc skd.mult_zeror)
    apply (subst bicon_comm)
    apply auto
    apply (subst bicon_conj1)
    apply auto
    apply (subgoal_tac "a2\<cdot>!a2 = \<zero>")
    apply (metis a_comm skd.mult_assoc skd.mult_zeror)
    apply (subst complement_zero)
    by auto
  finally show ?thesis
    by (metis skd.nat_antisym skd.zero_min)
qed

theorem kozen_scheme_equivalence: "seq scheme1 = seq scheme2"
proof -
  have "seq scheme1 = seq
    [x1,p41,p11,q214,q311,loop [!a1,p11,q214,q311],a1,p13
    ,loop [!a4 + seq [a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11],q214,q311,loop [!a1,p11,q214,q311],a1,p13]
    ,a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,a3,z2,halt]"
    by (simp add: scheme1_def p_def[symmetric] q_def[symmetric] a_def[symmetric] z_def[symmetric])

  also have "... = seq
    [x1,p41,p11,q214,q311,loop [!a1,p11,q214,q311]
    ,loop [a1,p13,!a4 + seq [a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11],q214,q311,loop [!a1,p11,q214,q311]]
    ,a1,p13,a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,a3,z2,halt]"
    by (cong, cut 1 2, cut 6 1, simp, cut 2 4, cut 3 2, simp only: ska.star_slide[simplified])

  also have "... = seq
    [x1,p41,p11,q214,q311
    ,(seq [!a1,p11,q214,q311] + seq [a1,p13,!a4 + seq [a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11],q214,q311])\<^sup>\<star>
    ,a1,p13,a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,a3,z2,halt]"
    by (cong, cut 1 1, cut 2 5, simp add: ska.star_denest[symmetric,simplified])

  also have "... = seq
    [x1,p41,p11,q214,q311
    ,(seq [!a1,p11,q214,q311] + seq [a1,p13,!a4,q214,q311] + seq [a1,p13,a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11,q214,q311])\<^sup>\<star>
    ,a1,p13,a4,(!a2\<cdot>p22)\<^sup>\<star>,a2,a3,z2,halt]"
    apply (cong, simp, subst skd.add_assoc[simplified])
    apply (rule_tac f = "\<lambda>x. (?v + x)\<^sup>\<star>" in arg_cong)
    apply (simp add: seq_foldr skd.mult_oner)
    by (smt skd.distl skd.distr skd.mult_assoc)

  also have "... = seq
    [x1,p41,p11,q214,q311
    ,(seq [!a1,!a4,p11,q214,q311] + seq [!a1,a4,p11,q214,q311] + seq [a1,!a4,p13,q214,q311]
    + seq [a1,a4,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11,q214,q311])\<^sup>\<star>
    ,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt]"
    apply congl
    apply (rule seq_head_eq)
    apply (rule arg_cong) back
    apply (rule plus_indiv)+
    apply (auto simp add: seq_head_elim_var[OF a_test])
    apply cong
    apply skat_comm
    apply cong
    apply skat_comm
    apply (commr1 1 2)
    apply (comml1 1 3)
    apply congl
    apply (comml1 2 3)
    apply congl
    apply (auto simp add: seq_foldr mult_oner p_def output_vars_kzp_def)
    by (metis (lifting) halt_first skat_null_zero skd.mult_assoc)

  also have "... = seq
    [x1,p41,p11,q214,q311
    ,(seq [!a1,a4,p11,q214,q311]
    + seq [a1,a4,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11,q214,q311])\<^sup>\<star>
    ,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt]"
    apply congl
    apply (cut 1 1, simp, cut 6 1, simp)
    apply (subst skd.add_assoc[simplified])
    apply (subst skd.add_comm[simplified]) back
    apply (subst skd.add_assoc[symmetric,simplified])
    apply (subst skd.add_assoc[simplified]) back
    apply (rule ska.kozen_skat_lemma[simplified])
    apply (subgoal_tac "seq [!a1,!a4,p11,q214,q311] = seq [!a1,p11,q214,q311,!a4]")
    apply (erule ssubst)
    apply (subgoal_tac "seq [a1,!a4,p13,q214,q311] = seq [a1,p13,q214,q311,!a4]")
    apply (erule ssubst)
    apply (commr1 3 1)
    apply (commr1 4 1)
    apply (simp add: skd.distr[simplified] skd.distl[simplified])
    apply (zero, auto simp add: skd.add_zerol)+
    prefer 3
    apply (subgoal_tac "seq [(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt] = seq [a4,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]")
    apply (erule ssubst)
    apply (subgoal_tac "seq [!a1,!a4,p11,q214,q311] = seq [!a1,p11,q214,q311,!a4]")
    apply (erule ssubst)
    apply (subgoal_tac "seq [a1,!a4,p13,q214,q311] = seq [a1,p13,q214,q311,!a4]")
    apply (erule ssubst)
    apply (simp add: skd.distr[simplified])
    apply (comml1 2 5)
    apply (comml1 4 5)
    apply (zero, auto simp add: skd.add_zerol)+
    apply seq_comm
    apply seq_comm
    apply (comml1 2 2, cong)
    by seq_comm

  also have "... = seq
    [x1,p41,p11,q214,q311
    ,(seq [a1,a4,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11,q214,q311])\<^sup>\<star>
    ,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt]"
    apply congr
    apply (subst seq_foldr)
    apply (subst seq_foldr) back back
    apply (simp add: skd.mult_assoc[symmetric,simplified] skd.mult_oner[simplified])
    apply (rule ska.kozen_skat_lemma_dual[simplified])
    apply (cut 1 6, cut 2 2, seq_select 2, subst kozen1_seq, seq_deselect)
    apply (subst seq_mult[symmetric], subst seq_mult[symmetric], simp)
    apply (subst zippify, simp)
    apply (subst zip_right)
    apply (subst zip_right)
    apply (comml1 1 4)
    apply (comml1 1 4)
    apply (subst seq_merge)
    apply (rule zip_zero)
    apply (metis (lifting) a_test bicon_zero)
    apply (subst skd.mult_assoc[simplified])
    apply (subst kozen1)
    apply (simp add: skd.mult_assoc[symmetric,simplified])
    apply (subst seq_singleton[symmetric])
    apply seq_rev
    apply (subst qes_snoc[symmetric])+
    apply (subst qes_snoc)
    apply (subst zip_right, subst zip_right)
    apply (comml1 1 4)
    apply (comml1 1 4)
    apply (subst seq_merge, rule zip_zero)
    by (metis (lifting) a_test bicon_zero)

  also have "... = seq
    [x1,p41,p11,q211,q311
    ,(seq [a1,a4,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3,p41,p11,q211,q311])\<^sup>\<star>
    ,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt]"
    by (simp add: seq_def skd.mult_onel[simplified], smt kozen2 skd.mult_assoc)

  also have "... = seq
    [x1,(seq [p41,p11,q211,q311,a1,a4,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3])\<^sup>\<star>
    ,p41,p11,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,a4,z2,halt]"
    by (cong, cut 1 4, cut 3 6, cut 6 4, cut 5 1, simp add: ska.star_slide)

  also have "... = seq
    [x1,(seq [p41,p11,q211,q311,a1,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3])\<^sup>\<star>
    ,p41,p11,q211,q311,a1,(!a2\<cdot>p22)\<^sup>\<star>,a2,a3,z2,halt]"
    apply (cut 2 6, zip 1 7, subst zip_comm, skat_comm)
    apply (zip 3 3)
    apply (subst zip_comm, skat_comm, subst zip_right)+
    apply (unzip+, cut 1 2, cut 4 6)
    apply (simp add: kozen3_seq)
    by (subst seq_mult[symmetric], simp)+

  also have "... = seq
    [x1,(seq [p41,p11,q211,q311,a1,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3])\<^sup>\<star>
    ,p41,p11,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]"
    by (congr, zip 3 7, subst zip_comm, skat_comm, unzip, seq_deselect)

  also have "... = seq
    [x1,(seq [p11,q211,q311,a1,p13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3])\<^sup>\<star>
    ,p11,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]"
    by (eliminate_variable 4)

  also have "... = seq
    [x1,p11,(seq [q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,!a3,p13,p11])\<^sup>\<star>
    ,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]"
    by (commr1 2 5, commr1 2 4 1, simp add: seq_def mult_onel, smt ska.star_slide skd.mult_assoc)

  also have "... = seq
    [s1,(seq [q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,!a3,r13])\<^sup>\<star>
    ,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]"
  proof -
    have "x1\<cdot>p11 = s1"
      by (simp add: vx_def f_def p_def s_def, subst skat_assign3, auto)
    moreover have "p13\<cdot>p11 = r13"
      by (simp add: f_def p_def r_def, subst skat_assign3, auto)
    ultimately show ?thesis
      by (simp add: seq_def skd.mult_onel) (smt skd.mult_assoc)
  qed

  also have "... = seq
    [s1,(seq [a1,q211,q311,r13,(!a2\<cdot>p22)\<^sup>\<star>,a2,!a3])\<^sup>\<star>
    ,q211,q311,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,a3,z2,halt]"
    by (comml1 2 4, comml1 2 7)

  also have "... = seq
    [s1,(seq [a1,q211,q311,!a2,r12,(!a2\<cdot>p22)\<^sup>\<star>,a2])\<^sup>\<star>
    ,q211,q311,a2,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,z2,halt]"
    apply (cut 2 1)
    apply (cut 3 3)
    apply (simp only: kozen4_seq seq_mult[symmetric] append.simps)
    apply (comml1 2 7, comml1 1 8, cut 1 2, cut 3 3, cut 2 1, cut 3 3)
    apply (simp add: kozen5_seq1 kozen5_seq2)
    by (simp add: seq_def mult_onel skd.mult_assoc[simplified])

  also have "... = seq
    [s1,(seq [a1,q211,!a2,r12,(!a2\<cdot>p22)\<^sup>\<star>,a2])\<^sup>\<star>
    ,q211,a2,(!a2\<cdot>p22)\<^sup>\<star>,a1,a2,z2,halt]"
    by (eliminate_variable 3)

  also have "... = seq
    [s1,(seq [a1,q211,r12,!a2,p22,(!a2\<cdot>p22)\<^sup>\<star>,a2])\<^sup>\<star>
    ,q211,a1,a2,z2,halt]"
  proof -
    have "!a2\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2 = !a2\<cdot>a2 + !a2\<cdot>!a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2"
      by (smt mult_oner ska.star_unfoldl_eq skd.distl skd.distr skd.mult_assoc)
    also have "... = !a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2"
      by (smt skd.add_zerol a_test not_closed skt.test_meet_idem complement_zero not_closed skt.test_mult_comm)
    finally have a: "!a2\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2 = !a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2" .

    have "a2\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2 = a2\<cdot>a2 + a2\<cdot>!a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2"
      by (smt mult_oner ska.star_unfoldl_eq skd.distl skd.distr skd.mult_assoc)
    also have "... = a2"
      by (metis skd.add_zeror skd.mult_zerol a_test complement_zero skt.test_meet_idem)
    finally have b: "a2\<cdot>(!a2\<cdot>p22)\<^sup>\<star>\<cdot>a2 = a2" .

    from a b show ?thesis
      by (comml1 2 4 1, simp add: seq_def mult_onel, smt a_comm skd.mult_assoc)
  qed

  also have "... = seq
    [s1,a1,q211,(seq [r12,!a2,p22,(!a2\<cdot>p22)\<^sup>\<star>,a2,a1,q211])\<^sup>\<star>,a2,z2,halt]"
    apply (comml1 1 4 1)
    apply (cut 1 1)
    apply (cut 2 3)
    apply (cut 3 2)
    apply (cut 2 1)
    apply (simp add: seq_singleton)
    apply (subst ska.star_slide[simplified])
    by (simp add: seq_def mult_onel skd.mult_assoc)

  also have "... = seq
    [s1,a1,q211,(seq [!a2,r12,p22,(!a2\<cdot>p22)\<^sup>\<star>,a2,a1,q211])\<^sup>\<star>,a2,z2,halt]"
    by (comml1 2 2)

  also have "... = seq
    [s1,a1,q211,(seq [!a2,r12,a1,p22,a2,q211] + seq [!a2,r12,a1,p22,!a2,p22,a2,q211])\<^sup>\<star>
    ,a2,z2, halt]"
  proof -
    have "r12\<cdot>a1\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star> = r12\<cdot>a1\<cdot>p22\<cdot>(\<one> + !a2\<cdot>p22 + !a2\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>)"
      apply (subst ska.star_unfoldl_eq[simplified])
      apply (subst ska.star_unfoldl_eq[simplified])
      by (smt skd.add_assoc skd.distl skd.mult_assoc skd.mult_oner)
    also have "... = r12\<cdot>a1\<cdot>p22 + r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22 + r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star>"
      by (smt skd.mult_oner skd.distl skd.mult_assoc)
    also have "... = r12\<cdot>a1\<cdot>p22 + r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22"
      by (smt lemma41 skd.add_zeror skd.mult_zerol)
    finally have "r12\<cdot>a1\<cdot>p22\<cdot>(!a2\<cdot>p22)\<^sup>\<star> = r12\<cdot>a1\<cdot>p22 + r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22" .

    thus ?thesis
      apply (cong, simp)
      apply (comml1 1 6)
      apply (simp add: seq_def skd.mult_onel)
      by (smt skd.distl skd.distr skd.mult_assoc)
  qed

  also have "... = seq
    [s1,a1,q211,(seq [!a2,r12,a1,p22,a2,q211] + seq [!a2,r12,a1,p22,!a2,p22,q211])\<^sup>\<star>
    ,a2,z2, halt]"
  proof -
    have "r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22 = r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>\<one>"
      by (metis skd.mult_oner)
    also have "... = r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>(a2 + !a2)"
      by (subst complement_one) auto
    also have "... = r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>a2 + r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>!a2"
      by (metis skd.distl)
    also have "... = r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>a2"
      by (smt lemma41 skd.add_zeror)
    finally have "r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22 = r12\<cdot>a1\<cdot>p22\<cdot>!a2\<cdot>p22\<cdot>a2" .

    thus ?thesis
      apply cong
      apply (rule arg_cong) back back back back
      apply (simp add: seq_def skd.mult_onel)
      by (smt skd.mult_assoc)
  qed

  also have "... = seq
    [s1,a1,q211,(seq [!a2,r12,a1,p22,a2,q211] + seq [!a2,r12,a1,p22,!a2,q211])\<^sup>\<star>
    ,a2,z2, halt]"
  proof -
    have "p22\<cdot>q211 = q211"
      by (simp add: p_def q_def g_def f_def skat_assign3)
    thus ?thesis
      by (simp add: seq_def skd.mult_onel) (smt skd.mult_assoc)
  qed

  also have "... = seq [s1,a1,q211,(seq [!a2,r12,a1,p22,(a2 + !a2),q211])\<^sup>\<star>,a2,z2, halt]"
    apply cong
    apply (rule arg_cong) back back back
    by (smt seq_cons skd.distl skd.distr)

  also have "... = seq [s1,a1,q211,(seq [!a2,r12,a1,p22,q211])\<^sup>\<star>,a2,z2, halt]"
    by (subst complement_one, auto simp add: seq_def skd.mult_onel skd.mult_oner)

  also have "... = seq [s1,a1,q211,(seq [!a2,r12,a1,q211])\<^sup>\<star>,a2,z2, halt]"
  proof -
    have "p22\<cdot>q211 = q211"
      by (simp add: p_def q_def g_def f_def skat_assign3)
    thus ?thesis
      by (simp add: seq_def skd.mult_onel) (smt skd.mult_assoc)
  qed

  also have "... = seq [d,s1,t2,(seq [!a2,c2,r12,u222])\<^sup>\<star>,a2,z2,halt]"
  proof -
    {
      have "s1\<cdot>a1\<cdot>q211 = d\<cdot>s1\<cdot>q211"
        by (simp add: s_def a_def f_def P_def d_def skat_assign4_var[symmetric])
      also have "... = d\<cdot>s1\<cdot>t2"
        apply (simp add: t_def s_def d_def f_def P_def q_def g_def vx_def skd.mult_assoc)
        apply (rule arg_cong) back
        apply (rule skat_assign2_var)
        by auto
      finally have "s1\<cdot>a1\<cdot>q211 = d\<cdot>s1\<cdot>t2" .
    }
    moreover
    {
      have "r12\<cdot>a1\<cdot>q211 = c2\<cdot>r12\<cdot>q211"
        by (simp add: r_def a_def f_def P_def c_def skat_assign4_var[symmetric])
      also have "... = c2\<cdot>r12\<cdot>u222"
        apply (simp add: c_def r_def u_def f_def P_def q_def g_def vx_def skd.mult_assoc)
        apply (rule arg_cong) back
        apply (rule skat_assign2_var)
        by auto
      finally have "r12\<cdot>a1\<cdot>q211 = c2\<cdot>r12\<cdot>u222" .
    }
    ultimately show ?thesis
      by (simp add: seq_def skd.mult_onel) (smt skd.mult_assoc)
  qed

  also have "... = seq [d,t2,(seq [!a2,c2,u222])\<^sup>\<star>,a2,z2,halt]"
    by (eliminate_variable 1)

  also have "... = seq [s2,a2,q222,(seq [!a2,r22,a2,q222])\<^sup>\<star>,a2,z2,halt]"
  proof -
    {
      have "d\<cdot>t2 = d\<cdot>s2\<cdot>q222"
        by (simp add: g_def d_def t_def s_def q_def skd.mult_assoc, subst skat_assign3, auto)
      also have "... = s2\<cdot>a2\<cdot>q222"
        by (simp add: d_def s_def a_def f_def P_def skat_assign4_var[symmetric])
      finally have "d\<cdot>t2 = s2\<cdot>a2\<cdot>q222" .
    }
    moreover
    {
      have "c2\<cdot>u222 = c2\<cdot>r22\<cdot>q222"
        by (simp add: g_def c_def u_def r_def q_def skd.mult_assoc, subst skat_assign3, auto)
      also have "... = r22\<cdot>a2\<cdot>q222"
        by (simp add: f_def P_def a_def r_def c_def skat_assign4_var[symmetric])
      finally have "c2\<cdot>u222 = r22\<cdot>a2\<cdot>q222" .
    }
    ultimately show "?thesis"
      by (simp add: seq_def skd.mult_onel) (smt skd.mult_assoc)
  qed

  also have "... = seq scheme2"
    by (simp add: scheme2_def) skat_simp

  finally show ?thesis .
qed

end


theory Ex_1_1
  imports Main
begin

primrec snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] a = [a]" |
"snoc (x # xs) a = x # snoc xs a"

value "snoc [] a = [a]"
value "snoc [a,b,c] d = [a,b,c,d]"

lemma snoc_append[simp]: "snoc xs a = xs @ [a]"
  apply (induction xs)
   apply (auto)
  done

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
  apply (induction xs)
  apply (auto)
  done

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Set Partitions\<close>

theory Card_Partitions
imports
  "HOL-Combinatorics.Stirling"
  Set_Partition
  Injectivity_Solver
begin

lemma set_partition_on_insert_with_fixed_card_eq:
  assumes "finite A"
  assumes "a \<notin> A"
  shows "{P. partition_on (insert a A) P \<and> card P = Suc k} = (do {
     P <- {P. partition_on A P \<and> card P = Suc k};
     p <- P;
     {insert (insert a p) (P - {p})}
  })
  \<union> (do {
    P <- {P. partition_on A P \<and> card P = k};
    {insert {a} P}
  })" (is "?S = ?T")
proof
  show "?S \<subseteq> ?T"
  proof
    fix P
    assume "P \<in> {P. partition_on (insert a A) P \<and> card P = Suc k}"
    from this have "partition_on (insert a A) P" and "card P = Suc k" by auto
    show "P \<in> ?T"
    proof cases
      assume "{a} \<in> P"
      have "partition_on A (P - {{a}})"
        using \<open>{a} \<in> P\<close> \<open>partition_on (insert a A) P\<close>[THEN partition_on_Diff, of "{{a}}"] \<open>a \<notin> A\<close>
        by auto
      moreover from \<open>{a} \<in> P\<close> \<open>card P = Suc k\<close> have "card (P - {{a}}) = k"
        by (subst card_Diff_singleton) (auto intro: card_ge_0_finite)
      moreover from \<open>{a} \<in> P\<close> have "P = insert {a} (P - {{a}})" by auto
      ultimately have "P \<in> {P. partition_on A P \<and> card P = k} \<bind> (\<lambda>P. {insert {a} P})"
        by auto
      from this show ?thesis by auto
    next
      assume "{a} \<notin> P"
      let ?p' = "(THE X. a \<in> X \<and> X \<in> P)"
      let ?p = "(THE X. a \<in> X \<and> X \<in> P) - {a}"
      let ?P' = "insert ?p (P - {?p'})"
      from \<open>partition_on (insert a A) P\<close> have "a \<in> (THE X. a \<in> X \<and> X \<in> P)"
        using partition_on_in_the_unique_part by fastforce
      from \<open>partition_on (insert a A) P\<close> have "(THE X. a \<in> X \<and> X \<in> P) \<in> P"
        using partition_on_the_part_mem by fastforce
      from this \<open>partition_on (insert a A) P\<close> have "(THE X. a \<in> X \<and> X \<in> P) - {a} \<notin> P"
        using partition_subset_imp_notin \<open>a \<in> (THE X. a \<in> X \<and> X \<in> P)\<close> by blast
      have "(THE X. a \<in> X \<and> X \<in> P) \<noteq> {a}"
        using \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> \<open>{a} \<notin> P\<close> by auto
      from \<open>partition_on (insert a A) P\<close> have "(THE X. a \<in> X \<and> X \<in> P) \<subseteq> insert a A"
        using \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> partition_onD1 by fastforce
      note facts_on_the_part_of = \<open>a \<in> (THE X. a \<in> X \<and> X \<in> P)\<close> \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close>
        \<open>(THE X. a \<in> X \<and> X \<in> P) - {a} \<notin> P\<close> \<open>(THE X. a \<in> X \<and> X \<in> P) \<noteq> {a}\<close>
        \<open>(THE X. a \<in> X \<and> X \<in> P) \<subseteq> insert a A\<close>
      from \<open>partition_on (insert a A) P\<close> \<open>finite A\<close> have "finite P"
        by (meson finite.insertI finite_elements)
      from \<open>partition_on (insert a A) P\<close> \<open>a \<notin> A\<close> have "partition_on (A - ?p) (P - {?p'})"
        using facts_on_the_part_of by (auto intro: partition_on_remove_singleton)
      from this have "partition_on A ?P'"
        using facts_on_the_part_of by (auto intro: partition_on_insert simp add: disjnt_iff)
      moreover have "card ?P' = Suc k"
      proof -
        from \<open>card P = Suc k\<close> have "card (P - {THE X. a \<in> X \<and> X \<in> P}) = k"
          using \<open>finite P\<close> \<open>(THE X. a \<in> X \<and> X \<in> P) \<in> P\<close> by simp
        from this show ?thesis
          using \<open>finite P\<close> \<open>(THE X. a \<in> X \<and> X \<in> P) - {a} \<notin> P\<close> by (simp add: card_insert_if)
      qed
      moreover have "?p \<in> ?P'" by auto
      moreover have "P = insert (insert a ?p) (?P' - {?p})"
        using facts_on_the_part_of by (auto simp add: insert_absorb)
      ultimately have "P \<in> {P. partition_on A P \<and> card P = Suc k} \<bind> (\<lambda>P. P \<bind> (\<lambda>p. {insert (insert a p) (P - {p})}))"
        by auto
      then show ?thesis by auto
    qed
  qed
next
  show "?T \<subseteq> ?S"
  proof
    fix P
    assume "P \<in> ?T" (is "_ \<in> ?subexpr1 \<union> ?subexpr2")
    from this show "P \<in> ?S"
    proof
      assume "P \<in> ?subexpr1"
      from this obtain p P' where "P = insert (insert a p) (P' - {p})"
        and "partition_on A P'" and "card P' = Suc k" and "p \<in> P'"  by auto
      from \<open>p \<in> P'\<close> \<open>partition_on A P'\<close> have "partition_on (A - p) (P' - {p})"
        by (simp add: partition_on_remove_singleton)
      from \<open>partition_on A P'\<close> \<open>finite A\<close> have "finite P"
        using \<open>P = _\<close> finite_elements by auto
      from \<open>partition_on A P'\<close> \<open>a \<notin> A\<close> have "insert a p \<notin> P' - {p}"
        using partition_onD1 by fastforce
      from \<open>P = _\<close> this \<open>card P' = Suc k\<close> \<open>finite P\<close> \<open>p \<in> P'\<close>
      have "card P = Suc k" by auto
      moreover have "partition_on (insert a A) P"
        using \<open>partition_on (A - p) (P' - {p})\<close> \<open>a \<notin> A\<close> \<open>p \<in> P'\<close> \<open>partition_on A P'\<close> \<open>P = _\<close>
        by (auto intro!: partition_on_insert dest: partition_onD1 simp add: disjnt_iff)
      ultimately show "P \<in> ?S" by auto
    next
      assume "P \<in> ?subexpr2"
      from this obtain P' where "P = insert {a} P'" and "partition_on A P'" and "card P' = k" by auto
      from \<open>partition_on A P'\<close> \<open>finite A\<close> have "finite P"
        using \<open>P = insert {a} P'\<close> finite_elements by auto
      from \<open>partition_on A P'\<close> \<open>a \<notin> A\<close> have "{a} \<notin> P'"
        using partition_onD1 by fastforce
      from \<open>P = insert {a} P'\<close> \<open>card P' = k\<close> this \<open>finite P\<close> have "card P = Suc k" by auto
      moreover from \<open>partition_on A P'\<close> \<open>a \<notin> A\<close> have "partition_on (insert a A) P"
        using \<open>P = insert {a} P'\<close> by (simp add: partition_on_insert_singleton)
      ultimately show "P \<in> ?S" by auto
    qed
  qed
qed

lemma injectivity_subexpr2:
  assumes "a \<notin> A"
  assumes "insert {a} P = insert {a} P'"
  assumes "(partition_on A P \<and> card P = k') \<and> partition_on A P' \<and> card P' = k'"
  shows "P = P'"
proof -
  from assms(1, 3) have "{a} \<notin> P" and "{a} \<notin> P'"
    using partition_onD1 by auto
  from \<open>{a} \<notin> P\<close> have "P = insert {a} P - {{a}}" by simp
  also from \<open>insert {a} P = insert {a} P'\<close> have "\<dots> = insert {a} P' - {{a}}" by simp
  also from \<open>{a} \<notin> P'\<close> have "\<dots> = P'" by simp
  finally show ?thesis .
qed

theorem card_partition_on:
  assumes "finite A"
  shows "card {P. partition_on A P \<and> card P = k} = Stirling (card A) k"
using assms
proof (induct A arbitrary: k)
  case empty
    have eq: "{P. P = {} \<and> card P = 0} = {{}}" by auto
    show ?case by (cases k) (auto simp add: partition_on_empty eq)
next
  case (insert a A)
  from this show ?case
  proof (cases k)
    case 0
    from insert(1) have empty: "{P. partition_on (insert a A) P \<and> card P = 0} = {}"
      unfolding partition_on_def by (auto simp add: card_eq_0_iff finite_UnionD)
    from 0 insert show ?thesis by (auto simp add: empty)
  next
    case (Suc k')
    let ?subexpr1 = "do {
      P <- {P. partition_on A P \<and> card P = Suc k'};
      p <- P;
      {insert (insert a p) (P - {p})}
    }"
    let ?subexpr2 = "do {
      P <- {P. partition_on A P \<and> card P = k'};
      {insert {a} P}
    }"
    let ?expr = "?subexpr1 \<union> ?subexpr2"
    have "card {P. partition_on (insert a A) P \<and> card P = k} = card ?expr"
      using \<open>finite A\<close> \<open>a \<notin> A\<close> \<open>k = Suc k'\<close> by (simp add: set_partition_on_insert_with_fixed_card_eq)
    also have "card ?expr = Stirling (card A) k' + Stirling (card A) (Suc k') * Suc k'"
    proof -
      have "finite ?subexpr1 \<and> card ?subexpr1 = Stirling (card A) (Suc k') * Suc k'"
      proof -
        from \<open>finite A\<close> have "finite {P. partition_on A P \<and> card P = Suc k'}"
          by (simp add: finitely_many_partition_on)
        moreover have "\<forall>X\<in>{P. partition_on A P \<and> card P = Suc k'}. finite (X \<bind> (\<lambda>p. {insert (insert a p) (X - {p})}))"
          using finite_elements \<open>finite A\<close> finite_bind
          by (metis (no_types, lifting) finite.emptyI finite_insert mem_Collect_eq)
        moreover have "disjoint_family_on (\<lambda>P. P \<bind> (\<lambda>p. {insert (insert a p) (P - {p})})) {P. partition_on A P \<and> card P = Suc k'}"
          by (injectivity_solver rule: injectivity_subexpr1(1)[OF \<open>a \<notin> A\<close>])
        moreover have "card (P \<bind> (\<lambda>p. {insert (insert a p) (P - {p})})) = Suc k'"
          if "P \<in> {P. partition_on A P \<and> card P = Suc k'}" for P
        proof -
          from that \<open>finite A\<close> have "finite P"
            using finite_elements by blast
          moreover have "inj_on (\<lambda>p. insert (insert a p) (P - {p})) P"
            using that injectivity_subexpr1(2)[OF \<open>a \<notin> A\<close>] by (simp add: inj_onI)
          moreover from that have "card P = Suc k'" by simp
          ultimately show ?thesis by (simp add: card_bind_singleton)
        qed
        ultimately have "card ?subexpr1 = card {P. partition_on A P \<and> card P = Suc k'} * Suc k'"
          by (subst card_bind_constant) simp+
        from this have "card ?subexpr1 = Stirling (card A) (Suc k') * Suc k'"
          using insert.hyps(3) by simp
        moreover have "finite ?subexpr1"
          using \<open>finite {P. partition_on A P \<and> card P = Suc k'}\<close>
          \<open>\<forall>X\<in>{P. partition_on A P \<and> card P = Suc k'}. finite (X \<bind> (\<lambda>p. {insert (insert a p) (X - {p})}))\<close>
          by (auto intro: finite_bind)
        ultimately show ?thesis by blast
      qed
      moreover have "finite ?subexpr2 \<and> card ?subexpr2 = Stirling (card A) k'"
      proof -
        from \<open>finite A\<close> have "finite {P. partition_on A P \<and> card P = k'}"
          by (simp add: finitely_many_partition_on)
        moreover have " inj_on (insert {a}) {P. partition_on A P \<and> card P = k'}"
          using injectivity_subexpr2[OF \<open>a \<notin> A\<close>] by (simp add: inj_on_def)
        ultimately have "card ?subexpr2 = card {P. partition_on A P \<and> card P = k'}"
          by (simp add: card_bind_singleton)
        also have "\<dots> = Stirling (card A) k'"
          using insert.hyps(3) .
        finally have "card ?subexpr2 = Stirling (card A) k'" .
        moreover have "finite ?subexpr2"
          by (simp add: \<open>finite {P. partition_on A P \<and> card P = k'}\<close> finite_bind)
        ultimately show ?thesis by blast
      qed
      moreover have "?subexpr1 \<inter> ?subexpr2 = {}"
      proof -
        have "\<forall>P\<in>?subexpr1. {a} \<notin> P"
          using insert.hyps(2) by (force elim!: partition_onE)
        moreover have "\<forall>P\<in>?subexpr2. {a} \<in> P" by auto
        ultimately show "?subexpr1 \<inter> ?subexpr2 = {}" by blast
      qed
      ultimately show ?thesis
        by (simp add: card_Un_disjoint)
    qed
    also have "\<dots> = Stirling (card (insert a A)) k"
      using insert(1, 2) \<open>k = Suc k'\<close> by simp
    finally show ?thesis .
  qed
qed

theorem card_partition_on_at_most_size:
  assumes "finite A"
  shows "card {P. partition_on A P \<and> card P \<le> k} = (\<Sum>j\<le>k. Stirling (card A) j)"
proof -
  have "card {P. partition_on A P \<and> card P \<le> k} = card (\<Union>j\<le>k. {P. partition_on A P \<and> card P = j})"
    by (rule arg_cong[where f="card"]) auto
  also have "\<dots> = (\<Sum>j\<le>k. card {P. partition_on A P \<and> card P = j})"
    by (subst card_UN_disjoint) (auto simp add: \<open>finite A\<close> finitely_many_partition_on)
  also have "(\<Sum>j\<le>k. card {P. partition_on A P \<and> card P = j}) = (\<Sum>j\<le>k. Stirling (card A) j)"
    using \<open>finite A\<close> by (simp add: card_partition_on)
  finally show ?thesis .
qed

theorem partition_on_size1:
  assumes "finite A"
  shows "{P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)} = {(\<lambda>a. {a}) ` A}"
proof
  show "{P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)} \<subseteq> {(\<lambda>a. {a}) ` A}"
  proof
    fix P
    assume P: "P \<in> {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}"
    have "P = (\<lambda>a. {a}) ` A"
    proof
      show "P \<subseteq> (\<lambda>a. {a}) ` A"
      proof
        fix X
        assume "X \<in> P"
        from P this obtain x where "X = {x}"
           by (auto simp add: card_Suc_eq)
        from this \<open>X \<in> P\<close> have "x \<in> A"
          using P unfolding partition_on_def by blast
        from this \<open>X = {x}\<close> show "X \<in>(\<lambda>a. {a}) ` A" by auto
      qed
    next
      show "(\<lambda>a. {a}) ` A \<subseteq> P"
      proof
        fix X
        assume "X \<in> (\<lambda>a. {a}) ` A"
        from this obtain x where X: "X = {x}" "x \<in> A" by auto
        have "\<Union>P = A"
          using P unfolding partition_on_def by blast
        from this \<open>x \<in> A\<close> obtain X' where "x \<in> X'" and "X' \<in> P"
          using UnionE by blast
        from \<open>X' \<in> P\<close> have "card X' = 1"
          using P unfolding partition_on_def by auto
        from this \<open>x \<in> X'\<close> have "X' = {x}"
          using card_1_singletonE by blast
        from this X(1) \<open>X' \<in> P\<close> show "X \<in> P" by auto
      qed
    qed
    from this show "P \<in> {(\<lambda>a. {a}) ` A}" by auto
  qed
next
  show "{(\<lambda>a. {a}) ` A} \<subseteq> {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}"
  proof
    fix P
    assume "P \<in> {(\<lambda>a. {a}) ` A}"
    from this have P: "P = (\<lambda>a. {a}) ` A" by auto
    from this have "partition_on A P" by (auto intro: partition_onI)
    from P this show "P \<in> {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}" by auto
  qed
qed

theorem card_partition_on_size1:
  assumes "finite A"
  shows "card {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)} = 1"
using assms partition_on_size1 by fastforce

lemma card_partition_on_size1_eq_1:
  assumes "finite A"
  assumes "card A \<le> k"
  shows "card {P. partition_on A P \<and> card P \<le> k \<and> (\<forall>X\<in>P. card X = 1)} = 1"
proof -
  {
    fix P
    assume "partition_on A P" "\<forall>X\<in>P. card X = 1"
    from this have "P \<in> {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}" by simp
    from this have "P \<in> {(\<lambda>a. {a}) ` A}"
      using partition_on_size1 \<open>finite A\<close> by auto
    from this have "P = (\<lambda>a. {a}) ` A" by auto
    moreover from this have "card P = card A"
      by (auto intro: card_image)
  }
  from this have "{P. partition_on A P \<and> card P \<le> k \<and> (\<forall>X\<in>P. card X = 1)} = {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}"
    using \<open>card A \<le> k\<close> by auto
  from this show ?thesis
    using \<open>finite A\<close> by (simp only: card_partition_on_size1)
qed

lemma card_partition_on_size1_eq_0:
  assumes "finite A"
  assumes "k < card A"
  shows "card {P. partition_on A P \<and> card P \<le> k \<and> (\<forall>X\<in>P. card X = 1)} = 0"
proof -
  {
    fix P
    assume "partition_on A P" "\<forall>X\<in>P. card X = 1"
    from this have "P \<in> {P. partition_on A P \<and> (\<forall>X\<in>P. card X = 1)}" by simp
    from this have "P \<in> {(\<lambda>a. {a}) ` A}"
      using partition_on_size1 \<open>finite A\<close> by auto
    from this have "P = (\<lambda>a. {a}) ` A" by auto
    from this have "card P = card A"
      by (auto intro: card_image)
  }
  from this assms(2) have "{P. partition_on A P \<and> card P \<le> k \<and> (\<forall>X\<in>P. card X = 1)} = {}"
    using Collect_empty_eq leD by fastforce
  from this show ?thesis by (simp only: card.empty)
qed

end


theory Gensyn_Descend_Facts imports Gensyn_Descend
begin

(* Some lemmas about the descendent relation.
 * Some of them could use cleaner, ISAR-based proofs (TODO)
 *)

lemma gensyn_get_list_len  :
  fixes ts :: "('x) gensyn list"
  shows "\<And> kh kt t' . gensyn_get_list ts (kh#kt) = Some t' \<Longrightarrow>
          kh < length ts"
proof(induction ts )
case Nil
then show ?case by auto
  next
  case (Cons th tt)
  then show ?case
    proof(cases kh)
    case 0
    then show ?thesis by auto
    next
      case (Suc n)
      then show ?thesis using Cons
        apply(auto)
        done
    qed
  qed

lemma gensyn_get_list_len' :
  assumes H:  "gensyn_get_list ts (kh#kt) = Some t'"
  shows "kh < length (ts)" using H
proof(induct ts arbitrary:kh)
case Nil
    then show ?case by auto  next
case (Cons a ts)
    then show ?case
    proof(cases kh)
      case 0 then show ?thesis by auto  next
      case (Suc nat) then show ?thesis using Cons by auto
    qed
qed

lemma gensyn_get_list_nth :
  shows "gensyn_get_list ts [kh] = Some t' \<Longrightarrow>
          ts ! kh = t'"
proof(induction ts arbitrary:kh)
  case Nil
then show ?case by auto
next
  case (Cons a ts)
  then show ?case
  proof(cases kh)
    case 0 then show ?thesis using Cons by auto next
    case (Suc nat) then show ?thesis using Cons by auto
  qed
qed

lemma gensyn_get_list_nth2 :
  shows "kh < length ts \<Longrightarrow>
         ts ! kh = t' \<Longrightarrow>
         gensyn_get_list ts [kh] = Some t'"
proof(induction ts arbitrary:kh)
  case Nil
  then show ?case by auto
next
  case (Cons a ts)
  then show ?case
  proof(cases kh)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc nat)
    then show ?thesis using Cons by auto
  qed
qed

lemma gensyn_get_list_child  :
  assumes H:  "gensyn_get_list ts (kh#kt) = Some t'"
  shows (*glc_C1 :*) "kh < length ts"
  and (*glc_C2:*) "gensyn_get (ts ! kh) kt = Some t'"
  using H
proof(induction ts arbitrary:kh)
  case Nil
  {
  case 1 then show ?case  by auto
  next case 2
  then show ?case by auto
  }
  case (Cons a ts)
  {
    case 1 then show ?case
    proof(cases kh)
      case 0 thus ?thesis by auto next
      case (Suc n) thus ?thesis using Cons 1 by auto
    qed

    case 2 then show ?case
    proof(cases kh)
      case 0 thus ?thesis using Cons 2
        apply(case_tac kt) apply(auto)
        apply(case_tac a) apply(auto) done next
      case (Suc n) thus ?thesis using Cons 2 by auto
    qed
  }
qed

(* need converse of previous lemma, to prove last-child lemma *)
lemma gensyn_get_list_child2 :
  assumes Hg: "gensyn_get t kt = Some t'"
  and Hl: "kh < length ts"
  and Hc: "ts ! kh = t"
shows
    "gensyn_get_list ts (kh#kt) = Some t'" using Hg Hl Hc
proof(induction ts arbitrary:kh)
case Nil then show ?case by auto
next
  case (Cons a ts)
  then show ?case
  proof(cases kh)
    case 0
    then show ?thesis using Cons
      apply(case_tac kt) apply(auto)
      apply(case_tac a) apply(auto) done
  next
    case (Suc nat)
    then show ?thesis using Cons by auto
  qed
qed

lemma gensyn_get_child :
  assumes H: "gensyn_get t (kh#kt) = Some t'"
  shows  "\<exists> t'1 . gensyn_get t [kh] = Some t'1 \<and>
            gensyn_get t'1 kt = Some t'" using H
proof(cases t)
  case (G x l)
  thus ?thesis using H gensyn_get_list_child gensyn_get_list_nth2
    by auto blast+
qed

lemma gensyn_get_child2 :
  assumes H1 : "gensyn_get t [kh] = Some t'1"
  and H2 : "gensyn_get t'1 kt = Some t'"
  shows  "gensyn_get t (kh#kt) = Some t'" using H1 H2
proof(cases t)
  case (G x l)
  thus ?thesis  using H1 H2 gensyn_get_list_child2[of t'1 kt t']
                           gensyn_get_list_len[of l kh "[]" t'1]
                           gensyn_get_list_nth[of l kh t'1] by auto
qed

lemma gensyn_get_last :
  assumes H: "gensyn_get t (k@[kl]) = Some t''"
  shows "\<exists> t' . (gensyn_get t k = Some (t' :: ('x) gensyn) \<and>
         gensyn_get t' [kl] = Some t'')"  using H
proof(induction k arbitrary: t kl t'')
  case Nil then show ?case by auto next
  case (Cons a k) then show ?case
  proof(cases t)
    case (G x l)
    hence 0: "gensyn_get (l ! a) (k@[kl]) = Some t''" using Cons gensyn_get_list_child G by auto
    hence 1: "\<exists> t' .  gensyn_get (l ! a) k = Some t' \<and> gensyn_get t' [kl] = Some t''" using Cons by auto
    hence 2: "a < length l" using Cons G gensyn_get_list_len by auto
    thus ?thesis using G gensyn_get_list_nth2 gensyn_get_list_child2 0 1 by auto blast+
  qed
qed

lemma gensyn_get_last2 :
  assumes H1: "gensyn_get t k = Some t'"
  and H2: "gensyn_get t' [kl] = Some t''"
shows "gensyn_get t (k@[kl]) = Some t''"  using H1 H2
proof(induction k arbitrary: t t' kl t'')
  case Nil
  then show ?case by auto next

  case (Cons a k)
  then show ?case
  proof(cases t)
    case (G x l)
    hence 0: "gensyn_get (l!a) (k) = Some t'" using Cons gensyn_get_list_child G by auto
    hence 1: "gensyn_get (l!a) (k@[kl]) = Some t''" using Cons by auto
    hence 2: "a < length l" using Cons G gensyn_get_list_len by auto
    show ?thesis using G gensyn_get_list_child2 0 1 2 by auto blast+
  qed
qed

lemma gensyn_get_comp :
  assumes H1: "gensyn_get t' p' = Some t''"
  assumes H2: "gensyn_get t p = Some t'"
  shows "gensyn_get t (p@p') = Some t''" using H1 H2
proof(induction p' arbitrary: t' t'' t p)
  case Nil
  then show ?case by auto
next
  case (Cons a' p')
  then show ?case
  proof(cases t')
    case (G x l) (* thus ?thesis using Cons H1 H2 *)
    obtain tmid where 1: "gensyn_get t' [a'] = Some tmid \<and>
                 gensyn_get tmid p' = Some t''" using Cons gensyn_get_child by blast
    hence 2: "gensyn_get t (p @ [a']) = Some tmid" using Cons gensyn_get_last2 by blast
    hence 3: "gensyn_get t ((p @ [a']) @ p') = Some t''"
        using Cons.IH[of tmid t'' t "p@[a']"] 1
        by auto
      show ?thesis using 3 by auto
    qed
  qed

lemma gensyn_get_comp2 :
  assumes H: "gensyn_get t (p1@p2) = Some t''"
  shows  "\<exists> t' . gensyn_get t p1 = Some t' \<and>
                 gensyn_get t' p2 = Some t''" using H
proof(induction p2 arbitrary: t p1 t'')
  case Nil
  then show ?case by auto
next
  case (Cons a k2t)
  hence 1: "gensyn_get t ((p1 @ [a])@k2t) = Some t''" by auto
  obtain t' where 2: "gensyn_get t (p1@[a]) = Some t' \<and>
                        gensyn_get t' k2t =
                        Some t''" using 1 Cons.IH[of t "p1@[a]" t''] by auto
  obtain t'2 where 3: "gensyn_get t p1 = Some t'2 \<and>
                        gensyn_get t'2 [a] = Some t'"
    using 2 gensyn_get_last[of t p1 a t'] by auto
  show ?case using 2 3 gensyn_get_child2 by auto blast+
qed

(* Compatibility between inductive and executable descend implementations *)
lemma gensyn_descend_eq_l2r :
  assumes H: "gensyn_get t (kh#kt) = Some t'"
  shows "gensyn_descend t t'(kh#kt)" using H
proof(induction kt arbitrary: t kh t')
  case Nil
  then show ?case
  proof(cases t)
    case (G x l)
    then show ?thesis
      using Nil gensyn_descend.intros(1)[of kh l]
              gensyn_get_list_child[of l kh "[]" t'] by auto
  qed
next
  case (Cons a kt)
  then show ?case
  (* why do we need the rule here? *)
  proof(cases t rule:gensyn.exhaust)
    case (G x l)
    obtain tmid where 1 : "gensyn_get t [kh] = Some tmid \<and> gensyn_get tmid (a#kt) = Some t'"
      using gensyn_get_child[of t kh "a#kt" t'] Cons by auto
    have 2 : "gensyn_descend tmid t' (a#kt)" using Cons 1 by auto
    have 3: "gensyn_descend t tmid [kh]" using 1 G gensyn_descend.intros(1)[of kh l]
                                    gensyn_get_list_child[of l kh "[]" tmid]
      by auto
    thus ?thesis using 2 gensyn_descend.intros(2) by fastforce
  qed
qed

lemma ll3_descend_nonnil :
assumes H: "gensyn_descend t t' k"
shows "\<exists> hd tl . k = hd # tl" using H
proof(induction rule:gensyn_descend.induct)
  case 1 thus ?case by auto next
  case 2 thus ?case by auto
qed

lemma ll_descend_eq_r2l :
"gensyn_descend t t' k \<Longrightarrow>
gensyn_get t k = Some t'"
proof(induction rule:gensyn_descend.induct)
  case (1 c ls t x)
  then show ?case using gensyn_get_list_nth2 by auto next
  case (2 t t' n t'' n')
  then show ?case using gensyn_get_comp by fastforce
qed

lemma cp_next_list_nonnil :
  shows "\<And> cp cp' . gensyn_cp_next_list (l :: ('x) gensyn list) cp = Some cp' \<longrightarrow>
    (? cph' cpt' . cp' = cph' # cpt')"
proof(induction l rule:gensyn_induct')
  case (1 x l)
  then show ?case
   proof(cases cp)
    case Nil then show ?thesis by auto next
    case (Cons a list) then show ?thesis
      apply(case_tac a) apply(clarsimp) apply(simp split:option.splits) apply(auto)
      done
  qed

next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis by auto
  next
    case (Cons a list)
    then show ?thesis using 3
    proof(cases l)
        assume Nil' : "l=[]"
        then show ?thesis using Nil' Cons 3 by auto next

        fix lh ll
        assume Cons' : "l = lh#ll"
        then show ?thesis
        proof(cases a)
          case 0
          then show ?thesis using Cons Cons' 3
            apply(case_tac t, auto)
            apply(auto split:option.splits)
            done
        next
          case (Suc nat)
          then show ?thesis using Cons Cons' 3
            apply(case_tac t, auto)
            apply(auto split:option.splits list.splits)
            done
        qed
        qed
      qed
qed

lemma gensyn_cp_next_list_lesser:

    assumes H: "a < length lt"
    shows "Some [Suc a] = gensyn_cp_next_list (lh # lt) [a]" using H
proof(induction a arbitrary: lt lh)
  case 0
  then show ?case
    apply(case_tac lt) apply(auto)
    apply(case_tac lh) apply(auto)
    apply(case_tac x2, auto)
    done
next
  case (Suc a)
  then show ?case
    apply(case_tac lt) apply(auto)
    done
qed

lemma gensyn_cp_next_list_greater:
    assumes H: "\<not> a < length lt"
    shows "None = gensyn_cp_next_list (lh # lt) [a]" using H
proof(induction a arbitrary: lt lh)
  case 0
  then show ?case
    apply(case_tac lt) apply(auto)
    apply(case_tac lh) apply(auto)
    apply(case_tac x2) apply(auto)
    done
next
  case (Suc a)
  then show ?case
    apply(case_tac lt) apply(auto)
    done
next
qed

(* Some ordering-like definitions for childpaths *)
fun cp_less_nilmax :: "childpath \<Rightarrow> childpath \<Rightarrow> bool"
  where
"cp_less_nilmax [] _ = False"
| "cp_less_nilmax (h#_) [] = True"
| "cp_less_nilmax (h1#t1) (h2#t2) =
  (if h1<h2 then True
   else (if h1 = h2 then cp_less_nilmax t1 t2
   else False))"

fun cp_less_nilmin :: "childpath \<Rightarrow> childpath \<Rightarrow> bool"
  where
"cp_less_nilmin _ [] = False"
| "cp_less_nilmin [] (h#_) = True"
| "cp_less_nilmin (h1#t1) (h2#t2) =
  (if h1<h2 then True
   else (if h1 = h2 then cp_less_nilmin t1 t2
   else False))"

fun cp_less :: "childpath \<Rightarrow> childpath \<Rightarrow> bool"
  where
"cp_less (h1#t1) (h2#t2) =
  (if h1 < h2 then True
    else (if h1 = h2 then cp_less t1 t2
    else False))"
| "cp_less _ _ = False"

lemma cp_next_less_minmax :
  "cp_less a b = (cp_less_nilmin a b \<and> cp_less_nilmax a b)"
proof(induction a arbitrary: b)
case Nil
then show ?case by auto
next
  case (Cons a1 a2)
  then show ?case
  proof(cases b)
    assume Nil' : "b = []"
    thus ?thesis by auto
  next
    fix bh bt
    assume Cons' : "b = bh#bt"
    thus ?thesis using Cons by auto
  qed
qed

lemma gensyn_cp_next_list_spec' [rule_format]:
  fixes s :: "('x) gensyn list"
  shows "! c c' c'' s'.
        (gensyn_cp_next_list l c = Some c' \<longrightarrow>
         cp_less c c' \<and>
          (
               gensyn_get_list l c'' = Some s' \<longrightarrow>
               cp_less c c'' \<longrightarrow>
              (c''= c' \<or> cp_less_nilmin c' c'')))
        \<and>
        (gensyn_cp_next_list l c = None \<longrightarrow>
          gensyn_get_list l c'' = Some s' \<longrightarrow>
          \<not> cp_less c c'')"
proof(induction l rule:gensyn_induct')
  case (1 x l)
  then show ?case
    apply(clarsimp)
    apply(case_tac c, auto) apply(case_tac a, auto) apply(simp split:option.splits)
       apply(case_tac c') apply(auto)
     apply(case_tac c') apply(auto)
    apply(case_tac c'') apply(auto)

    apply(case_tac a, auto)
      apply(simp split:if_split_asm option.splits)
    apply(case_tac c'') apply(auto)
      apply(simp split:if_split_asm option.splits)
      apply(simp split:if_split_asm option.splits)
     apply(case_tac listb) apply(auto)

    apply(case_tac c'') apply(auto)
      apply(simp split:if_split_asm option.splits)
     apply(case_tac aa, auto)
apply(case_tac aa, auto)
      apply(simp split:if_split_asm option.splits)

    apply(case_tac lista) apply(auto)
    done
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
    proof(cases l)
      case Nil
      then show ?thesis using 3
        apply(clarsimp)
        done
  next
    case (Cons a list)
    then show ?thesis using 3
      apply(clarsimp)
      apply(case_tac t, clarsimp)
      apply(case_tac "gensyn_cp_next_list (G x1 x2 # a # list) c")

       apply(clarsimp)
       apply(case_tac c) apply(clarsimp) apply(clarsimp)
       apply(case_tac aa) apply(clarsimp)
        apply(simp split:option.split_asm)
       apply(clarsimp)
        apply(simp split:option.split_asm)

        apply(rotate_tac -3)
        apply(drule_tac x = "nat#lista" in spec)  apply(clarsimp)
        apply(case_tac c'') apply(clarsimp) apply(clarsimp)
        apply(simp split:if_split_asm)

         apply(case_tac aa) apply(clarsimp) apply(clarsimp)
         apply(rotate_tac -5) apply(drule_tac x = "nata#listaa" in spec)
         apply(clarsimp)

      apply(clarsimp)
         apply(rotate_tac -5) apply(drule_tac x = "nat#listaa" in spec)
        apply(clarsimp)

      apply(case_tac x2a) apply(clarsimp)
         apply(rotate_tac 4) apply(drule_tac x = "nat#lista" in spec)
        apply(clarsimp)

      apply(case_tac x2a) apply(clarsimp)
         apply(rotate_tac 4) apply(drule_tac x = "nat#lista" in spec)
        apply(clarsimp)

      apply(clarsimp)
       apply(case_tac c) apply(clarsimp) apply(clarsimp)
       apply(case_tac aa) apply(clarsimp)
        apply(simp split:option.split_asm)
        apply(clarsimp)
        apply(case_tac c'') apply(clarsimp) apply(clarsimp)
        apply(simp split:if_split_asm)

      apply(case_tac listaa) apply(clarsimp) apply(clarsimp)

      apply(clarsimp)
         apply(drule_tac x = "0#lista" in spec)
        apply(clarsimp)
      apply(rotate_tac -1)
        apply(drule_tac x = "0#listaa" in spec) apply(clarsimp)
      apply(case_tac listaa) apply(clarsimp) apply(clarsimp)

       apply(clarsimp)
         apply(drule_tac x = "0#lista" in spec)
        apply(clarsimp)
      apply(rotate_tac -1)
      apply(case_tac c'') apply(clarsimp) apply(clarsimp)
       apply(simp split:if_split_asm)
       apply(drule_tac x = "0#listaa" in spec) apply(clarsimp)
       apply(case_tac listaa) apply(clarsimp) apply(clarsimp)

      apply(clarsimp)
      apply(case_tac " gensyn_cp_next_list (a # list) (nat # lista)")
       apply(clarsimp)
      apply(clarsimp)
      apply(case_tac aa) apply(clarsimp) apply(clarsimp)
      apply(rotate_tac -3) apply(drule_tac x = "nat#lista" in spec) apply(clarsimp)
      apply(simp split:if_split_asm) apply(clarsimp)
       apply(case_tac c'') apply(clarsimp) apply(clarsimp)
       apply(simp split:if_split_asm) apply(clarsimp)
         apply(drule_tac x = "aa # listb" in spec) apply(clarsimp)

      apply(case_tac ab) apply(clarsimp) apply(clarsimp)
        apply(drule_tac x = "nata # listb" in spec) apply(clarsimp)

      apply(case_tac ab) apply(clarsimp) apply(clarsimp)
       apply(drule_tac x = "nata # listb" in spec) apply(clarsimp)

       apply(case_tac c'') apply(clarsimp) apply(clarsimp)
         apply(drule_tac x = "aa # listb" in spec) apply(clarsimp)
      done
  qed
qed

lemma cp_less_irref :
"\<not> cp_less c c"
proof(induction c, auto)
qed

lemma cp_less_irref2 :
"cp_less c c \<Longrightarrow> False"
proof(induction c, auto)
qed

lemma cp_less_last :
 "cp_less (c@[t]) (c@[Suc t])"
proof(induction c, auto)
qed

lemma cp_less_suf :
  assumes H: "cp_less c1 c2"
  shows "cp_less (c1@suf) c2" using H
proof(induction c1 arbitrary: c2 suf)
  case Nil
then show ?case by auto
next
  case (Cons a c1)
  then show ?case
    apply(case_tac c2, auto)
    apply(case_tac "a < aa", auto)
    done
qed

end


(* Author: Lei Yu, University of Cambridge *)

section \<open>Code Generation Setup for Floats\<close>

theory Double
  imports
    Conversion_IEEE_Float
    "HOL-Library.Monad_Syntax"
    "HOL-Library.Code_Target_Numeral"
begin

text \<open>A type for code generation to SML/OCaml\<close>

typedef double = "UNIV::(11, 52) float set" ..

setup_lifting type_definition_double

instantiation double :: "{uminus,plus,times,minus,zero,one,abs,ord,inverse}" begin
lift_definition uminus_double::"double \<Rightarrow> double" is uminus .
lift_definition plus_double::"double \<Rightarrow> double \<Rightarrow> double" is plus .
lift_definition times_double::"double \<Rightarrow> double \<Rightarrow> double" is times .
lift_definition divide_double::"double \<Rightarrow> double \<Rightarrow> double" is divide .
lift_definition inverse_double::"double \<Rightarrow> double" is inverse .
lift_definition minus_double::"double \<Rightarrow> double \<Rightarrow> double" is minus .
lift_definition zero_double::"double" is "0" .
lift_definition one_double::"double" is "1" .
lift_definition less_eq_double::"double \<Rightarrow> double \<Rightarrow> bool" is "(\<le>)" .
lift_definition less_double::"double \<Rightarrow> double \<Rightarrow> bool" is "(<)" .
instance proof qed
end

lift_definition eq_double::"double\<Rightarrow>double\<Rightarrow>bool" is float_eq .

lift_definition sqrt_double::"double\<Rightarrow>double" is float_sqrt .

no_notation plus_infinity ("\<infinity>")

lift_definition infinity_double::"double" ("\<infinity>") is plus_infinity .

lift_definition is_normal::"double \<Rightarrow> bool" is IEEE.is_normal .
lift_definition is_zero::"double \<Rightarrow> bool" is IEEE.is_zero .
lift_definition is_finite::"double \<Rightarrow> bool" is IEEE.is_finite .
lift_definition is_nan::"double \<Rightarrow> bool" is IEEE.is_nan .

code_printing type_constructor double \<rightharpoonup>
  (SML) "real" and (OCaml) "float"

code_printing constant "0 :: double" \<rightharpoonup>
  (SML) "0.0" and (OCaml) "0.0"
declare zero_double.abs_eq[code del]

code_printing constant "1 :: double" \<rightharpoonup>
  (SML) "1.0" and (OCaml) "1.0"
declare one_double.abs_eq[code del]

code_printing constant "eq_double :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.== ((_:real), (_))" and (OCaml) "Pervasives.(=)"
declare eq_double.abs_eq[code del]

code_printing constant "Orderings.less_eq :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.<= ((_), (_))" and (OCaml) "Pervasives.(<=)"
declare less_double_def [code del]

code_printing constant "Orderings.less :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.< ((_), (_))" and (OCaml) "Pervasives.(<)"
declare less_eq_double_def[code del]

code_printing constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Real.+ ((_), (_))" and (OCaml) "Pervasives.( +. )"
declare plus_double_def[code del]

code_printing constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Real.* ((_), (_))" and (OCaml) "Pervasives.( *. )"
declare times_double_def [code del]

code_printing constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Real.- ((_), (_))" and (OCaml) "Pervasives.( -. )"
declare minus_double_def [code del]

code_printing constant "uminus :: double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Real.~" and (OCaml) "Pervasives.( ~-. )"

code_printing constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Real.'/ ((_), (_))" and (OCaml) "Pervasives.( '/. )"
declare divide_double_def [code del]

code_printing constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup>
  (SML) "Math.sqrt" and (OCaml) "Pervasives.sqrt"
declare sqrt_def[code del]

code_printing constant "infinity_double :: double" \<rightharpoonup>
  (SML) "Real.posInf"
declare infinity_double.abs_eq[code del]

code_printing constant "is_normal :: double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.isNormal"
declare [[code drop: "is_normal"]]

code_printing constant "is_finite :: double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.isFinite"
declare [[code drop: "is_finite"]]

code_printing constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.isNan"
declare [[code drop: "is_nan"]]

text \<open>Mapping natural numbers to doubles.\<close>
fun float_of :: "nat \<Rightarrow> double"
where
  "float_of 0 = 0"
| "float_of (Suc n) = float_of n + 1"

lemma "float_of 2 < float_of 3 + float_of 4"
  by eval

export_code float_of in SML

subsection \<open>Conversion from int\<close>

lift_definition double_of_int::"int \<Rightarrow> double" is "\<lambda>i. round To_nearest (real_of_int i)" .

context includes integer.lifting begin
lift_definition double_of_integer::"integer \<Rightarrow> double" is double_of_int .
end

lemma float_of_int[code]:
  "double_of_int i = double_of_integer (integer_of_int i)"
  by (auto simp: double_of_integer_def)

code_printing
  constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (SML) "Real.fromLargeInt"
declare [[code drop: double_of_integer]]

subsection \<open>Conversion to and from software floats, extracting information\<close>

text \<open>Need to trust a lot of code here...\<close>

lemma is_finite_double_eq:
  "is_finite_Float TYPE((11, 52)float) f \<longleftrightarrow>
    (let e = Float.exponent f; bm = bitlen (abs (mantissa f))
    in (bm \<le> 53 \<and> e + bm < 1025 \<and> - 1075 < e))"
  unfolding is_finite_Float_eq
  by (auto simp: Let_def)

code_printing
  code_module "IEEE_Mantissa_Exponent" \<rightharpoonup> (SML)
\<open>
structure IEEE_Mantissa_Exponent =
struct
fun to_man_exp_double x =
  if Real.isFinite x
  then case Real.toManExp x of {man = m, exp = e} =>
    SOME (Real.floor (Real.* (m, Math.pow (2.0, 53.0))), IntInf.- (e, 53))
  else NONE
fun normfloat (m, e) =
(if m mod 2 = 0 andalso m <> 0 then normfloat (m div 2, e + 1)
 else if m = 0 then (0, 0) else (m, e))
fun bitlen x = (if 0 < x then bitlen (x div 2) + 1 else 0)
fun is_finite_double_eq m e =
  let
    val (m, e) = normfloat (m, e)
    val bm = bitlen (abs m)
  in bm <= 53 andalso e + bm < 1025 andalso e > ~1075 end
fun from_man_exp_double m e =
  if is_finite_double_eq m e
  then SOME (Real.fromManExp {man = Real.fromLargeInt m, exp = e})
  else NONE
end
\<close>

lift_definition of_finite::"double \<Rightarrow> Float.float" is Conversion_IEEE_Float.of_finite .

definition man_exp_of_double::"double \<Rightarrow> (integer * integer)option" where
  "man_exp_of_double d = (if is_finite d then let f = of_finite d in
    Some (integer_of_int (mantissa f), integer_of_int (Float.exponent f)) else None)"

lift_definition of_finite_Float::"Float.float \<Rightarrow> double" is Conversion_IEEE_Float.of_finite_Float .

definition double_of_man_exp::"integer \<Rightarrow> integer \<Rightarrow> double option" where
  "double_of_man_exp m e = (let f = Float (int_of_integer m) (int_of_integer e) in
    if is_finite_Float TYPE((11, 52)float) f
    then Some (of_finite_Float f)
    else None)"

code_printing
  constant "man_exp_of_double :: double \<Rightarrow> (integer * integer) option" \<rightharpoonup>
    (SML) "IEEE'_Mantissa'_Exponent.to'_man'_exp'_double" |
  constant "double_of_man_exp :: integer \<Rightarrow> integer \<Rightarrow> double option" \<rightharpoonup>
    (SML) "IEEE'_Mantissa'_Exponent.from'_man'_exp'_double"
declare [[code drop: man_exp_of_double]]
declare [[code drop: double_of_man_exp]]

lift_definition Float_of_double::"double \<Rightarrow> Float.float option" is
  "\<lambda>x. if is_finite x then Some (of_finite x) else None" .

lift_definition double_of_Float::"Float.float \<Rightarrow> double option" is
  "\<lambda>x. if is_finite_Float TYPE((11, 52)float) x then Some (of_finite_Float x) else None" .

lemma compute_Float_of_double[code]:
  "Float_of_double x =
    map_option (\<lambda>(m, e). Float (int_of_integer m) (int_of_integer e)) (man_exp_of_double x)"
  apply (rule sym)
  by transfer (auto simp: man_exp_of_double_def Let_def mantissa_exponent[symmetric]
      Float_mantissa_exponent)

lemma compute_double_of_Float[code]:
  "double_of_Float f = double_of_man_exp (integer_of_int (mantissa f)) (integer_of_int (Float.exponent f))"
  unfolding double_of_man_exp_def Let_def Float_mantissa_exponent int_of_integer_integer_of_int
  apply auto
  subgoal by transfer auto
  subgoal by transfer auto
  done

definition "check_conversion m e =
  (let f = Float (int_of_integer m) (int_of_integer e) in
    do {
      d \<leftarrow> double_of_Float f;
      Float_of_double d
    } = (if is_finite_Float TYPE((11, 52)float) f then Some f else None))"

primrec check_all::"nat \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
  "check_all 0 P \<longleftrightarrow> True"
| "check_all (Suc i) P \<longleftrightarrow> P i \<and> check_all i P"

definition "check_conversions dm de =
  check_all (nat (2 * de)) (\<lambda>e. check_all (nat (2 * dm)) (\<lambda>m.
    check_conversion (integer_of_int (int m - dm)) (integer_of_int (int e - de))))"

lemma "check_conversions 100 100"
  by eval

end


theory Compatibility_Tac_Experiments
  imports Laws
begin

subsection \<open>Heterogenous variable lists\<close>

(* TODO: should not be axioms (or not be here) *)
typedecl 'a untyped_lvalue
axiomatization make_untyped_lvalue :: \<open>('a,'b) maps_hom \<Rightarrow> 'b untyped_lvalue\<close>
  and compatible_untyped :: \<open>'b untyped_lvalue \<Rightarrow> 'b untyped_lvalue \<Rightarrow> bool\<close>
axiomatization where
  compatible_untyped: \<open>compatible_untyped (make_untyped_lvalue F) (make_untyped_lvalue G)
    \<longleftrightarrow> compatible F G\<close>

inductive mutually_compatible :: \<open>'a untyped_lvalue list \<Rightarrow> bool\<close> where
  \<open>mutually_compatible []\<close>
| \<open>mutually_compatible vs \<Longrightarrow> list_all (compatible_untyped v) vs
    \<Longrightarrow> mutually_compatible (v#vs)\<close>

inductive compatible_with_all :: \<open>('a,'b) maps_hom \<Rightarrow> 'b untyped_lvalue list \<Rightarrow> bool\<close> where
  \<open>compatible_with_all _ []\<close>
| \<open>compatible_with_all v ws \<Longrightarrow> compatible_untyped (make_untyped_lvalue v) w \<Longrightarrow> compatible_with_all v (w#ws)\<close>

lemma l1:
  assumes \<open>mutually_compatible (make_untyped_lvalue a # as)\<close>
  shows \<open>compatible_with_all a as\<close>
  using assms apply cases apply (induction as)
   apply (simp add: compatible_with_all.intros(1))
  using compatible_with_all.intros(2) mutually_compatible.cases by fastforce

lemma l2:
  assumes \<open>mutually_compatible (a # as)\<close>
  shows \<open>mutually_compatible as\<close>
  using assms mutually_compatible.cases by blast

lemma l3:
  assumes \<open>compatible_with_all b (a # as)\<close>
  shows \<open>compatible_with_all b as\<close>
  using assms compatible_with_all.cases by auto

lemma l4:
  assumes \<open>compatible_with_all b (make_untyped_lvalue a # as)\<close>
  shows \<open>compatible b a\<close>
  using assms compatible_untyped compatible_with_all.cases by blast

lemma l4':
  assumes \<open>compatible_with_all b (make_untyped_lvalue a # as)\<close>
  shows \<open>compatible a b\<close>
  using assms compatible_sym l4 by blast

nonterminal untyped_lvalues
syntax "_COMPATIBLE" :: "args \<Rightarrow> 'b" ("COMPATIBLE '(_')")
syntax "_LVALUE_LIST" :: "args \<Rightarrow> 'b" ("UNTYPED'_LVALUE'_LIST '(_')")
syntax "_insert_make_untyped_lvalue" :: "args \<Rightarrow> 'b"

translations "COMPATIBLE (x)" == "CONST mutually_compatible (UNTYPED_LVALUE_LIST (x))"
translations "UNTYPED_LVALUE_LIST (x)" => "CONST make_untyped_lvalue x # CONST Nil"
translations "UNTYPED_LVALUE_LIST (x,xs)" => "CONST make_untyped_lvalue x # UNTYPED_LVALUE_LIST (xs)"

named_theorems compatible_lvalues

ML \<open>
fun show_compatibility_fact ctxt x y = let
  val facts = case Proof_Context.lookup_fact ctxt \<^named_theorems>\<open>compatible_lvalues\<close>
              of SOME {thms=thms, ...} => thms | NONE => error "internal error"
  fun show fact = let
    val list = case Thm.prop_of fact of Const(\<^const_name>\<open>Trueprop\<close>,_) $
                (Const(\<^const_name>\<open>mutually_compatible\<close>, _) $ list) => list
                | _ => raise TERM("show_compatibility_fact 1",[])
    val list = HOLogic.dest_list list
    val list = map (fn t => case t of Const(\<^const_name>\<open>make_untyped_lvalue\<close>, _) $ x => x
                     | _ => raise TERM("show_compatibility_fact 2",[])) list
    val index1 = find_index (fn v => v=x) list
    val _ = if index1 = ~1 then raise TERM("show_compatibility_fact 3",[]) else ()
    val index2 = find_index (fn v => v=y) list
    val _ = if index2 = ~1 then raise TERM("show_compatibility_fact 4",[]) else ()
    val _ = if index1 = index2 then raise TERM("show_compatibility_fact 5",[]) else ()
    val swap = index1 >= index2
    val (first,second) = if swap then (index2,index1) else (index1,index2)
    fun show'' 0 fact = let
          (* val _ = \<^print> (fact) *)
          val fact = (if swap then @{thm l4'} else @{thm l4}) OF [fact]
          in fact end
      | show'' pos fact = let
          (* val _ = \<^print> (pos, fact) *)
          val fact = @{thm l3} OF [fact]
          in show'' (pos-1) fact end
    fun show' 0 second fact = let
          val fact = @{thm l1} OF [fact]
          in show'' (second-1) fact end
      | show' first second fact = let
          val fact = @{thm l2} OF [fact]
          in show' (first - 1) (second - 1) fact end
    val result = show' first second fact
  in result end
  fun find [] = NONE
    | find (fact::facts) =
        SOME (show fact) handle TERM _ => find facts
  in find facts end
;;
show_compatibility_fact \<^context> \<^term>\<open>b\<close> \<^term>\<open>d\<close>
\<close>

ML \<open>
fun compatibility_tac ctxt = SUBGOAL (fn (t,i) => (
  case t of
    Const(\<^const_name>\<open>Trueprop\<close>,_) $ (Const(\<^const_name>\<open>compatible\<close>,_) $
      (Const(\<^const_name>\<open>pair\<close>,_) $ _ $ _) $ _) =>
        (resolve_tac ctxt [@{thm compatible3}] THEN_ALL_NEW compatibility_tac ctxt) i
(* TODO pair on the right side, chain *)
  | Const(\<^const_name>\<open>Trueprop\<close>,_) $ (Const(\<^const_name>\<open>compatible\<close>,_) $ x $ y) =>
      case show_compatibility_fact ctxt x y of
        SOME thm => solve_tac ctxt [thm] i
      | NONE => no_tac))
\<close>

simproc_setup "compatibility" ("compatible x y") = \<open>fn m => fn ctxt => fn ct => let
  val goal = Thm.apply (Thm.apply \<^cterm>\<open>(==) :: bool\<Rightarrow>bool\<Rightarrow>prop\<close> ct) \<^cterm>\<open>True\<close> |> Goal.init
  val goal = SINGLE (resolve_tac ctxt @{thms Eq_TrueI} 1) goal
  val goal = Option.mapPartial (SINGLE (compatibility_tac ctxt 1)) goal
  val thm = Option.map (Goal.finish ctxt) goal
  in thm end\<close>

lemma
  assumes [compatible_lvalues]: "COMPATIBLE (a,b,c,d,e)"
  shows "compatible d b"
  by simp

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin
imports LinArith
begin

subsection{* Fourier *}

definition qe_FM\<^sub>1 :: "atom list \<Rightarrow> atom fm" where
"qe_FM\<^sub>1 as = list_conj [Atom(combine p q). p\<leftarrow>lbounds as, q\<leftarrow>ubounds as]"

theorem I_qe_FM\<^sub>1:
assumes less: "\<forall>a \<in> set as. is_Less a" and dep: "\<forall>a \<in> set as. depends\<^sub>R a"
shows "R.I (qe_FM\<^sub>1 as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>R a (x#xs))"  (is "?L = ?R")
proof
  let ?Ls = "set(lbounds as)" let ?Us = "set(ubounds as)"
  let ?lbs = "UN (r,cs):?Ls. {r + \<langle>cs,xs\<rangle>}"
  let ?ubs = "UN (r,cs):?Us. {r + \<langle>cs,xs\<rangle>}"
  have fins: "finite ?lbs \<and> finite ?ubs" by auto
  have 2: "\<forall>f\<in> set as. \<exists>r c cs. f = Less r (c#cs) \<and>
          (c>0 \<and> (r/c,(-1/c)*\<^sub>s cs) \<in> ?Ls \<or> c<0 \<and> (r/c,(-1/c)*\<^sub>s cs) \<in> ?Us)"
    using dep less
    by(fastforce simp:set_lbounds set_ubounds is_Less_iff depends\<^sub>R_def
                split:list.splits)
  assume ?L
  have 1: "\<forall>x\<in>?lbs. \<forall>y\<in>?ubs. x < y"
  proof (rule ballI)+
    fix x y assume "x\<in>?lbs" "y\<in>?ubs"
    then obtain r cs
      where "(r,cs) \<in> ?Ls \<and> x = r + \<langle>cs,xs\<rangle>" by fastforce
    moreover from `y\<in>?ubs` obtain s ds
      where "(s,ds) \<in> ?Us \<and> y = s + \<langle>ds,xs\<rangle>" by fastforce
    ultimately show "x<y" using `?L`
      by(fastforce simp:qe_FM\<^sub>1_def algebra_simps iprod_left_diff_distrib)
  qed
  { assume nonempty: "?lbs \<noteq> {} \<and> ?ubs \<noteq> {}"
    hence "Max ?lbs < Min ?ubs" using fins 1
      by(blast intro: Max_less_iff[THEN iffD2] Min_gr_iff[THEN iffD2])
    then obtain m where "Max ?lbs < m \<and> m < Min ?ubs"
      using dense[where 'a = real] by blast
    hence "\<forall>a \<in> set as. I\<^sub>R a (m#xs)" using 2 nonempty
      by (auto simp:Ball_def Bex_def)(fastforce simp:field_simps)
    hence ?R .. }
  moreover
  { assume asm: "?lbs \<noteq> {} \<and> ?ubs = {}"
    have "\<forall>a \<in> set as. I\<^sub>R a ((Max ?lbs + 1) # xs)"
    proof
      fix a assume "a \<in> set as"
      then obtain r c cs
        where "a = Less r (c#cs)" "c>0" "(r/c,(-1/c)*\<^sub>s cs) \<in> ?Ls"
        using asm 2 by fastforce
      moreover hence "(r - \<langle>cs,xs\<rangle>)/c \<le> Max ?lbs"
        using asm fins
        by(auto intro!: Max_ge_iff[THEN iffD2])
          (force simp add:field_simps)
      ultimately show "I\<^sub>R a ((Max ?lbs + 1) # xs)" by (simp add: field_simps)
    qed
    hence ?R .. }
  moreover
  { assume asm: "?lbs = {} \<and> ?ubs \<noteq> {}"
    have "\<forall>a \<in> set as. I\<^sub>R a ((Min ?ubs - 1) # xs)"
    proof
      fix a assume "a \<in> set as"
      then obtain r c cs
        where "a = Less r (c#cs)" "c<0" "(r/c,(-1/c)*\<^sub>s cs) \<in> ?Us"
        using asm 2 by fastforce
      moreover hence "Min ?ubs \<le> (r - \<langle>cs,xs\<rangle>)/c"
        using asm fins
        by(auto intro!: Min_le_iff[THEN iffD2])
          (force simp add:field_simps)
      ultimately show "I\<^sub>R a ((Min ?ubs - 1) # xs)" by (simp add: field_simps)
    qed
    hence ?R .. }
  moreover
  { assume "?lbs = {} \<and> ?ubs = {}"
    hence ?R using 2 less by auto (rule, fast)
  }
  ultimately show ?R by blast
next
  let ?Ls = "set(lbounds as)" let ?Us = "set(ubounds as)"
  assume ?R
  then obtain x where 1: "\<forall>a\<in> set as. I\<^sub>R a (x#xs)" ..
  { fix r c cs s d ds
    assume "Less r (c#cs) \<in> set as" "0 < c" "Less s (d#ds) \<in> set as" "d < 0"
    hence "r < c*x + \<langle>cs,xs\<rangle>" "s < d*x + \<langle>ds,xs\<rangle>" "c > 0" "d < 0"
      using 1 by auto
    hence "(r - \<langle>cs,xs\<rangle>)/c < x" "x < (s - \<langle>ds,xs\<rangle>)/d" by(simp add:field_simps)+
    hence "(r - \<langle>cs,xs\<rangle>)/c < (s - \<langle>ds,xs\<rangle>)/d" by arith
  }
  thus ?L by (auto simp: qe_FM\<^sub>1_def iprod_left_diff_distrib less field_simps set_lbounds set_ubounds)
qed

corollary I_qe_FM\<^sub>1_pretty:
  "\<forall>a \<in> set as. is_Less a \<and> depends\<^sub>R a \<Longrightarrow> R.is_dnf_qe qe_FM\<^sub>1 as"
by(metis I_qe_FM\<^sub>1)

fun subst\<^sub>0 :: "atom \<Rightarrow> atom \<Rightarrow> atom" where
"subst\<^sub>0 (Eq r (c#cs)) a = (case a of
   Less s (d#ds) \<Rightarrow> Less (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)
 | Eq s (d#ds) \<Rightarrow> Eq (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs))"

lemma subst\<^sub>0_pretty:
 "subst\<^sub>0 (Eq r (c#cs)) (Less s (d#ds)) = Less (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)"
 "subst\<^sub>0 (Eq r (c#cs)) (Eq s (d#ds)) = Eq (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)"
by auto

lemma I_subst\<^sub>0: "depends\<^sub>R a \<Longrightarrow> c \<noteq> 0 \<Longrightarrow>
       I\<^sub>R (subst\<^sub>0 (Eq r (c#cs)) a) xs = I\<^sub>R a ((r - \<langle>cs,xs\<rangle>)/c # xs)"
apply(cases a)
by (auto simp add: depends\<^sub>R_def iprod_left_diff_distrib algebra_simps diff_divide_distrib split:list.splits)

interpretation R\<^sub>e!:
  ATOM_EQ neg\<^sub>R "(\<lambda>a. True)" I\<^sub>R depends\<^sub>R decr\<^sub>R
          "(\<lambda>Eq _ (c#_) \<Rightarrow> c \<noteq> 0 | _ \<Rightarrow> False)"
          "(\<lambda>Eq r cs \<Rightarrow> r=0 \<and> (\<forall>c\<in> set cs. c=0) | _ \<Rightarrow> False)" subst\<^sub>0
apply(unfold_locales)
   apply(simp del:subst\<^sub>0.simps add:I_subst\<^sub>0 split:atom.splits list.splits)
  apply(simp add: iprod0_if_coeffs0 split:atom.splits)
 apply(simp split:atom.splits list.splits)
 apply(rename_tac r ds c cs)
 apply(rule_tac x= "(r - \<langle>cs,xs\<rangle>)/c" in exI)
 apply (simp add: algebra_simps diff_divide_distrib)
apply(simp add: self_list_diff set_replicate_conv_if
        split:atom.splits list.splits)
done

(* FIXME does not help
setup {* Sign.revert_abbrev "" @{const_name R\<^sub>e.lift_dnfeq_qe} *}
*)

definition "qe_FM = R\<^sub>e.lift_dnfeq_qe qe_FM\<^sub>1"

lemma qfree_qe_FM\<^sub>1: "qfree (qe_FM\<^sub>1 as)"
by(auto simp:qe_FM\<^sub>1_def intro!:qfree_list_conj)

corollary I_qe_FM: "R.I (qe_FM \<phi>) xs = R.I \<phi> xs"
unfolding qe_FM_def
apply(rule R\<^sub>e.I_lift_dnfeq_qe)
 apply(rule qfree_qe_FM\<^sub>1)
apply(rule allI)
apply(rule I_qe_FM\<^sub>1)
 prefer 2 apply blast
apply(clarify)
apply(drule_tac x=a in bspec) apply simp
apply(simp add: depends\<^sub>R_def split:atom.splits list.splits)
done

theorem qfree_qe_FM: "qfree (qe_FM f)"
by(simp add:qe_FM_def R\<^sub>e.qfree_lift_dnfeq_qe qfree_qe_FM\<^sub>1)

subsubsection{* Tests *}

lemmas qesimps = qe_FM_def R\<^sub>e.lift_dnfeq_qe_def R\<^sub>e.lift_eq_qe_def R.qelim_def qe_FM\<^sub>1_def lbounds_def ubounds_def list_conj_def list_disj_def and_def or_def depends\<^sub>R_def

lemma "qe_FM(TrueF) = TrueF"
by(simp add:qesimps)

lemma
  "qe_FM(ExQ (And (Atom(Less 0 [1])) (Atom(Less 0 [-1])))) = Atom(Less 0 [])"
by(simp add:qesimps)

lemma
 "qe_FM(ExQ (And (Atom(Less 0 [1])) (Atom(Less (- 1) [-1])))) = Atom(Less (- 1) [])"
by(simp add:qesimps)

end


section "Collecting Semantics of Commands"

theory Collecting
imports Complete_Lattice_ix ACom
begin

subsection "Annotated commands as a complete lattice"

(* Orderings could also be lifted generically (thus subsuming the
instantiation for preord and order), but then less_eq_acom would need to
become a definition, eg less_eq_acom = lift2 less_eq, and then proofs would
need to unfold this defn first. *)

instantiation acom :: (order) order
begin

fun less_eq_acom :: "('a::order)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"(SKIP {S}) \<le> (SKIP {S'}) = (S \<le> S')" |
"(x ::= e {S}) \<le> (x' ::= e' {S'}) = (x=x' \<and> e=e' \<and> S \<le> S')" |
"(c1;;c2) \<le> (c1';;c2') = (c1 \<le> c1' \<and> c2 \<le> c2')" |
"(IF b THEN c1 ELSE c2 {S}) \<le> (IF b' THEN c1' ELSE c2' {S'}) =
  (b=b' \<and> c1 \<le> c1' \<and> c2 \<le> c2' \<and> S \<le> S')" |
"({Inv} WHILE b DO c {P}) \<le> ({Inv'} WHILE b' DO c' {P'}) =
  (b=b' \<and> c \<le> c' \<and> Inv \<le> Inv' \<and> P \<le> P')" |
"less_eq_acom _ _ = False"

lemma SKIP_le: "SKIP {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = SKIP {S'} \<and> S \<le> S')"
by (cases c) auto

lemma Assign_le: "x ::= e {S} \<le> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<le> S')"
by (cases c) auto

lemma Seq_le: "c1;;c2 \<le> c \<longleftrightarrow> (\<exists>c1' c2'. c = c1';;c2' \<and> c1 \<le> c1' \<and> c2 \<le> c2')"
by (cases c) auto

lemma If_le: "IF b THEN c1 ELSE c2 {S} \<le> c \<longleftrightarrow>
  (\<exists>c1' c2' S'. c= IF b THEN c1' ELSE c2' {S'} \<and> c1 \<le> c1' \<and> c2 \<le> c2' \<and> S \<le> S')"
by (cases c) auto

lemma While_le: "{Inv} WHILE b DO c {P} \<le> w \<longleftrightarrow>
  (\<exists>Inv' c' P'. w = {Inv'} WHILE b DO c' {P'} \<and> c \<le> c' \<and> Inv \<le> Inv' \<and> P \<le> P')"
by (cases w) auto

definition less_acom :: "'a acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"less_acom x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof (standard,goal_cases)
  case 1 show ?case by(simp add: less_acom_def)
next
  case (2 x) thus ?case by (induct x) auto
next
  case (3 x y z) thus ?case
  apply(induct x y arbitrary: z rule: less_eq_acom.induct)
  apply (auto intro: le_trans simp: SKIP_le Assign_le Seq_le If_le While_le)
  done
next
  case (4 x y) thus ?case
  apply(induct x y rule: less_eq_acom.induct)
  apply (auto intro: le_antisym)
  done
qed

end

fun sub\<^sub>1 :: "'a acom \<Rightarrow> 'a acom" where
"sub\<^sub>1(c1;;c2) = c1" |
"sub\<^sub>1(IF b THEN c1 ELSE c2 {S}) = c1" |
"sub\<^sub>1({I} WHILE b DO c {P}) = c"

fun sub\<^sub>2 :: "'a acom \<Rightarrow> 'a acom" where
"sub\<^sub>2(c1;;c2) = c2" |
"sub\<^sub>2(IF b THEN c1 ELSE c2 {S}) = c2"

fun invar :: "'a acom \<Rightarrow> 'a" where
"invar({I} WHILE b DO c {P}) = I"

fun lift :: "('a set \<Rightarrow> 'b) \<Rightarrow> com \<Rightarrow> 'a acom set \<Rightarrow> 'b acom"
where
"lift F com.SKIP M = (SKIP {F (post ` M)})" |
"lift F (x ::= a) M = (x ::= a {F (post ` M)})" |
"lift F (c1;;c2) M =
  lift F c1 (sub\<^sub>1 ` M);; lift F c2 (sub\<^sub>2 ` M)" |
"lift F (IF b THEN c1 ELSE c2) M =
  IF b THEN lift F c1 (sub\<^sub>1 ` M) ELSE lift F c2 (sub\<^sub>2 ` M)
  {F (post ` M)}" |
"lift F (WHILE b DO c) M =
 {F (invar ` M)}
 WHILE b DO lift F c (sub\<^sub>1 ` M)
 {F (post ` M)}"

global_interpretation Complete_Lattice_ix "%c. {c'. strip c' = c}" "lift Inter"
proof (standard,goal_cases)
  case (1 A _ a)
  have "a:A \<Longrightarrow> lift Inter (strip a) A \<le> a"
  proof(induction a arbitrary: A)
    case Seq from Seq.prems show ?case by(force intro!: Seq.IH)
  next
    case If from If.prems show ?case by(force intro!: If.IH)
  next
    case While from While.prems show ?case by(force intro!: While.IH)
  qed force+
  with 1 show ?case by auto
next
  case (2 b i A)
  thus ?case
  proof(induction b arbitrary: i A)
    case SKIP thus ?case by (force simp:SKIP_le)
  next
    case Assign thus ?case by (force simp:Assign_le)
  next
    case Seq from Seq.prems show ?case
      by (force intro!: Seq.IH simp:Seq_le)
  next
    case If from If.prems show ?case by (force simp: If_le intro!: If.IH)
  next
    case While from While.prems show ?case
      by(fastforce simp: While_le intro: While.IH)
  qed
next
  case (3 A i)
  have "strip(lift Inter i A) = i"
  proof(induction i arbitrary: A)
    case Seq from Seq.prems show ?case
      by (fastforce simp: strip_eq_Seq subset_iff intro!: Seq.IH)
  next
    case If from If.prems show ?case
      by (fastforce intro!: If.IH simp: strip_eq_If)
  next
    case While from While.prems show ?case
      by(fastforce intro: While.IH simp: strip_eq_While)
  qed auto
  thus ?case by auto
qed

lemma le_post: "c \<le> d \<Longrightarrow> post c \<le> post d"
by(induction c d rule: less_eq_acom.induct) auto

subsection "Collecting semantics"

fun step :: "state set \<Rightarrow> state set acom \<Rightarrow> state set acom" where
"step S (SKIP {P}) = (SKIP {S})" |
"step S (x ::= e {P}) =
  (x ::= e {{s'. \<exists>s\<in>S. s' = s(x := aval e s)}})" |
"step S (c1;; c2) = step S c1;; step (post c1) c2" |
"step S (IF b THEN c1 ELSE c2 {P}) =
   IF b THEN step {s:S. bval b s} c1 ELSE step {s:S. \<not> bval b s} c2
   {post c1 \<union> post c2}" |
"step S ({Inv} WHILE b DO c {P}) =
  {S \<union> post c} WHILE b DO (step {s:Inv. bval b s} c) {{s:Inv. \<not> bval b s}}"

definition CS :: "com \<Rightarrow> state set acom" where
"CS c = lfp (step UNIV) c"

lemma mono2_step: "c1 \<le> c2 \<Longrightarrow> S1 \<subseteq> S2 \<Longrightarrow> step S1 c1 \<le> step S2 c2"
proof(induction c1 c2 arbitrary: S1 S2 rule: less_eq_acom.induct)
  case 2 thus ?case by fastforce
next
  case 3 thus ?case by(simp add: le_post)
next
  case 4 thus ?case by(simp add: subset_iff)(metis le_post subsetD)+
next
  case 5 thus ?case by(simp add: subset_iff) (metis le_post subsetD)
qed auto

lemma mono_step: "mono (step S)"
by(blast intro: monoI mono2_step)

lemma strip_step: "strip(step S c) = strip c"
by (induction c arbitrary: S) auto

lemma lfp_cs_unfold: "lfp (step S) c = step S (lfp (step S) c)"
apply(rule lfp_unfold[OF _  mono_step])
apply(simp add: strip_step)
done

lemma CS_unfold: "CS c = step UNIV (CS c)"
by (metis CS_def lfp_cs_unfold)

lemma strip_CS[simp]: "strip(CS c) = c"
by(simp add: CS_def index_lfp[simplified])

end