(*  Title:        C2KA Stimulus Structure
    Author:       Maxime Buyse <maxime.buyse at polytechnique.edu>, 2019
    Maintainers:  Maxime Buyse <maxime.buyse at polytechnique.edu> and Jason Jaskolka <jason.jaskolka at carleton.ca>
*)

section \<open>Stimulus Structure \label{sec:stimulus_structure}\<close>

text \<open>
A stimulus constitutes the basis for behaviour. Because of this, each discrete, observable event
introduced to a system, such as that which occurs through the communication among agents or from the
system environment, is considered to be a stimulus which invokes a response from each system agent.

A \emph{stimulus structure} is an idempotent semiring~$\STIMstructure$ with a multiplicatively
absorbing~$\Dstim$ and identity~$\Nstim$. Within the context of stimuli,~$\STIMset$ is a set of
stimuli which may be introduced to a system. The operator~$\STIMplus$ is interpreted as a choice
between two stimuli and the operator~$\STIMdot$ is interpreted as a sequential composition of two
stimuli. The element~$\Dstim$ represents the \emph{deactivation stimulus} which influences all agents
to become inactive and the element~$\Nstim$ represents the \emph{neutral stimulus} which has no influence
on the behaviour of all agents. The natural ordering relation~$\STIMle$ on a stimulus structure~$\stim$
is called the sub-stimulus relation. For stimuli~$s,t \in \STIMset$, we write~$s \STIMle t$ and say
that~$s$ is a sub-stimulus of~$t$ if and only if~$s \STIMplus t = t$.
\<close>

theory Stimuli
  imports Main
begin

text \<open>
The class \emph{stimuli} describes the stimulus structure for \CCKAabbrv. We do not use
Isabelle's built-in theories for groups and orderings to allow a different notation for the operations
on stimuli to be consistent with~\<^cite>\<open>"Jaskolka2015ab"\<close>.
\<close>

class plus_ord =
  fixes leq::"'a \<Rightarrow> 'a \<Rightarrow> bool" ("(_/ \<le>\<^sub>\<S> _)"  [51, 51] 50)
  fixes add::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 65)
  assumes leq_def: "x \<le>\<^sub>\<S> y \<longleftrightarrow> x \<oplus> y = y"
  and add_assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
  and add_comm: "x \<oplus> y = y \<oplus> x"
begin

notation
  leq  ("'(\<le>')") and
  leq ("(_/ \<le>\<^sub>\<S> _)"  [51, 51] 50)

end

class stimuli = plus_ord +
  fixes seq_comp::"'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<odot>" 70)
  fixes neutral :: 'a ("\<nn>")
  and deactivation :: 'a ("\<dd>")
  and basic :: "'a set" ("\<S>\<^sub>a")
  assumes stim_idem [simp]: "x \<oplus> x = x"
  and seq_nl [simp]: "\<nn> \<odot> x = x"
  and seq_nr [simp]: "x \<odot> \<nn> = x"
  and add_zero [simp]: "\<dd> \<oplus> x = x"
  and absorbingl [simp]: "\<dd> \<odot> x = \<dd>"
  and absorbingr [simp]: "x \<odot> \<dd> = \<dd>"
  and zero_not_basic: "\<dd> \<notin> \<S>\<^sub>a"
begin

lemma inf_add_S_right: "x \<le>\<^sub>\<S> y \<Longrightarrow> x \<le>\<^sub>\<S> y \<oplus> z"
  unfolding leq_def
  by (simp add: add_assoc [symmetric])

lemma inf_add_S_left: "x \<le>\<^sub>\<S> y \<Longrightarrow> x \<le>\<^sub>\<S> z \<oplus> y"
  by (simp add: add_comm inf_add_S_right)

lemma leq_refl [simp]: "x \<le>\<^sub>\<S> x"
  unfolding leq_def
  by simp

end

end


theory Aabid_Iter_Reduce
imports Main
begin

datatype ('a,'b) monoidgentype = C 'a  'b (infix "!" 63)

datatype ('a,'b) groupgentype = P "('a,'b) monoidgentype"
                               | N  "('a,'b) monoidgentype"

type_synonym ('a,'b) word = "(('a,'b) groupgentype) list"

primrec inverse::"('a,'b) groupgentype \<Rightarrow> ('a,'b) groupgentype"
  where
"inverse (P x) = (N x)"
|"inverse (N x) = (P x)"

primrec wordinverse::"('a,'b) word \<Rightarrow> ('a, 'b) word"
  where
"wordinverse [] = []"
|"wordinverse (x#xs) =  (wordinverse xs)@[inverse x]"

inductive_set spanset::"('a,'b) word set\<Rightarrow> ('a,'b) word set"
  for S::"('a,'b) word set"
  where
"x \<in> S \<Longrightarrow> x \<in> spanset S"
|"x \<in> inver ` S \<Longrightarrow> x \<in> spanset S"
|"x \<in> S \<Longrightarrow> y \<in> spanset S \<Longrightarrow> x@y \<in> spanset S"
|"x \<in> inver ` S \<Longrightarrow> ys \<in> spanset S \<Longrightarrow> x@y \<in> spanset S"

definition setlistcross::"'a set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
 where
"setlistcross S xs = {[s]@xs | s. s \<in> S}"

primrec lengthword::"nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
  where
"lengthword 0 S = {[s] | s. s \<in> S}"
|"lengthword (Suc n) S = \<Union> {setlistcross S xs | xs. xs \<in> (lengthword n S)}"

abbreviation "ngroupword \<equiv> \<lambda> n (S::('a,'b) word set). lengthword n (S \<union> (wordinverse ` S))"

datatype char = G | H

fun reduction:: "('a,'b) word \<Rightarrow> ('a,'b) word"
 where
"reduction [] = []"
|"reduction [x] = [x]"
|"reduction (g1#g2#wrd) = (if (g1 = inverse g2)
                             then reduction wrd
                             else (g1#(reduction (g2#wrd))))"

value "reduction [P (C G (3::nat)), N (C G (3::nat)), (N (C G (2::nat)))]"

fun reduced::"('a,'b) word \<Rightarrow> bool"
  where
"reduced [] = True"
|"reduced [g] = True"
|"reduced (g#h#wrd) = (if (g \<noteq> inverse h) then reduced (h#wrd) else False)"

primrec iter::"nat \<Rightarrow>('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
"iter 0 f = (\<lambda> x. x)"
|"iter (Suc n) f = (\<lambda> x. f ((iter n f) x))"

lemma assumes "f x = x"
  shows "iter (n+1) f x = x"
  using assms
proof(induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

(*"iter lemma"*)
lemma assumes "iter (n+1) f x = iter n f x"
  shows "iter (k+(n+1)) f x = iter (k+n) f x"
  using assms
proof(induction k)
  case 0
  then show ?case
    by force
next
  case (Suc m)
  have "iter (m + (n + 1)) f x = iter (Suc m + n) f x" by simp
  then show ?case using Suc.IH Suc.prems by auto
qed

lemma assumes "reduced wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
      then show ?thesis using 3
        by force
    next
    case False
    have "reduced (g2#wrd)" using False 3 by force
      then show ?thesis using False 3 by force
    qed
  qed

lemma "length (reduction wrd) \<le> length wrd"
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3
    by auto
  qed
qed

lemma decreasing_length:
  assumes "reduction wrd \<noteq> wrd"
  shows "length (reduction wrd) < length wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have red_inv:"reduction (g1#g2#wrd) = reduction wrd" by auto
    then show ?thesis
    proof(cases "reduction wrd = wrd")
      case True
      then have "reduction (g1#g2#wrd) = wrd" using red_inv by auto
      then have "length (reduction (g1#g2#wrd)) = length wrd" by auto
      then show ?thesis
        by simp
    next
      case False
      then have "length (reduction wrd) < length wrd" using 3 True by argo
      then show ?thesis using red_inv by force
    qed
  next
    case False
    have prem:"reduction (g1#g2#wrd) \<noteq> (g1#g2#wrd)" using 3 by argo
    then have "reduction (g1#g2#wrd) = g1#reduction (g2#wrd)" using False by auto
    then have "reduction (g2#wrd) \<noteq> g2#wrd" using prem by fastforce
    then have "length (g2#wrd) > length (reduction (g2#wrd))" using 3 False by blast
    then have "length (g1#g2#wrd) > length (reduction (g1#g2#wrd))" using False by force
    then show ?thesis by fast
  qed
qed

lemma assumes "g = inverse h"
  shows "length (reduction (g#h#wrd)) < length (g#h#wrd)"
  using assms
proof(induction "length wrd")
  case 0
  then show ?case by auto
next
  case (Suc x)
  then show ?case
    by (metis decreasing_length length_Cons lessI less_SucI reduction.simps(3))
qed

lemma assumes "length (reduction (wrd)) = length wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case
    by simp
next
  case (2 x)
  then show ?case by simp
next
case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have "reduction (g1#g2#wrd) = reduction (wrd)" by simp
    then have "length (reduction (g1#g2#wrd)) = length (reduction (wrd))" by auto
    moreover have "length (wrd) > length (reduction wrd)" using 3 by (metis \<open>reduction (g1 # g2 # wrd) = reduction wrd\<close> decreasing_length impossible_Cons le_cases)
    then show ?thesis using 3 by auto
  next
    case False
    then show ?thesis using "3.prems" decreasing_length nat_neq_iff by blast
  qed
qed

(*"reduction-reduced lemma"*)
lemma assumes "reduction wrd = wrd"
  shows "reduced wrd"
  using assms
proof(induction wrd rule:reduction.induct)
case 1
then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case by (metis decreasing_length impossible_Cons length_Cons less_Suc_eq less_or_eq_imp_le list.inject reduced.simps(3) reduction.simps(3))
qed

definition iter_reduce ::  "('a,'b) word \<Rightarrow> ('a,'b) word"
  where "iter_reduce wrd = (iter (length wrd + 1) reduction) wrd"

lemma  "length ((iter (length xs) reduction) xs) \<le> length ((iter (length xs + 1) reduction) xs)"
proof(induction xs rule: reduction.induct)
case 1
then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case sorry
qed

lemma "(iter (length xs) reduction) xs = (iter (length xs + 1) reduction) xs"
proof(induction xs rule: reduction.induct)
case 1
then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
proof(cases "g1 = inverse g2")
  case True
  then show ?thesis sorry
next
  case False
  then show ?thesis sorry
qed
qed

lemma "\<exists>x \<le> length xs . (iter x reduction) xs = (iter (x+1) reduction) xs"
proof(induction xs rule: reduction.induct)
case 1
then show ?case by simp
next
  case (2 x)
  then show ?case by auto
next
  case (3 g1 g2 wrd)
  then show ?case sorry
qed

lemma correctness: "reduced (iter_reduce xs)"
proof-
(*
\<exists>x \<le> length xs . (iter x reduction) xs = (iter x+1 reductio)n xs <-- NEED TO PROVE
\<Rightarrow> (iter (length xs) reduction) xs = (iter (lenght xs + 1) reduction) xs (by iter lemma, already proved)
\<Rightarrow> reduction ((iter (length xs - 1) reduction) xs) =  (iter (length xs + 1) reduction) xs
\<Rightarrow> reduced ((iter (length xs + 1) reduction) xs) (by reduction-reduced lemma, already proved)
\<Rightarrow> reduced (iter_reduce xs)
*)


theory Iter_Reduction_Lemmas
  imports Main iter Cancellation
begin

fun reduce :: "('a,'b) word \<Rightarrow> ('a,'b) word"
  where
"reduce [] = []"|
"reduce [x] = [x]"|
"reduce (g1#g2#wrd) = (if (g1 = inverse g2)
                           then wrd
                           else (g1#(reduce (g2#wrd))))"

lemma cons_reduce:
  assumes "g1 \<noteq> inverse g2"
  shows "reduce (g1#g2#wrd) = (g1#(reduce (g2#wrd)))"
  by (simp add: assms)

lemma cancel_at_cons:
  assumes "i\<ge>0" "(1+i) < length a" "cancel_at i a = b"
  shows "cancel_at (1 + i) (c#a) = (c#b)"
proof-
  have "c#(take i a) = take (1 + i) (c#a)" using assms(1) assms(2) by auto
  moreover have "drop (i+2) a = drop (1 + (i+2)) (c#a)"using assms(1) assms(2) by simp
  ultimately show ?thesis unfolding cancel_at_def by (metis (no_types, lifting) add.commute append_Cons assms(3) cancel_at_def group_cancel.add2)
qed

lemma cancels_to_1_at_cons:
  assumes "i\<ge>0" "(1+i) < length a" "cancels_to_1_at i a b"
  shows "cancels_to_1_at (1 + i) (c#a) (c#b)"
  unfolding cancels_to_1_at_def
proof-
  have 1:"0 \<le> (1 + i)" using assms(1) by simp
  moreover have 2: "1 + (1 + i) < length (c # a)" using assms(2) by auto
  have "(inverse (a ! i)) = (a ! (i+1))" using assms(3) by (metis add.commute cancels_to_1_at_def)
  moreover then have 3: "inverse ((c # a) ! (1 + i)) = (c # a) ! (1 + (1 + i))" by simp
  have "(b = cancel_at i a)" using assms(3)using cancels_to_1_at_def by auto
  moreover then have 4: "c # b = cancel_at (1 + i) (c # a)" using cancel_at_cons assms(1) assms(2) by metis
  ultimately show "0 \<le> 1 + i \<and>
    1 + (1 + i) < length (c # a) \<and>
    inverse ((c # a) ! (1 + i)) = (c # a) ! (1 + (1 + i)) \<and>
    c # b = cancel_at (1 + i) (c # a)" using "2" "3" by blast
qed

lemma cancels_to_1_cons:
  assumes "cancels_to_1 a b"
  shows "cancels_to_1 (c#a) (c#b)"
  using assms
  unfolding cancels_to_1_def
proof-
  obtain i where "cancels_to_1_at i a b" using assms cancels_to_1_def by auto
  then have "i\<ge>0 \<and> (1+i) < length a" using cancels_to_1_at_def by auto
  then have "cancels_to_1_at (1 + i) (c#a) (c#b)" using \<open>cancels_to_1_at i a b\<close> cancels_to_1_at_cons by blast
  then show "\<exists>i. cancels_to_1_at i (c # a) (c # b)" by auto
qed

lemma cons_cancel_at: "cancels_to xs ys \<longrightarrow> cancels_to (x#xs) (x#ys)"
  unfolding cancels_to_def
  apply(rule impI)
proof(induction rule: rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have "cancels_to_1 b c" by simp
  then have "cancels_to_1 (x#b) (x#c)" by (simp add: cancels_to_1_cons)
  then show ?case using rtrancl_into_rtrancl.IH by auto
qed

lemma cancels_to_reduce:"cancels_to xs (reduce xs)"
proof(induction xs rule: reduce.induct)
  case 1
  then have "cancels_to [] []"  unfolding cancels_to_def by simp
  then show ?case by simp
next
  case (2 x)
  then have "cancels_to [x] [x]"  unfolding cancels_to_def by simp
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof (cases "g1 = inverse g2")
    case True
    have a: "(reduce (g1 # g2 # wrd)) = wrd" using True by simp
    then have 1: "reduce (g1 # g2 # wrd) = cancel_at 0 (g1 # g2 # wrd)" by (simp add: cancel_at_def)
    have 2: "(inverse ((g1 # g2 # wrd) ! 0) = ((g1 # g2 # wrd) ! (1 + 0)))" using True by (metis inverse_of_inverse nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc)
    have "cancels_to_1_at 0 (g1 # g2 # wrd) (reduce (g1 # g2 # wrd))" using cancels_to_1_at_def using "1" "2" by fastforce
    then have "cancels_to_1 (g1 # g2 # wrd) (reduce (g1 # g2 # wrd))" using cancels_to_1_def by blast
    then show ?thesis by (simp add: cancels_to_def)
next
  case False
  then have "cancels_to (g2 # wrd) (reduce (g2 # wrd))" by (simp add: "3.IH")
  then have "cancels_to (g1#g2#wrd) (g1#(reduce (g2 # wrd)))" by (simp add: cons_cancel_at)
    then show ?thesis using False by (simp add: cons_reduce)
    qed
  qed

lemma iter_cancels_to: "cancels_to xs (iter n reduce xs)"
proof(induction n)
  case 0
  have "(iter 0 reduce xs) = xs" by simp
  then show ?case unfolding cancels_to_def by simp
next
  case (Suc n)
  then have 1: "cancels_to xs (iter n reduce xs)" by auto
  have "(iter (Suc n) reduce xs) = reduce (iter  n reduce xs)" by simp
  moreover have "cancels_to (iter n reduce xs) (reduce (iter  n reduce xs))" using cancels_to_reduce by auto
  ultimately have "cancels_to (iter n reduce xs) (iter (Suc n) reduce xs)" by simp
  then show ?case using 1 unfolding cancels_to_def by auto
qed

lemma cons_reduced:
  assumes "g \<noteq> inverse h"
  shows "reduced (h # wrd) \<Longrightarrow> reduced (g#h#wrd)"
  using assms
proof-
  assume a:  "reduced (h#wrd)"
  have "reduced (g#h#wrd) = reduced (h#wrd)" using assms by simp
  then show ?thesis by (simp add: a)
qed

lemma cons_not_reduced: assumes "g \<noteq> inverse h"
  shows "\<not> reduced (g#h#wrd) \<Longrightarrow> \<not> reduced (h # wrd)"
  using assms
proof-
  assume a: "\<not> reduced (g#h#wrd)"
  have "reduced (h # wrd) \<Longrightarrow> reduced (g#h#wrd)" using assms cons_reduced by simp
  then show ?thesis using a by blast
qed

lemma reduce_minus: assumes "\<not> (reduced xs)"
  shows "length (reduce xs) = (length xs) - 2"
  using assms
proof(induction xs rule: reduce.induct)
  case 1
then show ?case by simp
next
  case (2 g)
  then have a: "\<not> reduced [g]" by blast
  have "reduced [g]" by auto
  then show ?case using a by blast
next
case (3 g h wrd)
  then show ?case
  proof(cases "g = inverse h")
    case True
    then have "reduce (g#h#wrd) = wrd" by simp
then show ?thesis by simp
next
  case False
  then have 1: "\<not> reduced (h # wrd)" using cons_not_reduced "3.prems" by auto
  then have a: "length (reduce (h # wrd)) = length (h # wrd) - 2" using "3.IH" False by blast
  have b: "length (h # wrd)  = length (g # h # wrd) - 1" by auto
  have 2:"reduce (g # h # wrd) = g#(reduce (h # wrd))" using False by simp
  moreover have "length (g#(reduce (h # wrd))) - 1 = length (reduce ( h # wrd))" by simp
  ultimately have c: "length (reduce ( h # wrd)) = length (reduce (g # h # wrd)) - 1" by simp
  then have " length (reduce (g # h # wrd)) - 1 = (length (g # h # wrd) - 1) - 2" using a b c by argo
  then have "length (reduce (g # h # wrd)) - 1 = length (g # h # wrd) - 2 - 1" by simp
  then show ?thesis by (smt (verit, ccfv_SIG) Suc_1 1 2 diff_Suc_1 diff_Suc_eq_diff_pred length_Cons reduced.elims(3))
  qed
qed

lemma reduced_reduce: assumes "reduced xs"
  shows "reduce xs = xs"
  using assms
proof(induction xs rule: reduce.induct)
  case 1
  then have "reduce [] = []" by simp
then show ?case by simp
next
  case (2 x)
  then have "reduce [x] = [x]" by simp
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then have 1: "g1 \<noteq> inverse g2" by auto
  then moreover have "reduced (g2 # wrd)" using cons_reduced "3.prems" by simp
  ultimately have "reduce (g2 # wrd) = g2 # wrd" using "3.IH" by blast
  then have "g1#(reduce (g2 # wrd)) = g1#g2 # wrd" by simp
  moreover have "reduce (g1#g2 # wrd) = (g1#reduce (g2 # wrd))" using 1  by simp
  ultimately show ?case by simp
qed

lemma reduced_imp_reduce: "reduced xs \<Longrightarrow> reduced (reduce xs)"
proof-
  assume assms: "reduced xs"
  then have "reduce xs = xs" using reduced_reduce by auto
  then show ?thesis using assms by simp
qed

lemma length_reduce:
 "length (reduce wrd) \<le> length wrd"
proof(induction wrd rule: reduce.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3 by auto
 qed
qed

lemma length_reduce_iter:  "length (iter n reduce xs) \<le> length xs"
proof(induction n)
  case 0
  then have "(iter 0 reduce xs) = xs" by simp
  then show ?case by simp
next
  case (Suc n)
  have "reduce (iter n reduce xs) = (iter (Suc n) reduce xs)" by simp
  moreover have "length (reduce (iter n reduce xs)) \<le> length (iter n reduce xs)" using length_reduce by fast
 ultimately have "length (reduce (iter n reduce xs)) \<le> length (iter n reduce xs)" by simp
  then show ?case using Suc.IH by simp
qed

lemma reduce_iter_minus: assumes "\<not> reduced (iter n reduce xs)"
  shows "length (iter n reduce xs) = length xs - (2*n)"
  using assms
proof(induction n)
  case 0
  have 1: "length xs - 2 * 0 = length xs" by simp
  have 2: "(iter 0 reduce xs) = xs" by simp
  then show ?case using 1 2 by simp
next
  case (Suc n)
  then have "\<not> reduced (iter (Suc n) reduce xs)" by simp
  moreover have b: "(iter (Suc n) reduce xs) = reduce (iter n reduce xs)" by simp
  ultimately have a: "\<not> reduced (iter n reduce xs)" using reduced_imp_reduce by auto
  then have " length (iter n reduce xs) = length xs - (2 * n)" using Suc.IH by auto
  then have c: "length (iter n reduce xs) - 2 = length xs - (2 * n) - 2" by simp
  have "length (iter n reduce xs) - 2 = length (iter (Suc n) reduce xs)" using a b reduce_minus by (simp add: reduce_minus)
  moreover have "length xs - (2 * n) - 2 = length xs - (2 * Suc n)" by simp
  ultimately show ?case using c  by presburger
qed

lemma assumes "\<not> reduced wrd"
  shows "length (reduce wrd) < length wrd"
  using assms
proof(induction wrd rule:reduce.induct)
  case 1
  then have "reduced []" by simp
  then show ?case using "1.prems" by simp
next
  case (2 x)
  then have "reduced [x]" by simp
  then show ?case using "2.prems" by simp
next
  case (3 g1 g2 wrd)
  have "length (g1 # g2 # wrd) > 0" by simp
  then show ?case using reduce_minus "3.prems" by force
qed

lemma not_reduced_iter: assumes  "reduced (iter n reduce xs)"
  shows "reduced (iter (n+1) reduce xs)"
  using assms
proof-
  have "(iter (n+1) reduce xs) = reduce (iter (n) reduce xs)" by simp
  then show ?thesis by (simp add: reduced_imp_reduce assms)
qed

lemma reduced_iter_suc: assumes "reduced (iter n reduce xs)"
  shows "reduced (iter (n+k) reduce xs)"
  using assms
proof(induction k)
case 0
then show ?case by simp
next
  case (Suc k)
  then have "reduced (iter (n + k) reduce xs)" by simp
  then show ?case using  reduced_imp_reduce by auto
qed

lemma not_reduced_iter_suc: assumes "\<not> reduced (iter n reduce xs)" "k \<le> n"
  shows "\<not> reduced (iter k reduce xs)"
proof-
  show ?thesis using reduced_iter_suc  using assms(1) assms(2) le_Suc_ex by blast
qed

lemma mult_2_greater:"((x::nat) div 2 + 1) * 2 \<ge> x"  by simp

lemma subtract_greater: assumes "(x::nat) \<ge> y"
  shows "y - x = 0"
  using assms
  by simp

end


(* Title:      Sums
   Author:     Insa Stucke (ist@informatik.uni-kiel.de)
*)

theory Relation_Algebra_Sums imports Groups "$AFP/Relation_Algebra/Relation_Algebra_Functions"

begin

text{* We provide the basics to reason about finite unions in relation algebras . Especially,
if one wants to deals with the Point Axiom many of the following properties are necessary.

In cardinalities.thy we often use another notation for set. Thus, we have to tackle problems
concerning this by proving some of the results for both representations. *}

declare [[show_sorts,show_types]]

context relation_algebra
begin

abbreviation Summ ("\<Squnion>_" [1000] 999)
  where "Summ \<equiv> comm_monoid_add.sum op + 0 (\<lambda>x . x)"

lemma leq_sum:
  assumes "finite X"
  and "x \<in> X"
  shows "x \<le> \<Squnion>X"
using assms sum.remove by fastforce

lemma leq_sum_p:
  assumes "finite { x . P x }"
  and "P y"
  shows "g y \<le> \<Squnion> { z. \<exists> x. z= g x \<and> P x }"
proof -
  have "finite { g x | x . P x }"
    by (simp add: assms)
  thus ?thesis
    using assms leq_sum by blast
qed

lemma lub_sum:
  assumes "finite X"
  and "\<forall>x\<in>X . x \<le> y"
  shows "\<Squnion>X \<le> y"
proof -
  have "(\<forall>x\<in>X . x \<le> y) \<longrightarrow> \<Squnion>X \<le> y"
    by (rule finite_induct) (simp_all add: assms)
  thus ?thesis
    by (simp add: assms)
qed

lemma setsum_sup:
  assumes "finite X"
  shows "\<Squnion>X \<le> y \<longleftrightarrow> (\<forall>x \<in> X. x \<le> y)"
using assms dual_order.trans lub_sum leq_sum by blast

lemma lub_sum_p:
  assumes fin: "finite { x . P x }"
  and ub: "\<forall>x . P x \<longrightarrow> f x \<le> y"
  shows "\<Squnion> { f x | x . P x } \<le> y"
proof -
  have "finite { f x | x . P x }"
    by (simp add: fin)
  thus ?thesis
    using lub_sum ub by auto
qed

lemma sum_leq:
  assumes fin: "finite { x . P x }"
  assumes leq: "\<forall>x . P x \<longrightarrow> f x \<le> g x"
  shows "\<Squnion> { f x | x . P x } \<le> \<Squnion> { g x | x . P x }"
proof (rule lub_sum_p)
  show "finite { x . P x }"
    by (simp add: fin)
next
  have "\<forall>x . P x \<longrightarrow> g x \<le> \<Squnion> { g x | x . P x }"
    by (simp add: fin leq_sum_p)
  thus "\<forall>x . P x \<longrightarrow> f x \<le> \<Squnion> { g x | x . P x }"
    using leq order.trans by blast
qed

lemma setsum_fun_add:
  assumes "finite { x . P x }"
  and fstrict: "f 0 = 0"
  and fadd: "\<And>x y. f (x + y) = f x + f y"
  shows "f (\<Squnion> { x . P x }) = \<Squnion>(f ` { x . P x })"
proof (induct rule: finite_induct[OF assms(1)])
  show "f (\<Squnion>{}) = \<Squnion>(f ` {})"
    by (simp add: fstrict)
  fix x :: 'a and  F ::" 'a set"
  assume finF: "finite F"
    and indhyp: "f (\<Squnion>F) = \<Squnion>(f ` F)"
  have "f (\<Squnion>(insert x F)) = f x + \<Squnion>(f ` F)"
    by (metis finF insert_absorb less_eq_def sum.insert leq_sum fadd indhyp)
  also have "... = \<Squnion>(f ` (insert x F))"
    by (metis (mono_tags, lifting) finF finite_imageI image_insert leq_sum local.less_eq_def local.sum.insert_if)
  finally show "f (\<Squnion>(insert x F)) = \<Squnion>(f ` insert x F)" .
qed

lemma setsum_fun_add':
  assumes "finite { x . P x }"
  and fstrict: "f 0 = 0"
  and fadd: "\<And>x y. f (x + y) = f x + f y"
  shows "f (\<Squnion> {x|x . P x }) = \<Squnion>({f x |x. P x })"
by (simp add: assms(1) fadd fstrict image_Collect setsum_fun_add)

lemma add_sum:
  assumes "finite F"
  shows "y + \<Squnion> F = \<Squnion> (insert y F)"
by (metis assms insert_absorb sum.insert sum.insert_remove sup.left_idem)

text{* Next we prove some distributivity laws. *}

lemma finite_p_fun:
  assumes "finite {x| x . P x }"
  shows "finite {f x| x. P x }"
proof -
  have a: "f ` {x| x . P x } = {f x| x. P x }"
    by auto
  thus ?thesis using assms by auto
qed

lemma sum_comp_distr_right:
  assumes "finite { x . P x }"
  shows "y;\<Squnion> {x|x . P x } = \<Squnion>{y;x| x. P x}"
by (simp add: assms image_Collect distrib_left setsum_fun_add)

lemma sum_comp_distr_right_fun:
  assumes "finite { x . P x }"
  shows "y;\<Squnion> {f x|x. P x } = \<Squnion>{y;(f x)| x. P x}"
proof -
  have "y;\<Squnion> {f x|x. P x } = y;\<Squnion> {z|z .\<exists>x. f x=z \<and> P x}" by metis
  also have "\<dots> = \<Squnion>{y;z|z .\<exists>x. f x=z \<and> P x}"
    proof (rule sum_comp_distr_right)
      show "finite {z.\<exists>x. f x=z \<and> P x}"
        proof -
          have a: "{z|z .\<exists>x. f x=z \<and> P x} = {f x | x. P x}" by blast
          thus ?thesis by (simp add: assms finite_image_set)
        qed
    qed
  also have "\<dots> = \<Squnion>{y;f x| x. P x}" by metis
  finally show ?thesis
    by blast
qed

lemma sum_comp_distr_left:
  assumes "finite {x . P x }"
  shows "(\<Squnion> {x|x . P x });y = \<Squnion>{x;y| x. P x}"
proof (rule setsum_fun_add')
  show "finite {x::'a. P x}"
    by (simp add: assms)
  next
  show "0 ; y = 0"
    by simp
  next
  show "\<And>(x::'a) ya::'a. (x + ya) ; y = x ; y + ya ; y"
    by simp
qed

lemma sum_cap_distr_left:
  assumes "finite {x . P x}"
  shows "y \<cdot> \<Squnion> {x | x . P x} = \<Squnion> {y \<cdot> x | x . P x}"
using setsum_fun_add' assms inf_sup_distrib1 by simp

lemma sum_cap_distr_right:
  assumes "finite {x . P x}"
  shows "\<Squnion> {x | x . P x} \<cdot> y = \<Squnion> {x\<cdot>y | x . P x}"
  using inf_commute assms sum_cap_distr_left inf_commute by auto

lemma sum_cap_distr_right_fun:
  assumes "finite {x . P x}"
  shows "\<Squnion> {f x | x . P x} \<cdot> y = \<Squnion> {(f x)\<cdot>y | x . P x}"
proof -
  have "\<Squnion> {f x | x . P x} \<cdot> y = \<Squnion> {z|z .\<exists>x. f x=z \<and> P x} \<cdot> y"
    by metis
  also have "\<dots> = \<Squnion>{z\<cdot>y|z .\<exists>x. f x=z \<and> P x}"
    proof (rule sum_cap_distr_right)
      show "finite {z.\<exists>x. f x=z \<and> P x}"
        proof -
          have a: "{z|z .\<exists>x. f x=z \<and> P x} = {f x | x. P x}" by blast
          thus ?thesis by (simp add: assms finite_image_set)
        qed
    qed
  also have "\<dots> = \<Squnion>{(f x)\<cdot>y| x. P x}"
    by metis
  finally show ?thesis
    by blast
qed

(*
lemma sum_cap_distr_right_f:
  assumes "finite {x . P x}"
  shows "\<Squnion> {f x | x . P x} \<cdot> y = \<Squnion> {(f x)\<cdot>y | x . P x}"
lemma sum_cap_distr_right':
  assumes "finite {x |x . P x}"
  shows "\<Squnion> {x | x . P x} \<cdot> y = \<Squnion> {x\<cdot>y | x . P x}"
proof (rule sum_cap_distr_right)
  show "finite {x. P x}"
    using assms by auto
qed
*)

lemma sum_cap_distr_left_set:
  assumes "finite F"
  shows "y \<cdot> \<Squnion> {x | x . x\<in>F} = \<Squnion> {y \<cdot> x | x . x\<in>F}"
proof (rule sum_cap_distr_left)
  show "finite {x::'a. x \<in> F}"
    by (simp add: assms)
qed

lemma sum_cap_distr_left_set':
  assumes "finite F"
  shows "y \<cdot> \<Squnion> F = \<Squnion> {y \<cdot> x | x . x\<in>F}"
using assms sum_cap_distr_left_set by auto

lemma sum_sum_comp:
  assumes  "finite {x . Q x}"
  shows "\<Squnion>{x;\<Squnion>{y|y . Q y}|x . P x} = \<Squnion>{\<Squnion>{x;y|y . Q y}|x . P x}"
using assms sum_comp_distr_right by auto

lemma setsum_fun_image_sup:
  assumes "finite A"
  shows "\<Squnion>(f ` A) \<le> z \<longleftrightarrow> (\<forall>x \<in> A. f x \<le> z)"
by (simp add: assms setsum_sup)

text{* The proofs of the following two lemmata follow the ones in in Kleene Algebra. *}

lemma flatten1_im:
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Squnion>((\<lambda>x. \<Squnion>(f x ` B)) ` A) = \<Squnion>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B))"
proof -
  have "\<forall>z. \<Squnion>((\<lambda>x. \<Squnion>(f x ` B)) ` A) \<le> z \<longleftrightarrow> \<Squnion>((\<lambda>p. f (fst p) (snd p)) ` (A \<times> B)) \<le> z"
    by (simp add: assms finite_cartesian_product setsum_fun_image_sup)
  thus ?thesis
    using antisym by blast
qed

lemma flatten1_im_p:
  assumes "finite {x. P x }"
  and "finite {x. Q x }"
  shows "\<Squnion>((\<lambda>x. \<Squnion>(f x ` {x. Q x })) ` {x. P x }) = \<Squnion>((\<lambda>p. f (fst p) (snd p)) ` ({x. P x } \<times> {x. Q x }))"
proof -
  have "\<forall>z. \<Squnion>((\<lambda>x. \<Squnion>(f x ` {x. Q x })) ` {x. P x }) \<le> z \<longleftrightarrow> \<Squnion>((\<lambda>p. f (fst p) (snd p)) ` ({x. P x } \<times> {x. Q x })) \<le> z"
    by (simp add: assms finite_cartesian_product setsum_fun_image_sup)
  thus ?thesis
    using antisym by blast
qed

lemma setsum_flatten1:
  assumes "finite (A :: 'a set)"
  and "finite (B :: 'a set)"
  shows "\<Squnion>{\<Squnion>{f x y |y. y \<in> B} |x. x \<in> A} = \<Squnion>{f x y |x y. x \<in> A \<and> y \<in> B}"
 apply (simp add: Setcompr_eq_image assms flatten1_im)
 apply (subst Setcompr_eq_image[symmetric])
 apply simp
done

lemma setsum_flatten1_p:
  assumes "finite {x|x ::'a. P x}"
  and "finite {x|x ::'a. Q x}"
  shows "\<Squnion>{\<Squnion>{f x y |y. P y} |x. Q x} = \<Squnion>{f x y |x y. Q x \<and> P y}"
proof -
  have "\<Squnion>{\<Squnion>{f x y |y. P y} |x. Q x} = \<Squnion>{\<Squnion>{f x y |y. y\<in> {z . P z}} |x. x \<in> {z . Q z}}"
    by simp
  also have "\<dots> = \<Squnion>{f x y |x y. x \<in> {z . Q z} \<and> y\<in> {z . P z}}"
    proof (rule setsum_flatten1)
      show "finite {z. Q z}"
        using assms by auto
      next
      show "finite {z. P z}"
        using assms by auto
    qed
  also have "\<dots> = \<Squnion>{f x y |x y. Q x \<and> P y}"
    by simp
  finally show ?thesis by auto
qed

lemma sum_sum_add_comp:
  assumes "finite {x . P x}"
  and "finite {y . Q y}"
  shows "\<Squnion>{x|x . P x};\<Squnion>{y\<^sup>\<smile>|y . Q y} = \<Squnion>{x;y\<^sup>\<smile>| x y. P x \<and> Q y}"
proof -
  have aux: "{y\<^sup>\<smile>|y . Q y}={z|z .\<exists>x. x\<^sup>\<smile>=z \<and>  Q x}"
    by blast
  have "\<Squnion>{x|x . P x};\<Squnion>{y\<^sup>\<smile>|y . Q y} = \<Squnion>{x;\<Squnion>{y\<^sup>\<smile>|y . Q y}|x . P x}"
    using assms(1) sum_comp_distr_left by blast
  also have "\<dots> = \<Squnion>{x;\<Squnion>{z|z .\<exists>x. x\<^sup>\<smile>=z \<and>  Q x}|x . P x}"
    by (simp add: aux)
  also have "\<dots> = \<Squnion>{\<Squnion>{x;z|z .\<exists>x. x\<^sup>\<smile>=z \<and>  Q x}|x . P x}"
    proof (rule sum_sum_comp)
      show "finite {x. \<exists>xa. xa\<^sup>\<smile> = x \<and> Q xa}"
        proof -
          have a: "{x. \<exists>z. z\<^sup>\<smile> = x \<and> Q z}={x\<^sup>\<smile> | x. Q x}"
            by blast
          thus ?thesis by (simp add: assms finite_image_set)
        qed
    qed
  also have "\<Squnion>{\<Squnion>{x;z|z .\<exists>x. x\<^sup>\<smile>=z \<and> Q x}|x . P x}= \<Squnion>{x;z|x z. P x \<and> (\<exists>y. y\<^sup>\<smile>=z \<and> Q y)}"
    proof (rule setsum_flatten1_p)
      show "finite {x |x. \<exists>xa. xa\<^sup>\<smile> = x \<and> Q xa}"
        by (metis assms(2) aux finite_imageI image_Collect)
      next
      show "finite {x |x. P x}"
        using assms(1) by auto
    qed
  also have "\<dots> = \<Squnion>{x;y\<^sup>\<smile>| x y. P x \<and> Q y}"
    by metis
  finally show ?thesis by auto
qed

text{* Definition of pairwise disjoint and some properties. *}

definition pairwise_disjoint:: "'a set \<Rightarrow> bool"
  where "pairwise_disjoint F \<equiv> \<forall> x y. x\<in>F \<and> y\<in>F \<and> x\<noteq>y \<longrightarrow> x\<cdot>y=0"

lemma pwd_insert:
  assumes "pairwise_disjoint (insert x F)"
  shows "\<forall> y. y\<in>F \<and> x\<noteq>y \<longrightarrow> x\<cdot>y=0"
using assms pairwise_disjoint_def by auto

lemma pwdset:
  assumes "finite F"
  and "pairwise_disjoint (insert x F)"
  and "x\<notin>F"
  shows "\<Squnion>{x \<cdot> y| y. y\<in> F} = 0"
proof (rule antisym)
  show "\<Squnion>{x \<cdot> y |y. y \<in> F} \<le> 0"
    proof (rule lub_sum_p)
      show "finite {x. x \<in> F}"
        by (simp add: assms)
    next
      show "\<forall>xa. xa \<in> F \<longrightarrow> x \<cdot> xa \<le> 0"
        using assms pwd_insert by blast
    qed
next
  show "0 \<le> \<Squnion>{x \<cdot> y |y::'a. y \<in> F}"
    by simp
qed

lemma pwd_mon:
  assumes "A\<subseteq>B"
  and "pairwise_disjoint B"
  shows "pairwise_disjoint A"
by (meson assms pairwise_disjoint_def subset_iff)

(*
lemma aux_sum: "{x |x. P x \<or> Q x} = {x |x. P x} + {x |x. Q x}"
by auto

lemma aux_sum': "finite A \<and> finite B \<longrightarrow> \<Squnion> (A+B) = \<Squnion>A + \<Squnion>B"
using setsum.union_diff2 setsum.union_inter by fastforce

lemma aux_sum'':
  assumes "finite {x |x. P x}"
  shows "\<Squnion>{x |x. P x} = \<Squnion>{x |x. P x \<and> Q x} + \<Squnion>{x |x. P x \<and> \<not>(Q x)}"
proof -
  have aux: "{x |x. (P x \<and> Q x) \<or> (P x \<and> \<not>(Q x))} = {x |x. P x \<and> Q x} + {x |x. P x \<and> \<not>(Q x)}"
    by auto
  have "\<Squnion>{x |x. P x} = \<Squnion>{x |x. (P x \<and> Q x) \<or> (P x \<and> \<not>(Q x))}"
    by meson
  also have "\<dots> = \<Squnion>{x |x. P x \<and> Q x} + \<Squnion>{x |x. P x \<and> \<not>(Q x)}"
    using assms aux_sum' aux  by auto
  finally show ?thesis
    by auto
qed

*)

end
end


(*  Title:      CCL/ex/Flag.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Dutch national flag program -- except that the point of Dijkstra's example was to use
  arrays and this uses lists. *}

theory Flag
imports List
begin

definition Colour :: "i set"
  where "Colour == Unit + Unit + Unit"

definition red :: "i"
  where "red == inl(one)"

definition white :: "i"
  where "white == inr(inl(one))"

definition blue :: "i"
  where "blue == inr(inr(one))"

definition ccase :: "[i,i,i,i]\<Rightarrow>i"
  where "ccase(c,r,w,b) == when(c, \<lambda>x. r, \<lambda>wb. when(wb, \<lambda>x. w, \<lambda>x. b))"

definition flag :: "i"
  where
    "flag == lam l. letrec
      flagx l be lcase(l,<[],<[],[]>>,
                       \<lambda>h t. split(flagx(t), \<lambda>lr p. split(p, \<lambda>lw lb.
                            ccase(h, <red$lr,<lw,lb>>,
                                     <lr,<white$lw,lb>>,
                                     <lr,<lw,blue$lb>>))))
      in flagx(l)"

axiomatization Perm :: "i \<Rightarrow> i \<Rightarrow> o"
definition Flag :: "i \<Rightarrow> i \<Rightarrow> o" where
  "Flag(l,x) == ALL lr:List(Colour).ALL lw:List(Colour).ALL lb:List(Colour).
                x = <lr,<lw,lb>> \<longrightarrow>
              (ALL c:Colour.(c mem lr = true \<longrightarrow> c=red) \<and>
                            (c mem lw = true \<longrightarrow> c=white) \<and>
                            (c mem lb = true \<longrightarrow> c=blue)) \<and>
              Perm(l,lr @ lw @ lb)"

lemmas flag_defs = Colour_def red_def white_def blue_def ccase_def

lemma ColourXH: "a : Colour \<longleftrightarrow> (a=red | a=white | a=blue)"
  unfolding simp_type_defs flag_defs by blast

lemma redT: "red : Colour"
  and whiteT: "white : Colour"
  and blueT: "blue : Colour"
  unfolding ColourXH by blast+

lemma ccaseT:
  "\<lbrakk>c:Colour; c=red \<Longrightarrow> r : C(red); c=white \<Longrightarrow> w : C(white); c=blue \<Longrightarrow> b : C(blue)\<rbrakk>
    \<Longrightarrow> ccase(c,r,w,b) : C(c)"
  unfolding flag_defs by ncanT

lemma "flag : List(Colour)->List(Colour)*List(Colour)*List(Colour)"
  apply (unfold flag_def)
  apply (typechk redT whiteT blueT ccaseT)
  apply clean_ccs
  apply (erule ListPRI [THEN ListPR_wf [THEN wfI]])
  apply assumption
  done

lemma "flag : PROD l:List(Colour).{x:List(Colour)*List(Colour)*List(Colour).Flag(x,l)}"
  apply (unfold flag_def)
  apply (gen_ccs redT whiteT blueT ccaseT)
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_nat_acc_alt_mul_comm
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun accplus :: "Nat => Nat => Nat" where
"accplus (Z) y = y"
| "accplus (S z) y = accplus z (S y)"

fun accaltmul :: "Nat => Nat => Nat" where
"accaltmul (Z) y = Z"
| "accaltmul (S z) (Z) = Z"
| "accaltmul (S z) (S x2) =
     accplus (S z) (accplus x2 (accaltmul z x2))"

theorem property0 :
  "((accaltmul x y) = (accaltmul y x))"
  oops

end


(* 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>
*)

section \<open>Relation Algebra\<close>

theory Relation_Algebra
  imports More_Boolean_Algebra Kleene_Algebra.Kleene_Algebra
begin

text \<open>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}).\<close>

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 \<open>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.\<close>

sublocale relation_algebra \<subseteq> dioid_one "(+)" "(;)" "(\<le>) " "(<)" "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 \<open>First we prove some basic facts about joins and meets.\<close>

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)"
using local.mult_isol_var local.sup.bounded_iff local.sup.cobounded2 local.sup_ge1 by presburger

text \<open>We now prove some simple facts about conversion.\<close>

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 \<open>The next lemmas show that conversion is self-conjugate in the sense of
Boolean algebra with operators.\<close>

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 \<open>The following lemmas link the relative product and meet.\<close>

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 \<open>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.\<close>

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 \<open>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.\<close>

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 \<open>The following Galois connections define residuals. They link relation
algebras with action algebras. This could be further explored and formalised.
\<close>

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 \<open>Variants of the modular law for relation algebras can now be
instantiated from Boolean algebras with operators.\<close>

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 \<open>The modular laws are used to prove the Dedekind rule.\<close>

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 \<open>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.\<close>

sublocale relation_algebra < dioid_one_zero "(+)" "(;)" "1'" 0 "(\<le>)" "(<)"
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 \<open>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.\<close>

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)"
apply (rule antisym)
apply (metis local.aux6 local.aux6_var local.aux9 local.compl_inf_bot local.compl_sup_top local.compl_unique local.distrib_left local.galois_2 local.sup_ge2)
using local.meet_iso local.mult_subdistl by blast

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 \<open>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.\<close>

end


(* Sections 2.1 through 2.3 *)
theory AToyList
imports Datatype
begin

datatype 'a list = Nil ("[]") | Cons 'a "'a list" (infixr "#" 65)

(* append one list to another *)
primrec app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
"([] @ ys)     = ys" |
"(x # xs) @ ys = x # xs @ ys"

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

lemma app_Nil2 [simp]: "xs @ [] = xs"
apply (induct_tac xs)
apply auto
done

lemma app_assoc [simp]: "(xs @ yz) @ zs = xs @ (yz @ zs)"
apply (induct_tac xs)
apply auto
done

lemma rev_app [simp]: "rev (xs @ ys) = rev ys @ rev xs"
apply (induct_tac xs)
apply auto
done

theorem rev_rev [simp]: "rev (rev xs) = xs"
apply (induct_tac xs)
apply auto
done

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Permutations as abstract type\<close>

theory Perm
  imports
    Transposition
begin

text \<open>
  This theory introduces basics about permutations, i.e. almost
  everywhere fix bijections.  But it is by no means complete.
  Grieviously missing are cycles since these would require more
  elaboration, e.g. the concept of distinct lists equivalent
  under rotation, which maybe would also deserve its own theory.
  But see theory \<open>src/HOL/ex/Perm_Fragments.thy\<close> for
  fragments on that.
\<close>

subsection \<open>Abstract type of permutations\<close>

typedef 'a perm = "{f :: 'a \<Rightarrow> 'a. bij f \<and> finite {a. f a \<noteq> a}}"
  morphisms "apply" Perm
proof
  show "id \<in> ?perm" by simp
qed

setup_lifting type_definition_perm

notation "apply" (infixl "\<langle>$\<rangle>" 999)

lemma bij_apply [simp]:
  "bij (apply f)"
  using "apply" [of f] by simp

lemma perm_eqI:
  assumes "\<And>a. f \<langle>$\<rangle> a = g \<langle>$\<rangle> a"
  shows "f = g"
  using assms by transfer (simp add: fun_eq_iff)

lemma perm_eq_iff:
  "f = g \<longleftrightarrow> (\<forall>a. f \<langle>$\<rangle> a = g \<langle>$\<rangle> a)"
  by (auto intro: perm_eqI)

lemma apply_inj:
  "f \<langle>$\<rangle> a = f \<langle>$\<rangle> b \<longleftrightarrow> a = b"
  by (rule inj_eq) (rule bij_is_inj, simp)

lift_definition affected :: "'a perm \<Rightarrow> 'a set"
  is "\<lambda>f. {a. f a \<noteq> a}" .

lemma in_affected:
  "a \<in> affected f \<longleftrightarrow> f \<langle>$\<rangle> a \<noteq> a"
  by transfer simp

lemma finite_affected [simp]:
  "finite (affected f)"
  by transfer simp

lemma apply_affected [simp]:
  "f \<langle>$\<rangle> a \<in> affected f \<longleftrightarrow> a \<in> affected f"
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a :: 'a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" by simp
  interpret bijection f by standard (rule \<open>bij f\<close>)
  have "f a \<in> {a. f a = a} \<longleftrightarrow> a \<in> {a. f a = a}" (is "?P \<longleftrightarrow> ?Q")
    by auto
  then show "f a \<in> {a. f a \<noteq> a} \<longleftrightarrow> a \<in> {a. f a \<noteq> a}"
    by simp
qed

lemma card_affected_not_one:
  "card (affected f) \<noteq> 1"
proof
  interpret bijection "apply f"
    by standard (rule bij_apply)
  assume "card (affected f) = 1"
  then obtain a where *: "affected f = {a}"
    by (rule card_1_singletonE)
  then have **: "f \<langle>$\<rangle> a \<noteq> a"
    by (simp flip: in_affected)
  with * have "f \<langle>$\<rangle> a \<notin> affected f"
    by simp
  then have "f \<langle>$\<rangle> (f \<langle>$\<rangle> a) = f \<langle>$\<rangle> a"
    by (simp add: in_affected)
  then have "inv (apply f) (f \<langle>$\<rangle> (f \<langle>$\<rangle> a)) = inv (apply f) (f \<langle>$\<rangle> a)"
    by simp
  with ** show False by simp
qed

subsection \<open>Identity, composition and inversion\<close>

instantiation Perm.perm :: (type) "{monoid_mult, inverse}"
begin

lift_definition one_perm :: "'a perm"
  is id
  by simp

lemma apply_one [simp]:
  "apply 1 = id"
  by (fact one_perm.rep_eq)

lemma affected_one [simp]:
  "affected 1 = {}"
  by transfer simp

lemma affected_empty_iff [simp]:
  "affected f = {} \<longleftrightarrow> f = 1"
  by transfer auto

lift_definition times_perm :: "'a perm \<Rightarrow> 'a perm \<Rightarrow> 'a perm"
  is comp
proof
  fix f g :: "'a \<Rightarrow> 'a"
  assume "bij f \<and> finite {a. f a \<noteq> a}"
    "bij g \<and>finite {a. g a \<noteq> a}"
  then have "finite ({a. f a \<noteq> a} \<union> {a. g a \<noteq> a})"
    by simp
  moreover have "{a. (f \<circ> g) a \<noteq> a} \<subseteq> {a. f a \<noteq> a} \<union> {a. g a \<noteq> a}"
    by auto
  ultimately show "finite {a. (f \<circ> g) a \<noteq> a}"
    by (auto intro: finite_subset)
qed (auto intro: bij_comp)

lemma apply_times:
  "apply (f * g) = apply f \<circ> apply g"
  by (fact times_perm.rep_eq)

lemma apply_sequence:
  "f \<langle>$\<rangle> (g \<langle>$\<rangle> a) = apply (f * g) a"
  by (simp add: apply_times)

lemma affected_times [simp]:
  "affected (f * g) \<subseteq> affected f \<union> affected g"
  by transfer auto

lift_definition inverse_perm :: "'a perm \<Rightarrow> 'a perm"
  is inv
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" and fin: "finite {b. f b \<noteq> b}"
    by auto
  interpret bijection f by standard (rule \<open>bij f\<close>)
  from fin show "bij (inv f) \<and> finite {a. inv f a \<noteq> a}"
    by (simp add: bij_inv)
qed

instance
  by standard (transfer; simp add: comp_assoc)+

end

lemma apply_inverse:
  "apply (inverse f) = inv (apply f)"
  by (fact inverse_perm.rep_eq)

lemma affected_inverse [simp]:
  "affected (inverse f) = affected f"
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" by simp
  interpret bijection f by standard (rule \<open>bij f\<close>)
  show "{a. inv f a \<noteq> a} = {a. f a \<noteq> a}"
    by simp
qed

global_interpretation perm: group times "1::'a perm" inverse
proof
  fix f :: "'a perm"
  show "1 * f = f"
    by transfer simp
  show "inverse f * f = 1"
  proof transfer
    fix f :: "'a \<Rightarrow> 'a" and a
    assume "bij f \<and> finite {b. f b \<noteq> b}"
    then have "bij f" by simp
    interpret bijection f by standard (rule \<open>bij f\<close>)
    show "inv f \<circ> f = id"
      by simp
  qed
qed

declare perm.inverse_distrib_swap [simp]

lemma perm_mult_commute:
  assumes "affected f \<inter> affected g = {}"
  shows "g * f = f * g"
proof (rule perm_eqI)
  fix a
  from assms have *: "a \<in> affected f \<Longrightarrow> a \<notin> affected g"
    "a \<in> affected g \<Longrightarrow> a \<notin> affected f" for a
    by auto
  consider "a \<in> affected f \<and> a \<notin> affected g
        \<and> f \<langle>$\<rangle> a \<in> affected f"
    | "a \<notin> affected f \<and> a \<in> affected g
        \<and> f \<langle>$\<rangle> a \<notin> affected f"
    | "a \<notin> affected f \<and> a \<notin> affected g"
    using assms by auto
  then show "(g * f) \<langle>$\<rangle> a = (f * g) \<langle>$\<rangle> a"
  proof cases
    case 1
    with * have "f \<langle>$\<rangle> a \<notin> affected g"
      by auto
    with 1 show ?thesis by (simp add: in_affected apply_times)
  next
    case 2
    with * have "g \<langle>$\<rangle> a \<notin> affected f"
      by auto
    with 2 show ?thesis by (simp add: in_affected apply_times)
  next
    case 3
    then show ?thesis by (simp add: in_affected apply_times)
  qed
qed

lemma apply_power:
  "apply (f ^ n) = apply f ^^ n"
  by (induct n) (simp_all add: apply_times)

lemma perm_power_inverse:
  "inverse f ^ n = inverse ((f :: 'a perm) ^ n)"
proof (induct n)
  case 0 then show ?case by simp
next
  case (Suc n)
  then show ?case
    unfolding power_Suc2 [of f] by simp
qed

subsection \<open>Orbit and order of elements\<close>

definition orbit :: "'a perm \<Rightarrow> 'a \<Rightarrow> 'a set"
where
  "orbit f a = range (\<lambda>n. (f ^ n) \<langle>$\<rangle> a)"

lemma in_orbitI:
  assumes "(f ^ n) \<langle>$\<rangle> a = b"
  shows "b \<in> orbit f a"
  using assms by (auto simp add: orbit_def)

lemma apply_power_self_in_orbit [simp]:
  "(f ^ n) \<langle>$\<rangle> a \<in> orbit f a"
  by (rule in_orbitI) rule

lemma in_orbit_self [simp]:
  "a \<in> orbit f a"
  using apply_power_self_in_orbit [of _ 0] by simp

lemma apply_self_in_orbit [simp]:
  "f \<langle>$\<rangle> a \<in> orbit f a"
  using apply_power_self_in_orbit [of _ 1] by simp

lemma orbit_not_empty [simp]:
  "orbit f a \<noteq> {}"
  using in_orbit_self [of a f] by blast

lemma not_in_affected_iff_orbit_eq_singleton:
  "a \<notin> affected f \<longleftrightarrow> orbit f a = {a}" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "f \<langle>$\<rangle> a = a"
    by (simp add: in_affected)
  then have "(f ^ n) \<langle>$\<rangle> a = a" for n
    by (induct n) (simp_all add: apply_times)
  then show ?Q
    by (auto simp add: orbit_def)
next
  assume ?Q
  then show ?P
    by (auto simp add: orbit_def in_affected dest: range_eq_singletonD [of _ _ 1])
qed

definition order :: "'a perm \<Rightarrow> 'a \<Rightarrow> nat"
where
  "order f = card \<circ> orbit f"

lemma orbit_subset_eq_affected:
  assumes "a \<in> affected f"
  shows "orbit f a \<subseteq> affected f"
proof (rule ccontr)
  assume "\<not> orbit f a \<subseteq> affected f"
  then obtain b where "b \<in> orbit f a" and "b \<notin> affected f"
    by auto
  then have "b \<in> range (\<lambda>n. (f ^ n) \<langle>$\<rangle> a)"
    by (simp add: orbit_def)
  then obtain n where "b = (f ^ n) \<langle>$\<rangle> a"
    by blast
  with \<open>b \<notin> affected f\<close>
  have "(f ^ n) \<langle>$\<rangle> a \<notin> affected f"
    by simp
  then have "f \<langle>$\<rangle> a \<notin> affected f"
    by (induct n) (simp_all add: apply_times)
  with assms show False
    by simp
qed

lemma finite_orbit [simp]:
  "finite (orbit f a)"
proof (cases "a \<in> affected f")
  case False then show ?thesis
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
next
  case True then have "orbit f a \<subseteq> affected f"
    by (rule orbit_subset_eq_affected)
  then show ?thesis using finite_affected
    by (rule finite_subset)
qed

lemma orbit_1 [simp]:
  "orbit 1 a = {a}"
  by (auto simp add: orbit_def)

lemma order_1 [simp]:
  "order 1 a = 1"
  unfolding order_def by simp

lemma card_orbit_eq [simp]:
  "card (orbit f a) = order f a"
  by (simp add: order_def)

lemma order_greater_zero [simp]:
  "order f a > 0"
  by (simp only: card_gt_0_iff order_def comp_def) simp

lemma order_eq_one_iff:
  "order f a = Suc 0 \<longleftrightarrow> a \<notin> affected f" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P then have "card (orbit f a) = 1"
    by simp
  then obtain b where "orbit f a = {b}"
    by (rule card_1_singletonE)
  with in_orbit_self [of a f]
    have "b = a" by simp
  with \<open>orbit f a = {b}\<close> show ?Q
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
next
  assume ?Q
  then have "orbit f a = {a}"
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
  then have "card (orbit f a) = 1"
    by simp
  then show ?P
    by simp
qed

lemma order_greater_eq_two_iff:
  "order f a \<ge> 2 \<longleftrightarrow> a \<in> affected f"
  using order_eq_one_iff [of f a]
  apply (auto simp add: neq_iff)
  using order_greater_zero [of f a]
  apply simp
  done

lemma order_less_eq_affected:
  assumes "f \<noteq> 1"
  shows "order f a \<le> card (affected f)"
proof (cases "a \<in> affected f")
  from assms have "affected f \<noteq> {}"
    by simp
  then obtain B b where "affected f = insert b B"
    by blast
  with finite_affected [of f] have "card (affected f) \<ge> 1"
    by (simp add: card.insert_remove)
  case False then have "order f a = 1"
    by (simp add: order_eq_one_iff)
  with \<open>card (affected f) \<ge> 1\<close> show ?thesis
    by simp
next
  case True
  have "card (orbit f a) \<le> card (affected f)"
    by (rule card_mono) (simp_all add: True orbit_subset_eq_affected card_mono)
  then show ?thesis
    by simp
qed

lemma affected_order_greater_eq_two:
  assumes "a \<in> affected f"
  shows "order f a \<ge> 2"
proof (rule ccontr)
  assume "\<not> 2 \<le> order f a"
  then have "order f a < 2"
    by (simp add: not_le)
  with order_greater_zero [of f a] have "order f a = 1"
    by arith
  with assms show False
    by (simp add: order_eq_one_iff)
qed

lemma order_witness_unfold:
  assumes "n > 0" and "(f ^ n) \<langle>$\<rangle> a = a"
  shows "order f a = card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n})"
proof  -
  have "orbit f a = (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n}" (is "_ = ?B")
  proof (rule set_eqI, rule)
    fix b
    assume "b \<in> orbit f a"
    then obtain m where "(f ^ m) \<langle>$\<rangle> a = b"
      by (auto simp add: orbit_def)
    then have "b = (f ^ (m mod n + n * (m div n))) \<langle>$\<rangle> a"
      by simp
    also have "\<dots> = (f ^ (m mod n)) \<langle>$\<rangle> ((f ^ (n * (m div n))) \<langle>$\<rangle> a)"
      by (simp only: power_add apply_times) simp
    also have "(f ^ (n * q)) \<langle>$\<rangle> a = a" for q
      by (induct q)
        (simp_all add: power_add apply_times assms)
    finally have "b = (f ^ (m mod n)) \<langle>$\<rangle> a" .
    moreover from \<open>n > 0\<close>
    have "m mod n < n"
      by simp
    ultimately show "b \<in> ?B"
      by auto
  next
    fix b
    assume "b \<in> ?B"
    then obtain m where "(f ^ m) \<langle>$\<rangle> a = b"
      by blast
    then show "b \<in> orbit f a"
      by (rule in_orbitI)
  qed
  then have "card (orbit f a) = card ?B"
    by (simp only:)
  then show ?thesis
    by simp
qed

lemma inj_on_apply_range:
  "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<order f a}"
proof -
  have "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<n}"
    if "n \<le> order f a" for n
  using that proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)
    then have prem: "n < order f a"
      by simp
    with Suc.hyps have hyp: "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<n}"
      by simp
    have "(f ^ n) \<langle>$\<rangle> a \<notin> (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {..<n}"
    proof
      assume "(f ^ n) \<langle>$\<rangle> a \<in> (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {..<n}"
      then obtain m where *: "(f ^ m) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a" and "m < n"
        by auto
      interpret bijection "apply (f ^ m)"
        by standard simp
      from \<open>m < n\<close> have "n = m + (n - m)"
        and nm: "0 < n - m" "n - m \<le> n"
        by arith+
      with * have "(f ^ m) \<langle>$\<rangle> a = (f ^ (m + (n - m))) \<langle>$\<rangle> a"
        by simp
      then have "(f ^ m) \<langle>$\<rangle> a = (f ^ m) \<langle>$\<rangle> ((f ^ (n - m)) \<langle>$\<rangle> a)"
        by (simp add: power_add apply_times)
      then have "(f ^ (n - m)) \<langle>$\<rangle> a = a"
        by simp
      with \<open>n - m > 0\<close>
      have "order f a = card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n - m})"
         by (rule order_witness_unfold)
      also have "card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n - m}) \<le> card {0..<n - m}"
        by (rule card_image_le) simp
      finally have "order f a \<le> n - m"
        by simp
      with prem show False by simp
    qed
    with hyp show ?case
      by (simp add: lessThan_Suc)
  qed
  then show ?thesis by simp
qed

lemma orbit_unfold_image:
  "orbit f a = (\<lambda>n. (f ^ n) \<langle>$\<rangle> a) ` {..<order f a}" (is "_ = ?A")
proof (rule sym, rule card_subset_eq)
  show "finite (orbit f a)"
    by simp
  show "?A \<subseteq> orbit f a"
    by (auto simp add: orbit_def)
  from inj_on_apply_range [of f a]
  have "card ?A = order f a"
    by (auto simp add: card_image)
  then show "card ?A = card (orbit f a)"
    by simp
qed

lemma in_orbitE:
  assumes "b \<in> orbit f a"
  obtains n where "b = (f ^ n) \<langle>$\<rangle> a" and "n < order f a"
  using assms unfolding orbit_unfold_image by blast

lemma apply_power_order [simp]:
  "(f ^ order f a) \<langle>$\<rangle> a = a"
proof -
  have "(f ^ order f a) \<langle>$\<rangle> a \<in> orbit f a"
    by simp
  then obtain n where
    *: "(f ^ order f a) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a"
    and "n < order f a"
    by (rule in_orbitE)
  show ?thesis
  proof (cases n)
    case 0 with * show ?thesis by simp
  next
    case (Suc m)
    from order_greater_zero [of f a]
      have "Suc (order f a - 1) = order f a"
      by arith
    from Suc \<open>n < order f a\<close>
      have "m < order f a"
      by simp
    with Suc *
    have "(inverse f) \<langle>$\<rangle> ((f ^ Suc (order f a - 1)) \<langle>$\<rangle> a) =
      (inverse f) \<langle>$\<rangle> ((f ^ Suc m) \<langle>$\<rangle> a)"
      by simp
    then have "(f ^ (order f a - 1)) \<langle>$\<rangle> a =
      (f ^ m) \<langle>$\<rangle> a"
      by (simp only: power_Suc apply_times)
        (simp add: apply_sequence mult.assoc [symmetric])
    with inj_on_apply_range
    have "order f a - 1 = m"
      by (rule inj_onD)
        (simp_all add: \<open>m < order f a\<close>)
    with Suc have "n = order f a"
      by auto
    with \<open>n < order f a\<close>
    show ?thesis by simp
  qed
qed

lemma apply_power_left_mult_order [simp]:
  "(f ^ (n * order f a)) \<langle>$\<rangle> a = a"
  by (induct n) (simp_all add: power_add apply_times)

lemma apply_power_right_mult_order [simp]:
  "(f ^ (order f a * n)) \<langle>$\<rangle> a = a"
  by (simp add: ac_simps)

lemma apply_power_mod_order_eq [simp]:
  "(f ^ (n mod order f a)) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a"
proof -
  have "(f ^ n) \<langle>$\<rangle> a = (f ^ (n mod order f a + order f a * (n div order f a))) \<langle>$\<rangle> a"
    by simp
  also have "\<dots> = (f ^ (n mod order f a) * f ^ (order f a * (n div order f a))) \<langle>$\<rangle> a"
    by (simp flip: power_add)
  finally show ?thesis
    by (simp add: apply_times)
qed

lemma apply_power_eq_iff:
  "(f ^ m) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a \<longleftrightarrow> m mod order f a = n mod order f a" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?Q
  then have "(f ^ (m mod order f a)) \<langle>$\<rangle> a = (f ^ (n mod order f a)) \<langle>$\<rangle> a"
    by simp
  then show ?P
    by simp
next
  assume ?P
  then have "(f ^ (m mod order f a)) \<langle>$\<rangle> a = (f ^ (n mod order f a)) \<langle>$\<rangle> a"
    by simp
  with inj_on_apply_range
  show ?Q
    by (rule inj_onD) simp_all
qed

lemma apply_inverse_eq_apply_power_order_minus_one:
  "(inverse f) \<langle>$\<rangle> a = (f ^ (order f a - 1)) \<langle>$\<rangle> a"
proof (cases "order f a")
  case 0 with order_greater_zero [of f a] show ?thesis
    by simp
next
  case (Suc n)
  moreover have "(f ^ order f a) \<langle>$\<rangle> a = a"
    by simp
  then have *: "(inverse f) \<langle>$\<rangle> ((f ^ order f a) \<langle>$\<rangle> a) = (inverse f) \<langle>$\<rangle> a"
    by simp
  ultimately show ?thesis
    by (simp add: apply_sequence mult.assoc [symmetric])
qed

lemma apply_inverse_self_in_orbit [simp]:
  "(inverse f) \<langle>$\<rangle> a \<in> orbit f a"
  using apply_inverse_eq_apply_power_order_minus_one [symmetric]
  by (rule in_orbitI)

lemma apply_inverse_power_eq:
  "(inverse (f ^ n)) \<langle>$\<rangle> a = (f ^ (order f a - n mod order f a)) \<langle>$\<rangle> a"
proof (induct n)
  case 0 then show ?case by simp
next
  case (Suc n)
  define m where "m = order f a - n mod order f a - 1"
  moreover have "order f a - n mod order f a > 0"
    by simp
  ultimately have *: "order f a - n mod order f a = Suc m"
    by arith
  moreover from * have m2: "order f a - Suc n mod order f a = (if m = 0 then order f a else m)"
    by (auto simp add: mod_Suc)
  ultimately show ?case
    using Suc
      by (simp_all add: apply_times power_Suc2 [of _ n] power_Suc [of _ m] del: power_Suc)
        (simp add: apply_sequence mult.assoc [symmetric])
qed

lemma apply_power_eq_self_iff:
  "(f ^ n) \<langle>$\<rangle> a = a \<longleftrightarrow> order f a dvd n"
  using apply_power_eq_iff [of f n a 0]
    by (simp add: mod_eq_0_iff_dvd)

lemma orbit_equiv:
  assumes "b \<in> orbit f a"
  shows "orbit f b = orbit f a" (is "?B = ?A")
proof
  from assms obtain n where "n < order f a" and b: "b = (f ^ n) \<langle>$\<rangle> a"
    by (rule in_orbitE)
  then show "?B \<subseteq> ?A"
    by (auto simp add: apply_sequence power_add [symmetric] intro: in_orbitI elim!: in_orbitE)
  from b have "(inverse (f ^ n)) \<langle>$\<rangle> b = (inverse (f ^ n)) \<langle>$\<rangle> ((f ^ n) \<langle>$\<rangle> a)"
    by simp
  then have a: "a = (inverse (f ^ n)) \<langle>$\<rangle> b"
    by (simp add: apply_sequence)
  then show "?A \<subseteq> ?B"
    apply (auto simp add: apply_sequence power_add [symmetric] intro: in_orbitI elim!: in_orbitE)
    unfolding apply_times comp_def apply_inverse_power_eq
    unfolding apply_sequence power_add [symmetric]
    apply (rule in_orbitI) apply rule
    done
qed

lemma orbit_apply [simp]:
  "orbit f (f \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply [simp]:
  "order f (f \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply)

lemma orbit_apply_inverse [simp]:
  "orbit f (inverse f \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply_inverse [simp]:
  "order f (inverse f \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply_inverse)

lemma orbit_apply_power [simp]:
  "orbit f ((f ^ n) \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply_power [simp]:
  "order f ((f ^ n) \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply_power)

lemma orbit_inverse [simp]:
  "orbit (inverse f) = orbit f"
proof (rule ext, rule set_eqI, rule)
  fix b a
  assume "b \<in> orbit f a"
  then obtain n where b: "b = (f ^ n) \<langle>$\<rangle> a" "n < order f a"
    by (rule in_orbitE)
  then have "b = apply (inverse (inverse f) ^ n) a"
    by simp
  then have "b = apply (inverse (inverse f ^ n)) a"
    by (simp add: perm_power_inverse)
  then have "b = apply (inverse f ^ (n * (order (inverse f ^ n) a - 1))) a"
    by (simp add: apply_inverse_eq_apply_power_order_minus_one power_mult)
  then show "b \<in> orbit (inverse f) a"
    by simp
next
  fix b a
  assume "b \<in> orbit (inverse f) a"
  then show "b \<in> orbit f a"
    by (rule in_orbitE)
      (simp add: apply_inverse_eq_apply_power_order_minus_one
      perm_power_inverse power_mult [symmetric])
qed

lemma order_inverse [simp]:
  "order (inverse f) = order f"
  by (simp add: order_def)

lemma orbit_disjoint:
  assumes "orbit f a \<noteq> orbit f b"
  shows "orbit f a \<inter> orbit f b = {}"
proof (rule ccontr)
  assume "orbit f a \<inter> orbit f b \<noteq> {}"
  then obtain c where "c \<in> orbit f a \<inter> orbit f b"
    by blast
  then have "c \<in> orbit f a" and "c \<in> orbit f b"
    by auto
  then obtain m n where "c = (f ^ m) \<langle>$\<rangle> a"
    and "c = apply (f ^ n) b" by (blast elim!: in_orbitE)
  then have "(f ^ m) \<langle>$\<rangle> a = apply (f ^ n) b"
    by simp
  then have "apply (inverse f ^ m) ((f ^ m) \<langle>$\<rangle> a) =
    apply (inverse f ^ m) (apply (f ^ n) b)"
    by simp
  then have *: "apply (inverse f ^ m * f ^ n) b = a"
    by (simp add: apply_sequence perm_power_inverse)
  have "a \<in> orbit f b"
  proof (cases n m rule: linorder_cases)
    case equal with * show ?thesis
      by (simp add: perm_power_inverse)
  next
    case less
    moreover define q where "q = m - n"
    ultimately have "m = q + n" by arith
    with * have "apply (inverse f ^ q) b = a"
      by (simp add: power_add mult.assoc perm_power_inverse)
    then have "a \<in> orbit (inverse f) b"
      by (rule in_orbitI)
    then show ?thesis
      by simp
  next
    case greater
    moreover define q where "q = n - m"
    ultimately have "n = m + q" by arith
    with * have "apply (f ^ q) b = a"
      by (simp add: power_add mult.assoc [symmetric] perm_power_inverse)
    then show ?thesis
      by (rule in_orbitI)
  qed
  with assms show False
    by (auto dest: orbit_equiv)
qed

subsection \<open>Swaps\<close>

lift_definition swap :: "'a \<Rightarrow> 'a \<Rightarrow> 'a perm"  ("\<langle>_ \<leftrightarrow> _\<rangle>")
  is "\<lambda>a b. transpose a b"
proof
  fix a b :: 'a
  have "{c. transpose a b c \<noteq> c} \<subseteq> {a, b}"
    by (auto simp add: transpose_def)
  then show "finite {c. transpose a b c \<noteq> c}"
    by (rule finite_subset) simp
qed simp

lemma apply_swap_simp [simp]:
  "\<langle>a \<leftrightarrow> b\<rangle> \<langle>$\<rangle> a = b"
  "\<langle>a \<leftrightarrow> b\<rangle> \<langle>$\<rangle> b = a"
  by (transfer; simp)+

lemma apply_swap_same [simp]:
  "c \<noteq> a \<Longrightarrow> c \<noteq> b \<Longrightarrow> \<langle>a \<leftrightarrow> b\<rangle> \<langle>$\<rangle> c = c"
  by transfer simp

lemma apply_swap_eq_iff [simp]:
  "\<langle>a \<leftrightarrow> b\<rangle> \<langle>$\<rangle> c = a \<longleftrightarrow> c = b"
  "\<langle>a \<leftrightarrow> b\<rangle> \<langle>$\<rangle> c = b \<longleftrightarrow> c = a"
  by (transfer; auto simp add: transpose_def)+

lemma swap_1 [simp]:
  "\<langle>a \<leftrightarrow> a\<rangle> = 1"
  by transfer simp

lemma swap_sym:
  "\<langle>b \<leftrightarrow> a\<rangle> = \<langle>a \<leftrightarrow> b\<rangle>"
  by (transfer; auto simp add: transpose_def)+

lemma swap_self [simp]:
  "\<langle>a \<leftrightarrow> b\<rangle> * \<langle>a \<leftrightarrow> b\<rangle> = 1"
  by transfer simp

lemma affected_swap:
  "a \<noteq> b \<Longrightarrow> affected \<langle>a \<leftrightarrow> b\<rangle> = {a, b}"
  by transfer (auto simp add: transpose_def)

lemma inverse_swap [simp]:
  "inverse \<langle>a \<leftrightarrow> b\<rangle> = \<langle>a \<leftrightarrow> b\<rangle>"
  by transfer (auto intro: inv_equality)

subsection \<open>Permutations specified by cycles\<close>

fun cycle :: "'a list \<Rightarrow> 'a perm"  ("\<langle>_\<rangle>")
where
  "\<langle>[]\<rangle> = 1"
| "\<langle>[a]\<rangle> = 1"
| "\<langle>a # b # as\<rangle> = \<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>"

text \<open>
  We do not continue and restrict ourselves to syntax from here.
  See also introductory note.
\<close>

subsection \<open>Syntax\<close>

bundle no_permutation_syntax
begin
  no_notation swap    ("\<langle>_ \<leftrightarrow> _\<rangle>")
  no_notation cycle   ("\<langle>_\<rangle>")
  no_notation "apply" (infixl "\<langle>$\<rangle>" 999)
end

bundle permutation_syntax
begin
  notation swap       ("\<langle>_ \<leftrightarrow> _\<rangle>")
  notation cycle      ("\<langle>_\<rangle>")
  notation "apply"    (infixl "\<langle>$\<rangle>" 999)
end

unbundle no_permutation_syntax

end