(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Relation Algebra *}

theory Relation_Algebra
  imports More_Boolean_Algebra "../Kleene_Algebra/Kleene_Algebra"
begin

text {* We follow Tarski's original article and Maddux's book, in particular we
use their notation. In contrast to Schmidt and Str\"ohlein we do not assume
that the Boolean algebra is complete and we do not consider the Tarski rule in
this development.

A main reason for using complete Boolean algebras seems to be that the
Knaster-Tarski fixpoint theorem becomes available for defining notions of
iteration. In fact, several chapters of Schmidt and Str\"ohlein's book deal
with iteration.

We capture iteration in an alternative way by linking relation algebras with
Kleene algebras (cf.~\emph{relation-algebra-rtc}). *}

class relation_algebra = boolean_algebra +
  fixes composition :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl ";" 75)
    and converse :: "'a \<Rightarrow> 'a" ("(_\<^sup>\<smile>)" [1000] 999)
    and unit :: "'a" ("1'")
  assumes comp_assoc: "(x ; y) ; z = x ; (y ; z)"
    and comp_unitr [simp]: "x ; 1' = x"
    and comp_distr: "(x + y) ; z = x ; z + y ; z"
    and conv_invol [simp]: "(x\<^sup>\<smile>)\<^sup>\<smile> = x"
    and conv_add [simp]: "(x + y)\<^sup>\<smile> = x\<^sup>\<smile> + y\<^sup>\<smile>"
    and conv_contrav [simp]: "(x ; y)\<^sup>\<smile> = y\<^sup>\<smile> ; x\<^sup>\<smile>"
    and comp_res: "x\<^sup>\<smile> ; -(x ; y) \<le> -y"

text {* We first show that every relation algebra is a dioid. We do not yet
treat the zero (the minimal element of the boolean reduct) since the proof of
the annihilation laws is rather tricky to automate. Following Maddux we derive
them from properties of Boolean algebras with operators. *}

sublocale relation_algebra < dioid_one "op +" "op ;" "op \<le> " "op <" "1'"
proof
  fix x y z :: 'a
  show "x ; y ; z = x ; (y ; z)"
    by (fact comp_assoc)
  show "x + y + z = x + (y + z)"
    by (metis sup.commute sup.left_commute)
  show "x + y = y + x"
    by (fact sup.commute)
  show "(x + y) ; z = x ; z + y ; z"
    by (fact comp_distr)
  show "x + x = x"
    by (fact sup.idem)
  show "x ; (y + z) = x ; y + x ; z"
    by (metis conv_invol conv_add conv_contrav comp_distr)
  show "x ; 1' = x"
    by (fact comp_unitr)
  show "1' ; x = x"
    by (metis comp_unitr conv_contrav conv_invol)
  show "x \<le> y \<longleftrightarrow> x + y = y"
    by (metis sup.commute sup_absorb1 sup_ge1)
  show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
    by (fact less_le)
qed

context relation_algebra
begin

text {* First we prove some basic facts about joins and meets. *}

lemma meet_interchange: "(w \<cdot> x) ; (y \<cdot> z) \<le> w ; y \<cdot> x ; z"
by (metis inf_le1 inf_le2 le_infI mult_isol_var)

lemma join_interchange: "w ; x + y ; z \<le> (w + y) ; (x + z)"
by (metis add_lub_var mult_isol_var sup_ge1 sup_ge2)

text {* We now prove some simple facts about conversion. *}

lemma conv_iso: "x \<le> y \<longleftrightarrow> x\<^sup>\<smile> \<le> y\<^sup>\<smile>"
by (metis conv_add conv_invol le_iff_sup)

lemma conv_zero [simp]: "0\<^sup>\<smile> = 0"
by (metis conv_add conv_invol sup_bot_right sup_eq_bot_iff)

lemma conv_one [simp]: "1\<^sup>\<smile> = 1"
by (metis conv_add conv_invol sup_top_left sup_top_right)

lemma conv_compl_aux: "(-x)\<^sup>\<smile> = (-x)\<^sup>\<smile> + (-x\<^sup>\<smile>)"
by (metis aux9 conv_add conv_one double_compl galois_aux4 inf.commute less_eq_def sup.commute sup_top_left)

lemma conv_compl: "(-x)\<^sup>\<smile> = -(x\<^sup>\<smile>)"
by (metis add_commute conv_add conv_compl_aux conv_invol)

lemma comp_res_aux [simp]: "x\<^sup>\<smile> ; -(x ; y) \<cdot> y = 0"
by (metis comp_res galois_aux)

lemma conv_e [simp]: "1'\<^sup>\<smile> = 1'"
by (metis comp_unitr conv_contrav conv_invol)

text {* The next lemmas show that conversion is self-conjugate in the sense of
Boolean algebra with operators. *}

lemma conv_self_conjugate: "x\<^sup>\<smile> \<cdot> y = 0 \<longleftrightarrow> x \<cdot> y\<^sup>\<smile> = 0"
by (metis conv_invol conv_times conv_zero)

lemma conv_self_conjugate_var: "is_conjugation converse converse"
by (metis conv_self_conjugate is_conjugation_def)

text {* The following lemmas link the relative product and meet. *}

lemma one_idem_mult [simp]: "1 ; 1 = 1"
by (metis compl_eq_compl_iff galois_aux2 inf.commute inf_top_right mult_1_left mult_isor top_greatest)

lemma mult_subdistl: "x ; (y \<cdot> z) \<le> x ; y"
by (metis inf_le1 mult_isol)

lemma mult_subdistr: "(x \<cdot> y) ; z \<le> x ; z"
by (metis inf_le1 mult_isor)

lemma mult_subdistr_var: "(x \<cdot> y) ; z \<le> x ; z \<cdot> y ; z"
by (metis inf.commute le_inf_iff mult_subdistr)

text {* The following lemmas deal with variants of the Peirce law, the
Schr\"oder laws and the Dedekind law. Some of them are obtained from Boolean
algebras with operators by instantiation, using conjugation properties.
However, Isabelle does not always pick up this relationship. *}

lemma peirce_1: "x ; y \<cdot> z\<^sup>\<smile> = 0 \<Longrightarrow> y ; z \<cdot> x\<^sup>\<smile> = 0"
by (metis compl_le_swap1 conv_contrav conv_self_conjugate galois_aux comp_res conv_invol galois_aux mult_isol order_trans)

lemma peirce: "x ; y \<cdot> z\<^sup>\<smile> = 0 \<longleftrightarrow> y ; z \<cdot> x\<^sup>\<smile> = 0"
by (metis peirce_1)

lemma schroeder_1: "x ; y \<cdot> z = 0 \<longleftrightarrow> y \<cdot> x\<^sup>\<smile> ; z = 0"
by (metis conv_invol peirce conv_contrav conv_invol conv_self_conjugate inf.commute)

lemma schroeder_2: "y ; x \<cdot> z = 0 \<longleftrightarrow> y \<cdot> z ; x\<^sup>\<smile> = 0"
by (metis conv_invol peirce schroeder_1)

text {* The following two conjugation properties between multiplication with
elements and their converses are used for deriving modular laws of relation
algebra from those of Boolean algebras with operators. *}

lemma schroeder_1_var: "is_conjugation (composition x) (composition (x\<^sup>\<smile>))"
by (metis schroeder_1 is_conjugation_def)

lemma schroeder_2_var: "is_conjugation (\<lambda>x. x ; y) (\<lambda>x. x ; y\<^sup>\<smile>)"
by (unfold is_conjugation_def, metis schroeder_2)

text {* The following Galois connections define residuals. They link relation
algebras with action algebras. This could be further explored and formalised.
*}

lemma conv_galois_1: "x ; y \<le> z \<longleftrightarrow> y \<le> -(x\<^sup>\<smile> ; -z)"
by (metis galois_aux galois_aux2 schroeder_1)

lemma conv_galois_2: "y ; x \<le> z \<longleftrightarrow> y \<le> -(-z ; x\<^sup>\<smile>)"
by (metis galois_aux galois_aux2 schroeder_2)

text {* Variants of the modular law for relation algebras can now be
instantiated from Boolean algebras with operators. *}

lemma modular_1_aux': "x ; (y \<cdot> -(x\<^sup>\<smile> ; z)) \<cdot> z = 0"
by (metis schroeder_1_var modular_1_aux)

lemma modular_1': "x ; y \<cdot> z = x ; (y \<cdot> x\<^sup>\<smile> ; z) \<cdot> z"
by (metis schroeder_1_var modular_1)

lemma modular_1_var: "x ; y \<cdot> z \<le> x ; (y \<cdot> x\<^sup>\<smile> ; z)"
by (metis inf.commute inf_le2 modular_1')

lemma modular_2_var: "x ; y \<cdot> z \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; y"
by (metis inf.commute inf_le2 modular_2')

lemma modular_var_2: "x ; y \<le> x ; (y \<cdot> x\<^sup>\<smile> ; 1)"
by (metis inf_top_right modular_1_var)

lemma modular_var_3: "x ; y \<le> (x \<cdot> 1 ; y\<^sup>\<smile>) ; y"
by (metis inf_top_right modular_2_var)

text {* The modular laws are used to prove the Dedekind rule. *}

lemma dedekind: "x ; y \<cdot> z \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; (y \<cdot> x\<^sup>\<smile> ; z)"
proof -
  have "x ; y \<cdot> z \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; (y \<cdot> ((x \<cdot> z ; y\<^sup>\<smile>)\<^sup>\<smile> ; z))"
    by (metis modular_2' modular_1_var)
  also have "\<dots> \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; (y \<cdot> x\<^sup>\<smile> ; z)"
    by (metis conv_iso inf_le1 inf_mono mult_isol mult_isor order_refl)
  thus ?thesis
    by (metis calculation order_trans)
qed

lemma dedekind_var_1: "x ; y \<le> (x \<cdot> 1 ; y\<^sup>\<smile>) ; (y \<cdot> x\<^sup>\<smile> ; 1)"
by (metis dedekind inf.commute inf_top_left)

end (* relation_algebra *)

text {* The Schr\"oder laws allow us, finally, to prove the annihilation laws
for zero. We formalise this by proving that relation algebras form dioids with
zero. *}

sublocale relation_algebra < dioid_one_zero "op +" "op ;" "1'" 0 "op \<le>" "op <"
proof
  fix x :: 'a
  show "0 + x = x"
    by (fact sup_bot_left)
  show "0 ; x = 0"
    by (metis f_strict schroeder_2_var)
  show "x ; 0 = 0"
    by (metis f_strict schroeder_1_var)
qed

context relation_algebra
begin

text {* Next we prove miscellaneous properties which we found in the books of
Maddux and Schmidt and Str\"ohlein. Most of them do not carry any meaningful
names. *}

lemma ra_1: "(x \<cdot> y ; 1) ; z = x ; z \<cdot> y ; 1"
proof (rule antisym)
  show "x ; z \<cdot> y ; 1 \<le> (x \<cdot> y ; 1) ; z"
    by (metis modular_2_var comp_assoc order_trans eq_refl inf_mono inf_top_left mult_isor mult_subdistl)
  show "(x \<cdot> y ; 1) ; z \<le> x ; z \<cdot> y ; 1"
    by (metis inf.commute inf_greatest inf_top_left mult.assoc mult_subdistl mult_subdistr order_trans)
qed

lemma ra_2: "x ; (z \<cdot> y ; 1) = (x \<cdot> (y ; 1)\<^sup>\<smile>) ; z"
proof (rule antisym)
  have "(x \<cdot> 1 ; (z \<cdot> y ; 1)\<^sup>\<smile>) ; z \<le> (x \<cdot> (y ; 1)\<^sup>\<smile>) ; z"
    by (metis conv_contrav conv_invol conv_one conv_times inf.idem inf.left_commute le_iff_inf meet_assoc mult_isor ra_1)
  thus "x ; (z \<cdot> y ; 1) \<le> (x \<cdot> (y ; 1)\<^sup>\<smile>) ; z"
    by (metis modular_var_3 mult_subdistl order_trans)
next
  have "x ; (z \<cdot> ((x \<cdot> (y ; 1)\<^sup>\<smile>)\<^sup>\<smile> ; 1)) \<le> x ; (z \<cdot> y ; 1)"
    by (metis conv_invol conv_times eq_refl inf_le2 inf_mono mult.assoc mult_isol mult_isor one_idem_mult)
  thus "x ; (z \<cdot> y ; 1) \<ge> (x \<cdot> (y ; 1)\<^sup>\<smile>) ; z"
    by (metis modular_var_2 mult_subdistr order_trans)
qed

lemma one_conv: "1' \<cdot> x ; 1 = 1' \<cdot> x ; x\<^sup>\<smile>"
by (metis inf.commute inf_top_left modular_1' mult.right_neutral)

lemma maddux_12: "-(y ; x) ; x\<^sup>\<smile> \<le> -y"
by (metis galois_aux inf.commute inf_compl_bot schroeder_2)

lemma maddux_141: "x ; y \<cdot> z = 0 \<longleftrightarrow> x\<^sup>\<smile> ; z \<cdot> y = 0"
by (metis inf.commute schroeder_1)

lemma maddux_142: "x\<^sup>\<smile> ; z \<cdot> y = 0 \<longleftrightarrow> z ; y\<^sup>\<smile> \<cdot> x = 0"
by (metis inf.commute schroeder_1 schroeder_2)

lemmas maddux_16 = modular_1_var

lemmas maddux_17 = modular_2_var

lemma maddux_20: "x \<le> x ; 1"
by (metis inf_top_left mult.right_neutral mult_subdistl)

lemma maddux_21: "x \<le> 1 ; x"
by (metis mult_isor mult_onel top_greatest)

lemma maddux_23: "x ; y \<cdot> -(x ; z) = x ; (y \<cdot> -z) \<cdot> -(x ; z)"
by (rule antisym) (metis add_ub2 aux9 galois_1 inf.commute distrib_left)+

lemma maddux_24: "-(x ; y) + x ; z = -(x ; (y \<cdot> -z)) + x ; z"
by (metis de_morgan_3 double_compl maddux_23)

lemma one_compl: "-(x ; 1) ; 1 = -(x ; 1)"
by (metis antisym conv_one maddux_12 mult.assoc one_idem_mult maddux_20)

lemma ss_p18: "x ; 1 = 0 \<longleftrightarrow> x = 0"
by (metis annil le_bot maddux_20)

end (* relation_algebra *)

text {* This finishes our development of the basic laws of relation algebras.
The next sections are devoted to special elements such as vectors, test or
subidentities, and, in particular, functions. *}

end


(*  Title:      HOL/Proofs/Extraction/Util.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section {* Auxiliary lemmas used in program extraction examples *}

theory Util
imports Old_Datatype
begin

text {*
Decidability of equality on natural numbers.
*}

lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp only: nat.simps, iprover?)+
  done

text {*
Well-founded induction on natural numbers, derived using the standard
structural induction rule.
*}

lemma nat_wf_ind:
  assumes R: "\<And>x::nat. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  shows "P z"
proof (rule R)
  show "\<And>y. y < z \<Longrightarrow> P y"
  proof (induct z)
    case 0
    thus ?case by simp
  next
    case (Suc n y)
    from nat_eq_dec show ?case
    proof
      assume ny: "n = y"
      have "P n"
        by (rule R) (rule Suc)
      with ny show ?case by simp
    next
      assume "n \<noteq> y"
      with Suc have "y < n" by simp
      thus ?case by (rule Suc)
    qed
  qed
qed

text {*
Bounded search for a natural number satisfying a decidable predicate.
*}

lemma search:
  assumes dec: "\<And>x::nat. P x \<or> \<not> P x"
  shows "(\<exists>x<y. P x) \<or> \<not> (\<exists>x<y. P x)"
proof (induct y)
  case 0 show ?case by simp
next
  case (Suc z)
  thus ?case
  proof
    assume "\<exists>x<z. P x"
    then obtain x where le: "x < z" and P: "P x" by iprover
    from le have "x < Suc z" by simp
    with P show ?case by iprover
  next
    assume nex: "\<not> (\<exists>x<z. P x)"
    from dec show ?case
    proof
      assume P: "P z"
      have "z < Suc z" by simp
      with P show ?thesis by iprover
    next
      assume nP: "\<not> P z"
      have "\<not> (\<exists>x<Suc z. P x)"
      proof
        assume "\<exists>x<Suc z. P x"
        then obtain x where le: "x < Suc z" and P: "P x" by iprover
        have "x < z"
        proof (cases "x = z")
          case True
          with nP and P show ?thesis by simp
        next
          case False
          with le show ?thesis by simp
        qed
        with P have "\<exists>x<z. P x" by iprover
        with nex show False ..
      qed
      thus ?case by iprover
    qed
  qed
qed

end


(*  Title:      HOL/Old_Number_Theory/Int2.thy
    Authors:    Jeremy Avigad, David Gray, and Adam Kramer
*)

section {*Integers: Divisibility and Congruences*}

theory Int2
imports Finite2 WilsonRuss
begin

definition MultInv :: "int => int => int"
  where "MultInv p x = x ^ nat (p - 2)"

subsection {* Useful lemmas about dvd and powers *}

lemma zpower_zdvd_prop1:
  "0 < n \<Longrightarrow> p dvd y \<Longrightarrow> p dvd ((y::int) ^ n)"
  by (induct n) (auto simp add: dvd_mult2 [of p y])

lemma zdvd_bounds: "n dvd m ==> m \<le> (0::int) | n \<le> m"
proof -
  assume "n dvd m"
  then have "~(0 < m & m < n)"
    using zdvd_not_zless [of m n] by auto
  then show ?thesis by auto
qed

lemma zprime_zdvd_zmult_better: "[| zprime p;  p dvd (m * n) |] ==>
    (p dvd m) | (p dvd n)"
  apply (cases "0 \<le> m")
  apply (simp add: zprime_zdvd_zmult)
  apply (insert zprime_zdvd_zmult [of "-m" p n])
  apply auto
  done

lemma zpower_zdvd_prop2:
    "zprime p \<Longrightarrow> p dvd ((y::int) ^ n) \<Longrightarrow> 0 < n \<Longrightarrow> p dvd y"
  apply (induct n)
   apply simp
  apply (frule zprime_zdvd_zmult_better)
   apply simp
  apply (force simp del:dvd_mult)
  done

lemma div_prop1:
  assumes "0 < z" and "(x::int) < y * z"
  shows "x div z < y"
proof -
  from `0 < z` have modth: "x mod z \<ge> 0" by simp
  have "(x div z) * z \<le> (x div z) * z" by simp
  then have "(x div z) * z \<le> (x div z) * z + x mod z" using modth by arith
  also have "\<dots> = x"
    by (auto simp add: zmod_zdiv_equality [symmetric] ac_simps)
  also note `x < y * z`
  finally show ?thesis
    apply (auto simp add: mult_less_cancel_right)
    using assms apply arith
    done
qed

lemma div_prop2:
  assumes "0 < z" and "(x::int) < (y * z) + z"
  shows "x div z \<le> y"
proof -
  from assms have "x < (y + 1) * z" by (auto simp add: int_distrib)
  then have "x div z < y + 1"
    apply (rule_tac y = "y + 1" in div_prop1)
    apply (auto simp add: `0 < z`)
    done
  then show ?thesis by auto
qed

lemma zdiv_leq_prop: assumes "0 < y" shows "y * (x div y) \<le> (x::int)"
proof-
  from zmod_zdiv_equality have "x = y * (x div y) + x mod y" by auto
  moreover have "0 \<le> x mod y" by (auto simp add: assms)
  ultimately show ?thesis by arith
qed

subsection {* Useful properties of congruences *}

lemma zcong_eq_zdvd_prop: "[x = 0](mod p) = (p dvd x)"
  by (auto simp add: zcong_def)

lemma zcong_id: "[m = 0] (mod m)"
  by (auto simp add: zcong_def)

lemma zcong_shift: "[a = b] (mod m) ==> [a + c = b + c] (mod m)"
  by (auto simp add: zcong_zadd)

lemma zcong_zpower: "[x = y](mod m) ==> [x^z = y^z](mod m)"
  by (induct z) (auto simp add: zcong_zmult)

lemma zcong_eq_trans: "[| [a = b](mod m); b = c; [c = d](mod m) |] ==>
    [a = d](mod m)"
  apply (erule zcong_trans)
  apply simp
  done

lemma aux1: "a - b = (c::int) ==> a = c + b"
  by auto

lemma zcong_zmult_prop1: "[a = b](mod m) ==> ([c = a * d](mod m) =
    [c = b * d] (mod m))"
  apply (auto simp add: zcong_def dvd_def)
  apply (rule_tac x = "ka + k * d" in exI)
  apply (drule aux1)+
  apply (auto simp add: int_distrib)
  apply (rule_tac x = "ka - k * d" in exI)
  apply (drule aux1)+
  apply (auto simp add: int_distrib)
  done

lemma zcong_zmult_prop2: "[a = b](mod m) ==>
    ([c = d * a](mod m) = [c = d * b] (mod m))"
  by (auto simp add: ac_simps zcong_zmult_prop1)

lemma zcong_zmult_prop3: "[| zprime p; ~[x = 0] (mod p);
    ~[y = 0] (mod p) |] ==> ~[x * y = 0] (mod p)"
  apply (auto simp add: zcong_def)
  apply (drule zprime_zdvd_zmult_better, auto)
  done

lemma zcong_less_eq: "[| 0 < x; 0 < y; 0 < m; [x = y] (mod m);
    x < m; y < m |] ==> x = y"
  by (metis zcong_not zcong_sym less_linear)

lemma zcong_neg_1_impl_ne_1:
  assumes "2 < p" and "[x = -1] (mod p)"
  shows "~([x = 1] (mod p))"
proof
  assume "[x = 1] (mod p)"
  with assms have "[1 = -1] (mod p)"
    apply (auto simp add: zcong_sym)
    apply (drule zcong_trans, auto)
    done
  then have "[1 + 1 = -1 + 1] (mod p)"
    by (simp only: zcong_shift)
  then have "[2 = 0] (mod p)"
    by auto
  then have "p dvd 2"
    by (auto simp add: dvd_def zcong_def)
  with `2 < p` show False
    by (auto simp add: zdvd_not_zless)
qed

lemma zcong_zero_equiv_div: "[a = 0] (mod m) = (m dvd a)"
  by (auto simp add: zcong_def)

lemma zcong_zprime_prod_zero: "[| zprime p; 0 < a |] ==>
    [a * b = 0] (mod p) ==> [a = 0] (mod p) | [b = 0] (mod p)"
  by (auto simp add: zcong_zero_equiv_div zprime_zdvd_zmult)

lemma zcong_zprime_prod_zero_contra: "[| zprime p; 0 < a |] ==>
  ~[a = 0](mod p) & ~[b = 0](mod p) ==> ~[a * b = 0] (mod p)"
  apply auto
  apply (frule_tac a = a and b = b and p = p in zcong_zprime_prod_zero)
  apply auto
  done

lemma zcong_not_zero: "[| 0 < x; x < m |] ==> ~[x = 0] (mod m)"
  by (auto simp add: zcong_zero_equiv_div zdvd_not_zless)

lemma zcong_zero: "[| 0 \<le> x; x < m; [x = 0](mod m) |] ==> x = 0"
  apply (drule order_le_imp_less_or_eq, auto)
  apply (frule_tac m = m in zcong_not_zero)
  apply auto
  done

lemma all_relprime_prod_relprime: "[| finite A; \<forall>x \<in> A. zgcd x y = 1 |]
    ==> zgcd (setprod id A) y = 1"
  by (induct set: finite) (auto simp add: zgcd_zgcd_zmult)

subsection {* Some properties of MultInv *}

lemma MultInv_prop1: "[| 2 < p; [x = y] (mod p) |] ==>
    [(MultInv p x) = (MultInv p y)] (mod p)"
  by (auto simp add: MultInv_def zcong_zpower)

lemma MultInv_prop2: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
  [(x * (MultInv p x)) = 1] (mod p)"
proof (simp add: MultInv_def zcong_eq_zdvd_prop)
  assume 1: "2 < p" and 2: "zprime p" and 3: "~ p dvd x"
  have "x * x ^ nat (p - 2) = x ^ (nat (p - 2) + 1)"
    by auto
  also from 1 have "nat (p - 2) + 1 = nat (p - 2 + 1)"
    by (simp only: nat_add_distrib)
  also have "p - 2 + 1 = p - 1" by arith
  finally have "[x * x ^ nat (p - 2) = x ^ nat (p - 1)] (mod p)"
    by (rule ssubst, auto)
  also from 2 3 have "[x ^ nat (p - 1) = 1] (mod p)"
    by (auto simp add: Little_Fermat)
  finally (zcong_trans) show "[x * x ^ nat (p - 2) = 1] (mod p)" .
qed

lemma MultInv_prop2a: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
    [(MultInv p x) * x = 1] (mod p)"
  by (auto simp add: MultInv_prop2 ac_simps)

lemma aux_1: "2 < p ==> ((nat p) - 2) = (nat (p - 2))"
  by (simp add: nat_diff_distrib)

lemma aux_2: "2 < p ==> 0 < nat (p - 2)"
  by auto

lemma MultInv_prop3: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
    ~([MultInv p x = 0](mod p))"
  apply (auto simp add: MultInv_def zcong_eq_zdvd_prop aux_1)
  apply (drule aux_2)
  apply (drule zpower_zdvd_prop2, auto)
  done

lemma aux__1: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
    [(MultInv p (MultInv p x)) = (x * (MultInv p x) *
      (MultInv p (MultInv p x)))] (mod p)"
  apply (drule MultInv_prop2, auto)
  apply (drule_tac k = "MultInv p (MultInv p x)" in zcong_scalar, auto)
  apply (auto simp add: zcong_sym)
  done

lemma aux__2: "[| 2 < p; zprime p; ~([x = 0](mod p))|] ==>
    [(x * (MultInv p x) * (MultInv p (MultInv p x))) = x] (mod p)"
  apply (frule MultInv_prop3, auto)
  apply (insert MultInv_prop2 [of p "MultInv p x"], auto)
  apply (drule MultInv_prop2, auto)
  apply (drule_tac k = x in zcong_scalar2, auto)
  apply (auto simp add: ac_simps)
  done

lemma MultInv_prop4: "[| 2 < p; zprime p; ~([x = 0](mod p)) |] ==>
    [(MultInv p (MultInv p x)) = x] (mod p)"
  apply (frule aux__1, auto)
  apply (drule aux__2, auto)
  apply (drule zcong_trans, auto)
  done

lemma MultInv_prop5: "[| 2 < p; zprime p; ~([x = 0](mod p));
    ~([y = 0](mod p)); [(MultInv p x) = (MultInv p y)] (mod p) |] ==>
    [x = y] (mod p)"
  apply (drule_tac a = "MultInv p x" and b = "MultInv p y" and
    m = p and k = x in zcong_scalar)
  apply (insert MultInv_prop2 [of p x], simp)
  apply (auto simp only: zcong_sym [of "MultInv p x * x"])
  apply (auto simp add: ac_simps)
  apply (drule zcong_trans, auto)
  apply (drule_tac a = "x * MultInv p y" and k = y in zcong_scalar, auto)
  apply (insert MultInv_prop2a [of p y], auto simp add: ac_simps)
  apply (insert zcong_zmult_prop2 [of "y * MultInv p y" 1 p y x])
  apply (auto simp add: zcong_sym)
  done

lemma MultInv_zcong_prop1: "[| 2 < p; [j = k] (mod p) |] ==>
    [a * MultInv p j = a * MultInv p k] (mod p)"
  by (drule MultInv_prop1, auto simp add: zcong_scalar2)

lemma aux___1: "[j = a * MultInv p k] (mod p) ==>
    [j * k = a * MultInv p k * k] (mod p)"
  by (auto simp add: zcong_scalar)

lemma aux___2: "[|2 < p; zprime p; ~([k = 0](mod p));
    [j * k = a * MultInv p k * k] (mod p) |] ==> [j * k = a] (mod p)"
  apply (insert MultInv_prop2a [of p k] zcong_zmult_prop2
    [of "MultInv p k * k" 1 p "j * k" a])
  apply (auto simp add: ac_simps)
  done

lemma aux___3: "[j * k = a] (mod p) ==> [(MultInv p j) * j * k =
     (MultInv p j) * a] (mod p)"
  by (auto simp add: mult.assoc zcong_scalar2)

lemma aux___4: "[|2 < p; zprime p; ~([j = 0](mod p));
    [(MultInv p j) * j * k = (MultInv p j) * a] (mod p) |]
       ==> [k = a * (MultInv p j)] (mod p)"
  apply (insert MultInv_prop2a [of p j] zcong_zmult_prop1
    [of "MultInv p j * j" 1 p "MultInv p j * a" k])
  apply (auto simp add: ac_simps zcong_sym)
  done

lemma MultInv_zcong_prop2: "[| 2 < p; zprime p; ~([k = 0](mod p));
    ~([j = 0](mod p)); [j = a * MultInv p k] (mod p) |] ==>
    [k = a * MultInv p j] (mod p)"
  apply (drule aux___1)
  apply (frule aux___2, auto)
  by (drule aux___3, drule aux___4, auto)

lemma MultInv_zcong_prop3: "[| 2 < p; zprime p; ~([a = 0](mod p));
    ~([k = 0](mod p)); ~([j = 0](mod p));
    [a * MultInv p j = a * MultInv p k] (mod p) |] ==>
      [j = k] (mod p)"
  apply (auto simp add: zcong_eq_zdvd_prop [of a p])
  apply (frule zprime_imp_zrelprime, auto)
  apply (insert zcong_cancel2 [of p a "MultInv p j" "MultInv p k"], auto)
  apply (drule MultInv_prop5, auto)
  done

end


(* Title: Liftings of Partial Semigroups
   Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Liftings of Partial Semigroups\<close>

theory Partial_Semigroup_Lifting
  imports Partial_Semigroups Binary_Modalities

begin

text \<open>First we show that partial semigroups are instances of relational semigroups. Then we extend the lifting results for relational
semigroups to partial semigroups.\<close>

subsection \<open>Relational Semigroups and Partial Semigroups\<close>

text \<open>Every partial semigroup is a relational partial semigroup.\<close>

context partial_semigroup
begin

sublocale rel_partial_semigroup: rel_semigroup "R"
  by standard (metis add_assoc add_assocD)

end

text \<open>Every partial monoid is a relational monoid.\<close>

context partial_monoid
begin

sublocale rel_partial_monoid: rel_monoid "R" "E"
  apply standard
    apply (metis unitl_ex)
    apply (metis unitr_ex)
   apply (metis add_assocD_var1 unitl_ex units_eq_var)
  by (metis add_assocD_var2 unitr_ex units_eq_var)

end

text \<open>Every PAS is a relational abelian semigroup.\<close>

context pas
begin

sublocale rel_pas: rel_ab_semigroup "R"
  apply standard
  using add_comm by blast

end

text \<open>Every PAM is a relational abelian monoid.\<close>

context pam
begin

sublocale rel_pam: rel_ab_monoid "R" "E" ..

end

subsection \<open>Liftings of Partial Abelian Semigroups\<close>

text \<open>Functions from partial semigroups into weak quantales form weak proto-quantales.\<close>

instantiation "fun" :: (partial_semigroup, weak_quantale) weak_proto_quantale
begin

definition times_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
  "times_fun \<equiv> rel_partial_semigroup.times_rel_fun"

text \<open>The following counterexample shows that the associativity law may fail in convolution algebras
of functions from partial semigroups into weak quantales. \<close>

lemma "(rel_partial_semigroup.times_rel_fun (rel_partial_semigroup.times_rel_fun f f) f) x =
  (rel_partial_semigroup.times_rel_fun (f::'a::partial_semigroup \<Rightarrow> 'b::weak_quantale) (rel_partial_semigroup.times_rel_fun f f)) x"
(*  nitpick[show_all]*)
  oops

lemma "rel_partial_semigroup.times_rel_fun (rel_partial_semigroup.times_rel_fun f g) h =
  rel_partial_semigroup.times_rel_fun (f::'a::partial_semigroup \<Rightarrow> 'b::weak_quantale) (rel_partial_semigroup.times_rel_fun g h)"
(*  nitpick[show_all]*)
  oops

instance
  by standard (simp_all add: times_fun_def rel_partial_semigroup.rel_fun_Sup_distr rel_magma.rel_fun_Sup_distl_weak)

end

text \<open>Functions from partial semigroups into quantales form quantales.\<close>

instance "fun" :: (partial_semigroup, quantale) quantale
  by standard (simp_all add: times_fun_def rel_partial_semigroup.rel_fun_assoc rel_magma.rel_fun_Sup_distl)

text \<open>The following counterexample shows that the right unit law may fail in convolution algebras
of functions from partial monoids into weak unital quantales. \<close>

lemma "(rel_partial_semigroup.times_rel_fun (f::'a::partial_monoid \<Rightarrow> 'b::unital_weak_quantale) rel_partial_monoid.pid) x = f x"
  (*nitpick[show_all]*)
  oops

text \<open>Functions from partial monoids into unital quantales form unital quantales.\<close>

instantiation "fun" :: (partial_monoid, unital_quantale) unital_quantale
begin

definition one_fun :: "'a \<Rightarrow> 'b" where
  "one_fun \<equiv> rel_partial_monoid.pid"

instance
  by standard (simp_all add: one_fun_def times_fun_def)

end

text \<open>These lifting results extend to PASs and PAMs as expected.\<close>

instance "fun" :: (pam, ab_quantale) ab_quantale
  by standard (simp_all add: times_fun_def rel_pas.rel_fun_comm)

instance "fun" :: (pam, bool_ab_quantale) bool_ab_quantale ..

instance "fun" :: (pam, bool_ab_unital_quantale) bool_ab_unital_quantale ..

sublocale ab_quantale < abq: pas "(*)" "\<lambda>_ _. True"
  apply standard
  apply (simp_all add: mult_assoc)
  by (simp add: mult_commute)

text \<open>Finally we prove some identities that hold in function spaces.\<close>

lemma times_fun_var: "(f * g) x = \<Squnion>{f y * g z | y z. R x y z}"
  by (simp add: times_fun_def rel_partial_semigroup.times_rel_fun_def bmod_comp_def)

lemma times_fun_var2: "(f * g) = (\<lambda>x. \<Squnion>{f y * g z | y z. R x y z})"
  by (auto simp: times_fun_var)

lemma times_fun_prod: "(f * g) = (\<lambda>(x, y). \<Squnion>{f (x, y1) * g (x, y2) | y1 y2. R y y1 y2})"
  by (auto simp: times_fun_var2 times_prod_def D_prod_def)

lemma one_fun_prod1 [simp]: "y \<in> E \<Longrightarrow> 1 (x, y) = 1"
  by (simp add: E_prod_def)

lemma one_fun_prod2 [simp]: "y \<notin> E \<Longrightarrow> 1 (x, y) = \<bottom>"
  by (simp add: E_prod_def)

lemma fres_galois_funI: "\<forall>x. (f * g) x \<le> h x \<Longrightarrow> f x \<le> (h \<leftarrow> g) x"
  by (meson fres_galois le_funD le_funI)

lemma times_fun_prod_canc: "(f * g) (x, y) = \<Squnion>{f (x, z) * g (x, rquot y z) | z. z \<preceq>\<^sub>R y}"
  apply (simp add: times_fun_prod)
  by (metis (no_types, lifting) gR_rel_defined gR_rel_mult add_canc1 add_canc2)

text \<open>The following statement shows, in a generalised setting, that the magic wand operator of separation
logic can be lifted from the heap subtraction operation generalised to a cancellative PAM.\<close>

lemma fres_lift: "(fres f g) (x::'b::cancellative_pam) = \<Sqinter>{(f y) \<leftarrow> (g z) | y z . z \<preceq>\<^sub>R y \<and> x = rquot y z}"
proof (rule antisym)
  { fix h y z
    assume assms: "h \<cdot> g \<le> f" "z \<preceq>\<^sub>R y" "x = rquot y z"
    moreover hence  "D z x"
      using add_rquot by blast
    moreover hence "h x \<cdot> g z \<le> (h \<cdot> g) (x \<oplus> z)"
      using add_comm by (auto simp add: times_fun_var intro!: Sup_upper)
    moreover hence "(h * g) (x \<oplus> z) \<le> f (z \<oplus> x)"
      by (simp add: \<open>D z x\<close> calculation(1) le_funD add_comm)
    ultimately have "h x \<le> (f (z \<oplus> x)) \<leftarrow> (g z)"
      by (auto simp: fres_def intro: Sup_upper)
    from this and assms have "h (rquot y z) \<le> (f y) \<leftarrow> (g z)"
      by (simp add: add_canc2)
}
  thus "(f \<leftarrow> g) x \<le> \<Sqinter>{(f y) \<leftarrow> (g z) |y z. z \<preceq>\<^sub>R y \<and> x = rquot y z}"
    by (clarsimp simp: fres_def intro!: Inf_greatest SUP_least)
next
  have "\<Sqinter>{(f y) \<leftarrow> (g z) |y z. z \<preceq>\<^sub>R y \<and> x = rquot y z} \<le> Sup{x. x \<cdot> g \<le> f} x"
    apply (clarsimp simp: times_fun_var intro!: SUP_upper le_funI Sup_least)
    apply (simp add: fres_galois)
    apply (intro Inf_lower)
    apply safe
    by (metis gR_rel_mult add_canc1 add_comm)
  thus "\<Sqinter>{(f y) \<leftarrow> (g z) |y z. z \<preceq>\<^sub>R y \<and> x = rquot y z} \<le> (f \<leftarrow> g) x "
    by (simp add: fres_def)
qed

end


section \<open>Permutations as Products of Disjoint Cycles\<close>

theory Executable_Permutations
imports
  "HOL-Combinatorics.Permutations"
  Graph_Theory.Auxiliary
  List_Aux
begin

subsection \<open>Cyclic Permutations\<close>

definition list_succ :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "list_succ xs x = (if x \<in> set xs then xs ! ((index xs x + 1) mod length xs) else x)"

text \<open>
  We demonstrate the functions on the following simple lemmas

  @{lemma "list_succ [1 :: int, 2, 3] 1 = 2" by code_simp}
  @{lemma "list_succ [1 :: int, 2, 3] 2 = 3" by code_simp}
  @{lemma "list_succ [1 :: int, 2, 3] 3 = 1" by code_simp}
\<close>

lemma list_succ_altdef:
  "list_succ xs x = (let n = index xs x in if n + 1 = length xs then xs ! 0 else if n + 1 < length xs then xs ! (n + 1) else x)"
  using index_le_size[of xs x] unfolding list_succ_def index_less_size_conv[symmetric] by (auto simp: Let_def)

lemma list_succ_Nil:
  "list_succ [] = id"
  by (simp add: list_succ_def fun_eq_iff)

lemma list_succ_singleton:
  "list_succ [x] = list_succ []"
  by (simp add: fun_eq_iff list_succ_def)

lemma list_succ_short:
  assumes "length xs < 2" shows "list_succ xs = id"
  using assms
  by (cases xs) (rename_tac [2] y ys, case_tac [2] ys, auto simp: list_succ_Nil list_succ_singleton)

lemma list_succ_simps:
  "index xs x + 1 = length xs \<Longrightarrow> list_succ xs x = xs ! 0"
  "index xs x + 1 < length xs \<Longrightarrow> list_succ xs x = xs ! (index xs x + 1)"
  "length xs \<le> index xs x \<Longrightarrow> list_succ xs x = x"
  by (auto simp: list_succ_altdef)

lemma list_succ_not_in:
  assumes "x \<notin> set xs" shows "list_succ xs x = x"
  using assms by (auto simp: list_succ_def)

lemma list_succ_list_succ_rev:
  assumes "distinct xs" shows "list_succ (rev xs) (list_succ xs x) = x"
proof -
  { assume "index xs x + 1 < length xs"
    moreover then have "length xs - Suc (Suc (length xs - Suc (Suc (index xs x)))) = index xs x"
      by linarith
    ultimately have ?thesis using assms
      by (simp add: list_succ_def index_rev index_nth_id rev_nth)
  }
  moreover
  { assume A: "index xs x + 1 = length xs"
    moreover
    from A have "xs \<noteq> []" by auto
    moreover
    with A have "last xs = xs ! index xs x" by (cases "length xs") (auto simp: last_conv_nth)
    ultimately
    have ?thesis
      using assms
      by (auto simp add: list_succ_def rev_nth index_rev index_nth_id last_conv_nth)
  }
  moreover
  { assume A: "index xs x \<ge> length xs"
    then have "x \<notin> set xs" by (metis index_less less_irrefl)
    then have ?thesis by (auto simp: list_succ_def) }
  ultimately show ?thesis by (metis discrete le_less not_less)
qed

lemma inj_list_succ: "distinct xs \<Longrightarrow> inj (list_succ xs)"
  by (metis injI list_succ_list_succ_rev)

lemma inv_list_succ_eq: "distinct xs \<Longrightarrow> inv (list_succ xs) = list_succ (rev xs)"
  by (metis distinct_rev inj_imp_inv_eq inj_list_succ list_succ_list_succ_rev)

lemma bij_list_succ: "distinct xs \<Longrightarrow> bij (list_succ xs)"
  by (metis bij_def inj_list_succ distinct_rev list_succ_list_succ_rev surj_def)

lemma list_succ_permutes:
  assumes "distinct xs" shows "list_succ xs permutes set xs"
  using assms by (auto simp: permutes_conv_has_dom bij_list_succ has_dom_def list_succ_def)

lemma permutation_list_succ:
  assumes "distinct xs" shows "permutation (list_succ xs)"
  using list_succ_permutes[OF assms] by (auto simp: permutation_permutes)

lemma list_succ_nth:
  assumes "distinct xs" "n < length xs" shows "list_succ xs (xs ! n) = xs ! (Suc n mod length xs)"
  using assms by (auto simp: list_succ_def index_nth_id)

lemma list_succ_last[simp]:
  assumes "distinct xs" "xs \<noteq> []" shows "list_succ xs (last xs) = hd xs"
  using assms by (auto simp: list_succ_def hd_conv_nth)

lemma list_succ_rotate1[simp]:
  assumes "distinct xs" shows "list_succ (rotate1 xs) = list_succ xs"
proof (rule ext)
  fix y show "list_succ (rotate1 xs) y = list_succ xs y"
    using assms
  proof (induct xs)
    case Nil then show ?case by simp
  next
    case (Cons x xs)
    show ?case
    proof (cases "x = y")
      case True
      then have "index (xs @ [y]) y = length xs"
        using \<open>distinct (x # xs)\<close> by (simp add: index_append)
      with True show ?thesis by (cases "xs=[]") (auto simp: list_succ_def nth_append)
    next
      case False
      then show ?thesis
        apply (cases "index xs y + 1 < length xs")
        apply (auto simp:list_succ_def index_append nth_append)
        by (metis Suc_lessI index_less_size_conv mod_self nth_Cons_0 nth_append nth_append_length)
    qed
  qed
qed

lemma list_succ_rotate[simp]:
  assumes "distinct xs" shows "list_succ (rotate n xs) = list_succ xs"
  using assms by (induct n) auto

lemma list_succ_in_conv:
  "list_succ xs x \<in> set xs \<longleftrightarrow> x \<in> set xs"
  by (auto simp: list_succ_def not_nil_if_in_set )

lemma list_succ_in_conv1:
  assumes "A \<inter> set xs = {}"
  shows "list_succ xs x \<in> A \<longleftrightarrow> x \<in> A"
  by (metis assms disjoint_iff_not_equal list_succ_in_conv list_succ_not_in)

lemma list_succ_commute:
  assumes "set xs \<inter> set ys = {}"
  shows "list_succ xs (list_succ ys x) = list_succ ys (list_succ xs x)"
proof -
  have "\<And>x. x \<in> set xs \<Longrightarrow> list_succ ys x = x"
     "\<And>x. x \<in> set ys \<Longrightarrow> list_succ xs x = x"
    using assms by (blast intro: list_succ_not_in)+
  then show ?thesis
    by (cases "x \<in> set xs \<union> set ys") (auto simp: list_succ_in_conv list_succ_not_in)
qed

subsection \<open>Arbitrary Permutations\<close>

fun lists_succ :: "'a list list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "lists_succ [] x = x"
| "lists_succ (xs # xss) x = list_succ xs (lists_succ xss x)"

definition distincts ::  "'a list list \<Rightarrow> bool" where
  "distincts xss \<equiv> distinct xss \<and> (\<forall>xs \<in> set xss. distinct xs \<and> xs \<noteq> []) \<and> (\<forall>xs \<in> set xss. \<forall>ys \<in> set xss. xs \<noteq> ys \<longrightarrow> set xs \<inter> set ys = {})"

lemma distincts_distinct: "distincts xss \<Longrightarrow> distinct xss"
  by (auto simp: distincts_def)

lemma distincts_Nil[simp]: "distincts []"
  by (simp add: distincts_def)

lemma distincts_single: "distincts [xs] \<longleftrightarrow> distinct xs \<and> xs \<noteq> []"
  by (auto simp add: distincts_def)

lemma distincts_Cons: "distincts (xs # xss)
   \<longleftrightarrow> xs \<noteq> [] \<and> distinct xs \<and> distincts xss \<and> (set xs \<inter> (\<Union>ys \<in> set xss. set ys)) = {}" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L then show ?R by (auto simp: distincts_def)
next
  assume ?R
  then have "distinct (xs # xss)"
    apply (auto simp: disjoint_iff_not_equal distincts_distinct)
    apply (metis length_greater_0_conv nth_mem)
    done
  moreover
  from \<open>?R\<close> have "\<forall>xs \<in> set (xs # xss). distinct xs \<and> xs \<noteq> []"
    by (auto simp: distincts_def)
  moreover
  from \<open>?R\<close> have "\<forall>xs' \<in> set (xs # xss). \<forall>ys \<in> set (xs # xss). xs' \<noteq> ys \<longrightarrow> set xs' \<inter> set ys = {}"
    by (simp add: distincts_def) blast
  ultimately show ?L unfolding distincts_def by (intro conjI)
qed

lemma distincts_Cons': "distincts (xs # xss)
   \<longleftrightarrow> xs \<noteq> [] \<and> distinct xs \<and> distincts xss \<and> (\<forall>ys \<in> set xss. set xs \<inter> set ys = {})" (is "?L \<longleftrightarrow> ?R")
 unfolding distincts_Cons by blast

lemma distincts_rev:
  "distincts (map rev xss) \<longleftrightarrow> distincts xss"
  by (simp add: distincts_def distinct_map)

lemma length_distincts:
  assumes "distincts xss"
  shows "length xss = card (set ` set xss)"
  using assms
proof (induct xss)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  then have "set xs \<notin> set ` set xss"
    using equals0I[of "set xs"] by (auto simp: distincts_Cons disjoint_iff_not_equal )
  with Cons show ?case by (auto simp add: distincts_Cons)
qed

lemma distincts_remove1: "distincts xss \<Longrightarrow> distincts (remove1 xs xss)"
  by (auto simp: distincts_def)

lemma distinct_Cons_remove1:
  "x \<in> set xs \<Longrightarrow> distinct (x # remove1 x xs) = distinct xs"
  by (induct xs) auto

lemma set_Cons_remove1:
  "x \<in> set xs \<Longrightarrow> set (x # remove1 x xs) = set xs"
  by (induct xs) auto

lemma distincts_Cons_remove1:
  "xs \<in> set xss \<Longrightarrow> distincts (xs # remove1 xs xss) = distincts xss"
  by (simp only: distinct_Cons_remove1 set_Cons_remove1 distincts_def)

lemma distincts_inj_on_set:
  assumes "distincts xss" shows "inj_on set (set xss)"
  by (rule inj_onI) (metis assms distincts_def inf.idem set_empty)

lemma distincts_distinct_set:
  assumes "distincts xss" shows "distinct (map set xss)"
  using assms by (auto simp: distinct_map distincts_distinct distincts_inj_on_set)

lemma distincts_distinct_nth:
  assumes "distincts xss" "n < length xss" shows "distinct (xss ! n)"
  using assms by (auto simp: distincts_def)

lemma lists_succ_not_in:
  assumes "x \<notin> (\<Union>xs\<in>set xss. set xs)" shows "lists_succ xss x = x"
  using assms by (induct xss) (auto simp: list_succ_not_in)

lemma lists_succ_in_conv:
  "lists_succ xss x \<in> (\<Union>xs\<in>set xss. set xs) \<longleftrightarrow> x \<in> (\<Union>xs\<in>set xss. set xs)"
  by (induct xss) (auto simp: list_succ_in_conv lists_succ_not_in list_succ_not_in)

lemma lists_succ_in_conv1:
  assumes "A \<inter> (\<Union>xs\<in>set xss. set xs) = {}"
  shows "lists_succ xss x \<in> A \<longleftrightarrow> x \<in> A"
  by (metis Int_iff assms emptyE lists_succ_in_conv lists_succ_not_in)

lemma lists_succ_Cons_pf: "lists_succ (xs # xss) = list_succ xs o lists_succ xss"
  by auto

lemma lists_succ_Nil_pf: "lists_succ [] = id"
  by (simp add: fun_eq_iff)

lemmas lists_succ_simps_pf = lists_succ_Cons_pf lists_succ_Nil_pf

lemma lists_succ_permutes:
  assumes "distincts xss"
  shows "lists_succ xss permutes (\<Union>xs \<in> set xss. set xs)"
  using assms
proof (induction xss)
  case Nil then show ?case by auto
next
  case (Cons xs xss)
  have "list_succ xs permutes (set xs)"
    using Cons by (intro list_succ_permutes) (simp add: distincts_def in_set_member)
  moreover
  have "lists_succ xss permutes (\<Union>ys \<in> set xss. set ys)"
    using Cons by (auto simp: Cons distincts_def)
  ultimately show "lists_succ (xs # xss) permutes (\<Union>ys \<in> set (xs # xss). set ys)"
    using Cons by (auto simp: lists_succ_Cons_pf intro: permutes_compose permutes_subset)
qed

lemma bij_lists_succ: "distincts xss \<Longrightarrow> bij (lists_succ xss)"
  by (induct xss) (auto simp: lists_succ_simps_pf bij_comp bij_list_succ distincts_Cons)

lemma lists_succ_snoc: "lists_succ (xss @ [xs]) = lists_succ xss o list_succ xs"
  by (induct xss) auto

lemma inv_lists_succ_eq:
  assumes "distincts xss"
  shows "inv (lists_succ xss) = lists_succ (rev (map rev xss))"
proof -
  have *: "\<And>f g. inv (\<lambda>b. f (g b)) = inv (f o g)" by (simp add: o_def)
  have **: "lists_succ [] = id" by auto
  show ?thesis
    using assms by (induct xss) (auto simp: * ** lists_succ_snoc lists_succ_Cons_pf o_inv_distrib
      inv_list_succ_eq distincts_Cons bij_list_succ bij_lists_succ)
qed

lemma lists_succ_remove1:
  assumes "distincts xss" "xs \<in> set xss"
  shows "lists_succ (xs # remove1 xs xss) = lists_succ xss"
  using assms
proof (induct xss)
  case Nil then show ?case by simp
next
  case (Cons ys xss)
  show ?case
  proof cases
    assume "xs = ys" then show ?case by simp
  next
    assume "xs \<noteq> ys"
    with Cons.prems have inter: "set xs \<inter> set ys = {}" and "xs \<in> set xss"
      by (auto simp: distincts_Cons)
    have dists:
        "distincts (xs # remove1 xs xss)"
        "distincts (xs # ys # remove1 xs xss)"
      using \<open>distincts (ys # xss)\<close> \<open>xs \<in> set xss\<close> by (auto simp: distincts_def)

    have "list_succ xs \<circ> (list_succ ys \<circ> lists_succ (remove1 xs xss))
        = list_succ ys \<circ> (list_succ xs \<circ> lists_succ (remove1 xs xss))"
      using inter unfolding fun_eq_iff comp_def
      by (subst list_succ_commute) auto
    also have "\<dots> = list_succ ys o (lists_succ (xs # remove1 xs xss))"
      using dists by (simp add: lists_succ_Cons_pf distincts_Cons)
    also have "\<dots> = list_succ ys o lists_succ xss"
      using \<open>xs \<in> set xss\<close> \<open>distincts (ys # xss)\<close>
      by (simp add: distincts_Cons Cons.hyps)
    finally
    show "lists_succ (xs # remove1 xs (ys # xss)) = lists_succ (ys # xss)"
      using Cons dists by (auto simp: lists_succ_Cons_pf distincts_Cons)
  qed
qed

lemma lists_succ_no_order:
  assumes "distincts xss" "distincts yss" "set xss = set yss"
  shows "lists_succ xss = lists_succ yss"
  using assms
proof (induct xss arbitrary: yss)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  have "xs \<notin> set xss" "xs \<in> set yss" using Cons.prems
    by (auto dest: distincts_distinct)
  have "lists_succ xss = lists_succ (remove1 xs yss)"
    using Cons.prems \<open>xs \<notin> _\<close>
    by (intro Cons.hyps) (auto simp add: distincts_Cons distincts_remove1 distincts_distinct)
  then have "lists_succ (xs # xss) = lists_succ (xs # remove1 xs yss)"
    using Cons.prems \<open>xs \<in> _\<close>
    by (simp add: lists_succ_Cons_pf distincts_Cons_remove1)
  then show ?case
    using Cons.prems \<open>xs \<in> _\<close> by (simp add: lists_succ_remove1)
qed

section \<open>List Orbits\<close>

text \<open>Computes the orbit of @{term x} under @{term f}\<close>
definition orbit_list :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "orbit_list f x \<equiv> iterate 0 (funpow_dist1 f x x) f x"

partial_function (tailrec)
  orbit_list_impl :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  "orbit_list_impl f s acc x = (let x' = f x in if x' = s then rev (x # acc) else orbit_list_impl f s (x # acc) x')"

context notes [simp] = length_fold_remove1_le begin
text \<open>Computes the list of orbits\<close>
fun orbits_list :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "orbits_list f [] = []"
| "orbits_list f (x # xs) =
     orbit_list f x # orbits_list f (fold remove1 (orbit_list f x) xs)"

fun orbits_list_impl :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "orbits_list_impl f [] = []"
| "orbits_list_impl f (x # xs) =
     (let fc = orbit_list_impl f x [] x in fc # orbits_list_impl f (fold remove1 fc xs))"

declare orbit_list_impl.simps[code]
end

abbreviation sset :: "'a list list \<Rightarrow> 'a set set" where
  "sset xss \<equiv> set ` set xss"

lemma iterate_funpow_step:
  assumes "f x \<noteq> y" "y \<in> orbit f x"
  shows "iterate 0 (funpow_dist1 f x y) f x = x # iterate 0 (funpow_dist1 f (f x) y) f (f x)"
proof -
  from assms have A: "y \<in> orbit f (f x)" by (simp add: orbit_step)
  have "iterate 0 (funpow_dist1 f x y) f x = x # iterate 1 (funpow_dist1 f x y) f x" (is "_ = _ # ?it")
    unfolding iterate_def by (simp add: upt_rec)
  also have "?it = map (\<lambda>n. (f ^^ n) x) (map Suc [0..<funpow_dist f (f x) y])"
    unfolding iterate_def map_Suc_upt by simp
  also have "\<dots> = map (\<lambda>n. (f ^^ n) (f x)) [0..<funpow_dist f (f x) y]"
    by (simp add: funpow_swap1)
  also have "\<dots> = iterate 0 (funpow_dist1 f (f x) y) f (f x)"
    unfolding iterate_def
    unfolding iterate_def by (simp add: funpow_dist_step[OF assms(1) A])
  finally show ?thesis .
qed

lemma orbit_list_impl_conv:
  assumes "y \<in> orbit f x"
  shows "orbit_list_impl f y acc x = rev acc @ iterate 0 (funpow_dist1 f x y) f x"
  using assms
proof (induct n\<equiv>"funpow_dist1 f x y" arbitrary: x acc)
  case (Suc x)

  show ?case
  proof cases
    assume "f x = y"
    then show ?thesis by (subst orbit_list_impl.simps) (simp add: Let_def iterate_def funpow_dist_0)
  next
    assume not_y :"f x \<noteq> y"

    have y_in_succ: "y \<in> orbit f (f x)"
      by (intro orbit_step Suc.prems not_y)

    have "orbit_list_impl f y acc x = orbit_list_impl f y (x # acc) (f x)"
      using not_y by (subst orbit_list_impl.simps) simp
    also have "\<dots> = rev (x # acc) @ iterate 0 (funpow_dist1 f (f x) y) f (f x)" (is "_ = ?rev @ ?it")
      by (intro Suc funpow_dist_step not_y y_in_succ)
    also have "\<dots> = rev acc @ iterate 0 (funpow_dist1 f x y) f x"
      using not_y Suc.prems by (simp add: iterate_funpow_step)
    finally show ?thesis .
  qed
qed

lemma orbit_list_conv_impl:
  assumes "x \<in> orbit f x"
  shows "orbit_list f x = orbit_list_impl f x [] x"
  unfolding orbit_list_impl_conv[OF assms] orbit_list_def by simp

lemma set_orbit_list:
  assumes "x \<in> orbit f x"
  shows "set (orbit_list f x) = orbit f x"
  by (simp add: orbit_list_def orbit_conv_funpow_dist1[OF assms] set_iterate)

lemma set_orbit_list':
  assumes "permutation f" shows "set (orbit_list f x) = orbit f x"
  using assms by (simp add: permutation_self_in_orbit set_orbit_list)

lemma distinct_orbit_list:
  assumes "x \<in> orbit f x"
  shows "distinct (orbit_list f x)"
  by (simp del: upt_Suc add: orbit_list_def iterate_def distinct_map inj_on_funpow_dist1[OF assms])

lemma distinct_orbit_list':
  assumes "permutation f" shows "distinct (orbit_list f x)"
  using assms by (simp add: permutation_self_in_orbit distinct_orbit_list)

lemma orbits_list_conv_impl:
  assumes "permutation f"
  shows "orbits_list f xs = orbits_list_impl f xs"
proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less show ?case
    using assms by (cases xs) (auto simp: assms less less_Suc_eq_le length_fold_remove1_le
      orbit_list_conv_impl permutation_self_in_orbit Let_def)
qed

lemma orbit_list_not_nil[simp]: "orbit_list f x \<noteq> []"
  by (simp add: orbit_list_def)

lemma sset_orbits_list:
  assumes "permutation f" shows "sset (orbits_list f xs) = (orbit f) ` set xs"
proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less
  show ?case
  proof (cases xs)
    case Nil then show ?thesis by simp
  next
    case (Cons x' xs')
    let ?xs'' = "fold remove1 (orbit_list f x') xs'"
    have A: "sset (orbits_list f ?xs'') = orbit f ` set ?xs''"
      using Cons by (simp add: less_Suc_eq_le length_fold_remove1_le less.hyps)
    have B: "set (orbit_list f x') = orbit f x'"
      by (rule set_orbit_list) (simp add: permutation_self_in_orbit assms)

    have "orbit f ` set (fold remove1 (orbit_list f x') xs') \<subseteq> orbit f ` set xs'"
      using set_fold_remove1[of _ xs'] by auto
    moreover
    have "orbit f ` set xs' - {orbit f x'} \<subseteq> (orbit f ` set (fold remove1 (orbit_list f x') xs'))" (is "?L \<subseteq> ?R")
    proof
      fix A assume "A \<in> ?L"
      then obtain y where "A = orbit f y" "y \<in> set xs'" by auto
      have "A \<noteq> orbit f x'" using \<open>A \<in> ?L\<close> by auto
      from \<open>A = _\<close> \<open>A \<noteq> _\<close> have "y \<notin> orbit f x'"
        by (meson assms cyclic_on_orbit orbit_cyclic_eq3 permutation_permutes)
      with \<open>y \<in> _\<close> have "y \<in> set (fold remove1 (orbit_list f x') xs')"
        by (auto simp: set_fold_remove1' set_orbit_list permutation_self_in_orbit assms)
      then show "A \<in> ?R" using \<open>A = _\<close> by auto
    qed
    ultimately
    show ?thesis by (auto simp: A B Cons)
  qed
qed

subsection \<open>Relation to @{term cyclic_on}\<close>

lemma list_succ_orbit_list:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  shows "list_succ (orbit_list f s) = f"
proof -
  have "distinct (orbit_list f s)" "\<And>x. x \<notin> set (orbit_list f s) \<Longrightarrow> x = f x"
    using assms by (simp_all add: distinct_orbit_list set_orbit_list)
  moreover
  have "\<And>i. i < length (orbit_list f s) \<Longrightarrow> orbit_list f s ! (Suc i mod length (orbit_list f s)) = f (orbit_list f s ! i)"
    using funpow_dist1_prop[OF \<open>s \<in> orbit f s\<close>] by (auto simp: orbit_list_def funpow_mod_eq)
  ultimately show ?thesis
    by (auto simp: list_succ_def fun_eq_iff)
qed

lemma list_succ_funpow_conv:
  assumes A: "distinct xs" "x \<in> set xs"
  shows "(list_succ xs ^^ n) x = xs ! ((index xs x + n) mod length xs)"
proof -
  have "xs \<noteq> []" using assms by auto
  then show ?thesis
    by (induct n) (auto simp: hd_conv_nth A index_nth_id list_succ_def mod_simps)
qed

lemma orbit_list_succ:
  assumes "distinct xs" "x \<in> set xs"
  shows "orbit (list_succ xs) x = set xs"
proof (intro set_eqI iffI)
  fix y assume "y \<in> orbit (list_succ xs) x"
  then show "y \<in> set xs"
    by induct (auto simp: list_succ_in_conv \<open>x \<in> set xs\<close>)
next
  fix y assume "y \<in> set xs"
  moreover
  { fix i j have "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> \<exists>n. xs ! j = xs ! ((i + n) mod length xs)"
      using assms by (auto simp: exI[where x="j + (length xs - i)"])
  }
  ultimately
  show "y \<in> orbit (list_succ xs) x"
    using assms by (auto simp: orbit_altdef_permutation permutation_list_succ list_succ_funpow_conv index_nth_id in_set_conv_nth)
qed

lemma cyclic_on_list_succ:
  assumes "distinct xs" "xs \<noteq> []" shows "cyclic_on (list_succ xs) (set xs)"
  using assms last_in_set by (auto simp: cyclic_on_def orbit_list_succ)

lemma obtain_orbit_list_func:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  obtains xs where "f = list_succ xs" "set xs = orbit f s" "distinct xs" "hd xs = s"
proof -
  { from assms have "f = list_succ (orbit_list f s)" by (simp add: list_succ_orbit_list)
    moreover
    have "set (orbit_list f s) = orbit f s" "distinct (orbit_list f s)"
      by (auto simp: set_orbit_list distinct_orbit_list assms)
    moreover have "hd (orbit_list f s) = s"
      by (simp add: orbit_list_def iterate_def hd_map del: upt_Suc)
    ultimately have "\<exists>xs. f = list_succ xs \<and> set xs = orbit f s \<and> distinct xs \<and> hd xs = s" by blast
  } then show ?thesis by (metis that)
qed

lemma cyclic_on_obtain_list_succ:
  assumes "cyclic_on f S" "\<And>x. x \<notin> S \<Longrightarrow> f x = x"
  obtains xs where "f = list_succ xs" "set xs = S" "distinct xs"
proof -
  from assms obtain s where s: "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"  "S = orbit f s"
    by (auto simp: cyclic_on_def)
  then show ?thesis by (metis that obtain_orbit_list_func)
qed

lemma cyclic_on_obtain_list_succ':
  assumes "cyclic_on f S" "f permutes S"
  obtains xs where "f = list_succ xs" "set xs = S" "distinct xs"
  using assms unfolding permutes_def by (metis cyclic_on_obtain_list_succ)

lemma list_succ_unique:
  assumes "s \<in> orbit f s" "\<And>x. x \<notin> orbit f s \<Longrightarrow> f x = x"
  shows "\<exists>!xs. f = list_succ xs \<and> distinct xs \<and> hd xs = s \<and> set xs = orbit f s"
proof -
  from assms obtain xs where xs: "f = list_succ xs" "distinct xs" "hd xs = s" "set xs = orbit f s"
    by (rule obtain_orbit_list_func)
  moreover
  { fix zs
    assume A: "f = list_succ zs" "distinct zs" "hd zs = s" "set zs = orbit f s"
    then have "zs \<noteq> []" using \<open>s \<in> orbit f s\<close> by auto
    from \<open>distinct xs\<close> \<open>distinct zs\<close> \<open>set xs = orbit f s\<close> \<open>set zs = orbit f s\<close>
    have len: "length xs = length zs" by (metis distinct_card)

    { fix n assume "n < length xs"
      then have "zs ! n = xs ! n"
      proof (induct n)
        case 0 with A xs \<open>zs \<noteq> []\<close> show ?case by (simp add: hd_conv_nth nth_rotate_conv_nth)
      next
        case (Suc n)
        then have "list_succ zs (zs ! n) = list_succ xs (xs! n)"
          using \<open>f = list_succ xs\<close> \<open>f = list_succ zs\<close> by simp
        with \<open>Suc n < _\<close> show ?case
          by (simp add:list_succ_nth len \<open>distinct xs\<close> \<open>distinct zs\<close>)
      qed }
    then have "zs = xs" by (metis len nth_equalityI) }
  ultimately show ?thesis by metis
qed

lemma distincts_orbits_list:
  assumes "distinct as" "permutation f"
  shows "distincts (orbits_list f as)"
  using assms(1)
proof (induct "length as" arbitrary: as rule: less_induct)
  case less
  show ?case
  proof (cases as)
    case Nil then show ?thesis by simp
  next
    case (Cons a as')
    let ?as' = "fold remove1 (orbit_list f a) as'"
    from Cons less.prems have A: "distincts (orbits_list f (fold remove1 (orbit_list f a) as'))"
      by (intro less) (auto simp: distinct_fold_remove1 length_fold_remove1_le less_Suc_eq_le)

    have B: "set (orbit_list f a) \<inter> \<Union>(sset (orbits_list f (fold remove1 (orbit_list f a) as'))) = {}"
    proof -
      have "orbit f a \<inter> set (fold remove1 (orbit_list f a) as') = {}"
        using assms less.prems Cons by (simp add: set_fold_remove1_distinct set_orbit_list')
      then have "orbit f a \<inter> \<Union> (orbit f ` set (fold remove1 (orbit_list f a) as')) = {}"
        by auto (metis assms(2) cyclic_on_orbit disjoint_iff_not_equal permutation_self_in_orbit[OF assms(2)] orbit_cyclic_eq3 permutation_permutes)
      then show ?thesis using assms
      by (auto simp: set_orbit_list' sset_orbits_list disjoint_iff_not_equal)
    qed
    show ?thesis
      using A B assms by (auto simp: distincts_Cons Cons distinct_orbit_list')
  qed
qed

lemma cyclic_on_lists_succ':
  assumes "distincts xss"
  shows "A \<in> sset xss \<Longrightarrow> cyclic_on (lists_succ xss) A"
  using assms
proof (induction xss arbitrary: A)
  case Nil then show ?case by auto
next
  case (Cons xs xss A)
  then have inter: "set xs \<inter> (\<Union>ys\<in>set xss. set ys) = {}" by (auto simp: distincts_Cons)

  note pcp[OF _ _ inter] = permutes_comp_preserves_cyclic1 permutes_comp_preserves_cyclic2
  from Cons show "cyclic_on (lists_succ (xs # xss)) A"
    by (cases "A = set xs")
      (auto intro: pcp simp: cyclic_on_list_succ list_succ_permutes
        lists_succ_permutes lists_succ_Cons_pf distincts_Cons)
qed

lemma cyclic_on_lists_succ:
  assumes "distincts xss"
  shows "\<And>xs. xs \<in> set xss \<Longrightarrow> cyclic_on (lists_succ xss) (set xs)"
  using assms by (auto intro: cyclic_on_lists_succ')

lemma permutes_as_lists_succ:
  assumes "distincts xss"
  assumes ls_eq: "\<And>xs. xs \<in> set xss \<Longrightarrow> list_succ xs = perm_restrict f (set xs)"
  assumes "f permutes (\<Union>(sset xss))"
  shows "f = lists_succ xss"
  using assms
proof (induct xss arbitrary: f)
  case Nil then show ?case by simp
next
  case (Cons xs xss)
  let ?sets = "\<lambda>xss. \<Union>ys \<in> set xss. set ys"

  have xs: "distinct xs" "xs \<noteq> []" using Cons by (auto simp: distincts_Cons)

  have f_xs: "perm_restrict f (set xs) = list_succ xs"
    using Cons by simp

  have co_xs: "cyclic_on (perm_restrict f (set xs)) (set xs)"
    unfolding f_xs using xs by (rule cyclic_on_list_succ)

  have perm_xs: "perm_restrict f (set xs) permutes set xs"
    unfolding f_xs using \<open>distinct xs\<close> by (rule list_succ_permutes)

  have perm_xss: "perm_restrict f (?sets xss) permutes (?sets xss)"
  proof -
    have "perm_restrict f (?sets (xs # xss) - set xs) permutes (?sets (xs # xss) - set xs)"
      using Cons co_xs by (intro perm_restrict_diff_cyclic) (auto simp: cyclic_on_perm_restrict)
    also have "?sets (xs # xss) - set xs = ?sets xss"
      using Cons by (auto simp: distincts_Cons)
    finally show ?thesis .
  qed

  have f_xss: "perm_restrict f (?sets xss) = lists_succ xss"
  proof -
    have *: "\<And>xs. xs \<in> set xss \<Longrightarrow> ((\<Union>x\<in>set xss. set x) \<inter> set xs) = set xs"
      by blast
    with perm_xss Cons.prems show ?thesis
      by (intro Cons.hyps) (auto simp: distincts_Cons perm_restrict_perm_restrict *)
  qed

  from Cons.prems show "f = lists_succ (xs # xss)"
    by (simp add: lists_succ_Cons_pf distincts_Cons f_xss[symmetric]
      perm_restrict_union perm_xs perm_xss)
qed

lemma cyclic_on_obtain_lists_succ:
  assumes
    permutes: "f permutes S" and
    S: "S = \<Union>(sset css)" and
    dists: "distincts css" and
    cyclic: "\<And>cs. cs \<in> set css \<Longrightarrow> cyclic_on f (set cs)"
  obtains xss where "f = lists_succ xss" "distincts xss" "map set xss = map set css" "map hd xss = map hd css"
proof -
  let ?fc = "\<lambda>cs. perm_restrict f (set cs)"
  define some_list where "some_list cs = (SOME xs. ?fc cs = list_succ xs \<and> set xs = set cs \<and> distinct xs \<and> hd xs = hd cs)" for cs
  { fix cs assume "cs \<in> set css"
    then have "cyclic_on (?fc cs) (set cs)" "\<And>x. x \<notin> set cs \<Longrightarrow> ?fc cs x = x" "hd cs \<in> set cs"
      using cyclic dists by (auto simp add: cyclic_on_perm_restrict perm_restrict_def distincts_def)
    then have "hd cs \<in> orbit (?fc cs) (hd cs)"  "\<And>x. x \<notin> orbit (?fc cs) (hd cs) \<Longrightarrow> ?fc cs x = x" "hd cs \<in> set cs" "set cs = orbit (?fc cs) (hd cs)"
      by (auto simp: cyclic_on_alldef)
    then have "\<exists>xs. ?fc cs = list_succ xs \<and> set xs = set cs \<and> distinct xs \<and> hd xs = hd cs"
      by (metis obtain_orbit_list_func)
    then have "?fc cs = list_succ (some_list cs) \<and> set (some_list cs) = set cs \<and> distinct (some_list cs) \<and> hd (some_list cs) = hd cs"
      unfolding some_list_def by (rule someI_ex)
    then have "?fc cs = list_succ (some_list cs)" "set (some_list cs) = set cs" "distinct (some_list cs)" "hd (some_list cs) = hd cs"
      by auto
  } note sl_cs  = this

  have "\<And>cs. cs \<in> set css \<Longrightarrow> cs \<noteq> []" using dists by (auto simp: distincts_def)
  then have some_list_ne: "\<And>cs. cs \<in> set css \<Longrightarrow> some_list cs \<noteq> []"
    by (metis set_empty sl_cs(2))

  have set: "map set (map some_list css) = map set css" "map hd (map some_list css) = map hd css"
    using sl_cs(2,4) by (auto simp add: map_idI)

  have distincts: "distincts (map some_list css)"
  proof -
    have c_dist: "\<And>xs ys. \<lbrakk>xs\<in>set css; ys\<in>set css; xs \<noteq> ys\<rbrakk> \<Longrightarrow> set xs \<inter> set ys = {}"
      using dists by (auto simp: distincts_def)

    have "distinct (map some_list css)"
    proof -
      have "inj_on some_list (set css)"
        using sl_cs(2) c_dist by (intro inj_onI) (metis inf.idem set_empty)
      with \<open>distincts css\<close> show ?thesis
        by (auto simp: distincts_distinct distinct_map)
    qed
    moreover
    have "\<forall>xs\<in>set (map some_list css). distinct xs \<and> xs \<noteq> []"
      using sl_cs(3) some_list_ne by auto
    moreover
    from c_dist have "(\<forall>xs\<in>set (map some_list css). \<forall>ys\<in>set (map some_list css). xs \<noteq> ys \<longrightarrow> set xs \<inter> set ys = {})"
      using sl_cs(2) by auto
    ultimately
    show ?thesis by (simp add: distincts_def)
  qed

  have f: "f = lists_succ (map some_list css)"
    using distincts
  proof (rule permutes_as_lists_succ)
    fix xs assume "xs \<in> set (map some_list css)"
    then show "list_succ xs = perm_restrict f (set xs)"
      using sl_cs(1) sl_cs(2) by auto
  next
    have "S = (\<Union>xs\<in>set (map some_list css). set xs)"
      using S sl_cs(2) by auto
    with permutes show "f permutes \<Union>(sset (map some_list css))"
      by simp
  qed

  from f distincts set  show ?thesis ..
qed

subsection \<open>Permutations of a List\<close>

lemma length_remove1_less:
  assumes "x \<in> set xs" shows "length (remove1 x xs) < length xs"
proof -
  from assms have "0 < length xs" by auto
  with assms show ?thesis by (auto simp: length_remove1)
qed
context notes [simp] = length_remove1_less begin
fun permutations :: "'a list \<Rightarrow> 'a list list" where
  permutations_Nil: "permutations [] = [[]]"
| permutations_Cons:
    "permutations xs = [y # ys. y <- xs, ys <- permutations (remove1 y xs)]"
end

declare permutations_Cons[simp del]

text \<open>
  The function above returns all permutations of a list. The function below computes
  only those which yield distinct cyclic permutation functions (cf. @{term list_succ}).
\<close>

fun cyc_permutations :: "'a list \<Rightarrow> 'a list list" where
  "cyc_permutations [] = [[]]"
| "cyc_permutations (x # xs) = map (Cons x) (permutations xs)"

lemma nil_in_permutations[simp]: "[] \<in> set (permutations xs) \<longleftrightarrow> xs = []"
  by (induct xs) (auto simp: permutations_Cons)

lemma permutations_not_nil:
  assumes "xs \<noteq> []"
  shows "permutations xs = concat (map (\<lambda>x. map ((#) x) (permutations (remove1 x xs))) xs)"
  using assms by (cases xs) (auto simp: permutations_Cons)

lemma set_permutations_step:
  assumes "xs \<noteq> []"
  shows "set (permutations xs) = (\<Union>x \<in> set xs. Cons x ` set (permutations (remove1 x xs)))"
  using assms by (cases xs) (auto simp: permutations_Cons)

lemma in_set_permutations:
  assumes "distinct xs"
  shows "ys \<in> set (permutations xs) \<longleftrightarrow> distinct ys \<and> set xs = set ys" (is "?L xs ys \<longleftrightarrow> ?R xs ys")
  using assms
proof (induct "length xs" arbitrary: xs ys)
  case 0 then show ?case by auto
next
  case (Suc n)
  then have "xs \<noteq> []" by auto

  show ?case
  proof
    assume "?L xs ys"
    then obtain y ys' where "ys = y # ys'" "y \<in> set xs" "ys' \<in> set (permutations (remove1 (hd ys) xs))"
      using \<open>xs \<noteq> []\<close> by (auto simp: permutations_not_nil)
    moreover
    then have "?R (remove1 y xs) ys'"
      using Suc.prems Suc.hyps(2) by (intro Suc.hyps(1)[THEN iffD1]) (auto simp: length_remove1)
    ultimately show "?R xs ys"
      using Suc by auto
  next
    assume "?R xs ys"
    with \<open>xs \<noteq> []\<close> obtain y ys' where "ys = y # ys'" "y \<in> set xs" by (cases ys) auto
    moreover
    then have "ys' \<in> set (permutations (remove1 y xs))"
      using Suc \<open>?R xs ys\<close> by (intro Suc.hyps(1)[THEN iffD2]) (auto simp: length_remove1)
    ultimately
    show "?L xs ys"
      using \<open>xs \<noteq> []\<close> by (auto simp: permutations_not_nil)
  qed
qed

lemma in_set_cyc_permutations:
  assumes "distinct xs"
  shows "ys \<in> set (cyc_permutations xs) \<longleftrightarrow> distinct ys \<and> set xs = set ys \<and> hd ys = hd xs" (is "?L xs ys \<longleftrightarrow> ?R xs ys")
proof (cases xs)
  case (Cons x xs) with assms show ?thesis
    by (cases ys) (auto simp: in_set_permutations intro!: imageI)
qed auto

lemma in_set_cyc_permutations_obtain:
  assumes "distinct xs" "distinct ys" "set xs = set ys"
  obtains n where "rotate n ys \<in> set (cyc_permutations xs)"
proof (cases xs)
  case Nil with assms have "rotate 0 ys \<in> set (cyc_permutations xs)" by auto
  then show ?thesis ..
next
  case (Cons x xs')
  let ?ys' = "rotate (index ys x) ys"
  have "ys \<noteq> []" "x \<in> set ys"
    using Cons assms by auto
  then have "distinct ?ys' \<and> set xs = set ?ys' \<and> hd ?ys' = hd xs"
    using assms Cons by (auto simp add: hd_rotate_conv_nth)
  with \<open>distinct xs\<close> have "?ys' \<in> set (cyc_permutations xs)"
    by (rule in_set_cyc_permutations[THEN iffD2])
  then show ?thesis ..
qed

lemma list_succ_set_cyc_permutations:
  assumes "distinct xs" "xs \<noteq> []"
  shows "list_succ ` set (cyc_permutations xs) = {f. f permutes set xs \<and> cyclic_on f (set xs)}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix f assume "f \<in> ?L"
  moreover have "\<And>ys. set xs = set ys \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> ys \<noteq> []" by auto
  ultimately show "f \<in> ?R"
    using assms by (auto simp: in_set_cyc_permutations list_succ_permutes cyclic_on_list_succ)
next
  fix f assume "f \<in> ?R"
  then obtain ys where ys: "list_succ ys = f" "distinct ys" "set ys = set xs"
    by (auto elim: cyclic_on_obtain_list_succ')
  moreover
  with \<open>distinct xs\<close> obtain n where "rotate n ys \<in> set (cyc_permutations xs)"
    by (auto elim: in_set_cyc_permutations_obtain)
  then have "list_succ (rotate n ys) \<in> ?L" by simp
  ultimately
  show "f \<in> ?L" by simp
qed

subsection \<open>Enumerating Permutations from List Orbits\<close>

definition cyc_permutationss :: "'a list list \<Rightarrow> 'a list list list" where
  "cyc_permutationss = product_lists o map cyc_permutations"

lemma cyc_permutationss_Nil[simp]: "cyc_permutationss [] = [[]]"
  by (auto simp: cyc_permutationss_def)

lemma in_set_cyc_permutationss:
  assumes "distincts xss"
  shows "yss \<in> set (cyc_permutationss xss) \<longleftrightarrow> distincts yss \<and> map set xss = map set yss \<and> map hd xss = map hd yss"
proof -
  { assume A: "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map cyc_permutations xss)"
    then have "length yss = length xss" by (auto simp: list_all2_lengthD)
    then have "\<Union>(sset xss) = \<Union>(sset yss)" "distincts yss" "map set xss = map set yss" "map hd xss = map hd yss"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_cyc_permutations)
  } note X = this
  { assume A: "distincts yss" "map set xss = map set yss" "map hd xss = map hd yss"
    then have "length yss = length xss" by (auto dest: map_eq_imp_length_eq)
    then have "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map cyc_permutations xss)"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_cyc_permutations)
  } note Y = this
  show "?thesis"
    unfolding cyc_permutationss_def
    by (auto simp: product_lists_set intro: X Y)
qed

lemma lists_succ_set_cyc_permutationss:
  assumes "distincts xss"
  shows "lists_succ ` set (cyc_permutationss xss) = {f. f permutes \<Union>(sset xss) \<and> (\<forall>c \<in> sset xss. cyclic_on f c)}" (is "?L = ?R")
  using assms
proof (intro set_eqI iffI)
  fix f assume "f \<in> ?L"
  then obtain yss where "yss \<in> set (cyc_permutationss xss)" "f = lists_succ yss" by (rule imageE)
  moreover
  from \<open>yss \<in> _\<close> assms have "set (map set xss) = set (map set yss)"
    by (auto simp: in_set_cyc_permutationss)
  then have "sset xss = sset yss" by simp
  ultimately
  show "f \<in> ?R"
    using assms
  by (auto simp: in_set_cyc_permutationss cyclic_on_lists_succ') (metis lists_succ_permutes)
next
  fix f assume "f \<in> ?R"
  then have "f permutes \<Union>(sset xss)" "\<And>cs. cs \<in> set xss \<Longrightarrow> cyclic_on f (set cs)"
    by auto
  from this(1) refl assms this(2)
  obtain yss where "f = lists_succ yss" "distincts yss" "map set yss = map set xss" "map hd yss = map hd xss"
    by (rule cyclic_on_obtain_lists_succ)
  with assms show "f \<in> ?L" by (auto intro!: imageI simp: in_set_cyc_permutationss)
qed

subsection \<open>Lists of Permutations\<close>

definition permutationss :: "'a list list \<Rightarrow> 'a list list list" where
  "permutationss = product_lists o map permutations"

lemma permutationss_Nil[simp]: "permutationss [] = [[]]"
  by (auto simp: permutationss_def)

lemma permutationss_Cons:
  "permutationss (xs # xss) = concat (map (\<lambda>ys. map (Cons ys) (permutationss xss)) (permutations xs))"
  by (auto simp: permutationss_def)

lemma in_set_permutationss:
  assumes "distincts xss"
  shows "yss \<in> set (permutationss xss) \<longleftrightarrow> distincts yss \<and> map set xss = map set yss"
proof -
  { assume A: "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map permutations xss)"
    then have "length yss = length xss" by (auto simp: list_all2_lengthD)
    then have "\<Union>(sset xss) = \<Union>(sset yss)" "distincts yss" "map set xss = map set yss"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: distincts_Cons in_set_permutations)
  } note X = this
  { assume A: "distincts yss" "map set xss = map set yss"
    then have "length yss = length xss" by (auto dest: map_eq_imp_length_eq)
    then have "list_all2 (\<lambda>x ys. x \<in> set ys) yss (map permutations xss)"
      using A assms
      by (induct yss xss rule: list_induct2) (auto simp: in_set_permutations distincts_Cons)
  } note Y = this
  show "?thesis"
    unfolding permutationss_def
    by (auto simp: product_lists_set intro: X Y)
qed

lemma set_permutationss:
  assumes "distincts xss"
  shows "set (permutationss xss) = {yss. distincts yss \<and> map set xss = map set yss}"
  using in_set_permutationss[OF assms] by blast

lemma permutations_complete: (* could generalize with multi-sets *)
  assumes "distinct xs" "distinct ys" "set xs = set ys"
  shows "ys \<in> set (permutations xs)"
  using assms
proof (induct "length xs" arbitrary: xs ys)
  case 0 then show ?case by simp
next
  case (Suc n)
  from Suc.hyps have "xs \<noteq> []" by auto
  then obtain y ys' where [simp]: "ys = y # ys'" "y \<in> set xs" using Suc.prems by (cases ys) auto
  have "ys' \<in> set (permutations (remove1 y xs))"
    using Suc.prems \<open>Suc n = _\<close> by (intro Suc.hyps) (simp_all add: length_remove1 )
  then show ?case using \<open>xs \<noteq> []\<close> by (auto simp: set_permutations_step)
qed

end


theory Homework8
imports "../Tutorials/IMPArrayHoarePartial"
begin
  context includes IMP_Syntax begin

  (*
    ISSUED: Wednesday, Nov 8
    DUE: Wednesday, Nov 15, 11:59pm
    POINTS: 10 (3+3+4) and 4 bonus points
  *)

  (*
    General remark:
      If you cannot discharge all verification conditions (VCs), single them
      out and use sorry only on that specific VC!
      Sometimes sledgehammer might help, and sometimes your invariant may
      just be too weak. It might make sense to try to prove the VC on paper,
      and then translate your paper proof to an Isar proof,
      or try to figure out why the VC is not provable and alter the
      invariant accordingly.

      In case of odd-looking problems with the VCG, do not hesitate to
      contact me, it might actually be a bug in the VCGs setup, as you are
      the first people to use it ;)
      Most often, it will be a forgotten variable binding or CLR, though!

  *)

  section \<open>Part 1\<close>
    (*
      Warm-up: Division by approximation from below.
    *)

    (* Hint: The following lemma might be useful to discharge a proof obligation! *)
    lemma div1_aux: "\<lbrakk>(0::int) \<le> n\<^sub>0; q\<^sub>0 \<noteq> 0; \<not> r * q\<^sub>0 \<le> n\<^sub>0; (r - 1) * q\<^sub>0 \<le> n\<^sub>0\<rbrakk> \<Longrightarrow> r - 1 = n\<^sub>0 div q\<^sub>0"
      by (smt Divides.pos_mod_sign cancel_div_mod_rules(2) mult.commute mult_right_mono_neg nonzero_mult_div_cancel_right zdiv_mono1)

    abbreviation "div_prog \<equiv>
      CLR r;;
      r ::= N 1;;
      WHILE ($r * $q <= $n) DO (
        r ::= Plus ($r) (N 1)
      );;
      r ::= Minus ($r) (N 1)
      "

    definition Idiv :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
      where "Idiv n\<^sub>0 q\<^sub>0 r \<equiv> (0 \<le> n\<^sub>0) \<and>((r-1)*q\<^sub>0) \<le> n\<^sub>0"  (* Provide an invariant! *)

lemma div_aux: " 0 \<le> n\<^sub>0 \<Longrightarrow> q\<^sub>0 \<noteq> 0 \<Longrightarrow> r * q\<^sub>0 \<le> n\<^sub>0 \<Longrightarrow> Idiv n\<^sub>0 q\<^sub>0 r \<Longrightarrow> Idiv n\<^sub>0 q\<^sub>0 (r + 1)"
" 0 \<le> n\<^sub>0 \<Longrightarrow> q\<^sub>0 \<noteq> 0 \<Longrightarrow> \<not> r * q\<^sub>0 \<le> n\<^sub>0 \<Longrightarrow> Idiv n\<^sub>0 q\<^sub>0 r \<Longrightarrow> r - 1 = n\<^sub>0 div q\<^sub>0"
"0 \<le> n\<^sub>0 \<Longrightarrow> q\<^sub>0 \<noteq> 0 \<Longrightarrow> Idiv n\<^sub>0 q\<^sub>0 1"
   apply (simp add: Idiv_def)
  using Idiv_def div1_aux apply blast
  by (simp add: Idiv_def)

    lemma "\<lbrakk>0\<le>n\<^sub>0; q\<^sub>0\<noteq>0\<rbrakk> \<Longrightarrow>                          (* Precondition *)
      \<Turnstile> {\<lambda>s. s ''n'' = var n\<^sub>0 \<and> s ''q'' = var q\<^sub>0}   (* Input variable binding *)
          div_prog
        {\<lambda>s.
          \<exists>r. s ''r'' = var r                       (* Output variable bindings *)
          \<and> s ''n'' = var n\<^sub>0 \<and> s ''q'' = var q\<^sub>0     (* Unchanged variables *)
          \<and> r = n\<^sub>0 div q\<^sub>0 }"                        (* Postconditions *)

      apply (rewrite annot_invar[where
        I="\<lambda>s. \<exists>r. s ''r'' = var r                  (* Variables changed in the loop *)
            \<and> s ''n'' = var n\<^sub>0 \<and> s ''q'' = var q\<^sub>0   (* Unchanged variables *)
            \<and> Idiv n\<^sub>0 q\<^sub>0 r                          (* Logical invariant *)
        "])
      supply div_aux[simp]
      apply vcg
      done

  section \<open>Part 2\<close>

    (*
      Slightly more complex: discrete 2's logarithm!

      Approximation from below, combined with
      iteratively computing \<open>a = 2^r\<close>.
    *)

    abbreviation "log2_prog \<equiv>
      CLR r;; CLR a;;
      r ::= N 1;;
      a ::= N 2;;
      WHILE ($a <= $n) DO (
        a ::= $a * N 2;;
        r ::= Plus ($r) (N 1)
      );;
      r ::= Minus ($r) (N 1)
      "

 schematic_goal [simplified]: "(log2_prog,<''n'':=var 2>) \<Rightarrow> ?s"
  by BigSteps

    definition Ilog2 :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
      "Ilog2 n\<^sub>0 a r \<equiv> 2^ nat (r) = a \<and>
                      2^ nat (r-1) \<le> n\<^sub>0 \<and>
                      n\<^sub>0 \<ge>0 \<and> r\<ge>1"  (* Provide an invariant! *)

lemma log2_aux: "1 \<le> n\<^sub>0 \<Longrightarrow> Ilog2 n\<^sub>0 2 1"
                "1 \<le> n\<^sub>0 \<Longrightarrow> \<not> a \<le> n\<^sub>0 \<Longrightarrow> Ilog2 n\<^sub>0 a r \<Longrightarrow> 2 ^ nat (r - 1) \<le> n\<^sub>0 \<and> n\<^sub>0 < 2 ^ nat r"
                "1 \<le> n\<^sub>0 \<Longrightarrow> a \<le> n\<^sub>0 \<Longrightarrow> Ilog2 n\<^sub>0 a r \<Longrightarrow> Ilog2 n\<^sub>0 (a * 2) (r + 1)"
supply nat_add_distrib[simp]
apply (auto simp:Ilog2_def algebra_simps)
done

    lemma "1\<le>n\<^sub>0 \<Longrightarrow>
      \<Turnstile> {\<lambda>s. s ''n'' = var n\<^sub>0}
          log2_prog
        {\<lambda>s.
          \<exists>r. s ''r'' = var r \<and> s ''n'' = var n\<^sub>0
          \<and> 2^nat r \<le> n\<^sub>0 \<and> n\<^sub>0 < 2^nat (r+1) }"
      (*
        Come up with the variable bindings in the invariant yourself!
        See explanation and examples in tutorial! *)
      apply (rewrite annot_invar[where
        I="\<lambda>s.
           \<exists>r a. s ''r'' = var r \<and> s ''a'' = var a
           \<and> s ''n'' = var n\<^sub>0
           \<and> Ilog2  n\<^sub>0 a r "])
        supply log2_aux[simp]
      apply vcg
      done

  section \<open>Part 3\<close>

    (*
      Do it yourself: Factorial for positive numbers.
      Only the specification is given, you must come up with the program,
      and prove it correct.

      Use a counting-up algorithm, then it's unlikely
      that you need to prove additional properties of \<open>ifact\<close>!
    *)
    definition ifact :: "int \<Rightarrow> int" where "ifact n = (\<Prod>i=1..n. i)"

    lemma ifact_simp[simp]: "0\<le>(i::int) \<Longrightarrow> {1..1 + i} = insert (i+1) {1..i}" by auto

    (*
      These are the recursion equations for the integer factorial:
    *)
    lemma ifact_simps[simp]:
      "i\<ge>0 \<Longrightarrow> ifact (i+1) = (i+1)*ifact i"
      "i\<ge>0 \<Longrightarrow> ifact (1+i) = (1+i)*ifact i"
      "i\<le>0 \<Longrightarrow> ifact i = 1"
      unfolding ifact_def
      by (auto simp: algebra_simps)

    lemma ifact_nonzero[simp]: "ifact n\<^sub>0 \<noteq> 0" unfolding ifact_def by auto

    value "ifact 5"

    (*
      The following program uses a counting-up loop to compute the factorial.
    *)
abbreviation "fact_prog \<equiv>
  CLR r;; CLR a;;
  r ::= N 1;;
  a ::= N 0;;
  WHILE ($a < $n ) DO(
    a ::= Plus ($a) (N 1);;
    r ::= Times ($r) ($a)

  )

" (* Do not forget to CLR your auxiliary and output variables!*)
definition Ifact :: "int \<Rightarrow> int \<Rightarrow> int\<Rightarrow> bool" where
  "Ifact n\<^sub>0 r a \<equiv> (r = ifact a) \<and>
                   r\<ge>1 \<and>
                   n\<^sub>0\<ge>0 \<and>
                   a\<ge>0 \<and> a \<le> n\<^sub>0 "
    (* Prove it correct! Find an invariant, and use the VCG. *)
lemma ifact_aux: " 0 \<le> n\<^sub>0 \<Longrightarrow> Ifact n\<^sub>0 1 0"
    by (auto simp: Ifact_def algebra_simps)

lemma ifact_aux2: " 0 \<le> n\<^sub>0 \<Longrightarrow> \<not> a < n\<^sub>0 \<Longrightarrow> Ifact n\<^sub>0 r a \<Longrightarrow> r = ifact n\<^sub>0"
  by (auto simp: Ifact_def algebra_simps)

lemma ifact_aux3: "0 \<le> n\<^sub>0 \<Longrightarrow> a < n\<^sub>0 \<Longrightarrow> Ifact n\<^sub>0 r a \<Longrightarrow> Ifact n\<^sub>0 (r * (a + 1)) (a + 1)"
  apply (auto simp: Ifact_def)
  by (smt zero_less_mult_iff)

    lemma "0\<le>n\<^sub>0 \<Longrightarrow>
      \<Turnstile> {\<lambda>s. s ''n'' = var n\<^sub>0 }
           fact_prog
        {\<lambda>s. \<exists>r. s ''r'' = var r \<and> s ''n'' = var n\<^sub>0 \<and> r = (ifact n\<^sub>0) }"

      apply (rewrite annot_invar[where
        I="\<lambda>s. \<exists>r a. s ''r'' = var r \<and> s ''a'' = var a   (* Variables changed in the loop *)
            \<and> s ''n'' = var n\<^sub>0                          (* Unchanged variables *)
            \<and> (Ifact n\<^sub>0 r a)                                  (* Logical invariant *)
        "])
      supply ifact_aux[simp]
      supply ifact_aux2[simp]
      supply ifact_aux3[simp]
      apply vcg
      done

  section \<open>Bonus\<close>

    (* Now you are on your own! Bonus homework!

      Implement an IMP-program to compute the Fibonacci numbers, and
      show that it is correct.

      Do not forget to Clear any non-input variable that you use!

      Warning: You may run into some problems with conversions
        between integers and natural numbers. In this case, try to go to Isar,
        and/or prove adequate auxiliary lemmas. Also sledgehammer may help.
    *)

    (* These are the Fibonacci numbers *)

    fun fib :: "nat \<Rightarrow> nat" where
      "fib 0 = 1"
    | "fib (Suc 0) = 1"
    | "fib (Suc (Suc n)) = fib n + fib (Suc n)"

    (* A postcondition for integers might contain something like *)
    prop \<open>0\<le>n\<^sub>0 \<and> r = int (fib (nat n\<^sub>0))\<close>

    (* Write a program *)
abbreviation "fib_prog \<equiv>
CLR r1;; CLR r2;;CLR r;;CLR c;;
r1::= N 1;;
r2::= N 1;;
r::=  N 1;;
c ::= N 1;;
WHILE ($c < $n)DO(
    r  ::= Plus ($r1) ($r2);;
    r1 ::= $r2;;
    r2 ::= $r;;
    c  ::= Plus ($c) (N 1)
)
"

  schematic_goal [simplified]: "(fib_prog,<''n'':=var 2>) \<Rightarrow> ?s"
  by BigSteps

  definition Ifib :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
    where "Ifib c n\<^sub>0 r r1 r2 \<equiv> 1 \<le> c  \<and>
                               0 \<le> n\<^sub>0 \<and>
                               r \<ge> 1  \<and>
                               r1 \<ge> 1 \<and> r2 \<ge> 1 \<and> r1\<le>r2 \<and>
                               (if c >1 \<and> n\<^sub>0 \<ge>c then r = r1+r2 else r = 1)"

 lemma fib_aux: " 0 \<le> n\<^sub>0 \<Longrightarrow> c < n\<^sub>0 \<Longrightarrow> Ifib c n\<^sub>0 r r1 r2 \<Longrightarrow> Ifib (c + 1) n\<^sub>0 (r1 + r2) r2 (r1 + r2)"
  apply (auto simp:Ifib_def)
sorry

 lemma fib_aux1: "0 \<le> n\<^sub>0 \<Longrightarrow> \<not> c < n\<^sub>0 \<Longrightarrow> Ifib c n\<^sub>0 r r1 r2 \<Longrightarrow> r = int (fib (nat n\<^sub>0))"
  apply (auto simp:Ifib_def)
   sorry

lemma fib_aux2: " 0 \<le> n\<^sub>0 \<Longrightarrow> Ifib 1 n\<^sub>0 1 1 1"
apply (auto simp:Ifib_def)
 done
    (* Come up with a reasonable specification and prove it correct! *)
lemma "0\<le>n\<^sub>0 \<Longrightarrow>
  \<Turnstile> {\<lambda>s.  s ''n'' = var n\<^sub>0}
      fib_prog
    {\<lambda>s.
    \<exists>r. s ''r'' = var r
    \<and>  s ''n'' = var n\<^sub>0
    \<and> 0\<le>n\<^sub>0 \<and> r = int (fib (nat n\<^sub>0))}"

    apply (rewrite annot_invar[where
    I="\<lambda>s. \<exists>r r1 r2 c. s ''r'' = var r \<and>s ''r1'' = var r1 \<and>s ''r2'' = var r2  \<and>s ''c'' = var c    (* Variables changed in the loop *)
        \<and> s ''n'' = var n\<^sub>0        (* Unchanged variables *)
        \<and> Ifib c n\<^sub>0 r r1 r2          (* Logical invariant *)
    "])
    supply fib_aux[simp]
    supply fib_aux1[simp]
    supply fib_aux2[simp]
    apply vcg
    done

  end
end