(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Nondeterministic state and error monads with failure in Isabelle.
*)

chapter "Nondeterministic State Monad with Failure"

theory NonDetMonad
imports "../Lib"
begin

text {*
  \label{c:monads}

  State monads are used extensively in the seL4 specification. They are
  defined below.
*}

section "The Monad"

text {*
  The basic type of the nondeterministic state monad with failure is
  very similar to the normal state monad. Instead of a pair consisting
  of result and new state, we return a set of these pairs coupled with
  a failure flag. Each element in the set is a potential result of the
  computation. The flag is @{const True} if there is an execution path
  in the computation that may have failed. Conversely, if the flag is
  @{const False}, none of the computations resulting in the returned
  set can have failed.  *}
type_synonym ('s,'a) nondet_monad = "'s \<Rightarrow> ('a \<times> 's) set \<times> bool"

text {*
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.
*}
definition
  return :: "'a \<Rightarrow> ('s,'a) nondet_monad" where
  "return a \<equiv> \<lambda>s. ({(a,s)},False)"

text {*
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by @{text g} applied to the result sets of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on any of the results of @{text f}.
*}
definition
  bind :: "('s, 'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) nondet_monad) \<Rightarrow>
           ('s, 'b) nondet_monad" (infixl ">>=" 60)
  where
  "bind f g \<equiv> \<lambda>s. (\<Union>(fst ` case_prod g ` fst (f s)),
                   True \<in> snd ` case_prod g ` fst (f s) \<or> snd (f s))"

text {*
  Sometimes it is convenient to write @{text bind} in reverse order.
*}
abbreviation(input)
  bind_rev :: "('c \<Rightarrow> ('a, 'b) nondet_monad) \<Rightarrow> ('a, 'c) nondet_monad \<Rightarrow>
               ('a, 'b) nondet_monad" (infixl "=<<" 60) where
  "g =<< f \<equiv> f >>= g"

text {*
  The basic accessor functions of the state monad. @{text get} returns
  the current state as result, does not fail, and does not change the state.
  @{text "put s"} returns nothing (@{typ unit}), changes the current state
  to @{text s} and does not fail.
*}
definition
  get :: "('s,'s) nondet_monad" where
  "get \<equiv> \<lambda>s. ({(s,s)}, False)"

definition
  put :: "'s \<Rightarrow> ('s, unit) nondet_monad" where
  "put s \<equiv> \<lambda>_. ({((),s)}, False)"

subsection "Nondeterminism"

text {*
  Basic nondeterministic functions. @{text "select A"} chooses an element
  of the set @{text A}, does not change the state, and does not fail
  (even if the set is empty). @{text "f OR g"} executes @{text f} or
  executes @{text g}. It retuns the union of results of @{text f} and
  @{text g}, and may have failed if either may have failed.
*}
definition
  select :: "'a set \<Rightarrow> ('s,'a) nondet_monad" where
  "select A \<equiv> \<lambda>s. (A \<times> {s}, False)"

definition
  alternative :: "('s,'a) nondet_monad \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow>
                  ('s,'a) nondet_monad"
  (infixl "OR" 20)
where
  "f OR g \<equiv> \<lambda>s. (fst (f s) \<union> fst (g s), snd (f s) \<or> snd (g s))"

text {* Alternative notation for @{text OR} *}
notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

text {* A variant of @{text select} that takes a pair. The first component
  is a set as in normal @{text select}, the second component indicates
  whether the execution failed. This is useful to lift monads between
  different state spaces.
*}
definition
  select_f :: "'a set \<times> bool  \<Rightarrow> ('s,'a) nondet_monad" where
  "select_f S \<equiv> \<lambda>s. (fst S \<times> {s}, snd S)"

text {* @{text select_state} takes a relationship between
  states, and outputs nondeterministically a state
  related to the input state. *}

definition
  state_select :: "('s \<times> 's) set \<Rightarrow> ('s, unit) nondet_monad"
where
  "state_select r \<equiv> \<lambda>s. ((\<lambda>x. ((), x)) ` {s'. (s, s') \<in> r}, \<not> (\<exists>s'. (s, s') \<in> r))"

subsection "Failure"

text {* The monad function that always fails. Returns an empty set of
results and sets the failure flag. *}
definition
  fail :: "('s, 'a) nondet_monad" where
 "fail \<equiv> \<lambda>s. ({}, True)"

text {* Assertions: fail if the property @{text P} is not true *}
definition
  assert :: "bool \<Rightarrow> ('a, unit) nondet_monad" where
 "assert P \<equiv> if P then return () else fail"

text {* Fail if the value is @{const None},
  return result @{text v} for @{term "Some v"} *}
definition
  assert_opt :: "'a option \<Rightarrow> ('b, 'a) nondet_monad" where
 "assert_opt v \<equiv> case v of None \<Rightarrow> fail | Some v \<Rightarrow> return v"

text {* An assertion that also can introspect the current state. *}

definition
  state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) nondet_monad"
where
  "state_assert P \<equiv> get >>= (\<lambda>s. assert (P s))"

subsection "Generic functions on top of the state monad"

text {* Apply a function to the current state and return the result
without changing the state. *}
definition
  gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) nondet_monad" where
 "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

text {* Modify the current state using the function passed in. *}
definition
  modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) nondet_monad" where
 "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

lemma simpler_gets_def: "gets f = (\<lambda>s. ({(f s, s)}, False))"
  apply (simp add: gets_def return_def bind_def get_def)
  done

lemma simpler_modify_def:
  "modify f = (\<lambda>s. ({((), f s)}, False))"
  by (simp add: modify_def bind_def get_def put_def)

text {* Execute the given monad when the condition is true,
  return @{text "()"} otherwise. *}
definition
  "when" :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow>
           ('s, unit) nondet_monad" where
  "when P m \<equiv> if P then m else return ()"

text {* Execute the given monad unless the condition is true,
  return @{text "()"} otherwise. *}
definition
  unless :: "bool \<Rightarrow> ('s, unit) nondet_monad \<Rightarrow>
            ('s, unit) nondet_monad" where
  "unless P m \<equiv> when (\<not>P) m"

text {*
  Perform a test on the current state, performing the left monad if
  the result is true or the right monad if the result is false.
*}
definition
  condition :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad \<Rightarrow> ('s, 'r) nondet_monad"
where
  "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

text {*
Apply an option valued function to the current state, fail
if it returns @{const None}, return @{text v} if it returns
@{term "Some v"}.
*}
definition
  gets_the :: "('s \<Rightarrow> 'a option) \<Rightarrow> ('s, 'a) nondet_monad" where
 "gets_the f \<equiv> gets f >>= assert_opt"

subsection {* The Monad Laws *}

text {* A more expanded definition of @{text bind} *}
lemma bind_def':
  "(f >>= g) \<equiv>
       \<lambda>s. ({(r'', s''). \<exists>(r', s') \<in> fst (f s). (r'', s'') \<in> fst (g r' s') },
                     snd (f s) \<or> (\<exists>(r', s') \<in> fst (f s). snd (g r' s')))"
  apply (rule eq_reflection)
  apply (auto simp add: bind_def split_def Let_def)
  done

text {* Each monad satisfies at least the following three laws. *}

text {* @{term return} is absorbed at the left of a @{term bind},
  applying the return value directly: *}
lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def)

text {* @{term return} is absorbed on the right of a @{term bind} *}
lemma bind_return [simp]: "(m >>= return) = m"
  apply (rule ext)
  apply (simp add: bind_def return_def split_def)
  done

text {* @{term bind} is associative *}
lemma bind_assoc:
  fixes m :: "('a,'b) nondet_monad"
  fixes f :: "'b \<Rightarrow> ('a,'c) nondet_monad"
  fixes g :: "'c \<Rightarrow> ('a,'d) nondet_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  apply (unfold bind_def Let_def split_def)
  apply (rule ext)
  apply clarsimp
  apply (auto intro: rev_image_eqI)
  done

section {* Adding Exceptions *}

text {*
  The type @{typ "('s,'a) nondet_monad"} gives us nondeterminism and
  failure. We now extend this monad with exceptional return values
  that abort normal execution, but can be handled explicitly.
  We use the sum type to indicate exceptions.

  In @{typ "('s, 'e + 'a) nondet_monad"}, @{typ "'s"} is the state,
  @{typ 'e} is an exception, and @{typ 'a} is a normal return value.

  This new type itself forms a monad again. Since type classes in
  Isabelle are not powerful enough to express the class of monads,
  we provide new names for the @{term return} and @{term bind} functions
  in this monad. We call them @{text returnOk} (for normal return values)
  and @{text bindE} (for composition). We also define @{text throwError}
  to return an exceptional value.
*}
definition
  returnOk :: "'a \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "returnOk \<equiv> return o Inr"

definition
  throwError :: "'e \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throwError \<equiv> return o Inl"

text {*
  Lifting a function over the exception type: if the input is an
  exception, return that exception; otherwise continue execution.
*}
definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow>
           'e +'a \<Rightarrow> ('s, 'e + 'b) nondet_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e
                      | Inr v' \<Rightarrow> f v'"

text {*
  The definition of @{term bind} in the exception monad (new
  name @{text bindE}): the same as normal @{term bind}, but
  the right-hand side is skipped if the left-hand side
  produced an exception.
*}
definition
  bindE :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
            ('a \<Rightarrow> ('s, 'e + 'b) nondet_monad) \<Rightarrow>
            ('s, 'e + 'b) nondet_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

text {*
  Lifting a normal nondeterministic monad into the
  exception monad is achieved by always returning its
  result as normal result and never throwing an exception.
*}
definition
  liftE :: "('s,'a) nondet_monad \<Rightarrow> ('s, 'e+'a) nondet_monad"
where
  "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"

text {*
  Since the underlying type and @{text return} function changed,
  we need new definitions for when and unless:
*}
definition
  whenE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow>
            ('s, 'e + unit) nondet_monad"
  where
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  unlessE :: "bool \<Rightarrow> ('s, 'e + unit) nondet_monad \<Rightarrow>
            ('s, 'e + unit) nondet_monad"
  where
  "unlessE P f \<equiv> if P then returnOk () else f"

text {*
  Throwing an exception when the parameter is @{term None}, otherwise
  returning @{term "v"} for @{term "Some v"}.
*}
definition
  throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) nondet_monad" where
  "throw_opt ex x \<equiv>
  case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

text {*
  Failure in the exception monad is redefined in the same way
  as @{const whenE} and @{const unlessE}, with @{term returnOk}
  instead of @{term return}.
*}
definition
  assertE :: "bool \<Rightarrow> ('a, 'e + unit) nondet_monad" where
 "assertE P \<equiv> if P then returnOk () else fail"

subsection "Monad Laws for the Exception Monad"

text {* More direct definition of @{const liftE}: *}
lemma liftE_def2:
  "liftE f = (\<lambda>s. ((\<lambda>(v,s'). (Inr v, s')) ` fst (f s), snd (f s)))"
  by (auto simp: liftE_def return_def split_def bind_def)

text {* Left @{const returnOk} absorbtion over @{term bindE}: *}
lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  apply (unfold bindE_def returnOk_def)
  apply (clarsimp simp: lift_def)
  done

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (rule ext)
     (simp add: lift_def throwError_def split: sum.splits)

text {* Right @{const returnOk} absorbtion over @{term bindE}: *}
lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

text {* Associativity of @{const bindE}: *}
lemma bindE_assoc:
  "(m >>=E f) >>=E g = m >>=E (\<lambda>x. f x >>=E g)"
  apply (simp add: bindE_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. m >>= x"])
  apply (rule ext)
  apply (case_tac x, simp_all add: lift_def throwError_def)
  done

text {* @{const returnOk} could also be defined via @{const liftE}: *}
lemma returnOk_liftE:
  "returnOk x = liftE (return x)"
  by (simp add: liftE_def returnOk_def)

text {* Execution after throwing an exception is skipped: *}
lemma throwError_bindE [simp]:
  "(throwError E >>=E f) = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

section "Syntax"

text {* This section defines traditional Haskell-like do-syntax
  for the state monad in Isabelle. *}

subsection "Syntax for the Nondeterministic State Monad"

text {* We use @{text K_bind} to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored *}
definition
  K_bind_def [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do ((_);//(_))//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

text {* Syntax examples: *}
lemma "do x \<leftarrow> return 1;
          return (2::nat);
          return x
       od =
       return 1 >>=
       (\<lambda>x. return (2::nat) >>=
            K_bind (return x))"
  by (rule refl)

lemma "do x \<leftarrow> return 1;
          return 2;
          return x
       od = return 1"
  by simp

subsection "Syntax for the Exception Monad"

text {*
  Since the exception monad is a different type, we
  need to syntactically distinguish it in the syntax.
  We use @{text doE}/@{text odE} for this, but can re-use
  most of the productions from @{text do}/@{text od}
  above.
*}

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE ((_);//(_))//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "b >>=E (CONST K_bind e)"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

text {* Syntax examples: *}
lemma "doE x \<leftarrow> returnOk 1;
           returnOk (2::nat);
           returnOk x
       odE =
       returnOk 1 >>=E
       (\<lambda>x. returnOk (2::nat) >>=E
            K_bind (returnOk x))"
  by (rule refl)

lemma "doE x \<leftarrow> returnOk 1;
           returnOk 2;
           returnOk x
       odE = returnOk 1"
  by simp

section "Library of Monadic Functions and Combinators"

text {* Lifting a normal function into the monad type: *}
definition
  liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('s, 'b) nondet_monad"
where
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"

text {* The same for the exception monad: *}
definition
  liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) nondet_monad \<Rightarrow> ('s,'e+'b) nondet_monad"
where
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

text {*
  Run a sequence of monads from left to right, ignoring return values. *}
definition
  sequence_x :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, unit) nondet_monad"
where
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

text {*
  Map a monadic function over a list by applying it to each element
  of the list from left to right, ignoring return values.
*}
definition
  mapM_x :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, unit) nondet_monad"
where
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

text {*
  Map a monadic function with two parameters over two lists,
  going through both lists simultaneously, left to right, ignoring
  return values.
*}
definition
  zipWithM_x :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) nondet_monad"
where
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"

text {* The same three functions as above, but returning a list of
return values instead of @{text unit} *}
definition
  sequence :: "('s, 'a) nondet_monad list \<Rightarrow> ('s, 'a list) nondet_monad"
where
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  mapM :: "('a \<Rightarrow> ('s,'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'b list) nondet_monad"
where
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  zipWithM :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) nondet_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) nondet_monad"
where
  "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"

definition
  foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) nondet_monad"
where
  "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "

definition
  foldME ::"('b \<Rightarrow> 'a \<Rightarrow> ('s,('e + 'b)) nondet_monad) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> ('s, ('e + 'b)) nondet_monad"
where "foldME m a xs \<equiv> foldr (\<lambda>p q. q >>=E swp m p) xs (returnOk a)"

text {* The sequence and map functions above for the exception monad,
with and without lists of return value *}
definition
  sequenceE_x :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+unit) nondet_monad"
where
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE _ <- x; y odE) xs (returnOk ())"

definition
  mapME_x :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+unit) nondet_monad"
where
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  sequenceE :: "('s, 'e+'a) nondet_monad list \<Rightarrow> ('s, 'e+'a list) nondet_monad"
where
  "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                 in foldr mcons xs (returnOk [])"

definition
  mapME :: "('a \<Rightarrow> ('s,'e+'b) nondet_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+'b list) nondet_monad"
where
  "mapME f xs \<equiv> sequenceE (map f xs)"

text {* Filtering a list using a monadic function as predicate: *}
primrec
  filterM :: "('a \<Rightarrow> ('s, bool) nondet_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) nondet_monad"
where
  "filterM P []       = return []"
| "filterM P (x # xs) = do
     b  <- P x;
     ys <- filterM P xs;
     return (if b then (x # ys) else ys)
   od"

section "Catching and Handling Exceptions"

text {*
  Turning an exception monad into a normal state monad
  by catching and handling any potential exceptions:
*}
definition
  catch :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
            ('e \<Rightarrow> ('s, 'a) nondet_monad) \<Rightarrow>
            ('s, 'a) nondet_monad" (infix "<catch>" 10)
where
  "f <catch> handler \<equiv>
     do x \<leftarrow> f;
        case x of
          Inr b \<Rightarrow> return b
        | Inl e \<Rightarrow> handler e
     od"

text {*
  Handling exceptions, but staying in the exception monad.
  The handler may throw a type of exceptions different from
  the left side.
*}
definition
  handleE' :: "('s, 'e1 + 'a) nondet_monad \<Rightarrow>
               ('e1 \<Rightarrow> ('s, 'e2 + 'a) nondet_monad) \<Rightarrow>
               ('s, 'e2 + 'a) nondet_monad" (infix "<handle2>" 10)
where
  "f <handle2> handler \<equiv>
   do
      v \<leftarrow> f;
      case v of
        Inl e \<Rightarrow> handler e
      | Inr v' \<Rightarrow> return (Inr v')
   od"

text {*
  A type restriction of the above that is used more commonly in
  practice: the exception handle (potentially) throws exception
  of the same type as the left-hand side.
*}
definition
  handleE :: "('s, 'x + 'a) nondet_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) nondet_monad) \<Rightarrow>
              ('s, 'x + 'a) nondet_monad" (infix "<handle>" 10)
where
  "handleE \<equiv> handleE'"

text {*
  Handling exceptions, and additionally providing a continuation
  if the left-hand side throws no exception:
*}
definition
  handle_elseE :: "('s, 'e + 'a) nondet_monad \<Rightarrow>
                   ('e \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'ee + 'b) nondet_monad) \<Rightarrow>
                   ('s, 'ee + 'b) nondet_monad"
  ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
   do v \<leftarrow> f;
   case v of Inl e  \<Rightarrow> handler e
           | Inr v' \<Rightarrow> continue v'
   od"

subsection "Loops"

text {*
  Loops are handled using the following inductive predicate;
  non-termination is represented using the failure flag of the
  monad.
*}

inductive_set
  whileLoop_results :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> ((('r \<times> 's) option) \<times> (('r \<times> 's) option)) set"
  for C B
where
    "\<lbrakk> \<not> C r s \<rbrakk> \<Longrightarrow> (Some (r, s), Some (r, s)) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; snd (B r s) \<rbrakk> \<Longrightarrow> (Some (r, s), None) \<in> whileLoop_results C B"
  | "\<lbrakk> C r s; (r', s') \<in> fst (B r s); (Some (r', s'), z) \<in> whileLoop_results C B  \<rbrakk>
       \<Longrightarrow> (Some (r, s), z) \<in> whileLoop_results C B"

inductive_cases whileLoop_results_cases_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_cases whileLoop_results_cases_fail: "(Some x, None) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps: "(Some x, y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_valid: "(Some x, Some y) \<in> whileLoop_results C B"
inductive_simps whileLoop_results_simps_start_fail [simp]: "(None, x) \<in> whileLoop_results C B"

inductive
  whileLoop_terminates :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'r) nondet_monad) \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> bool"
  for C B
where
    "\<not> C r s \<Longrightarrow> whileLoop_terminates C B r s"
  | "\<lbrakk> C r s; \<forall>(r', s') \<in> fst (B r s). whileLoop_terminates C B r' s' \<rbrakk>
        \<Longrightarrow> whileLoop_terminates C B r s"

inductive_cases whileLoop_terminates_cases: "whileLoop_terminates C B r s"
inductive_simps whileLoop_terminates_simps: "whileLoop_terminates C B r s"

definition
  "whileLoop C B \<equiv> (\<lambda>r s.
     ({(r',s'). (Some (r, s), Some (r', s')) \<in> whileLoop_results C B},
        (Some (r, s), None) \<in> whileLoop_results C B \<or> (\<not> whileLoop_terminates C B r s)))"

notation (output)
  whileLoop  ("(whileLoop (_)//  (_))" [1000, 1000] 1000)

definition
  whileLoopE :: "('r \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('r \<Rightarrow> ('s, 'e + 'r) nondet_monad)
      \<Rightarrow> 'r \<Rightarrow> 's \<Rightarrow> (('e + 'r) \<times> 's) set \<times> bool"
where
  "whileLoopE C body \<equiv>
      \<lambda>r. whileLoop (\<lambda>r s. (case r of Inr v \<Rightarrow> C v s | _ \<Rightarrow> False)) (lift body) (Inr r)"

notation (output)
  whileLoopE  ("(whileLoopE (_)//  (_))" [1000, 1000] 1000)

section "Hoare Logic"

subsection "Validity"

text {* This section defines a Hoare logic for partial correctness for
  the nondeterministic state monad as well as the exception monad.
  The logic talks only about the behaviour part of the monad and ignores
  the failure flag.

  The logic is defined semantically. Rules work directly on the
  validity predicate.

  In the nondeterministic state monad, validity is a triple of precondition,
  monad, and postcondition. The precondition is a function from state to
  bool (a state predicate), the postcondition is a function from return value
  to state to bool. A triple is valid if for all states that satisfy the
  precondition, all result values and result states that are returned by
  the monad satisfy the postcondition. Note that if the computation returns
  the empty set, the triple is trivially valid. This means @{term "assert P"}
  does not require us to prove that @{term P} holds, but rather allows us
  to assume @{term P}! Proving non-failure is done via separate predicate and
  calculus (see below).
*}
definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>(r,s') \<in> fst (f s). Q r s')"

text {*
  We often reason about invariant predicates. The following provides shorthand syntax
  that avoids repeating potentially long predicates.
*}
abbreviation (input)
  invariant :: "('s,'a) nondet_monad \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<lbrace>_\<rbrace>" [59,0] 60)
where
  "invariant f P \<equiv> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"

text {*
  Validity for the exception monad is similar and build on the standard
  validity above. Instead of one postcondition, we have two: one for
  normal and one for exceptional results.
*}
definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>v s. case v of Inr r \<Rightarrow> Q r s | Inl e \<Rightarrow> E e s \<rbrace>"

text {*
  The following two instantiations are convenient to separate reasoning
  for exceptional and normal case.
*}
definition
  validE_R :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>, -")
where
 "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<equiv> validE P f Q (\<lambda>x y. True)"

definition
  validE_E :: "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) nondet_monad \<Rightarrow>
               ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>")
where
 "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"

text {* Abbreviations for trivial preconditions: *}
abbreviation(input)
  top :: "'a \<Rightarrow> bool" ("\<top>")
where
  "\<top> \<equiv> \<lambda>_. True"

abbreviation(input)
  bottom :: "'a \<Rightarrow> bool" ("\<bottom>")
where
  "\<bottom> \<equiv> \<lambda>_. False"

text {* Abbreviations for trivial postconditions (taking two arguments): *}
abbreviation(input)
  toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
where
 "\<top>\<top> \<equiv> \<lambda>_ _. True"

abbreviation(input)
  botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")
where
 "\<bottom>\<bottom> \<equiv> \<lambda>_ _. False"

text {*
  Lifting @{text "\<and>"} and @{text "\<or>"} over two arguments.
  Lifting @{text "\<and>"} and @{text "\<or>"} over one argument is already
  defined (written @{text "and"} and @{text "or"}).
*}
definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

subsection "Determinism"

text {* A monad of type @{text nondet_monad} is deterministic iff it
returns exactly one state and result and does not fail *}
definition
  det :: "('a,'s) nondet_monad \<Rightarrow> bool"
where
  "det f \<equiv> \<forall>s. \<exists>r. f s = ({r},False)"

text {* A deterministic @{text nondet_monad} can be turned
  into a normal state monad: *}
definition
  the_run_state :: "('s,'a) nondet_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "the_run_state M \<equiv> \<lambda>s. THE s'. fst (M s) = {s'}"

subsection "Non-Failure"

text {*
  With the failure flag, we can formulate non-failure separately
  from validity. A monad @{text m} does not fail under precondition
  @{text P}, if for no start state in that precondition it sets
  the failure flag.
*}
definition
  no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> bool"
where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> \<not> (snd (m s))"

text {*
  It is often desired to prove non-failure and a Hoare triple
  simultaneously, as the reasoning is often similar. The following
  definitions allow such reasoning to take place.
*}

definition
  validNF ::"('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
      ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "validNF P f Q \<equiv> valid P f Q \<and> no_fail P f"

definition
  validE_NF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)")
where
  "validE_NF P f Q E \<equiv> validE P f Q E \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace> P \<rbrace> B \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! = \<lbrace> P \<rbrace> B \<lbrace> \<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s \<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

text {*
  Usually, well-formed monads constructed from the primitives
  above will have the following property: if they return an
  empty set of results, they will have the failure flag set.
*}
definition
  empty_fail :: "('s,'a) nondet_monad \<Rightarrow> bool"
where
  "empty_fail m \<equiv> \<forall>s. fst (m s) = {} \<longrightarrow> snd (m s)"

text {*
  Useful in forcing otherwise unknown executions to have
  the @{const empty_fail} property.
*}
definition
  mk_ef :: "'a set \<times> bool \<Rightarrow> 'a set \<times> bool"
where
  "mk_ef S \<equiv> (fst S, fst S = {} \<or> snd S)"

section "Basic exception reasoning"

text {*
  The following predicates @{text no_throw} and @{text no_return} allow
  reasoning that functions in the exception monad either do
  no throw an exception or never return normally.
*}

definition "no_throw P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_ _. False \<rbrace>"

definition "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"

end


header {* Basic lemmas about functions *}

theory FunctionLemmas

imports Main
  "~~/src/HOL/Library/FuncSet"
begin

text {*These are used in simplification. Note that the difference from Pi-mem is that the statement
about the function comes first, so Isabelle can more easily figure out what $S$ is.*}

lemma PiE_mem2: "f \<in> S\<rightarrow>\<^sub>E T \<Longrightarrow> x \<in> S \<Longrightarrow> f x \<in> T"
  unfolding PiE_def by auto
lemma Pi_mem2: "f \<in> S\<rightarrow> T \<Longrightarrow> x \<in> S \<Longrightarrow> f x \<in> T"
  unfolding Pi_def by auto

end


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory System_S2 imports System_S0 begin

text \<open>System S2 from Boleslaw Sobocinski: Note on a Problem of Paul Barnays (1955) \<close>

text \<open>Derivations are taken from the above paper\<close>

inductive S2 (\<open>\<SS>\<^sub>2\<close>) where
  S2_MP: \<open>\<SS>\<^sub>2 q\<close> if \<open>\<SS>\<^sub>2 p\<close> and \<open>\<SS>\<^sub>2 (p \<rightarrow> q)\<close> |
  S2_1:  \<open>\<SS>\<^sub>2 (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close> |
  S2_2:  \<open>\<SS>\<^sub>2 ((p \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> (p \<rightarrow> r)))\<close> |
  S2_3:  \<open>\<SS>\<^sub>2 (((\<sim> p) \<rightarrow> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close>

lemma S2_4: \<open>\<SS>\<^sub>2 ((\<sim> (q \<rightarrow> (r \<rightarrow> p))) \<rightarrow> (p \<rightarrow> s))\<close>
  using S2_1 S2_2 S2_MP by metis

lemma S2_5: \<open>\<SS>\<^sub>2 (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> (s \<rightarrow> p))))\<close>
  using S2_1 S2_3 S2_4 S2_MP by metis

lemma S2_6: \<open>\<SS>\<^sub>2 (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> (s \<rightarrow> (t \<rightarrow> p)))))\<close>
  using S2_3 S2_4 S2_MP by metis

lemma S2_7: \<open>\<SS>\<^sub>2 ((\<sim> ((\<sim> q) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> s)))\<close>
  using S2_2 S2_MP by metis

lemma S2_8: \<open>\<SS>\<^sub>2 ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> (t \<rightarrow> (v \<rightarrow> ((\<sim> q) \<rightarrow> (p \<rightarrow> r))))))\<close>
  using S2_3 S2_6 S2_7 S2_MP by metis

lemma S2_9: \<open>\<SS>\<^sub>2 ((\<sim> ((p \<rightarrow> q) \<rightarrow> q)) \<rightarrow> (((\<sim> p) \<rightarrow> q) \<rightarrow> r))\<close>
  using S2_2 S2_3 S2_MP by metis

lemma S2_10: \<open>\<SS>\<^sub>2 (((\<sim> p) \<rightarrow> q) \<rightarrow> (s \<rightarrow> (t \<rightarrow> ((\<sim> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r)))))\<close>
  using S2_3 S2_8 S2_9 S2_MP by metis

lemma S2_11: \<open>\<SS>\<^sub>2 (((\<sim> p) \<rightarrow> q) \<rightarrow> (r \<rightarrow> (s \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))))\<close>
  using S2_3 S2_5 S2_9 S2_MP by metis

lemma S2_12: \<open>\<SS>\<^sub>2 ((p \<rightarrow> q) \<rightarrow> (s \<rightarrow> ((q \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (p \<rightarrow> r))))\<close>
  using S2_3 S2_7 S2_11 S2_MP by metis

lemma S2_13: \<open>\<SS>\<^sub>2 ((\<sim> q) \<rightarrow> (p \<rightarrow> (\<sim> (p \<rightarrow> q))))\<close>
  using S2_1 S2_2 S2_3 S2_MP by metis

lemma S2_14: \<open>\<SS>\<^sub>2 ((\<sim> (p \<rightarrow> (\<sim> (p \<rightarrow> q)))) \<rightarrow> ((\<sim> q) \<rightarrow> r))\<close>
  using S2_2 S2_13 S2_MP by metis

lemma S2_15: \<open>\<SS>\<^sub>2 ((\<sim> q) \<rightarrow> (((\<sim> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S2_3 S2_12 S2_14 S2_MP by metis

lemma S2_16: \<open>\<SS>\<^sub>2 (((\<sim> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> q)) \<rightarrow> (p \<rightarrow> q))\<close>
  using S2_1 S2_3 S2_15 S2_MP by metis

lemma S2_17: \<open>\<SS>\<^sub>2 (p \<rightarrow> p)\<close>
  using S2_1 S2_12 S2_16 S2_MP by metis

lemma S2_18: \<open>\<SS>\<^sub>2 ((\<sim> p) \<rightarrow> (p \<rightarrow> q))\<close>
  using S2_2 S2_17 S2_MP by metis

lemma S2_19: \<open>\<SS>\<^sub>2 ((\<sim> (p \<rightarrow> q)) \<rightarrow> ((\<sim> p) \<rightarrow> r))\<close>
  using S2_2 S2_18 S2_MP by metis

lemma S2_20: \<open>\<SS>\<^sub>2 ((\<sim> p) \<rightarrow> (r \<rightarrow> (s \<rightarrow> (p \<rightarrow> q))))\<close>
  using S2_3 S2_5 S2_19 S2_MP by metis

lemma S2_21: \<open>\<SS>\<^sub>2 (p \<rightarrow> (q \<rightarrow> (\<sim> (\<sim> p))))\<close>
  using S2_1 S2_3 S2_19 S2_MP by metis

lemma S2_22: \<open>\<SS>\<^sub>2 (p \<rightarrow> (\<sim> (\<sim> p)))\<close>
  using S2_3 S2_18 S2_21 S2_MP by metis

lemma S2_23: \<open>\<SS>\<^sub>2 ((\<sim> (\<sim> p)) \<rightarrow> (t \<rightarrow> ((\<sim> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r))))\<close>
  using S2_10 S2_12 S2_17 S2_18 S2_MP by metis

lemma S2_24: \<open>\<SS>\<^sub>2 (p \<rightarrow> ((\<sim> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r)))\<close>
  using S2_12 S2_17 S2_22 S2_23 S2_MP by metis

lemma S2_25: \<open>\<SS>\<^sub>2 ((\<sim> q ) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using S2_3 S2_20 S2_24 S2_MP by metis

theorem S2_if_S0: \<open>\<SS>\<^sub>2 p\<close> if \<open>\<SS>\<^sub>0 p\<close> using that
  by (induct) (metis S2.intros(1), metis S2_5, metis S2_25, metis S2_3)

theorem S2_iff_L1: \<open>\<SS>\<^sub>2 p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have S2_1: \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> (r \<rightarrow> p)))\<close> for p q r
    using L1_completeness by simp
  have S2_2: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((\<sim> q) \<rightarrow> (p \<rightarrow> r)))\<close> for p q r
    using L1_completeness by simp
  have S2_3: \<open>\<turnstile> (((\<sim> p) \<rightarrow> q) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> q))\<close> for p q
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<SS>\<^sub>2 p\<close>
    using that by (induct) (metis MP, metis S2_1, metis S2_2, metis S2_3)
  show \<open>\<SS>\<^sub>2 p\<close> if \<open>\<turnstile> p\<close>
    using that S0_if_L1 S2_if_S0 by simp
qed

theorem S2_soundness: \<open>\<SS>\<^sub>2 p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: S2.induct) auto

theorem S2_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<SS>\<^sub>2 p\<close>
  using S2_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<SS>\<^sub>2 p\<close>
  unfolding valid_def using S2_soundness S2_completeness by blast

lemmas S2 = S2.intros main

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Example III: abstract algebra\<close>
theory CZH_EX_Algebra
  imports CZH_EX_TS
begin

subsection\<open>Background\<close>

text\<open>
The section presents several examples of algebraic structures formalized
in \<open>ZFC in HOL\<close>. The definitions were adopted (with amendments) from the
main library of Isabelle/HOL.
\<close>

named_theorems sgrp_struct_field_simps

lemmas [sgrp_struct_field_simps] = \<A>_def

subsection\<open>Semigroup\<close>

subsubsection\<open>Foundations\<close>

definition mbinop where [sgrp_struct_field_simps]: "mbinop = 1\<^sub>\<nat>"

locale \<Z>_sgrp_basis = \<Z>_vfsequence \<alpha> \<SS> + op: binop \<open>\<SS>\<lparr>\<A>\<rparr>\<close> \<open>\<SS>\<lparr>mbinop\<rparr>\<close>
  for \<alpha> \<SS> +
  assumes \<Z>_sgrp_length: "vcard \<SS> = 2\<^sub>\<nat>"

abbreviation sgrp_app :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>\<odot>\<^sub>\<circ>\<index>\<close> 70)
  where "sgrp_app \<SS> a b \<equiv> \<SS>\<lparr>mbinop\<rparr>\<lparr>a, b\<rparr>\<^sub>\<bullet>"
notation sgrp_app (infixl \<open>\<odot>\<^sub>\<circ>\<close> 70)

text\<open>Rules.\<close>

lemma \<Z>_sgrp_basisI[intro]:
  assumes "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 2\<^sub>\<nat>"
    and "binop (\<SS>\<lparr>\<A>\<rparr>) (\<SS>\<lparr>mbinop\<rparr>)"
  shows "\<Z>_sgrp_basis \<alpha> \<SS>"
  using assms unfolding \<Z>_sgrp_basis_def \<Z>_sgrp_basis_axioms_def by simp

lemma \<Z>_sgrp_basisD[dest]:
  assumes "\<Z>_sgrp_basis \<alpha> \<SS>"
  shows "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 2\<^sub>\<nat>"
    and "binop (\<SS>\<lparr>\<A>\<rparr>) (\<SS>\<lparr>mbinop\<rparr>)"
  using assms unfolding \<Z>_sgrp_basis_def \<Z>_sgrp_basis_axioms_def by auto

lemma \<Z>_sgrp_basisE[elim]:
  assumes "\<Z>_sgrp_basis \<alpha> \<SS>"
  shows "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 2\<^sub>\<nat>"
    and "binop (\<SS>\<lparr>\<A>\<rparr>) (\<SS>\<lparr>mbinop\<rparr>)"
  using assms unfolding \<Z>_sgrp_basis_def \<Z>_sgrp_basis_axioms_def by auto

subsubsection\<open>Simple semigroup\<close>

locale \<Z>_sgrp = \<Z>_sgrp_basis \<alpha> \<SS> for \<alpha> \<SS> +
  assumes \<Z>_sgrp_assoc:
    "\<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"

text\<open>Rules.\<close>

lemma \<Z>_sgrpI[intro]:
  assumes "\<Z>_sgrp_basis \<alpha> \<SS>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  shows "\<Z>_sgrp \<alpha> \<SS>"
  using assms unfolding \<Z>_sgrp_def \<Z>_sgrp_axioms_def by simp

lemma \<Z>_sgrpD[dest]:
  assumes "\<Z>_sgrp \<alpha> \<SS>"
  shows "\<Z>_sgrp_basis \<alpha> \<SS>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  using assms unfolding \<Z>_sgrp_def \<Z>_sgrp_axioms_def by simp_all

lemma \<Z>_sgrpE[elim]:
  assumes "\<Z>_sgrp \<alpha> \<SS>"
  obtains "\<Z>_sgrp_basis \<alpha> \<SS>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  using assms by auto

subsection\<open>Commutative semigroup\<close>

locale \<Z>_csgrp = \<Z>_sgrp \<alpha> \<SS> for \<alpha> \<SS> +
  assumes \<Z>_csgrp_commutative:
    "\<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow> a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b = b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> a"

text\<open>Rules.\<close>

lemma \<Z>_csgrpI[intro]:
  assumes "\<Z>_sgrp \<alpha> \<SS>"
    and "\<And>a b. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow> a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b = b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> a"
  shows "\<Z>_csgrp \<alpha> \<SS>"
  using assms unfolding \<Z>_csgrp_def \<Z>_csgrp_axioms_def by simp

lemma \<Z>_csgrpD[dest]:
  assumes "\<Z>_csgrp \<alpha> \<SS>"
  shows "\<Z>_sgrp \<alpha> \<SS>"
    and "\<And>a b. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow> a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b = b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> a"
  using assms unfolding \<Z>_csgrp_def \<Z>_csgrp_axioms_def by simp_all

lemma \<Z>_csgrpE[elim]:
  assumes "\<Z>_csgrp \<alpha> \<SS>"
  obtains "\<Z>_sgrp \<alpha> \<SS>"
    and "\<And>a b. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow> a \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b = b \<odot>\<^sub>\<circ>\<^bsub>\<SS>\<^esub> a"
  using assms by auto

subsection\<open>Semiring\<close>

subsubsection\<open>Foundations\<close>

definition vplus :: V where [sgrp_struct_field_simps]: "vplus = 1\<^sub>\<nat>"
definition vmult :: V where [sgrp_struct_field_simps]: "vmult = 2\<^sub>\<nat>"

abbreviation vplus_app :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>+\<^sub>\<circ>\<index>\<close> 65)
  where "a +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b \<equiv> \<SS>\<lparr>vplus\<rparr>\<lparr>a,b\<rparr>\<^sub>\<bullet>"
notation vplus_app (infixl \<open>+\<^sub>\<circ>\<index>\<close> 65)

abbreviation vmult_app :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>*\<^sub>\<circ>\<index>\<close> 70)
  where "a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b \<equiv> \<SS>\<lparr>vmult\<rparr>\<lparr>a,b\<rparr>\<^sub>\<bullet>"
notation vmult_app (infixl \<open>*\<^sub>\<circ>\<index>\<close> 70)

subsubsection\<open>Simple semiring\<close>

locale \<Z>_srng = \<Z>_vfsequence \<alpha> \<SS> for \<alpha> \<SS> +
  assumes \<Z>_srng_length: "vcard \<SS> = 3\<^sub>\<nat>"
    and \<Z>_srng_\<Z>_csgrp_vplus: "\<Z>_csgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>"
    and \<Z>_srng_\<Z>_sgrp_vmult: "\<Z>_sgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>"
    and \<Z>_srng_distrib_right:
      "\<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
        (a +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
    and \<Z>_srng_distrib_left:
      "\<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
        a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
begin

sublocale vplus: \<Z>_csgrp \<alpha> \<open>[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<close>
  rewrites "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<SS>\<lparr>\<A>\<rparr>"
    and "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<lparr>mbinop\<rparr> = \<SS>\<lparr>vplus\<rparr>"
    and "sgrp_app [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ> = vplus_app \<SS>"
proof(rule \<Z>_srng_\<Z>_csgrp_vplus)
  show "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<SS>\<lparr>\<A>\<rparr>"
    and [simp]: "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<lparr>mbinop\<rparr> = \<SS>\<lparr>vplus\<rparr>"
    by (auto simp: \<A>_def mbinop_def nat_omega_simps)
  show "(\<odot>\<^sub>\<circ>\<^bsub>[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>\<^esub>) = (+\<^sub>\<circ>\<^bsub>\<SS>\<^esub>)" by simp
qed

sublocale vmult: \<Z>_sgrp \<alpha> \<open>[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<close>
  rewrites "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<SS>\<lparr>\<A>\<rparr>"
    and "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<lparr>mbinop\<rparr> = \<SS>\<lparr>vmult\<rparr>"
    and "sgrp_app [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ> = vmult_app \<SS>"
proof(rule \<Z>_srng_\<Z>_sgrp_vmult)
  show "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<SS>\<lparr>\<A>\<rparr>"
    and [simp]: "[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<lparr>mbinop\<rparr> = \<SS>\<lparr>vmult\<rparr>"
    by (auto simp: \<A>_def mbinop_def nat_omega_simps)
  show "(\<odot>\<^sub>\<circ>\<^bsub>[\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>\<^esub>) = (*\<^sub>\<circ>\<^bsub>\<SS>\<^esub>)" by simp
qed

end

text\<open>Rules.\<close>

lemma \<Z>_srngI[intro]:
  assumes "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 3\<^sub>\<nat>"
    and "\<Z>_csgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>"
    and "\<Z>_sgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  shows "\<Z>_srng \<alpha> \<SS>"
  using assms unfolding \<Z>_srng_def \<Z>_srng_axioms_def by simp

lemma \<Z>_srngD[dest]:
  assumes "\<Z>_srng \<alpha> \<SS>"
  shows "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 3\<^sub>\<nat>"
    and "\<Z>_csgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>"
    and "\<Z>_sgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  using assms unfolding \<Z>_srng_def \<Z>_srng_axioms_def by simp_all

lemma \<Z>_srngE[elim]:
  assumes "\<Z>_srng \<alpha> \<SS>"
  obtains "\<Z>_vfsequence \<alpha> \<SS>"
    and "vcard \<SS> = 3\<^sub>\<nat>"
    and "\<Z>_csgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vplus\<rparr>]\<^sub>\<circ>"
    and "\<Z>_sgrp \<alpha> [\<SS>\<lparr>\<A>\<rparr>, \<SS>\<lparr>vmult\<rparr>]\<^sub>\<circ>"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      (a +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
    and "\<And>a b c. \<lbrakk> a \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; b \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr>; c \<in>\<^sub>\<circ> \<SS>\<lparr>\<A>\<rparr> \<rbrakk> \<Longrightarrow>
      a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (b +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c) = (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> b) +\<^sub>\<circ>\<^bsub>\<SS>\<^esub> (a *\<^sub>\<circ>\<^bsub>\<SS>\<^esub> c)"
  using assms unfolding \<Z>_srng_def \<Z>_srng_axioms_def by auto

subsection\<open>Integer numbers form a semiring\<close>

definition vint_struct :: V (\<open>\<SS>\<^sub>\<int>\<close>)
  where "vint_struct = [\<int>\<^sub>\<circ>, vint_plus, vint_mult]\<^sub>\<circ>"

named_theorems vint_struct_simps

lemma vint_struct_\<A>[vint_struct_simps]: "\<SS>\<^sub>\<int>\<lparr>\<A>\<rparr> = \<int>\<^sub>\<circ>"
  unfolding vint_struct_def by (auto simp: sgrp_struct_field_simps)

lemma vint_struct_vplus[vint_struct_simps]: "\<SS>\<^sub>\<int>\<lparr>vplus\<rparr> = vint_plus"
  unfolding vint_struct_def
  by (simp add: sgrp_struct_field_simps nat_omega_simps)

lemma vint_struct_vmult[vint_struct_simps]: "\<SS>\<^sub>\<int>\<lparr>vmult\<rparr> = vint_mult"
  unfolding vint_struct_def
  by (simp add: sgrp_struct_field_simps nat_omega_simps)

context \<Z>
begin

lemma \<Z>_srng_vint: "\<Z>_srng \<alpha> \<SS>\<^sub>\<int>"
proof(intro \<Z>_srngI, unfold vint_struct_simps)

  interpret \<SS>: vfsequence \<open>\<SS>\<^sub>\<int>\<close> unfolding vint_struct_def by simp

  show vint_struct: "\<Z>_vfsequence \<alpha> \<SS>\<^sub>\<int>"
  proof(intro \<Z>_vfsequenceI)
    show "vfsequence \<SS>\<^sub>\<int>" unfolding vint_struct_def by simp
    show "\<R>\<^sub>\<circ> \<SS>\<^sub>\<int> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    proof(intro vsubsetI)
      fix x assume "x \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> \<SS>\<^sub>\<int>"
      then consider \<open>x = \<int>\<^sub>\<circ>\<close> | \<open>x = vint_plus\<close> | \<open>x = vint_mult\<close>
        unfolding vint_struct_def by fastforce
      then show "x \<in>\<^sub>\<circ> Vset \<alpha>"
      proof cases
        case 1 with \<Z>_Vset_\<omega>2_vsubset_Vset vint_in_Vset_\<omega>2 show ?thesis by auto
      next
        case 2
        have "\<D>\<^sub>\<circ> vint_plus \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding vint_plus.nop_vdomain
        proof(rule Limit_vcpower_in_VsetI)
          from Axiom_of_Infinity show "2\<^sub>\<nat> \<in>\<^sub>\<circ> Vset \<alpha>" by auto
          from \<Z>_Vset_\<omega>2_vsubset_Vset show "\<int>\<^sub>\<circ> \<in>\<^sub>\<circ> Vset \<alpha>"
            by (auto intro: vint_in_Vset_\<omega>2)
        qed auto
        moreover from \<Z>_Vset_\<omega>2_vsubset_Vset have "\<R>\<^sub>\<circ> vint_plus \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding vint_plus.nop_onto_vrange by (auto intro: vint_in_Vset_\<omega>2)
        ultimately show "x \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding 2
          by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_plus_def)
      next
        case 3
        have "\<D>\<^sub>\<circ> vint_mult \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding vint_mult.nop_vdomain
        proof(rule Limit_vcpower_in_VsetI)
          from Axiom_of_Infinity show "2\<^sub>\<nat> \<in>\<^sub>\<circ> Vset \<alpha>" by auto
          from \<Z>_Vset_\<omega>2_vsubset_Vset show "\<int>\<^sub>\<circ> \<in>\<^sub>\<circ> Vset \<alpha>"
            by (auto intro: vint_in_Vset_\<omega>2)
        qed auto
        moreover from \<Z>_Vset_\<omega>2_vsubset_Vset Axiom_of_Infinity have
          "\<R>\<^sub>\<circ> vint_mult \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding vint_mult.nop_onto_vrange by (auto intro: vint_in_Vset_\<omega>2)
        ultimately show "x \<in>\<^sub>\<circ> Vset \<alpha>"
          unfolding 3
          by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_mult_def)
      qed
    qed
  qed (simp add: \<Z>_axioms)

  interpret vint_struct: \<Z>_vfsequence \<alpha> \<open>\<SS>\<^sub>\<int>\<close> by (rule vint_struct)

  show "vcard \<SS>\<^sub>\<int> = 3\<^sub>\<nat>"
    unfolding vint_struct_def by (simp add: nat_omega_simps)

  have [vint_struct_simps]:
    "[\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<int>\<^sub>\<circ>" "[\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ>\<lparr>mbinop\<rparr> = vint_plus"
    "[\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ>\<lparr>\<A>\<rparr> = \<int>\<^sub>\<circ>" "[\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ>\<lparr>mbinop\<rparr> = vint_mult"
    by (auto simp: sgrp_struct_field_simps nat_omega_simps)

  have [vint_struct_simps]:
    "sgrp_app [\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ> = (+\<^sub>\<int>)"
    "sgrp_app [\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ> = (*\<^sub>\<int>)"
    unfolding vint_struct_simps by simp_all

  show "\<Z>_csgrp \<alpha> [\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ>"
  proof(intro \<Z>_csgrpI, unfold vint_struct_simps)
    show "\<Z>_sgrp \<alpha> [\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ>"
    proof(intro \<Z>_sgrpI \<Z>_sgrp_basisI, unfold vint_struct_simps)
      show "\<Z>_vfsequence \<alpha> [\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ>"
      proof(intro \<Z>_vfsequenceI)
        show "\<R>\<^sub>\<circ> [\<int>\<^sub>\<circ>, vint_plus]\<^sub>\<circ> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
        proof(intro vfsequence_vrange_vconsI)
          from \<Z>_Vset_\<omega>2_vsubset_Vset show [simp]: "\<int>\<^sub>\<circ> \<in>\<^sub>\<circ> Vset \<alpha>"
            by (auto intro: vint_in_Vset_\<omega>2)
          show "vint_plus \<in>\<^sub>\<circ> Vset \<alpha>"
          proof(rule vbrelation.vbrelation_Limit_in_VsetI)
            from Axiom_of_Infinity show "\<D>\<^sub>\<circ> vint_plus \<in>\<^sub>\<circ> Vset \<alpha>"
              unfolding vint_plus.nop_vdomain
              by (intro Limit_vcpower_in_VsetI) auto
            from Axiom_of_Infinity show "\<R>\<^sub>\<circ> vint_plus \<in>\<^sub>\<circ> Vset \<alpha>"
              unfolding vint_plus.nop_onto_vrange by auto
          qed (simp_all add: vint_plus_def)
        qed simp_all
      qed (simp_all add: \<Z>_axioms)
    qed
      (
         auto simp:
          nat_omega_simps
          vint_plus.binop_axioms
          vint_assoc_law_addition
      )
  qed (simp add: vint_commutative_law_addition)

  show "\<Z>_sgrp \<alpha> [\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ>"
  proof
    (
      intro \<Z>_sgrpI \<Z>_sgrp_basisI;
      (unfold vint_struct_simps | tactic\<open>all_tac\<close>)
    )
    show "\<Z>_vfsequence \<alpha> [\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ>"
    proof(intro \<Z>_vfsequenceI; (unfold vint_struct_simps | tactic\<open>all_tac\<close>))
      from \<Z>_axioms show "\<Z> \<alpha>" by simp
      show "\<R>\<^sub>\<circ> [\<int>\<^sub>\<circ>, vint_mult]\<^sub>\<circ> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
      proof(intro vfsequence_vrange_vconsI)
        from \<Z>_Vset_\<omega>2_vsubset_Vset show [simp]: "\<int>\<^sub>\<circ> \<in>\<^sub>\<circ> Vset \<alpha>"
          by (auto intro: vint_in_Vset_\<omega>2)
        show "vint_mult \<in>\<^sub>\<circ> Vset \<alpha>"
        proof(rule vbrelation.vbrelation_Limit_in_VsetI)
          from Axiom_of_Infinity show "\<D>\<^sub>\<circ> vint_mult \<in>\<^sub>\<circ> Vset \<alpha>"
            unfolding vint_mult.nop_vdomain
            by (intro Limit_vcpower_in_VsetI) auto
          from Axiom_of_Infinity show "\<R>\<^sub>\<circ> vint_mult \<in>\<^sub>\<circ> Vset \<alpha>"
            unfolding vint_mult.nop_onto_vrange by auto
        qed (simp_all add: vint_mult_def)
      qed simp_all
    qed auto
  qed
    (
      auto simp:
        nat_omega_simps
        vint_mult.binop_axioms
        vint_assoc_law_multiplication
    )

qed
  (
    auto simp:
      vint_commutative_law_multiplication
      vint_plus_closed
      vint_distributive_law
  )

text\<open>Interpretation.\<close>

interpretation vint: \<Z>_srng \<alpha> \<open>\<SS>\<^sub>\<int>\<close>
  rewrites "\<SS>\<^sub>\<int>\<lparr>\<A>\<rparr> = \<int>\<^sub>\<circ>"
    and "\<SS>\<^sub>\<int>\<lparr>vplus\<rparr> = vint_plus"
    and "\<SS>\<^sub>\<int>\<lparr>vmult\<rparr> = vint_mult"
    and "vplus_app (\<SS>\<^sub>\<int>) = vint_plus_app"
    and "vmult_app (\<SS>\<^sub>\<int>) = vint_mult_app"
  unfolding vint_struct_simps by (rule \<Z>_srng_vint) simp_all

thm vint.vmult.\<Z>_sgrp_assoc
thm vint.vplus.\<Z>_sgrp_assoc
thm vint.\<Z>_srng_distrib_left

end

text\<open>\newpage\<close>

end


(*
    Title:      Gram_Schmidt_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Gram Schmidt over IArrays\<close>

theory Gram_Schmidt_IArrays
imports
  QR_Decomposition
  Matrix_To_IArray_QR
begin

subsection\<open>Some previous definitions, lemmas and instantiations about iarrays\<close>

definition iarray_of_iarray_to_list_of_list :: "'a iarray iarray => 'a list list"
  where "iarray_of_iarray_to_list_of_list A = map IArray.list_of (map ((!!) A) [0..<IArray.length A])"

instantiation iarray :: (scaleR) scaleR
begin
definition "scaleR_iarray k A = IArray.of_fun (\<lambda>i. k *\<^sub>R (A !! i)) (IArray.length A)"
instance proof qed
end

instantiation iarray :: (times) times
begin
definition "times_iarray A B = IArray.of_fun (\<lambda>i. A!!i * B !! i) (IArray.length A)"
instance proof qed
end

lemma plus_iarray_component:
  assumes iA: "i<IArray.length A"
  and iB: "i<IArray.length B"
  shows "(A+B) !! i = A!!i + B!!i"
proof (unfold plus_iarray_def Let_def )
  have "IArray.of_fun
    (\<lambda>a. IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! a +
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! a)
    (max (IArray.length A) (IArray.length B)) !!
    i = IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! i +
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! i"
    by (rule of_fun_nth, metis iB less_max_iff_disj)
  also have "...= (\<lambda>a. if a < IArray.length A then A !! a else 0) i +
    (\<lambda>a. if a < IArray.length B then B !! a else 0) i"
    using of_fun_nth[of i "(max (IArray.length A) (IArray.length B))"] using iB by simp
  also have "...= A!!i + B !! i" using iA iB by simp
  finally show "IArray.of_fun
    (\<lambda>a. IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! a +
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! a)
    (max (IArray.length A) (IArray.length B)) !!
    i =
    A !! i + B !! i" .
qed

lemma minus_iarray_component:
  assumes iA: "i<IArray.length A"
  and iB: "i<IArray.length B"
  shows "(A-B) !! i = A!!i - B!!i"
proof (unfold minus_iarray_def Let_def )
  have "IArray.of_fun
    (\<lambda>a. IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! a -
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! a)
    (max (IArray.length A) (IArray.length B)) !!
    i = IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! i -
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! i"
    by (rule of_fun_nth, metis iB less_max_iff_disj)
  also have "...= (\<lambda>a. if a < IArray.length A then A !! a else 0) i -
    (\<lambda>a. if a < IArray.length B then B !! a else 0) i"
    using of_fun_nth[of i "(max (IArray.length A) (IArray.length B))"] using iB by simp
  also have "...= A!!i - B !! i" using iA iB by simp
  finally show "IArray.of_fun
    (\<lambda>a. IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (max (IArray.length A) (IArray.length B)) !! a -
    IArray.of_fun (\<lambda>a. if a < IArray.length B then B !! a else 0) (max (IArray.length A) (IArray.length B)) !! a)
    (max (IArray.length A) (IArray.length B)) !! i = A !! i - B !! i" .
qed

lemma length_plus_iarray:
  "IArray.length (A+B)=max (IArray.length A) (IArray.length B)"
  unfolding plus_iarray_def Let_def by auto

lemma length_sum_iarray:
  assumes "finite S" and "S\<noteq>{}"
  shows "IArray.length (sum f S) = Max {IArray.length (f x)| x. x \<in> S}"
  using assms
proof (induct S,simp)
  case (insert x F)
    show?case
proof (cases "F={}")
  case True show ?thesis unfolding True by auto
next
  case False
  have rw: "IArray.length (sum f F) = Max {IArray.length (f x) |x. x \<in> F}"
    by (rule insert.hyps, simp add: False)
  have set_rw: "(insert (IArray.length (f x)) {IArray.length (f x) |x. x \<in> F}) = {IArray.length (f a) |a. a \<in> insert x F}"
    by auto
  have "IArray.length (sum f (insert x F)) = IArray.length (f x + sum f F)"
    by (metis insert.hyps(1) insert.hyps(2) sum_clauses(2))
  also have "... = max (IArray.length (f x)) (IArray.length (sum f F))"
    unfolding length_plus_iarray ..
  also have "... = max (IArray.length (f x)) (Max {IArray.length (f a) |a. a \<in> F})" unfolding rw by simp
  also have "... =  Max (insert (IArray.length (f x)) {IArray.length (f a) |a. a \<in> F})"
  proof(rule Max_insert[symmetric])
    show "finite {IArray.length (f x) |x. x \<in> F}" using insert.hyps(1) by auto
    show "{IArray.length (f x) |x. x \<in> F} \<noteq> {}" by (metis (lifting, mono_tags) False empty_Collect_eq ex_in_conv)
  qed
  also have "...=  Max {IArray.length (f a) |a. a \<in> insert x F}" unfolding set_rw ..
  finally show ?thesis .
  qed
qed

lemma sum_component_iarray:
  assumes a: "\<forall>x\<in>S. i<IArray.length (f x)"
  and f: "finite S"
  and S: "S\<noteq>{}" \<comment> \<open>If S is empty, then the sum will return the empty
  iarray and it makes no sense to access the component i\<close>
  shows "sum f S !! i = (\<Sum>x\<in>S. f x !! i)"
  using f a S
proof (induct S, simp)
  case (insert x F)
  have finite_F: "finite F" by (metis insert.hyps(1))
  show ?case
  proof (cases "F={}")
    case True
    have "sum f (insert x F) !! i = f x !! i" unfolding True by auto
    also have "... = (\<Sum>x\<in>insert x F. f x !! i)" unfolding True by auto
    finally show ?thesis .
  next
    case False
    have hyp: "(sum f F !! i)=(\<Sum>x\<in>F. f x !! i)"
    proof  (rule insert.hyps)
      show "\<forall>x\<in>F. i < IArray.length (f x)" by (metis insert.prems(1) insertCI)
      show "F \<noteq> {}" using False .
    qed
    have "sum f (insert x F) !! i = (f x + sum f F) !! i"
      by (metis insert.hyps(1) insert.hyps(2) sum_clauses(2))
    also have "... = (f x) !! i + (sum f F !! i)"
    proof (rule plus_iarray_component)
      obtain a where a: "a\<in>F" using False by auto
      have finite_C: "finite {IArray.length (f x) |x. x \<in> F}" using finite_F by auto
      have not_empty_C: "{IArray.length (f x) |x. x \<in> F} \<noteq>{}" using False by simp
      show "i < IArray.length (f x)" by (metis insert.prems(1) insertI1)
      show "i < IArray.length (sum f F)"
        unfolding length_sum_iarray[OF finite_F False]
        unfolding Max_gr_iff[OF finite_C not_empty_C]
      proof (rule bexI[of _ "IArray.length (f a)"])
        show "i < IArray.length (f a)" using insert.prems(1) a by auto
        show "IArray.length (f a) \<in> {IArray.length (f x) |x. x \<in> F}" using a by auto
      qed
    qed
    also have "...= (f x) !! i + (\<Sum>x\<in>F. f x !! i)" unfolding hyp ..
    also have "...= (\<Sum>x\<in>insert x F. f x !! i)"
      by (metis (mono_tags) insert.hyps(1) insert.hyps(2) sum_clauses(2))
    finally show "sum f (insert x F) !! i = (\<Sum>x\<in>insert x F. f x !! i)" .
  qed
qed

lemma length_zero_iarray: "IArray.length 0 = 0"
  unfolding zero_iarray_def by simp

lemma minus_zero_iarray:
  fixes A::"'a::{group_add} iarray"
  shows "A - 0 = A"
proof (unfold iarray_exhaust2 list_eq_iff_nth_eq, auto, unfold IArray.length_def[symmetric] IArray.sub_def[symmetric])
  have max_eq: "(max (IArray.length A) (IArray.length 0))= IArray.length A"
    unfolding zero_iarray_def by auto
  show length_eq: "IArray.length (A - 0) = IArray.length A"
    unfolding minus_iarray_def Let_def unfolding max_eq by auto
  fix i assume i: "i < IArray.length (A - 0)"
  hence i2: "i< (IArray.length A)" unfolding length_eq .
  have "A - 0 = IArray.of_fun
    (\<lambda>a. IArray.of_fun (\<lambda>a. if a < IArray.length A then A !! a else 0) (IArray.length A) !! a -
    IArray.of_fun (\<lambda>a. if a < IArray.length (0::'a iarray) then 0 !! a else 0) (IArray.length A) !! a)
    (IArray.length A)"
    unfolding minus_iarray_def Let_def unfolding max_eq ..
  also have "... !! i = A !! i" unfolding of_fun_nth[OF i2] length_zero_iarray using i2 by auto
  finally show "(A - 0) !! i = A !! i" .
qed

subsection\<open>Inner mult over real iarrays\<close>

definition inner_iarray :: "real iarray => real iarray => real"  (infixl "\<bullet>i" 70)
  where "inner_iarray A B = sum (\<lambda>n. A !! n * B !! n) {0..<IArray.length A}"

lemma vec_to_iarray_inner:
  "a \<bullet> b = vec_to_iarray a \<bullet>i vec_to_iarray b"
proof (unfold inner_iarray_def inner_vec_def, auto, unfold IArray.sub_def[symmetric] IArray.length_def[symmetric])
  have set_rw: "{0..<IArray.length (vec_to_iarray a)}  = (to_nat)`(UNIV::'a set)"
    unfolding vec_to_iarray_def
    using to_nat_less_card using bij_to_nat[where ?'a='a]
    unfolding bij_betw_def by auto
  have inj: "inj_on (to_nat::'a=>nat) (UNIV::'a set)"
    by (metis strict_mono_imp_inj_on strict_mono_to_nat)
  have "(\<Sum>n = 0..<IArray.length (vec_to_iarray a). vec_to_iarray a !! n * vec_to_iarray b !! n)
    = (\<Sum>n\<in>range (to_nat::'a=>nat). vec_to_iarray a !! n * vec_to_iarray b !! n)"
    unfolding set_rw ..
  also have "... = (\<Sum>x\<in>(UNIV::'a set). vec_to_iarray a !! to_nat x * vec_to_iarray b !! to_nat x)"
    unfolding sum.reindex[OF inj] o_def ..
  also have "...= (\<Sum>x\<in>UNIV. a $ x * b $ x)" unfolding vec_to_iarray_nth' ..
  finally show "(\<Sum>i\<in>UNIV. a $ i * b $ i)
    = (\<Sum>n = 0..<IArray.length (vec_to_iarray a). vec_to_iarray a !! n * vec_to_iarray b !! n)" ..
qed

lemma vec_to_iarray_scaleR:
  "vec_to_iarray (a *\<^sub>R x) = a *\<^sub>R (vec_to_iarray x)"
  unfolding scaleR_vec_def scaleR_iarray_def vec_to_iarray_def by auto

subsection\<open>Gram Schmidt over IArrays\<close>

definition "Gram_Schmidt_column_k_iarrays A k
  = tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>a b. (if b = k
  then (column_iarray b A - sum (\<lambda>x. (((column_iarray b A) \<bullet>i x) / (x \<bullet>i x)) *\<^sub>R x)
  (set (List.map (\<lambda>n. column_iarray n A) [0..<b])))
  else (column_iarray b A)) !! a)"

definition "Gram_Schmidt_upt_k_iarrays A k = List.foldl Gram_Schmidt_column_k_iarrays A [0..<(Suc k)]"
definition "Gram_Schmidt_matrix_iarrays A = Gram_Schmidt_upt_k_iarrays A (ncols_iarray A - 1)"

lemma matrix_to_iarray_Gram_Schmidt_column_k:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  shows "matrix_to_iarray (Gram_Schmidt_column_k A k) = Gram_Schmidt_column_k_iarrays (matrix_to_iarray A) k"
proof (unfold iarray_exhaust2 list_eq_iff_nth_eq, rule conjI, auto, unfold IArray.sub_def[symmetric] IArray.length_def[symmetric])
  show "IArray.length (matrix_to_iarray (Gram_Schmidt_column_k A k)) = IArray.length (Gram_Schmidt_column_k_iarrays (matrix_to_iarray A) k)"
    unfolding matrix_to_iarray_def Gram_Schmidt_column_k_iarrays_def tabulate2_def unfolding nrows_iarray_def by auto
  fix i assume i: "i < IArray.length (matrix_to_iarray (Gram_Schmidt_column_k A k))"
  show "IArray.length (matrix_to_iarray (Gram_Schmidt_column_k A k) !! i)
    = IArray.length (Gram_Schmidt_column_k_iarrays (matrix_to_iarray A) k !! i)"
    unfolding matrix_to_iarray_def Gram_Schmidt_column_k_iarrays_def tabulate2_def
    unfolding nrows_iarray_def ncols_iarray_def o_def
  proof (auto)
    have f1: "i < card (UNIV::'rows set)"
      by (metis i length_eq_card_rows)
    have f2: "\<And>x\<^sub>5. IArray.list_of (vec_to_iarray x\<^sub>5)
      = List.map (\<lambda>uua. x\<^sub>5 $ (from_nat uua::'cols)::real) [0..<card (UNIV::'cols set)]"
      by (metis list_of.simps IArray.of_fun_def vec_to_iarray_def)
    thus "length (IArray.list_of (List.map (\<lambda>x. vec_to_iarray (Gram_Schmidt_column_k A k $ from_nat x)) [0..<card (UNIV::'rows set)] ! i))
    = length (IArray.list_of (List.map (\<lambda>i. IArray (List.map (\<lambda>b. IArray.list_of (if b = k then column_iarray b (IArray (List.map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<card (UNIV::'rows set)]))
    - (\<Sum>x\<in>set (List.map (\<lambda>n. column_iarray n (IArray (List.map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<card (UNIV::'rows set)]))) [0..< b]). (column_iarray b (IArray (List.map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<card (UNIV::'rows set)])) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x) else column_iarray b (IArray (List.map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<card (UNIV::'rows set)]))) ! i) [0..< length (IArray.list_of (vec_to_iarray (A $ from_nat 0)))])) [0..<card (UNIV::'rows set)] ! i))"
      using f1 by auto
  qed
next
  fix i ia
  assume i: "i < IArray.length (matrix_to_iarray (Gram_Schmidt_column_k A k))"
    and ia: "ia < IArray.length (matrix_to_iarray (Gram_Schmidt_column_k A k) !! i)"
  have i_nrows: "i<nrows A" using i unfolding matrix_to_iarray_def nrows_def by auto
  have ia_ncols: "ia<ncols A" using ia unfolding matrix_to_iarray_def o_def vec_to_iarray_def ncols_def
    by (auto, metis (no_types) Ex_list_of_length i_nrows length_map list_of.simps map_nth nrows_def nth_map)
  have i_nrows_iarray: "i<nrows_iarray (matrix_to_iarray A)" using i_nrows by (metis matrix_to_iarray_nrows)
  have ia_ncols_iarray: "ia<ncols_iarray (matrix_to_iarray A)" using ia_ncols by (metis matrix_to_iarray_ncols)
  show "matrix_to_iarray (Gram_Schmidt_column_k A k) !! i !! ia = Gram_Schmidt_column_k_iarrays (matrix_to_iarray A) k !! i !! ia"
    unfolding Gram_Schmidt_column_k_def Gram_Schmidt_column_k_iarrays_def
    unfolding matrix_to_iarray_nth[of _ "from_nat i::'rows" "from_nat ia::'cols",
      unfolded to_nat_from_nat_id[OF i_nrows[unfolded nrows_def]]
      to_nat_from_nat_id[OF ia_ncols[unfolded ncols_def]]]
    unfolding tabulate2_def
    unfolding of_fun_nth[OF i_nrows_iarray]
    unfolding of_fun_nth[OF ia_ncols_iarray]
  proof (unfold proj_onto_def proj_def[abs_def], auto, unfold IArray.sub_def[symmetric])
    have inj: "inj_on vec_to_iarray {column i A |i. i < from_nat k}" unfolding inj_on_def
      by (auto, metis vec_to_iarray_morph)
    have set_rw: "{column i A |i. i < from_nat k} = (\<lambda>n. column n A)` {0..<from_nat k}"
    proof (unfold image_def, auto)
      fix a::'cols assume a: "a < from_nat k"
      show "\<exists>x\<in>{0..<from_nat k}. column a A = column x A"
        by (rule bexI[of _ a], auto simp add: a least_mod_type)
    qed
    have set_rw2: "vec_to_iarray` {column i A |i. i < from_nat k}
      = (\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}"
    proof (unfold image_def, auto)
      fix a::'cols assume a: "a < from_nat k"
      show "\<exists>x\<in>{0..<k}. vec_to_iarray (column a A) = column_iarray x (matrix_to_iarray A)"
        by (rule bexI[of _ "to_nat a"], auto simp add:  a to_nat_le vec_to_iarray_column)
    next
      fix xa assume xa: "xa < k"
      have xa': "(from_nat xa::'cols) < from_nat k" by (rule from_nat_mono[OF xa k[unfolded ncols_def]])
      show "\<exists>x. (\<exists>i. x = column i A \<and> i < from_nat k) \<and> column_iarray xa (matrix_to_iarray A) =  vec_to_iarray x"
        apply (rule exI[of _ "column (from_nat xa) A"])
        apply auto apply (rule exI[of _ "from_nat xa"])
        apply (auto simp add: xa' vec_to_iarray_column)
        by (metis k order.strict_trans vec_to_iarray_column vec_to_iarray_column' xa)
    qed
    show "column (from_nat k) A $ from_nat i -
      (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x)) =
      (column_iarray k (matrix_to_iarray A) -
      (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x)) !! i"
    proof (cases "k=0")
      case True
      have set_rw_empty: "{column i A |i. i < from_nat k}={}"
        unfolding True from_nat_0 using least_mod_type not_le by auto
      have "column (from_nat k) A $ from_nat i -
        (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x
        * x $ from_nat i / (x \<bullet> x)) =
        column (from_nat k) A $ from_nat i - 0" unfolding set_rw_empty by simp
      also have "...= column (from_nat k) A $ from_nat i" by simp
      also have "...= (column_iarray k (matrix_to_iarray A) - 0) !! i"
        unfolding minus_zero_iarray
        unfolding vec_to_iarray_column'[OF k, symmetric]
        unfolding vec_to_iarray_nth[OF i_nrows[unfolded nrows_def]] ..
      also have "...= (column_iarray k (matrix_to_iarray A) -
        (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x))
        !! i" unfolding True by auto
      finally show ?thesis .
    next
      case False
      have "(\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x/ (x \<bullet>i x)) *\<^sub>R x) !! i =
        (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}.
        (( column_iarray k (matrix_to_iarray A) \<bullet>i x/ (x \<bullet>i x)) *\<^sub>R x) !! i)"
      proof (rule sum_component_iarray)
        show "\<forall>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. i < IArray.length ((column_iarray k (matrix_to_iarray A) \<bullet>i x/ (x \<bullet>i x)) *\<^sub>R x)"
        proof (unfold column_iarray_def, auto)
          fix x :: nat
          have "i < length (IArray.list_of (IArray (map (vec_to_iarray \<circ> ($) A \<circ> mod_type_class.from_nat) [0..<card (UNIV::'rows set)])))"
            by (metis i_nrows_iarray IArray.length_def matrix_to_iarray_def nrows_iarray_def)
          thus "i < length (IArray.list_of ((IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! k) [0..<length (IArray.list_of (matrix_to_iarray A))]) \<bullet>i IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! x) [0..<length (IArray.list_of (matrix_to_iarray A))]) / (IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! x) [0..<length (IArray.list_of (matrix_to_iarray A))]) \<bullet>i IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! x) [0..<length (IArray.list_of (matrix_to_iarray A))]))) *\<^sub>R IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! x) [0..<length (IArray.list_of (matrix_to_iarray A))])))"
            by (simp add: matrix_to_iarray_def scaleR_iarray_def)
        qed
        show "finite ((\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k})" by auto
        show "(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k} \<noteq> {}" using False by auto
      qed
      also have "... = (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}.
        (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x !! i)"
      proof (rule sum.cong)
        fix x assume "x \<in> (\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}"
        from this obtain n where x: "x = column_iarray n (matrix_to_iarray A)" and n: "n<k" by auto
        have n_ncols: "n<ncols A" by (metis k n order.strict_trans)
        have c_eq: "column_iarray k (matrix_to_iarray A) = vec_to_iarray (column (from_nat k::'cols) A)"
          by (metis k vec_to_iarray_column')
        show "((column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x) !! i
          = (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x !! i"
          unfolding x
          unfolding vec_to_iarray_column[symmetric, of "from_nat n::'cols",
            unfolded to_nat_from_nat_id[OF n_ncols[unfolded ncols_def]]]
          unfolding c_eq
          unfolding vec_to_iarray_inner[symmetric]
          unfolding vec_to_iarray_nth[OF i_nrows[unfolded nrows_def]]
          unfolding vector_scaleR_component[symmetric]
          unfolding vec_to_iarray_nth'[symmetric]
          unfolding to_nat_from_nat_id[OF i_nrows[unfolded nrows_def]]
          unfolding vec_to_iarray_scaleR ..
      qed (simp)
      also have "... =  (\<Sum>x\<in>vec_to_iarray ` {column i A |i. i < from_nat k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x !! i)"
        unfolding set_rw2[symmetric] ..
      also have "...=
        (\<Sum>x\<in>{column i A |i. i < from_nat k}. (column (from_nat k) A \<bullet> x / (x \<bullet> x)) *\<^sub>R vec_to_iarray x !! i)"
        unfolding sum.reindex[OF inj] o_def
        unfolding vec_to_iarray_column[of "from_nat k::'cols",symmetric,unfolded to_nat_from_nat_id[OF k[unfolded ncols_def]]]
        unfolding vec_to_iarray_inner[symmetric] ..
      also have "...
        = (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x))"
        unfolding vec_to_iarray_nth[OF i_nrows[unfolded nrows_def]] by auto
      finally have *: "(\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x) !! i
        = (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x))" .
      have "(column_iarray k (matrix_to_iarray A) -
        (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x)) !! i =
        (column_iarray k (matrix_to_iarray A) !! i -
        (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x) !! i)"
      proof (rule minus_iarray_component)
        have finite: "finite ((\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k})"
          using False by auto
        have not_empty: "(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k} \<noteq> {}"
          by (metis False atLeastLessThan_empty_iff2 empty_is_image neq0_conv)
        let ?C="{IArray.length ((column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x) |x. x \<in> (\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}}"
        have finite_C: "finite ?C" by auto
        have not_empty_C: "?C \<noteq> {}" using False by auto
        let ?x="(column_iarray 0 (matrix_to_iarray A))"
        let ?c="IArray.length ((column_iarray k (matrix_to_iarray A) \<bullet>i ?x / (?x \<bullet>i ?x)) *\<^sub>R ?x)"
        show "i < IArray.length (column_iarray k (matrix_to_iarray A))"
          unfolding column_iarray_def
          by (auto, metis i_nrows_iarray IArray.length_def nrows_iarray_def)
        show "i < IArray.length (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x)"
          unfolding length_sum_iarray[OF finite not_empty]
          unfolding Max_gr_iff[OF finite_C not_empty_C]
        proof (rule bexI[of _ "?c"])
          show "i < ?c"
          proof (unfold column_iarray_def, auto)
            have "i < card (UNIV::'rows set)"
              by (metis (no_types) i_nrows nrows_def)
            thus "i < length (IArray.list_of ((IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! k) [0..<length (IArray.list_of (matrix_to_iarray A))]) \<bullet>i IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! 0) [0..<length (IArray.list_of (matrix_to_iarray A))]) / (IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! 0) [0..<length (IArray.list_of (matrix_to_iarray A))]) \<bullet>i IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! 0) [0..<length (IArray.list_of (matrix_to_iarray A))]))) *\<^sub>R IArray (map (\<lambda>n. IArray.list_of (IArray.list_of (matrix_to_iarray A) ! n) ! 0) [0..<length (IArray.list_of (matrix_to_iarray A))])))"
              by (simp add: matrix_to_iarray_def scaleR_iarray_def)
          qed
          show "?c \<in> {IArray.length ((column_iarray k (matrix_to_iarray A) \<bullet>i x / (x \<bullet>i x)) *\<^sub>R x)
            |x. x \<in> (\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}}"
            using False by auto
        qed
      qed
      also have "... = column_iarray k (matrix_to_iarray A) !! i -
        (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x))"
        unfolding * ..
      also have "... = column (from_nat k) A $ from_nat i -
        (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x))"
        unfolding vec_to_iarray_column[of "from_nat k::'cols",symmetric,unfolded to_nat_from_nat_id[OF k[unfolded ncols_def]]]
        unfolding vec_to_iarray_nth[OF i_nrows[unfolded nrows_def]] ..
      finally show "column (from_nat k) A $ from_nat i -
        (\<Sum>x\<in>{column i A |i. i < from_nat k}. column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x)) =
        (column_iarray k (matrix_to_iarray A) -
        (\<Sum>x\<in>(\<lambda>n. column_iarray n (matrix_to_iarray A)) ` {0..<k}. (column_iarray k (matrix_to_iarray A) \<bullet>i  x/ (x \<bullet>i x)) *\<^sub>R x)) !! i"
        ..
    qed
    show "column (from_nat ia) A $ from_nat i = column_iarray ia (matrix_to_iarray A) !! i"
      unfolding vec_to_iarray_nth[symmetric, OF i_nrows[unfolded nrows_def]]
      unfolding vec_to_iarray_column'[symmetric, OF ia_ncols] ..
    assume ia_not_k: "ia \<noteq> k"
      and eq: "from_nat ia = (from_nat k::'cols)"
    have "ia=k" by (rule from_nat_eq_imp_eq[OF eq ia_ncols[unfolded ncols_def] k[unfolded ncols_def]])
    thus "column (from_nat k) A $ from_nat i
      - (\<Sum>x\<in>{column i A |i. i < from_nat k}.
      column (from_nat k) A \<bullet> x * x $ from_nat i / (x \<bullet> x))
      = column_iarray ia (matrix_to_iarray A) !! i"
      using ia_not_k by contradiction
  qed
qed

lemma matrix_to_iarray_Gram_Schmidt_upt_k:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  shows "matrix_to_iarray (Gram_Schmidt_upt_k A k) = Gram_Schmidt_upt_k_iarrays (matrix_to_iarray A) k"
  using k
proof (induct k)
  case 0
  show ?case unfolding Gram_Schmidt_upt_k_def Gram_Schmidt_upt_k_iarrays_def
    by (simp add: matrix_to_iarray_Gram_Schmidt_column_k[OF "0.prems"])
next
  case (Suc k)
  have k: "k<ncols (Gram_Schmidt_upt_k A k)" using Suc.prems unfolding ncols_def by simp
  have k2: "Suc k < ncols (Gram_Schmidt_upt_k A k)" using Suc.prems unfolding ncols_def .
  have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by simp
  have hyp: "matrix_to_iarray (Gram_Schmidt_upt_k A k) = Gram_Schmidt_upt_k_iarrays (matrix_to_iarray A) k"
    by (metis Suc.hyps Suc.prems Suc_lessD)
  show "matrix_to_iarray (Gram_Schmidt_upt_k A (Suc k)) = Gram_Schmidt_upt_k_iarrays (matrix_to_iarray A) (Suc k)"
    unfolding Gram_Schmidt_upt_k_def Gram_Schmidt_upt_k_iarrays_def
    unfolding list_rw
    unfolding foldl_append
    unfolding foldl.simps
    unfolding Gram_Schmidt_upt_k_def[symmetric] Gram_Schmidt_upt_k_iarrays_def[symmetric]
    unfolding hyp[symmetric]
    by (rule matrix_to_iarray_Gram_Schmidt_column_k[OF k2])
qed

lemma matrix_to_iarray_Gram_Schmidt_matrix[code_unfold]:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (Gram_Schmidt_matrix A) = Gram_Schmidt_matrix_iarrays (matrix_to_iarray A)"
  unfolding Gram_Schmidt_matrix_def Gram_Schmidt_matrix_iarrays_def
  unfolding matrix_to_iarray_ncols[symmetric]
  by (rule matrix_to_iarray_Gram_Schmidt_upt_k, simp add: ncols_def)

text\<open>Examples:\<close>

value"let A = list_of_list_to_matrix [[4,5],[8,1],[-1,5]]::real^2^3
  in iarray_of_iarray_to_list_of_list (matrix_to_iarray (Gram_Schmidt_matrix A))"

value "let A = IArray[IArray[4,5],IArray[8,1],IArray[-1,5]]
  in iarray_of_iarray_to_list_of_list (Gram_Schmidt_matrix_iarrays A)"

end


(*
 * Rational Preference Relations (RPRs).
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced July 2006.
 * License: BSD
 *)

(*<*)
theory RPRs

imports FSext

begin
(*>*)

(* **************************************** *)

section\<open>Preliminaries\<close>

text\<open>

The auxiliary concepts defined here are standard \cite{Routley:79, Sen:70a,
Taylor:2005}. Throughout we make use of a fixed set @{term "A"} of
alternatives, drawn from some arbitrary type @{typ "'a"} of suitable
size. Taylor \cite{Taylor:2005} terms this set an \emph{agenda}. Similarly
we have a type @{typ "'i"} of individuals and a population @{term "Is"}.

\<close>

(* **************************************** *)

subsection\<open>Rational Preference Relations (RPRs)\<close>

text\<open>

Definitions for rational preference relations (RPRs), which represent
indifference or strict preference amongst some set of alternatives.  These
are also called \emph{weak orders} or (ambiguously) \emph{ballots}.

Unfortunately Isabelle's standard ordering operators and lemmas are
typeclass-based, and as introducing new types is painful and we need several
orders per type, we need to repeat some things.

\<close>

type_synonym 'a RPR = "('a * 'a) set"

abbreviation rpr_eq_syntax :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<preceq> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<preceq> y == (x, y) \<in> r"

definition indifferent_pref :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<approx> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<approx> y \<equiv> (x \<^bsub>r\<^esub>\<preceq> y \<and> y \<^bsub>r\<^esub>\<preceq> x)"

lemma indifferent_prefI[intro]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<preceq> x \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<approx> y"
  unfolding indifferent_pref_def by simp

definition strict_pref :: "'a \<Rightarrow> 'a RPR \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<^bsub>_\<^esub>\<prec> _" [50, 1000, 51] 50) where
  "x \<^bsub>r\<^esub>\<prec> y \<equiv> (x \<^bsub>r\<^esub>\<preceq> y \<and> \<not>(y \<^bsub>r\<^esub>\<preceq> x))"

lemma strict_pref_def_irrefl[simp]: "\<not> (x \<^bsub>r\<^esub>\<prec> x)" unfolding strict_pref_def by blast

lemma strict_prefI[intro]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; \<not>(y \<^bsub>r\<^esub>\<preceq> x) \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> y"
  unfolding strict_pref_def by simp

text\<open>

Traditionally, @{term "x \<^bsub>r\<^esub>\<preceq> y"} would be written $x\ R\ y$,
@{term "x \<^bsub>r\<^esub>\<approx> y"} as $x\ I\ y$ and @{term "x
\<^bsub>r\<^esub>\<prec> y"} as $x\ P\ y$, where the relation $r$ is implicit, and
profiles are indexed by subscripting.

\<close>

text\<open>

\emph{Complete} means that every pair of distinct alternatives is
ranked. The "distinct" part is a matter of taste, as it makes sense to
regard an alternative as as good as itself. Here I take reflexivity
separately.

\<close>

definition complete :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "complete A r \<equiv> (\<forall>x \<in> A. \<forall>y \<in> A - {x}. x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x)"

lemma completeI[intro]:
  "(\<And>x y. \<lbrakk> x \<in> A; y \<in> A; x \<noteq> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x) \<Longrightarrow> complete A r"
  unfolding complete_def by auto

lemma completeD[dest]:
  "\<lbrakk> complete A r; x \<in> A; y \<in> A; x \<noteq> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def by auto

lemma complete_less_not: "\<lbrakk> complete A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def strict_pref_def by auto

lemma complete_indiff_not: "\<lbrakk> complete A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<approx> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> y \<or> y \<^bsub>r\<^esub>\<prec> x"
  unfolding complete_def indifferent_pref_def strict_pref_def by auto

lemma complete_exh:
  assumes "complete A r"
      and "hasw [x,y] A"
  obtains (xPy) "x \<^bsub>r\<^esub>\<prec> y"
    | (yPx) "y \<^bsub>r\<^esub>\<prec> x"
    | (xIy) "x \<^bsub>r\<^esub>\<approx> y"
  using assms unfolding complete_def strict_pref_def indifferent_pref_def by auto

text\<open>

Use the standard @{term "refl"}. Also define \emph{irreflexivity}
analogously to how @{term "refl"} is defined in the standard library.

\<close>

declare refl_onI[intro] refl_onD[dest]

lemma complete_refl_on:
  "\<lbrakk> complete A r; refl_on A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding complete_def by auto

definition irrefl :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "irrefl A r \<equiv> r \<subseteq> A \<times> A \<and> (\<forall>x \<in> A. \<not> x \<^bsub>r\<^esub>\<preceq> x)"

lemma irreflI[intro]: "\<lbrakk> r \<subseteq> A \<times> A; \<And>x. x \<in> A \<Longrightarrow> \<not> x \<^bsub>r\<^esub>\<preceq> x \<rbrakk> \<Longrightarrow> irrefl A r"
  unfolding irrefl_def by simp

lemma irreflD[dest]: "\<lbrakk> irrefl A r; (x, y) \<in> r \<rbrakk> \<Longrightarrow> hasw [x,y] A"
  unfolding irrefl_def by auto

lemma irreflD'[dest]:
  "\<lbrakk> irrefl A r; r \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x y. hasw [x,y] A \<and> (x, y) \<in> r"
  unfolding irrefl_def by auto

text\<open>Rational preference relations, also known as weak orders and (I
guess) complete pre-orders.\<close>

definition rpr :: "'a set \<Rightarrow> 'a RPR \<Rightarrow> bool" where
  "rpr A r \<equiv> complete A r \<and> refl_on A r \<and> trans r"

lemma rprI[intro]: "\<lbrakk> complete A r; refl_on A r; trans r \<rbrakk> \<Longrightarrow> rpr A r"
  unfolding rpr_def by simp

lemma rprD: "rpr A r \<Longrightarrow> complete A r \<and> refl_on A r \<and> trans r"
  unfolding rpr_def by simp

lemma rpr_in_set[dest]: "\<lbrakk> rpr A r; x \<^bsub>r\<^esub>\<preceq> y \<rbrakk> \<Longrightarrow> {x,y} \<subseteq> A"
  unfolding rpr_def refl_on_def by auto

lemma rpr_refl[dest]: "\<lbrakk> rpr A r; x \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by blast

lemma rpr_less_not: "\<lbrakk> rpr A r; hasw [x,y] A; \<not> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by (auto simp add: complete_less_not)

lemma rpr_less_imp_le[simp]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y"
  unfolding strict_pref_def by simp

lemma rpr_less_imp_neq[simp]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<noteq> y"
  unfolding strict_pref_def by blast

lemma rpr_less_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<prec> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_le_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<preceq> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> z"
  unfolding rpr_def trans_def by blast

lemma rpr_le_less_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<preceq> y; y \<^bsub>r\<^esub>\<prec> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_less_le_trans[trans]: "\<lbrakk> x \<^bsub>r\<^esub>\<prec> y; y \<^bsub>r\<^esub>\<preceq> z; rpr A r \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<prec> z"
  unfolding rpr_def strict_pref_def trans_def by blast

lemma rpr_complete: "\<lbrakk> rpr A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<^bsub>r\<^esub>\<preceq> y \<or> y \<^bsub>r\<^esub>\<preceq> x"
  unfolding rpr_def by (blast dest: complete_refl_on)

(* **************************************** *)

subsection\<open>Profiles\<close>

text \<open>A \emph{profile} (also termed a collection of \emph{ballots}) maps
each individual to an RPR for that individual.\<close>

type_synonym ('a, 'i) Profile = "'i \<Rightarrow> 'a RPR"

definition profile :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> bool" where
  "profile A Is P \<equiv> Is \<noteq> {} \<and> (\<forall>i \<in> Is. rpr A (P i))"

lemma profileI[intro]: "\<lbrakk> \<And>i. i \<in> Is \<Longrightarrow> rpr A (P i); Is \<noteq> {} \<rbrakk> \<Longrightarrow> profile A Is P"
  unfolding profile_def by simp

lemma profile_rprD[dest]: "\<lbrakk> profile A Is P; i \<in> Is \<rbrakk> \<Longrightarrow> rpr A (P i)"
  unfolding profile_def by simp

lemma profile_non_empty: "profile A Is P \<Longrightarrow> Is \<noteq> {}"
  unfolding profile_def by simp

(*<*)
end
(*>*)