           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CMS
imports Infra
begin

(*****************************************************************

         1. Metric space (MS)
         2. Complete metric space (CMS)
         3. Contracting map
         4. Banach Theorem

 *****************************************************************)

(*
axclass ms0 < type
consts
  distance    :: "'a::ms0 * 'a::ms0 => real"  (* Distance function *)
*)

class ms0 =
  fixes distance    :: "'a * 'a => real"  ("distance") (* Distance function *)

(**********************************************************
                    metric space (MS)
 **********************************************************)

(*  isabelle 2009-1
axclass
  ms < ms0
  positive_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). 0 <= distance(x,y)"
  diagonal_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). (distance(x,y) = 0) = (x = y)"
  symmetry_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). distance(x,y) = distance(y,x)"
  triangle_inequality_ms:
    "ALL (x::'a::ms0) (y::'a::ms0) (z::'a::ms0).
       distance(x,z) <= distance(x,y)+distance(y,z)"
*)

class ms = ms0 +
  assumes positive_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). 0 <= distance(x,y)"
  assumes diagonal_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). (distance(x,y) = 0) = (x = y)"
  assumes symmetry_ms           :
    "ALL (x::'a::ms0) (y::'a::ms0). distance(x,y) = distance(y,x)"
  assumes triangle_inequality_ms:
    "ALL (x::'a::ms0) (y::'a::ms0) (z::'a::ms0).
       distance(x,z) <= distance(x,y)+distance(y,z)"

(*
class ms = ms0 +
  assumes positive_ms           :
    "0 <= distance(x,y)"
  assumes diagonal_ms           :
    "(distance(x,y) = 0) = (x = y)"
  assumes symmetry_ms           :
    "distance(x,y) = distance(y,x)"
  assumes triangle_inequality_ms:
    "distance(x,z) <= distance(x,y)+distance(y,z)"
*)

declare positive_ms [simp]

(*
lemma all_positive_ms:
      "ALL (x::'a::ms) (y::'a::ms). 0 <= distance(x,y)"
by (simp add: positive_ms)

lemma all_diagonal_ms:
      "ALL (x::'a::ms) (y::'a::ms). (distance(x,y) = 0) = (x = y)"
by (simp add: diagonal_ms)

lemma all_symmetry_ms:
  "ALL (x::'a::ms) (y::'a::ms). distance(x,y) = distance(y,x)"
by (simp add: symmetry_ms)

lemma all_triangle_inequality_ms:
  "ALL (x::'a::ms) (y::'a::ms) (z::'a::ms).
   distance(x,z) <= distance(x,y)+distance(y,z)"
by (simp add: triangle_inequality_ms)
*)

(*------------------*
 | cauchy and limit |
 *------------------*)

definition
  cauchy     :: "'a::ms infinite_seq => bool"
  where
  cauchy_def :"cauchy xs == ALL delta::real.
               0 < delta --> (EX n. ALL i j.
                    ((n <= i & n <= j) --> (distance(xs i, xs j) < delta)))"

definition
  convergeTo :: "'a::ms infinite_seq => 'a::ms => bool"
                ("_ convergeTo _" [55,55] 55)
  where
  convergeTo_def :"xs convergeTo x == ALL eps::real. 0 < eps --> (EX n. ALL m.
                    n <= m --> distance(x, xs m) < eps)"

(*definition
  hasLimit   :: "'a::ms infinite_seq => bool"
  ...
*)

definition
  Limit      :: "'a::ms infinite_seq => 'a::ms"
  where
  Limit_def      :"Limit xs    == THE x. xs convergeTo x"

(*---------*
 | mapping |
 *---------*)
(* Isabelle 2013
consts
  non_expanding     :: "('a::ms => 'b::ms) => bool"
  contraction       :: "('a::ms => 'b::ms) => bool"
  contraction_alpha :: "('a::ms => 'b::ms) => real => bool"
  map_alpha         :: "('a::ms => 'b::ms) => real => bool"

defs
  non_expanding_def    :
     "non_expanding f == map_alpha f 1"
  contraction_def      :
     "contraction f == EX (alpha::real). contraction_alpha f alpha"
  contraction_alpha_def:
     "contraction_alpha f alpha == (alpha < 1 & map_alpha f alpha)"
  map_alpha_def:
     "map_alpha f alpha == (0 <= alpha &
              (ALL x y. distance(f x,f y) <= (alpha * distance(x,y))))"
*)

definition
  map_alpha         :: "('a::ms => 'b::ms) => real => bool"
  where
  map_alpha_def:
     "map_alpha f alpha == (0 <= alpha &
              (ALL x y. distance(f x,f y) <= (alpha * distance(x,y))))"

              definition
  non_expanding     :: "('a::ms => 'b::ms) => bool"
  where
  non_expanding_def    :
     "non_expanding f == map_alpha f 1"

definition
  contraction_alpha :: "('a::ms => 'b::ms) => real => bool"
  where
  contraction_alpha_def:
     "contraction_alpha f alpha == (alpha < 1 & map_alpha f alpha)"

definition
  contraction       :: "('a::ms => 'b::ms) => bool"
  where
  contraction_def      :
     "contraction f == EX (alpha::real). contraction_alpha f alpha"

(**********************************************************
                     small lemmas
 **********************************************************)

lemma same_pnt_zero[simp]: "distance((x::'a::ms),x)=0"
by (simp add: diagonal_ms)

lemma diff_pnt_pos_only_if:
  "0 < distance(x::'a::ms,y) ==> x ~= y"
apply (case_tac "x = y")
by (simp_all)

lemma diff_pnt_pos_if:
  "(x::'a::ms) ~= y ==> 0 < distance(x,y)"
apply (case_tac "distance (x, y) = 0")
apply (simp add: diagonal_ms)
by (simp add: less_le)

lemma diff_pnt_pos:
  "(0 < distance(x::'a::ms,y)) = (x ~= y)"
apply (rule iffI)
apply (simp add: diff_pnt_pos_only_if)
apply (simp add: diff_pnt_pos_if)
done

(**********************************************************
                         map
 **********************************************************)

(*** contraction_alpha ***)

lemma contraction_alpha_range:
  "contraction_alpha f alpha ==> 0 <= alpha & alpha < 1"
by (simp add: contraction_alpha_def map_alpha_def)

(*** contraction --> non expanding ***)

lemma contraction_non_expanding:
  "contraction f ==> non_expanding f"

apply (simp add: contraction_def contraction_alpha_def map_alpha_def
                 non_expanding_def)
apply (elim conjE exE)
apply (intro allI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)

apply (subgoal_tac "alpha * distance (x, y) <= 1 * distance (x, y)")
apply (simp)

by (rule mult_right_mono, simp_all)

(*** composition ***)
(* map_alpha *)

lemma compo_map_alpha:
   "[| map_alpha f alpha1 ; map_alpha g alpha2 |]
     ==> map_alpha (f o g) (alpha1 * alpha2)"
apply (simp add: map_alpha_def)
apply (elim conjE)
apply (insert mult_right_mono[of 0 alpha1 alpha2], simp)

apply (intro allI)
apply (drule_tac x="g x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="g y" in spec)
apply (drule_tac x="y" in spec)

apply (subgoal_tac
  "alpha1 * distance (g x, g y) <= alpha1 * alpha2 * distance (x, y)") (* ...1 *)
apply (simp)
      (* 1 *)
(* by (simp add: real_mult_assoc mult_left_mono)  isabelle 2011 *)
by (simp add: mult.assoc mult_left_mono)

lemma compo_contra_alpha:
   "[| contraction_alpha f alpha1 ; contraction_alpha g alpha2 |]
     ==> contraction_alpha (f o g) (alpha1 * alpha2)"
apply (simp add: contraction_alpha_def)
apply (simp add: compo_map_alpha)
apply (simp add: map_alpha_def)
apply (case_tac "alpha2 = 0", simp)
apply (insert real_mult_less_mono[of alpha1 "1::real" alpha2 "1::real"])
by (force)

lemma compo_non_expand_map_alpha:
   "[| non_expanding f ; map_alpha g alpha |]
     ==> map_alpha (f o g) alpha"
apply (simp add: non_expanding_def)
apply (insert compo_map_alpha[of f 1 g alpha])
by (simp)

lemma compo_map_alpha_non_expand:
   "[| map_alpha f alpha ; non_expanding g |]
     ==> map_alpha (f o g) alpha"
apply (simp add: non_expanding_def)
apply (insert compo_map_alpha[of f alpha g 1])
by (simp)

lemma compo_non_expand_contra_alpha:
   "[| non_expanding f ; contraction_alpha g alpha |]
     ==> contraction_alpha (f o g) alpha"
apply (simp add: contraction_alpha_def)
by (simp add: compo_non_expand_map_alpha)

lemma compo_contra_alpha_non_expand:
   "[| contraction_alpha f alpha ; non_expanding g |]
     ==> contraction_alpha (f o g) alpha"
apply (simp add: contraction_alpha_def)
by (simp add: compo_map_alpha_non_expand)

lemma compo_non_expand:
   "[| non_expanding f ; non_expanding g |]
     ==> non_expanding (f o g)"
apply (simp add: non_expanding_def)
apply (insert compo_map_alpha[of f 1 g 1])
by (simp)

(**********************************************************
                     convergeTo
 **********************************************************)

(*** The limit is unique ***)

lemma unique_convergence:
  "[| xs convergeTo x ; xs convergeTo y |] ==> x = y"

apply (case_tac "x = y")
apply (simp)

apply (simp add: convergeTo_def)

apply (drule_tac x="distance (x, y) /2" in spec)
apply (drule_tac x="distance (x, y) /2" in spec)
apply (simp add: diff_pnt_pos)
apply (elim exE)

apply (rename_tac n m)
apply (drule_tac x="max n m" in spec)
apply (drule_tac x="max n m" in spec)
apply (simp)
 (* apply (simp add: le_maxI1 le_maxI2)  Isabelle 2005 *)

apply (insert triangle_inequality_ms)
apply (drule_tac x="x" in spec)
apply (drule_tac x="xs (max n m)" in spec)
apply (drule_tac x="y" in spec)

apply (simp add: symmetry_ms)
done

(*** Convergence implies cauchy seq***)

lemma convergece_cauchy: "xs convergeTo x ==> cauchy xs"

apply (simp add: cauchy_def)
apply (intro allI impI)

apply (simp add: convergeTo_def)
apply (drule_tac x="delta/2" in spec)
apply (simp)
apply (erule exE)

apply (rule_tac x="n" in exI)
apply (intro allI impI)

apply (frule_tac x="i" in spec)
apply (drule_tac x="j" in spec)
apply (simp)

apply (insert triangle_inequality_ms)
apply (drule_tac x="xs i" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="xs j" in spec)
apply (simp add: symmetry_ms)
done

(**********************************************************
                Complete metric space (CMS)
 **********************************************************)

(*
isabelle2009-1

axclass
  cms < ms

  complete_ms: "ALL xs. cauchy xs --> (EX x. xs convergeTo x)"

*)

class cms = ms +
assumes complete_ms: "ALL (xs::(nat=>'a::ms)). cauchy xs --> (EX x. xs convergeTo x)"

(**********************************************************
                     CMS lemmas
 **********************************************************)

lemma convergeTo_to_Limit :
    "cauchy (xs::'a::cms infinite_seq)
       ==> (xs convergeTo x) = (x = Limit xs)"
apply (simp add: Limit_def)
apply (rule iffI)
apply (rule sym)
apply (rule the_equality)
apply (simp)
apply (simp add: unique_convergence)

apply (simp)
apply (insert complete_ms)
apply (drule_tac x="xs" in spec, simp)
apply (erule exE)
apply (rule theI[of "(%x. xs convergeTo x)"])
apply (simp)
apply (simp add: unique_convergence)
done

lemma Limit_to_convergeTo:
    "cauchy (xs::'a::cms infinite_seq)
       ==> (x = Limit xs) = (xs convergeTo x)"
by (simp add: convergeTo_to_Limit)

lemma Limit_to_convergeTo_sym:
    "cauchy (xs::'a::cms infinite_seq)
       ==> (Limit xs = x) = (xs convergeTo x)"
apply (simp add: convergeTo_to_Limit)
by (fast)

lemmas Limit_iff = Limit_to_convergeTo Limit_to_convergeTo_sym

lemma Limit_is:
  "cauchy (xs::'a::cms infinite_seq) ==> xs convergeTo Limit xs"
by (simp add: convergeTo_to_Limit)

(**********************************************************
                     Banach Theory
 **********************************************************)

(*** step 1 (cauchy) ***)

lemma Banach_lm_contraction:
  "[| contraction_alpha f alpha ; ALL i. xs (Suc i) = f(xs i) |]
    ==> distance(xs n, f(xs n)) <= alpha^n * distance(xs 0, f(xs 0))"
apply (induct_tac n)
apply (simp)
apply (simp)
apply (simp add: contraction_alpha_def map_alpha_def)
apply (elim conjE)
apply (drule_tac x="0" in spec)    (* for convenienec *)

apply (drule_tac x="xs n" in spec)
apply (drule_tac x="f (xs n)" in spec)

apply (subgoal_tac "alpha * distance (xs n, f (xs n))
                 <= alpha * (alpha ^ n * distance (xs 0, f (xs 0)))")
apply (simp)
apply (rule mult_left_mono)
by (simp_all)

lemma Banach_lm_triangle:
  "distance((xs::'a::cms infinite_seq) r, xs (r+n)) <=
   prog_sum0 n (%m. distance(xs (r+m-(1::nat)), xs (r+m)))"
apply (induct_tac n)
apply (simp)

apply (simp)
apply (insert triangle_inequality_ms)
apply (drule_tac x="xs r" in spec)
apply (drule_tac x="xs (r + n)" in spec)
apply (drule_tac x="xs (Suc (r + n))" in spec)
apply (simp)
done

lemma Banach_lm_geo_prog_sum:
  "[| contraction_alpha f alpha ; (ALL i. xs (Suc i) = f(xs i)) |]
   ==>  prog_sum0 n (%m::nat. distance(xs (r+m-(1::nat)), xs (r+m)))
        <= prog_sum r (r+n) (geo_prop (distance(xs 0, xs 1)) alpha)"
apply (induct_tac n)
apply (simp add: prog_sum_def)

apply (simp add: prog_sum_def)
apply (subgoal_tac
        "distance (xs (r + n), f (xs (r + n)))
      <= geo_prop (distance (xs 0, f (xs 0))) alpha (Suc (r + n))")
apply (simp)

apply (insert Banach_lm_contraction[of f alpha xs])
apply (simp add: geo_prop_def)
done

lemma Banach_lm_ineq:
  "[| contraction_alpha f alpha ;
      (ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i)) |]
     ==> distance(xs r, xs (r+n)) <=
         distance (xs 0, f(xs 0)) * alpha^r / (1-alpha)"
apply (insert Banach_lm_triangle[of xs r n])
apply (insert Banach_lm_geo_prog_sum[of f "alpha" xs n r])
apply (insert geo_prog_sum_infinite_div
       [of "distance (xs 0, xs 1)" "alpha" r "r+n"])
by (simp add: contraction_alpha_def map_alpha_def)

lemma Banach_lm_cauchy_lm_pos_distance:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      0 < delta ; 0 < distance (xs 0, f(xs 0)) |]
    ==> (EX n. ALL m. distance (xs n, xs (n+m)) < delta)"
apply (insert pow_convergence[of
       "alpha" "delta*(1-alpha)/distance (xs 0, f(xs 0))"])
apply (simp add: contraction_alpha_range)

(* for Isabelle 2013
apply (subgoal_tac "0 < delta * (1 - alpha) / distance (xs 0, f (xs 0))")
apply (simp)
*)

apply (elim conjE exE)
apply (rule_tac x="n" in exI)
apply (rule allI)

      (* give a subgoal to use transitivity *)
apply (subgoal_tac
 "distance (xs n, xs (n + m))
  <= distance (xs 0, f (xs 0)) * alpha ^ n / (1 - alpha) &
     distance (xs 0, f (xs 0)) * alpha ^ n / (1 - alpha)
     < delta")
apply (erule conjE, simp)
apply (simp add: Banach_lm_ineq)
apply (simp_all add: real_mult_div_commute
                     contraction_alpha_def map_alpha_def)
      (* contraction_alpha_range did not work well here *)
(*
for Isabelle2007
apply (simp_all add: zero_le_power real_mult_div_commute
                     contraction_alpha_def map_alpha_def)
*)
done

lemma Banach_lm_cauchy_lm_zero_distance:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      0 < delta ; distance (xs 0, f(xs 0)) = 0 |]
      ==> (EX n. ALL m. distance (xs n, xs (n+m)) < delta)"
apply (simp add: diagonal_ms)
apply (rule_tac x="0" in exI)
apply (rule allI)
apply (subgoal_tac "distance (xs 0, xs m) <= 0", simp)
by (insert Banach_lm_ineq[of f "alpha" "xs" 0], simp)

lemma Banach_lm_cauchy_lm:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ; 0 < delta |]
    ==> (EX n. ALL m. distance (xs n, xs (n+m)) < delta)"
apply (case_tac "0 < distance (xs 0, f(xs 0))")
apply (simp add: Banach_lm_cauchy_lm_pos_distance)
apply (case_tac "distance (xs 0, f(xs 0)) = 0")
apply (simp add: Banach_lm_cauchy_lm_zero_distance)

apply (insert positive_ms)
apply (drule_tac x="xs 0" in spec)
apply (drule_tac x="f(xs 0)" in spec)
by (simp)

lemma Banach_lm_cauchy:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) |]
    ==> cauchy xs"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (subgoal_tac "EX n. ALL m. distance (xs n, xs (n + m)) < delta/2")
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)

apply (drule_tac x="0" in spec)     (* dummy *)
apply (frule_tac x="i-n" in spec)
apply (drule_tac x="j-n" in spec)
apply (simp)

apply (insert triangle_inequality_ms)
apply (drule_tac x="xs i" in spec)
apply (drule_tac x="xs n" in spec)
apply (drule_tac x="xs j" in spec)
apply (simp add: symmetry_ms)

apply (rule Banach_lm_cauchy_lm)
by (auto)

(*** step 2 (converge to a fixpoint) ***)

lemma Banach_lm_converge:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) |]
    ==> EX x. xs convergeTo x"
by (simp add: Banach_lm_cauchy complete_ms)

lemma Banach_lm_fixpoint_lm:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      xs convergeTo y ; 0 < eps |]
    ==> distance(y, f y) < eps"
apply (simp add: convergeTo_def)

apply (rotate_tac 2)
apply (drule_tac x="eps/2" in spec)
apply (simp)
apply (erule exE)
apply (rotate_tac -1)
apply (frule_tac x="n" in spec)
apply (drule_tac x="Suc n" in spec)
apply (simp)

apply (insert triangle_inequality_ms)
apply (drule_tac x="y" in spec)
apply (drule_tac x="xs (Suc n)" in spec)
apply (drule_tac x="f y" in spec)

apply (simp add: contraction_alpha_def map_alpha_def)
apply (elim conjE)

apply (rotate_tac -1)
apply (drule_tac x="xs n" in spec)
apply (drule_tac x="y" in spec)

apply (insert symmetry_ms)
apply (drule_tac x="xs n" in spec)
apply (drule_tac x="y" in spec)
apply (simp)

apply (subgoal_tac "alpha * distance (y, xs n) <= 1 * distance (y, xs n)")
apply (simp)

apply (rule mult_right_mono)
by (simp_all)

lemma Banach_lm_fixpoint:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      xs convergeTo y |]
    ==> y = f y"

apply (case_tac "0 < distance(y, f y)")
apply (insert Banach_lm_fixpoint_lm[of f alpha xs y "distance (y, f y)"])
apply (simp)

apply (case_tac "0 = distance(y, f y)")
apply (simp add: diagonal_ms)

(* distance(y, f y) < 0 *)
 apply (insert positive_ms)
 apply (drule_tac x="y" in spec)
 apply (drule_tac x="f y" in spec)
 apply (simp)
done

(*** step 3 (unique fixpoint) ***)

lemma Banach_lm_unique_lm:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      y = f y ; z = f z |]
        ==> distance(y, z) <= alpha * distance(y, z)"
apply (simp add: contraction_alpha_def map_alpha_def)
apply (elim conjE)
apply (drule_tac x="y" in spec)
apply (drule_tac x="z" in spec)
apply (simp)
done

lemma Banach_lm_unique:
  "[| contraction_alpha f alpha ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) ;
      y = f y ; z = f z |]
        ==> y = z"
apply (case_tac "0 < distance(y, z)")
apply (insert Banach_lm_unique_lm[of f alpha xs y z])
apply (simp add: contraction_alpha_def)
apply (insert mult_less_cancel_right[of alpha "distance (y, z)" 1])
apply (simp)

apply (case_tac "0 = distance(y, z)")
apply (simp add: diagonal_ms)

(* distance(y, Z) < 0 *)
apply (simp add: less_le)
done

(*** final step (Banach Theory) ***)

(*------------------*
 |     Banach lm    |
 *------------------*)

theorem Banach_thm_xs:
  "[| contraction f ;
      ALL i. (xs::'a::cms infinite_seq) (Suc i) = f(xs i) |]
        ==> (EX y. (xs convergeTo y & y isUFP f))"
apply (simp add: contraction_def)
apply (erule exE)
apply (subgoal_tac "EX y. xs convergeTo y")
apply (erule exE)
apply (rule_tac x="y" in exI)
apply (simp)

apply (subgoal_tac "y = f y")
apply (simp add: isUFP_def)
apply (intro allI impI)
apply (rule Banach_lm_unique[of f _ xs])
apply (simp_all)

apply (simp add: Banach_lm_fixpoint)
apply (simp add: Banach_lm_converge)
done

(*-------------------*
 |      Banach       |
 *-------------------*)

theorem Banach_thm:
  "contraction (f::('a::cms => 'a))
     ==> f hasUFP & (%n. (f^^n) x0) convergeTo UFP f"
apply (subgoal_tac "f hasUFP", simp)
apply (insert Banach_thm_xs[of f "(%n. ((f^^n) x0))"])
apply (simp)
apply (elim conjE exE)

apply (insert UFP_is[of f], simp)
apply (subgoal_tac "y = UFP f", simp)
apply (simp add: UFP_unique)

apply (simp add: hasUFP_def)
apply (erule exE)
apply (rule_tac x="y" in exI, simp)
done

(*------------------*
 | Banach existency |
 *------------------*)

theorem Banach_thm_EX: "contraction (f::('a::cms => 'a)) ==> f hasUFP"
by (simp add: Banach_thm)

end


theory Queue
  imports Main
begin

datatype MessageId = MessageId nat

fun getMessageId where
  "getMessageId (MessageId n) = n"

record 'a Queue =
  messages :: "nat \<rightharpoonup> 'a"

definition finiteQueue where
  "finiteQueue st = Finite_Set.finite (dom (messages st))"

definition empty where
  "empty = \<lparr> messages = Map.empty \<rparr>"

definition insert where
  "insert st v \<equiv> st \<lparr> messages := (messages st) ((SOME x. x \<notin> dom (messages st)) \<mapsto> v) \<rparr>"

definition get :: "'a Queue \<Rightarrow> MessageId \<Rightarrow> 'a option" where
  "get st m = messages st (getMessageId m)"

definition delete :: "'a Queue \<Rightarrow> MessageId \<Rightarrow> 'a Queue" where
  "delete st m = st \<lparr> messages := (messages st) (getMessageId m := None) \<rparr>"

lemma insert_existence: "finiteQueue st \<Longrightarrow> \<exists>x. x \<notin> dom (messages st)"
  apply (simp add: finiteQueue_def)
  by (simp add: ex_new_if_finite)

lemma insert_new_point_exists:
  "finiteQueue st \<Longrightarrow> \<exists>m \<in> dom (messages (insert st v)). get (insert st v) (MessageId m) = Some v"
  apply (simp add: finiteQueue_def)
  by (simp add: Queue.insert_def get_def)

lemma insert_get: "get st m = Some v \<Longrightarrow> get (insert st v) m = Some v"
  by (simp add: get_def insert_def)

definition pick :: "'a Queue \<Rightarrow> nat \<Rightarrow> (MessageId \<times> 'a) list" where
  "pick st n = map (\<lambda>x. (MessageId x, the (get st (MessageId x)))) (SOME xs. set xs \<subseteq> dom (messages st) \<and> length xs = min n (card (dom (messages st))))"

lemma pick_existence: "finite X \<Longrightarrow> \<exists>(xs :: nat list). set xs \<subseteq> X \<and> length xs = min n (card X)"
  apply (cases "card X < n")
proof-
  assume "finite X" "card X < n"
  have "\<exists>xs. set xs \<subseteq> X \<and> length xs = card X"
    by (metis \<open>finite X\<close> equalityD2 finite_list length_remdups_card_conv set_remdups)
  have "min n (card X) = card X"
    by (simp add: \<open>card X < n\<close> less_or_eq_imp_le min_absorb2)
  show ?thesis
    by (simp add: \<open>\<exists>xs. set xs \<subseteq> X \<and> length xs = card X\<close> \<open>min n (card X) = card X\<close>)
next
  assume "finite X" "\<not> card X < n"
  have "n \<le> card X"
    using \<open>\<not> card X < n\<close> not_less by blast
  have "n \<le> card (X :: nat set) \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> card Y = n"
    apply (induct n arbitrary: X)
    using card_empty apply blast
  proof-
    fix n :: nat and X :: "nat set"
    assume hyp: "\<And>(X :: nat set). n \<le> card X \<Longrightarrow> \<exists>Y\<subseteq>X. card Y = n" "Suc n \<le> card X"
    obtain x xs where "X = {x} \<union> xs" "n \<le> card xs" "x \<notin> xs"
      by (metis \<open>Suc n \<le> card X\<close> card_le_Suc_iff insert_is_Un)
    obtain Y where "Y \<subseteq> xs" "card Y = n"
      using \<open>n \<le> card xs\<close> hyp(1) by auto
    have "x \<notin> Y"
      using \<open>Y \<subseteq> xs\<close> \<open>x \<notin> xs\<close> by blast
    have "card (Y \<union> {x}) = Suc n"
      by (metis Suc_le_lessD Un_insert_right \<open>X = {x} \<union> xs\<close> \<open>Y \<subseteq> xs\<close> \<open>card Y = n\<close> \<open>x \<notin> Y\<close> card_gt_0_iff card_infinite card_insert_disjoint finite_Un finite_subset hyp(2) sup_bot.right_neutral)
    show "\<exists>Y\<subseteq>X. card Y = Suc n"
      by (metis Un_insert_right \<open>X = {x} \<union> xs\<close> \<open>Y \<subseteq> xs\<close> \<open>card (Y \<union> {x}) = Suc n\<close> insert_is_Un insert_subset order_refl order_trans sup_bot.right_neutral)
  qed
  have "\<exists>xs. set xs \<subseteq> X \<and> length xs = n"
    by (metis \<open>\<not> card X < n\<close> \<open>finite X\<close> \<open>n \<le> card X \<Longrightarrow> \<exists>Y\<subseteq>X. card Y = n\<close> finite_list le_less_linear length_remdups_card_conv rev_finite_subset set_remdups)
  show ?thesis
    by (simp add: \<open>\<exists>xs. set xs \<subseteq> X \<and> length xs = n\<close> \<open>n \<le> card X\<close> min_def)
qed

lemma pick_internal_set_some: "\<lbrakk> finiteQueue st; V = (SOME xs. set xs \<subseteq> dom (messages st) \<and> length xs = min n (card (dom (messages st)))) \<rbrakk>
  \<Longrightarrow> set V \<subseteq> dom (messages st) \<and> length V = min n (card (dom (messages st)))"
  apply (simp add: finiteQueue_def)
  by (smt pick_existence tfl_some)

lemma pick_fst_in_domain: "\<lbrakk> finiteQueue st; (m,v) \<in> set (pick st n) \<rbrakk> \<Longrightarrow> getMessageId m \<in> dom (messages st)"
proof-
  assume "finiteQueue st" "(m,v) \<in> set (pick st n)"
  have "getMessageId m \<in> set (SOME xs. set xs \<subseteq> dom (messages st) \<and> length xs = min n (card (dom (messages st))))"
    using \<open>(m,v) \<in> set (pick st n)\<close>
    by (auto simp add: pick_def)
  show "getMessageId m \<in> dom (messages st)"
    by (meson \<open>finiteQueue st\<close> \<open>getMessageId m \<in> set (SOME xs. set xs \<subseteq> dom (messages st) \<and> length xs = min n (card (dom (messages st))))\<close> in_mono pick_internal_set_some)
qed

lemma pick_get: "\<lbrakk> finiteQueue st; (m,v) \<in> set (pick st n) \<rbrakk> \<Longrightarrow> get st m = Some v"
proof-
  assume "finiteQueue st" "(m,v) \<in> set (pick st n)"
  show "get st m = Some v"
    using \<open>(m,v) \<in> set (pick st n)\<close>
    apply (auto simp add: pick_def)
    by (metis \<open>(m, v) \<in> set (pick st n)\<close> \<open>finiteQueue st\<close> domIff get_def option.exhaust_sel pick_fst_in_domain)
qed

end


theory Sorting_Setup
imports "../../sepref/IICF/IICF" "../../sepref/IICF/Impl/Proto_IICF_EOArray" Sorting_Misc
begin
  hide_const (open) Word.slice array_assn

definition "le_by_lt lt a b \<equiv> \<not>lt b a"
definition "lt_by_le le a b \<equiv> le a b \<and> \<not>le b a"

locale weak_ordering_le =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<le>" 50)
  assumes trans: "a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>\<le> c"
  assumes connex: "a\<^bold>\<le>b \<or> b\<^bold>\<le>a"

locale weak_ordering_lt =
  fixes less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold><" 50)
  assumes asym: "a\<^bold><b \<Longrightarrow> \<not>b\<^bold><a"
  assumes itrans: "a\<^bold><c \<Longrightarrow> a\<^bold><b \<or> b\<^bold><c"

locale weak_ordering =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<le>" 50)
  fixes less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold><" 50)
  assumes trans[trans]: "a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>\<le> c"
  assumes connex: "a\<^bold>\<le>b \<or> b\<^bold>\<le>a"
  assumes asym: "a\<^bold><b \<Longrightarrow> \<not>b\<^bold><a"
  assumes itrans: "a\<^bold><c \<Longrightarrow> a\<^bold><b \<or> b\<^bold><c"
  assumes lt_by_le: "lt_by_le (\<^bold>\<le>) = (\<^bold><)"
  assumes le_by_lt: "le_by_lt (\<^bold><) = (\<^bold>\<le>)"
begin

  lemma unfold_lt_to_le: "a \<^bold>< b \<longleftrightarrow> a\<^bold>\<le>b \<and> \<not>b\<^bold>\<le>a" unfolding lt_by_le[symmetric] lt_by_le_def by simp
  lemma unfold_le_to_lt: "a \<^bold>\<le> b \<longleftrightarrow> \<not>b\<^bold><a" unfolding le_by_lt[symmetric] le_by_lt_def by simp

  abbreviation (input) greater_eq (infix "\<^bold>\<ge>" 50) where "b\<^bold>\<ge>a \<equiv> a\<^bold>\<le>b"
  abbreviation (input) greater (infix "\<^bold>>" 50) where "b\<^bold>>a \<equiv> a\<^bold><b"

  lemma wo_refl[iff]: "a \<^bold>\<le> a" using connex by auto
  lemma wo_irrefl[iff]: "\<not>a\<^bold><a" using asym by blast
  lemma wo_less_trans[trans]: "a\<^bold><b \<Longrightarrow> b\<^bold><c \<Longrightarrow> a\<^bold><c" using asym itrans by blast

  text \<open>Compatibility lemmas, similar names as for order\<close>

  lemma wo_leI: "\<not> x \<^bold>< y \<Longrightarrow> y \<^bold>\<le> x" by (simp add: unfold_le_to_lt)

  lemma wo_leD: "y \<^bold>\<le> x \<Longrightarrow> \<not> x \<^bold>< y" by (simp add: unfold_le_to_lt)

  lemma wo_not_le_imp_less: "\<not> y \<^bold>\<le> x \<Longrightarrow> x \<^bold>< y" by (simp add: unfold_le_to_lt)

  lemma wo_le_less_trans[trans]: "x \<^bold>\<le> y \<Longrightarrow> y \<^bold>< z \<Longrightarrow> x \<^bold>< z"
    using itrans wo_leD by blast

  lemma wo_less_le_trans[trans]: "x \<^bold>< y \<Longrightarrow> y \<^bold>\<le> z \<Longrightarrow> x \<^bold>< z"
    using itrans wo_leD by blast

  lemma wo_less_not_sym: "x \<^bold>< y \<Longrightarrow> \<not> (y \<^bold>< x)"
    using asym by blast

  lemma wo_less_asym: "x \<^bold>< y \<Longrightarrow> (\<not> P \<Longrightarrow> y \<^bold>< x) \<Longrightarrow> P"
    using asym by blast

end

sublocale weak_ordering_lt < weak_ordering "le_by_lt (\<^bold><)"
  apply (unfold_locales)
  unfolding le_by_lt_def lt_by_le_def using asym itrans by blast+

sublocale weak_ordering_le < weak_ordering "(\<^bold>\<le>)" "lt_by_le (\<^bold>\<le>)"
  apply (unfold_locales)
  unfolding le_by_lt_def lt_by_le_def using trans connex by blast+

lemma linwo: "weak_ordering (\<le>) ((<)::_::linorder \<Rightarrow> _)"
  apply unfold_locales
  unfolding le_by_lt_def lt_by_le_def
  by (auto simp: fun_eq_iff)

lemma funwo: "weak_ordering (\<lambda>a b. f a \<le> f b) (\<lambda>a b. f a < f b)" for f :: "'a \<Rightarrow> 'b::linorder"
  apply unfold_locales
  unfolding le_by_lt_def lt_by_le_def
  by (auto simp: fun_eq_iff)

lemma le_by_linorder[simp]: "le_by_lt ((<)::_::linorder \<Rightarrow> _) = (\<le>)"
  unfolding le_by_lt_def less_le_not_le by (intro ext) auto

lemma lt_by_linorder[simp]: "lt_by_le ((\<le>)::_::linorder \<Rightarrow> _) = (<)"
  unfolding lt_by_le_def less_le_not_le by (intro ext) auto

lemma bex_intv_shift_aux: "(\<forall>x\<in>{0..<Suc n}. P x) \<longleftrightarrow> (P 0 \<and> (\<forall>x\<in>{0..<n}. P (Suc x)))"
  apply auto
  using less_Suc_eq_0_disj by auto

lemma sorted_wrt_adjacent: "\<lbrakk>transp R\<rbrakk> \<Longrightarrow> sorted_wrt R xs \<longleftrightarrow> (\<forall>i\<in>{0..<length xs-1}. R (xs!i) (xs!Suc i))"
  supply [simp del] = sorted_wrt.simps(2) and [simp] = sorted_wrt2_simps
  apply (induction xs rule: induct_list012)
  apply (auto simp: bex_intv_shift_aux)
  done

abbreviation "sorted_wrt_lt lt \<equiv> sorted_wrt (le_by_lt lt)"

lemma sorted_wrt_lt_adjacent:
  assumes "weak_ordering_lt lt"
  shows "sorted_wrt_lt lt xs \<longleftrightarrow> (\<forall>i\<in>{0..<length xs-1}. \<not>lt (xs!Suc i) (xs!i))"
proof -
  interpret weak_ordering_lt lt by fact

  show ?thesis
    apply (subst sorted_wrt_adjacent)
    apply (simp_all add: le_by_lt_def)
    done

qed

lemma sorted_sorted_wrt_lt: "sorted = sorted_wrt_lt ((<)::_::linorder \<Rightarrow>_)"
  apply (intro ext) unfolding sorted_sorted_wrt by simp

definition "sort_spec lt xs xs' \<equiv> mset xs'=mset xs \<and> sorted_wrt_lt lt xs'"

definition "slice_sort_spec lt xs\<^sub>0 l h \<equiv> doN {
    ASSERT (l\<le>h \<and> h\<le>length xs\<^sub>0);
    SPEC (\<lambda>xs. length xs = length xs\<^sub>0 \<and> take l xs = take l xs\<^sub>0 \<and> drop h xs = drop h xs\<^sub>0 \<and> sort_spec lt (Misc.slice l h xs\<^sub>0) (Misc.slice l h xs))
  }"

lemma slice_sort_spec_refine_sort: "\<lbrakk>(xsi,xs) \<in> slice_rel xs\<^sub>0 l h; l'=l; h'=h\<rbrakk> \<Longrightarrow> slice_sort_spec lt xsi l h \<le>\<Down>(slice_rel xs\<^sub>0 l' h') (SPEC (sort_spec lt xs))"
  unfolding slice_sort_spec_def sort_spec_def
  apply (refine_vcg RES_refine)
  by (auto simp: slice_rel_def in_br_conv)

lemma slice_sort_spec_eq_sort': "\<lbrakk>(xsi,xs) \<in> slicep_rel l h; xsi'=xsi; l'=l; h'=h\<rbrakk> \<Longrightarrow> \<Down>(slice_rel xsi' l' h') (SPEC (sort_spec lt xs)) = slice_sort_spec lt xsi l h"
  unfolding slice_sort_spec_def sort_spec_def
  apply (auto simp: slice_rel_def slicep_rel_def in_br_conv build_rel_SPEC_conv)
  done

corollary slice_sort_spec_refine_sort': "\<lbrakk>(xsi,xs) \<in> slicep_rel l h; xsi'=xsi; l'=l; h'=h\<rbrakk> \<Longrightarrow> slice_sort_spec lt xsi l h \<le>\<Down>(slice_rel xsi' l' h') (SPEC (sort_spec lt xs))"
  by (simp add: slice_sort_spec_eq_sort')

corollary slice_sort_spec_refine_sort'_sym: "\<lbrakk>(xsi,xs) \<in> slicep_rel l h; xsi'=xsi; l'=l; h'=h\<rbrakk> \<Longrightarrow> \<Down>(slice_rel xsi' l' h') (SPEC (sort_spec lt xs)) \<le> slice_sort_spec lt xsi l h"
  by (simp add: slice_sort_spec_eq_sort')

lemma slice_sort_spec_alt: "slice_sort_spec lt xs l h = doN {
    ASSERT (l\<le>h \<and> h\<le>length xs);
    SPEC (\<lambda>xs'. eq_outside_range xs' xs l h
      \<and> mset (slice l h xs') = mset (slice l h xs)
      \<and> sorted_wrt_lt lt (slice l h xs')
    )
  }"
  unfolding slice_sort_spec_def sort_spec_def eq_outside_range_def
  by (auto simp: pw_eq_iff refine_pw_simps)

  lemma slice_sort_spec_sem_alt: "slice_sort_spec lt xs l h = doN {
      ASSERT (l \<le> h \<and> h \<le> length xs);
      SPEC (\<lambda>xs'. slice_eq_mset l h xs xs' \<and> sorted_wrt_lt lt (slice l h xs'))
    }"
    unfolding slice_sort_spec_alt
    by (auto simp: pw_eq_iff refine_pw_simps slice_eq_mset_alt slice_eq_mset_eq_length eq_outside_rane_lenD dest: eq_outside_range_sym)

text \<open> Sorting a permutation of a list amounts to sorting the list! \<close>
lemma sort_spec_permute: "\<lbrakk>mset xs' = mset xs; sort_spec lt xs' ys\<rbrakk> \<Longrightarrow> sort_spec lt xs ys"
  unfolding sort_spec_def by auto

context weak_ordering begin
  sepref_decl_op cmpo_idxs: "\<lambda>xs i j. the (xs!i) \<^bold>< the (xs!j)"
    :: "[\<lambda>((xs,i),j). i<length xs \<and> j<length xs \<and> xs!i\<noteq>None \<and> xs!j\<noteq>None]\<^sub>f
      (\<langle>\<langle>Id::'a rel\<rangle>option_rel\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel \<rightarrow> bool_rel"
    by simp

  sepref_decl_op cmp_idxs: "\<lambda>xs i j. xs!i \<^bold>< xs!j"
    :: "[\<lambda>((xs,i),j). i<length xs \<and> j<length xs]\<^sub>f
      (\<langle>Id::'a rel\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel \<rightarrow> bool_rel"
    by simp

  sepref_decl_op cmpo_v_idx: "\<lambda>xs v j. v \<^bold>< the (xs!j)" :: "[\<lambda>((xs,v),j). j<length xs \<and> xs!j \<noteq> None]\<^sub>f (\<langle>\<langle>Id::'a rel\<rangle>option_rel\<rangle>list_rel \<times>\<^sub>r (Id::'a rel)) \<times>\<^sub>r nat_rel \<rightarrow> bool_rel"
    by simp

  sepref_decl_op cmpo_idx_v: "\<lambda>xs i v. the (xs!i) \<^bold>< v" :: "[\<lambda>((xs,i),v). i<length xs \<and> xs!i\<noteq>None]\<^sub>f (\<langle>\<langle>Id::'a rel\<rangle>option_rel\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r (Id::'a rel) \<rightarrow> bool_rel"
    by simp

(*
  definition refines_cmp_idxs :: "('a list \<Rightarrow> _ \<Rightarrow> assn) \<Rightarrow> (_ \<Rightarrow> 'l::len2 word \<Rightarrow> 'l word \<Rightarrow> 1 word llM) \<Rightarrow> bool"
    where "refines_cmp_idxs A ci_impl \<equiv> (uncurry2 ci_impl, uncurry2 (PR_CONST mop_cmp_idxs)) \<in> A\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"

  lemma gen_refines_cmp_idxsD:
      "GEN_ALGO ci_impl (refines_cmp_idxs A)
        \<Longrightarrow> (uncurry2 ci_impl, uncurry2 (PR_CONST mop_cmp_idxs)) \<in> A\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    and gen_refines_cmp_idxsI[intro?]:
      "(uncurry2 ci_impl, uncurry2 (PR_CONST mop_cmp_idxs)) \<in> A\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn
        \<Longrightarrow> GEN_ALGO ci_impl (refines_cmp_idxs A)"
    unfolding refines_cmp_idxs_def GEN_ALGO_def by auto
*)

end

definition "refines_relp A R Rimpl \<equiv> (uncurry Rimpl,uncurry (RETURN oo R)) \<in> A\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool1_assn"

term "GEN_ALGO Rimpl (refines_relp A R)"

lemma gen_refines_relpD: "GEN_ALGO Rimpl (refines_relp A R) \<Longrightarrow> (uncurry Rimpl,uncurry (RETURN oo R)) \<in> A\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool1_assn"
  by (simp add: GEN_ALGO_def refines_relp_def)

lemma gen_refines_relpI[intro?]: "(uncurry Rimpl,uncurry (RETURN oo R)) \<in> A\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool1_assn \<Longrightarrow> GEN_ALGO Rimpl (refines_relp A R)"
  by (simp add: GEN_ALGO_def refines_relp_def)

(*
locale sort_impl_context = weak_ordering +
  fixes cmp_idxs_impl :: "'ai::llvm_rep \<Rightarrow> 'l::len2 word \<Rightarrow> 'l word \<Rightarrow> 1 word llM"
    and arr_assn :: "'a list \<Rightarrow> 'ai \<Rightarrow> assn"
  assumes cmp_idxs_impl: "GEN_ALGO cmp_idxs_impl (refines_cmp_idxs arr_assn)"

begin

  lemmas lt_hnr[sepref_fr_rules] = gen_refines_cmp_idxsD[OF cmp_idxs_impl]

  declare [[sepref_register_adhoc "(\<^bold><)"]]

end
*)

(* TODO: Move *)

locale sort_impl_context = weak_ordering +
  fixes lt_impl :: "'ai::llvm_rep \<Rightarrow> 'ai \<Rightarrow> 1 word llM"
    and elem_assn :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
  assumes lt_impl: "GEN_ALGO lt_impl (refines_relp elem_assn (\<^bold><))"
  notes lt_hnr[sepref_fr_rules] = gen_refines_relpD[OF lt_impl]

  notes [[sepref_register_adhoc "(\<^bold><)"]]
begin

  abbreviation "arr_assn \<equiv> woarray_assn elem_assn"

  definition "cmpo_idxs2 xs\<^sub>0 i j \<equiv> doN {
    ASSERT (i \<noteq> j);
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    (vj,xs) \<leftarrow> mop_eo_extract xs j;
    let r = vi \<^bold>< vj;
    xs \<leftarrow> mop_eo_set xs i vi; \<comment> \<open>TODO: Let's hope the optimizer eliminates these assignments. In mid-term, eliminate them during sepref phase!\<close>
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "cmpo_v_idx2 xs\<^sub>0 v j \<equiv> doN {
    (vj,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 j;
    let r = v \<^bold>< vj;
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "cmpo_idx_v2 xs\<^sub>0 i v \<equiv> doN {
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    let r = vi \<^bold>< v;
    xs \<leftarrow> mop_eo_set xs i vi;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "cmp_idxs2 xs\<^sub>0 i j \<equiv> doN {
    xs \<leftarrow> mop_to_eo_conv xs\<^sub>0;
    b \<leftarrow> cmpo_idxs2 xs i j;
    xs \<leftarrow> mop_to_wo_conv xs;
    unborrow xs xs\<^sub>0;
    RETURN b
  }"

  lemma cmpo_idxs2_refine: "(uncurry2 cmpo_idxs2, uncurry2 (PR_CONST mop_cmpo_idxs)) \<in> [\<lambda>((xs,i),j). i\<noteq>j]\<^sub>f (Id\<times>\<^sub>rId)\<times>\<^sub>rId \<rightarrow> \<langle>Id\<rangle>nres_rel"
    unfolding cmpo_idxs2_def
    apply (intro frefI nres_relI)
    apply clarsimp
    subgoal for xs i j
      apply refine_vcg
      apply (simp_all add: list_update_swap[of i j] map_update[symmetric])
      done
    done

  lemma cmpo_v_idx2_refine: "(cmpo_v_idx2, PR_CONST mop_cmpo_v_idx) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    unfolding cmpo_v_idx2_def
    apply clarsimp
    apply refine_vcg
    apply auto
    done

  lemma cmpo_idx_v2_refine: "(cmpo_idx_v2, PR_CONST mop_cmpo_idx_v) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    unfolding cmpo_idx_v2_def
    apply clarsimp
    apply refine_vcg
    apply auto
    done

  lemma cmp_idxs2_refine: "(uncurry2 cmp_idxs2,uncurry2 (PR_CONST mop_cmp_idxs))\<in>[\<lambda>((xs,i),j). i\<noteq>j]\<^sub>f (Id\<times>\<^sub>rId)\<times>\<^sub>rId \<rightarrow> \<langle>Id\<rangle>nres_rel"
    unfolding cmp_idxs2_def mop_cmp_idxs_def PR_CONST_def
    apply (intro frefI nres_relI)
    apply clarsimp
    apply refine_vcg
    apply (rule order_trans)
    apply (rule cmpo_idxs2_refine[param_fo, THEN nres_relD], assumption, (rule IdI)+)
    by (auto simp: pw_le_iff refine_pw_simps)

  sepref_definition cmp_idxs_impl [llvm_inline] is "uncurry2 cmp_idxs2" :: "(woarray_assn elem_assn)\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding cmp_idxs2_def cmpo_idxs2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_definition cmpo_idxs_impl [llvm_inline] is "uncurry2 cmpo_idxs2" :: "(eoarray_assn elem_assn)\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding cmpo_idxs2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_definition cmpo_v_idx_impl [llvm_inline] is "uncurry2 cmpo_v_idx2" :: "(eoarray_assn elem_assn)\<^sup>k *\<^sub>a elem_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding cmpo_v_idx2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_definition cmpo_idx_v_impl [llvm_inline] is "uncurry2 cmpo_idx_v2" :: "(eoarray_assn elem_assn)\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding cmpo_idx_v2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  context notes [fcomp_norm_unfold] = list_rel_id_simp option_rel_id_simp begin
    sepref_decl_impl (ismop) cmp_idxs_impl.refine[FCOMP cmp_idxs2_refine] .
    sepref_decl_impl (ismop) cmpo_idxs_impl.refine[FCOMP cmpo_idxs2_refine] .
    sepref_decl_impl (ismop) cmpo_v_idx_impl.refine[FCOMP cmpo_v_idx2_refine] .
    sepref_decl_impl (ismop) cmpo_idx_v_impl.refine[FCOMP cmpo_idx_v2_refine] .
  end

end

locale pure_sort_impl_context = sort_impl_context +
  assumes pureA[safe_constraint_rules]: "CONSTRAINT is_pure elem_assn"
  notes [sepref_frame_free_rules] = mk_free_is_pure[OF CONSTRAINT_D[OF pureA]]
begin

  definition "cmp_idxs2' xs i j \<equiv> doN {
    ASSERT (i<length xs \<and> j<length xs);
    RETURN (xs!i \<^bold>< xs!j)
  }"

  lemma cmp_idxs2'_refine: "(cmp_idxs2',PR_CONST mop_cmp_idxs)\<in>Id\<rightarrow>Id\<rightarrow>Id\<rightarrow>\<langle>Id\<rangle>nres_rel"
    unfolding cmp_idxs2'_def mop_cmp_idxs_def
    apply clarsimp
    apply refine_vcg
    by auto

  sepref_definition cmp_idxs'_impl [llvm_inline] is "uncurry2 cmp_idxs2'" :: "(woarray_assn elem_assn)\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding cmp_idxs2'_def PR_CONST_def
    by sepref

  context notes [fcomp_norm_unfold] = list_rel_id_simp option_rel_id_simp begin
    sepref_decl_impl (ismop) cmp_idxs'_impl.refine[FCOMP cmp_idxs2'_refine] .
  end

  (*
  xxx, ctd here: Adapt sorting algorithms to use cmp_idxs!
    then refine to delayed swap and eo-optimizations!
  *)

  (*
  lemma mop_cmp_idxs_alt: "mop_cmp_idxs xs i j = doN { x \<leftarrow> mop_list_get xs i; y \<leftarrow> mop_list_get xs j; RETURN (x \<^bold>< y) }"
    by (auto simp: pw_eq_iff refine_pw_simps)

  sepref_def cmp_idxs_impl [llvm_inline] is "uncurry2 (PR_CONST mop_cmp_idxs)" :: "(array_assn elem_assn)\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding mop_cmp_idxs_alt PR_CONST_def
    apply sepref_dbg_keep
    done
  *)
  (*
  sublocale sort_impl_context "(\<^bold>\<le>)" "(\<^bold><)" cmp_idxs_impl "array_assn elem_assn"
    apply unfold_locales
    apply rule
    by (rule cmp_idxs_impl.refine)
  *)

end

(*
  TODO: Explicit ownership collection data structures!

    Idea: Make ownership abstractly visible by sum type as abstract element type
      Inl x - element x, but no ownership (free to overwrite or return)
      Inr x - element x with ownership

    operation get: transfers ownership, leaves Inl
    operation set: overwrites Inl, Inr must be freed (by user!?)
    operation ret: returns ownership, also concrete value must not have changed.
      *** Hard to implement, as abstractly not visible! BUT not needed for sorting,
          and optimizer may eliminate redundant writes in many cases!

*)

(*
locale sort_impl_context = weak_ordering +
  fixes lt_impl :: "'ai::llvm_rep \<Rightarrow> 'ai \<Rightarrow> 1 word llM"
    and elem_assn :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
  assumes lt_impl: "GEN_ALGO lt_impl (refines_relp elem_assn (\<^bold><))"
  assumes pureA[safe_constraint_rules]: "CONSTRAINT is_pure elem_assn"
  notes [sepref_frame_free_rules] = mk_free_is_pure[OF CONSTRAINT_D[OF pureA]]

  notes lt_hnr[sepref_fr_rules] = gen_refines_relpD[OF lt_impl]

  notes [[sepref_register_adhoc "(\<^bold><)"]]

begin
  abbreviation "arr_assn \<equiv> array_assn elem_assn"
end
*)
(* TODO: Refine lemmas to support more general size datatypes! *)

type_synonym size_t = "64"
abbreviation "size_assn \<equiv> snat_assn' TYPE(size_t)"

lemma unat_sort_impl_context: "pure_sort_impl_context (\<le>) (<) ll_icmp_ult unat_assn"
  apply intro_locales
  apply (rule linwo)
  apply unfold_locales
  apply rule
  apply (rule hn_unat_ops)
  apply (solve_constraint)
  done

subsection \<open>Parameterized Sorting\<close>

text \<open>Extension of a weak ordering with explicit carrier set is always possible,
  e.g., by putting all elements not in the carrier set into one equivalence class,
  which is smaller than any other class.\<close>
locale weak_ordering_on_lt =
  fixes C :: "'a set"
    and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold><" 50)
  assumes asym: "\<lbrakk> a\<in>C; b\<in>C \<rbrakk> \<Longrightarrow> a\<^bold><b \<Longrightarrow> \<not>b\<^bold><a"
  assumes itrans: "\<lbrakk> a\<in>C; b\<in>C; c\<in>C \<rbrakk> \<Longrightarrow> a\<^bold><c \<Longrightarrow> a\<^bold><b \<or> b\<^bold><c"

definition "ext_lt C lt a b \<equiv> lt a b \<and> a\<in>C \<and> b\<in>C \<or> a\<in>C \<and> b\<notin>C"

lemma weak_ordering_on_lt_extend: "weak_ordering_lt (ext_lt C lt) \<longleftrightarrow> weak_ordering_on_lt C lt"
  unfolding weak_ordering_on_lt_def weak_ordering_lt_def ext_lt_def
  by blast

(* TODO: Restrict cdom constraint to slice! *)
definition "pslice_sort_spec cdom pless cparam xs l h \<equiv> doN {
  \<^cancel>\<open>ASSERT (set (slice l h xs) \<subseteq> cdom cparam);\<close>
  ASSERT (set xs \<subseteq> cdom cparam);
  slice_sort_spec (pless cparam) xs l h
}"

locale parameterized_weak_ordering =
  fixes cdom :: "'cparam \<Rightarrow> 'a set"
    and pless :: "'cparam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
    and pcmp :: "'cparam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool nres"
  assumes weak_ordering_on_lt: "weak_ordering_on_lt (cdom cparam) (pless cparam)"
  assumes pcmp_correct[refine_vcg]: "\<lbrakk> a\<in>cdom cparam; b\<in>cdom cparam\<rbrakk>
    \<Longrightarrow> pcmp cparam a b \<le> SPEC (\<lambda>r. r \<longleftrightarrow> pless cparam a b)"
begin

  definition "cdom_rel cparam \<equiv> br id (\<lambda>x. x\<in>cdom cparam)"
  definition "cdom_list_rel cparam \<equiv> \<langle>cdom_rel cparam\<rangle>list_rel"
  definition "cdom_olist_rel cparam \<equiv> \<langle>\<langle>cdom_rel cparam\<rangle>option_rel\<rangle>list_rel"

  lemma br_id_list_rel_conv: "(xs,xs')\<in>\<langle>br id I\<rangle>list_rel \<longleftrightarrow> xs=xs' \<and> set xs' \<subseteq> Collect I"
    apply (induction xs arbitrary: xs')
    subgoal for xs' by (auto)
    subgoal for x xs xs' by (cases xs') (auto simp: in_br_conv)
    done

  lemma br_id_olist_rel_conv: "(xs,xs')\<in>\<langle>\<langle>br id I\<rangle>option_rel\<rangle>list_rel \<longleftrightarrow> xs=xs' \<and> (\<forall>x. Some x\<in>set xs' \<longrightarrow> I x)"
    apply (induction xs arbitrary: xs')
    subgoal for xs' by (auto)
    subgoal for x xs xs' by (cases xs') (auto simp: in_br_conv option_rel_def)
    done

  lemma cdom_list_rel_alt: "cdom_list_rel cparam = br id (\<lambda>xs. set xs \<subseteq> cdom cparam)"
    unfolding cdom_list_rel_def cdom_rel_def
    by (auto simp: in_br_conv br_id_list_rel_conv)

  lemma cdom_olist_rel_alt: "cdom_olist_rel cparam = br id (\<lambda>xs. \<forall>x. Some x \<in> set xs \<longrightarrow> x\<in>cdom cparam)"
    unfolding cdom_olist_rel_def cdom_rel_def
    by (auto simp: in_br_conv br_id_olist_rel_conv)

  definition "less' cparam \<equiv> (ext_lt (cdom cparam) (pless cparam))"

  lemma weak_ordering_lt: "weak_ordering_lt (less' cparam)"
    using weak_ordering_on_lt less'_def by (simp add: weak_ordering_on_lt_extend)

  lemma weak_ordering: "weak_ordering (le_by_lt (less' cparam)) (less' cparam)"
  proof -
    interpret weak_ordering_lt "less' cparam" by (rule weak_ordering_lt)
    show ?thesis by unfold_locales
  qed

  sublocale WO: weak_ordering "le_by_lt (less' cparam)" "less' cparam"
    by (rule weak_ordering)

  lemma sorted_wrt_ext: "set xs \<subseteq> cdom cparam \<Longrightarrow> sorted_wrt (less' cparam) xs = sorted_wrt (pless cparam) xs"
    apply (intro iffI; erule sorted_wrt_mono_rel[rotated])
    apply (auto simp: less'_def ext_lt_def)
    done

  (* TODO: Move *)
  lemma set_slice_ss: "set (slice l h xs) \<subseteq> set xs"
    by (metis Misc.slice_def dual_order.trans set_drop_subset set_take_subset)

  lemma slice_sort_spec_xfer: "\<Down> (cdom_list_rel cparam) (slice_sort_spec (less' cparam) xs l h) \<le> pslice_sort_spec cdom pless cparam xs l h"
    unfolding pslice_sort_spec_def cdom_list_rel_alt
    apply (auto simp: pw_le_iff refine_pw_simps in_br_conv)
    unfolding slice_sort_spec_alt
    apply (auto simp: refine_pw_simps)
    using sorted_wrt_ext
    by (smt ext_lt_def le_by_lt_def less'_def set_slice_ss sorted_wrt_mono_rel subsetD)

(*
  lemma pslice_sort_spec_xfer:
    assumes "m \<le> slice_sort_spec (less' cparam) xs l h"
    assumes "mm \<le> \<Down>(cdom_list_rel cparam) m"
    assumes "(xs',xs)\<in>cdom_list_rel cparam"
    shows "mm \<le> pslice_sort_spec cdom pless cparam xs l h"
    using assms unfolding pslice_sort_spec_def cdom_list_rel_alt
    apply (auto simp: pw_le_iff refine_pw_simps in_br_conv)
    unfolding slice_sort_spec_alt
    apply (auto simp: refine_pw_simps)
    using sorted_wrt_ext
    by (smt ext_lt_def le_by_lt_def less'_def set_slice_ss sorted_wrt_mono_rel subset_code(1))
*)

  lemma olist_to_eo_conv_refine[refine]:
    "(xs',xs)\<in>cdom_list_rel cparam \<Longrightarrow> mop_to_eo_conv xs' \<le> \<Down>(cdom_olist_rel cparam) (mop_to_eo_conv xs)"
    apply (rule nres_relD)
    unfolding mop_to_eo_conv_def cdom_olist_rel_def cdom_list_rel_def
    by (parametricity)

  lemma olist_to_wo_conv_refine[refine]:
    "\<lbrakk>(xs',xs)\<in>cdom_olist_rel cparam\<rbrakk> \<Longrightarrow> mop_to_wo_conv xs' \<le> \<Down>(cdom_list_rel cparam) (mop_to_wo_conv xs)"
    apply simp
    apply refine_rcg
    apply (auto simp: cdom_olist_rel_alt cdom_list_rel_alt in_br_conv)
    by (metis option.collapse)

  lemma olist_extract_refine[refine]: "\<lbrakk> (xs',xs)\<in>cdom_olist_rel cparam; (i',i)\<in>Id \<rbrakk>
    \<Longrightarrow> mop_eo_extract xs' i' \<le> \<Down> ((br id (\<lambda>x. x\<in>cdom cparam)) \<times>\<^sub>r cdom_olist_rel cparam) (mop_eo_extract xs i)"
    unfolding mop_eo_extract_alt
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_alt in_br_conv)
    by (metis in_set_upd_cases option.distinct(1))

  lemma listo_eo_set_refine[refine]: "\<lbrakk>
    (xs',xs)\<in>cdom_olist_rel cparam;
    (i',i)\<in>Id;
    (v',v)\<in>Id; v\<in>cdom cparam
  \<rbrakk> \<Longrightarrow> mop_eo_set xs' i' v' \<le> \<Down> (cdom_olist_rel cparam) (mop_eo_set xs i v)"
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_alt in_br_conv)
    by (metis in_set_upd_cases option.sel)

  definition "pcmpo_idxs2 cparam xs\<^sub>0 i j \<equiv> doN {
    ASSERT (i \<noteq> j);
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    (vj,xs) \<leftarrow> mop_eo_extract xs j;
    r \<leftarrow> pcmp cparam vi vj;
    xs \<leftarrow> mop_eo_set xs i vi; \<comment> \<open>TODO: Let's hope the optimizer eliminates these assignments. In mid-term, eliminate them during sepref phase!\<close>
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmpo_v_idx2 cparam xs\<^sub>0 v j \<equiv> doN {
    (vj,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 j;
    r \<leftarrow> pcmp cparam v vj;
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmpo_idx_v2 cparam xs\<^sub>0 i v \<equiv> doN {
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    r \<leftarrow> pcmp cparam vi v;
    xs \<leftarrow> mop_eo_set xs i vi;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmp_idxs2 cparam xs\<^sub>0 i j \<equiv> doN {
    xs \<leftarrow> mop_to_eo_conv xs\<^sub>0;
    b \<leftarrow> pcmpo_idxs2 cparam xs i j;
    xs \<leftarrow> mop_to_wo_conv xs;
    unborrow xs xs\<^sub>0;
    RETURN b
  }"

  lemma pcmpo_idxs_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    i\<noteq>j;
    (i',i)\<in>Id;
    (j',j)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_idxs2 cparam xs' i' j' \<le> \<Down> bool_rel (WO.mop_cmpo_idxs cparam xs i j)"
    unfolding pcmpo_idxs2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_alt in_br_conv less'_def ext_lt_def
           list_update_swap[of i j] map_update[symmetric])
    done

  lemma pcmpo_v_idx_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    (v',v)\<in>Id; v\<in>cdom cparam;
    (i',i)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_v_idx2 cparam xs' v' i' \<le> \<Down> bool_rel (WO.mop_cmpo_v_idx cparam xs v i)"
    unfolding pcmpo_v_idx2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_alt in_br_conv less'_def ext_lt_def)
    done

  lemma pcmpo_idx_v_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    (v',v)\<in>Id; v\<in>cdom cparam;
    (i',i)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_idx_v2 cparam xs' i' v' \<le> \<Down> bool_rel (WO.mop_cmpo_idx_v cparam xs i v)"
    unfolding pcmpo_idx_v2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_alt in_br_conv less'_def ext_lt_def)
    done

  lemma pcmp_idxs_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_list_rel cparam;
    i\<noteq>j;
    (i',i)\<in>Id;
    (j',j)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmp_idxs2 cparam xs' i' j' \<le> \<Down> bool_rel (WO.mop_cmp_idxs cparam xs i j)"
    unfolding pcmp_idxs2_def pcmpo_idxs2_def
    apply simp
    apply refine_vcg
    apply (auto 0 3 simp: cdom_list_rel_alt in_br_conv less'_def ext_lt_def
           list_update_swap[of i j] map_update[symmetric])
    using nth_mem by blast

end

(*
locale parameterized_weak_ordering = weak_ordering +
  fixes (*cparam :: 'cparam*)
        cdom :: "'cparam \<Rightarrow> 'a set"
    and pcmp :: "'cparam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool nres"
  assumes pcmp_correct[refine_vcg]: "\<lbrakk> a\<in>cdom cparam; b\<in>cdom cparam\<rbrakk>
    \<Longrightarrow> pcmp cparam a b \<le> SPEC (\<lambda>r. r \<longleftrightarrow> a\<^bold><b)"

begin
  (* TODO: The refinements established here are just a special case of list-element refinement.
    We should use list-rel here! And generic parametricity lemmas from the operations!
  *)
  definition "cdom_list_rel cparam \<equiv> br id (\<lambda>xs. set xs \<subseteq> cdom cparam)"
  definition "cdom_olist_rel cparam \<equiv> br id (\<lambda>xs. \<forall>x. Some x \<in> set xs \<longrightarrow> x\<in>cdom cparam)"

  lemma olist_to_eo_conv_refine[refine]:
    "(xs',xs)\<in>cdom_list_rel cparam \<Longrightarrow> mop_to_eo_conv xs' \<le> \<Down>(cdom_olist_rel cparam) (mop_to_eo_conv xs)"
    unfolding mop_to_eo_conv_def cdom_list_rel_def cdom_olist_rel_def
    by (auto simp: in_br_conv)

  lemma olist_to_wo_conv_refine[refine]:
    "\<lbrakk>(xs',xs)\<in>cdom_olist_rel cparam\<rbrakk> \<Longrightarrow> mop_to_wo_conv xs' \<le> \<Down>(cdom_list_rel cparam) (mop_to_wo_conv xs)"
    apply simp
    apply refine_rcg
    apply (auto simp: cdom_olist_rel_def cdom_list_rel_def in_br_conv)
    by (metis option.collapse)

  lemma olist_extract_refine[refine]: "\<lbrakk> (xs',xs)\<in>cdom_olist_rel cparam; (i',i)\<in>Id \<rbrakk>
    \<Longrightarrow> mop_eo_extract xs' i' \<le> \<Down> ((br id (\<lambda>x. x\<in>cdom cparam)) \<times>\<^sub>r cdom_olist_rel cparam) (mop_eo_extract xs i)"
    unfolding mop_eo_extract_alt
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_def in_br_conv)
    by (metis in_set_upd_cases option.distinct(1))

  lemma listo_eo_set_refine[refine]: "\<lbrakk>
    (xs',xs)\<in>cdom_olist_rel cparam;
    (i',i)\<in>Id;
    (v',v)\<in>Id; v\<in>cdom cparam
  \<rbrakk> \<Longrightarrow> mop_eo_set xs' i' v' \<le> \<Down> (cdom_olist_rel cparam) (mop_eo_set xs i v)"
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_def in_br_conv)
    by (metis in_set_upd_cases option.sel)

  definition "pcmpo_idxs2 cparam xs\<^sub>0 i j \<equiv> doN {
    ASSERT (i \<noteq> j);
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    (vj,xs) \<leftarrow> mop_eo_extract xs j;
    r \<leftarrow> pcmp cparam vi vj;
    xs \<leftarrow> mop_eo_set xs i vi; \<comment> \<open>TODO: Let's hope the optimizer eliminates these assignments. In mid-term, eliminate them during sepref phase!\<close>
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmpo_v_idx2 cparam xs\<^sub>0 v j \<equiv> doN {
    (vj,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 j;
    r \<leftarrow> pcmp cparam v vj;
    xs \<leftarrow> mop_eo_set xs j vj;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmpo_idx_v2 cparam xs\<^sub>0 i v \<equiv> doN {
    (vi,xs) \<leftarrow> mop_eo_extract xs\<^sub>0 i;
    r \<leftarrow> pcmp cparam vi v;
    xs \<leftarrow> mop_eo_set xs i vi;
    unborrow xs xs\<^sub>0;
    RETURN r
  }"

  definition "pcmp_idxs2 cparam xs\<^sub>0 i j \<equiv> doN {
    xs \<leftarrow> mop_to_eo_conv xs\<^sub>0;
    b \<leftarrow> pcmpo_idxs2 cparam xs i j;
    xs \<leftarrow> mop_to_wo_conv xs;
    unborrow xs xs\<^sub>0;
    RETURN b
  }"

  lemma pcmpo_idxs_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    i\<noteq>j;
    (i',i)\<in>Id;
    (j',j)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_idxs2 cparam xs' i' j' \<le> \<Down> bool_rel (mop_cmpo_idxs xs i j)"
    unfolding pcmpo_idxs2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_def in_br_conv
           list_update_swap[of i j] map_update[symmetric])
    done

  lemma pcmpo_v_idx_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    (v',v)\<in>Id; v\<in>cdom cparam;
    (i',i)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_v_idx2 cparam xs' v' i' \<le> \<Down> bool_rel (mop_cmpo_v_idx xs v i)"
    unfolding pcmpo_v_idx2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_def in_br_conv)
    done

  lemma pcmpo_idx_v_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_olist_rel cparam;
    (v',v)\<in>Id; v\<in>cdom cparam;
    (i',i)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmpo_idx_v2 cparam xs' i' v' \<le> \<Down> bool_rel (mop_cmpo_idx_v xs i v)"
    unfolding pcmpo_idx_v2_def
    apply simp
    apply refine_vcg
    apply (auto simp: cdom_olist_rel_def in_br_conv)
    done

  lemma pcmp_idxs_refine[refine]: "\<lbrakk>
    (xs',xs)\<in> cdom_list_rel cparam;
    i\<noteq>j;
    (i',i)\<in>Id;
    (j',j)\<in>Id
  \<rbrakk> \<Longrightarrow> pcmp_idxs2 cparam xs' i' j' \<le> \<Down> bool_rel (mop_cmp_idxs xs i j)"
    unfolding pcmp_idxs2_def pcmpo_idxs2_def
    apply simp
    apply refine_vcg
    apply (auto 0 3 simp: cdom_list_rel_def in_br_conv
           list_update_swap[of i j] map_update[symmetric])
    done

end
*)

text \<open>The compare function takes an external parameter.\<close>

term mop_eo_set

locale random_access_iterator =
  fixes wo_assn :: "'a list \<Rightarrow> 'oi::llvm_rep \<Rightarrow> assn"
    and eo_assn :: "'a option list \<Rightarrow> 'oi \<Rightarrow> assn"
    and elem_assn :: "'a \<Rightarrow> 'ai::llvm_rep \<Rightarrow> assn"
    and to_eo_impl :: "'oi \<Rightarrow> 'oi llM"
    and to_wo_impl :: "'oi \<Rightarrow> 'oi llM"
    and extract_impl :: "'oi \<Rightarrow> 'size::len2 word \<Rightarrow> ('ai \<times> 'oi) llM"
    and set_impl :: "'oi \<Rightarrow> 'size word \<Rightarrow> 'ai \<Rightarrow> 'oi llM"
  assumes
          to_eo_hnr: "(to_eo_impl, mop_to_eo_conv) \<in> wo_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ai. cnc_assn (\<lambda>x. x=ai) eo_assn)"
      and to_wo_hnr: "(to_wo_impl, mop_to_wo_conv) \<in> eo_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ai. cnc_assn (\<lambda>x. x=ai) wo_assn)"
      and eo_extract_hnr_aux: "(uncurry extract_impl, uncurry mop_eo_extract) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ (ai,_). elem_assn \<times>\<^sub>a cnc_assn (\<lambda>x. x = ai) eo_assn)"
      and eo_set_hnr_aux: "(uncurry2 set_impl, uncurry2 mop_eo_set) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>d \<rightarrow>\<^sub>a\<^sub>d (\<lambda>_ ((ai,_),_). cnc_assn (\<lambda>x. x=ai) eo_assn)"

  notes [[sepref_register_adhoc to_eo_impl to_wo_impl extract_impl set_impl]]
begin

context
  notes [fcomp_norm_simps] = option_rel_id_simp list_rel_id prod_rel_id_simp hrr_comp_id_conv
begin

  private method rl_mono =
    (rule hfref_cons;
      clarsimp_all;
      clarsimp_all simp: cnc_assn_def sep_algebra_simps entails_lift_extract_simps)

  lemma eo_extract_nodep_hnr_aux:
    "(uncurry extract_impl, uncurry mop_eo_extract) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn \<times>\<^sub>a eo_assn"
    using eo_extract_hnr_aux
    by rl_mono

  lemma eo_set_nodep_hnr_aux:
    "(uncurry2 set_impl, uncurry2 mop_eo_set) \<in> eo_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a elem_assn\<^sup>d \<rightarrow>\<^sub>a eo_assn"
    using eo_set_hnr_aux
    by rl_mono

  lemma to_eo_nodep_hnr[sepref_fr_rules]: "(to_eo_impl, mop_to_eo_conv) \<in> wo_assn\<^sup>d \<rightarrow>\<^sub>a eo_assn"
    using to_eo_hnr
    by rl_mono

  lemma to_wo_nodep_hnr[sepref_fr_rules]: "(to_wo_impl, mop_to_wo_conv) \<in> eo_assn\<^sup>d \<rightarrow>\<^sub>a wo_assn"
    using to_wo_hnr
    by rl_mono

  sepref_decl_impl (ismop,no_register) eo_extract: eo_extract_hnr_aux .
  sepref_decl_impl (ismop) eo_extract_nodep: eo_extract_nodep_hnr_aux .

  sepref_decl_impl (ismop,no_register) eo_set: eo_set_hnr_aux .
  sepref_decl_impl (ismop) eo_set_nodep: eo_set_nodep_hnr_aux .

  lemmas eo_hnr_dep = eo_extract_dep_hnr eo_extract_hnr_mop eo_set_hnr eo_set_hnr_mop
    to_eo_hnr to_wo_hnr
  lemmas eo_hnr_nodep = eo_extract_nodep_hnr eo_extract_nodep_hnr_mop eo_set_nodep_hnr eo_set_nodep_hnr_mop
    to_eo_nodep_hnr to_wo_nodep_hnr

  sepref_definition swap_eo_impl_aux is "uncurry2 swap_eo" :: "wo_assn\<^sup>d *\<^sub>a (snat_assn' TYPE('size))\<^sup>k *\<^sub>a (snat_assn' TYPE('size))\<^sup>k \<rightarrow>\<^sub>a wo_assn"
    unfolding swap_eo_def
    by sepref

end

concrete_definition (in -) swap_eo_impl[llvm_inline] is random_access_iterator.swap_eo_impl_aux_def

context
  notes [fcomp_norm_simps] = option_rel_id_simp list_rel_id prod_rel_id_simp hrr_comp_id_conv
begin
  sepref_decl_impl (ismop) swap_eo_impl_aux.refine[FCOMP swap_eo_refine, unfolded swap_eo_impl.refine[OF random_access_iterator_axioms]]
     uses mop_list_swap.fref[where A=Id] .

end

(*  sepref_decl_impl (ismop) swap_eo_impl.refine[FCOMP swap_eo_refine] uses mop_list_swap.fref[where A=Id] .*)

end

definition "refines_param_relp P A R Rimpl \<equiv> (uncurry2 Rimpl,uncurry2 R) \<in> P\<^sup>k*\<^sub>aA\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool1_assn"

lemma gen_refines_param_relpD: "GEN_ALGO Rimpl (refines_param_relp P A R)
  \<Longrightarrow> (uncurry2 Rimpl,uncurry2 R) \<in> P\<^sup>k*\<^sub>aA\<^sup>k*\<^sub>aA\<^sup>k\<rightarrow>\<^sub>abool1_assn"
  by (simp add: GEN_ALGO_def refines_param_relp_def)

locale parameterized_sort_impl_context = random_access_iterator + parameterized_weak_ordering +
  constrains "cdom" :: "'cparam \<Rightarrow> _" and pless :: _ and pcmp :: "'cparam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool nres"
    and elem_assn :: "'a \<Rightarrow> 'ai::llvm_rep \<Rightarrow> assn"
    and wo_assn :: "'a list \<Rightarrow> 'oi::llvm_rep \<Rightarrow> assn"
    and eo_assn :: "'a option list \<Rightarrow> 'oi \<Rightarrow> assn"
    and elem_assn :: "'a \<Rightarrow> 'ai::llvm_rep \<Rightarrow> assn"
    and to_eo_impl :: "'oi \<Rightarrow> 'oi llM"
    and to_wo_impl :: "'oi \<Rightarrow> 'oi llM"
    and extract_impl :: "'oi \<Rightarrow> size_t word \<Rightarrow> ('ai \<times> 'oi) llM"
    and set_impl :: "'oi \<Rightarrow> size_t word \<Rightarrow> 'ai \<Rightarrow> 'oi llM"

  fixes pcmp_impl :: "'cparami \<Rightarrow> 'ai \<Rightarrow> 'ai \<Rightarrow> 1 word llM"
    and cparam_assn :: "'cparam \<Rightarrow> 'cparami \<Rightarrow> assn"

  assumes lt_impl: "GEN_ALGO pcmp_impl (refines_param_relp cparam_assn elem_assn pcmp)"
  notes pcmp_aux_hnr[sepref_fr_rules] = gen_refines_param_relpD[OF lt_impl]

  notes [[sepref_register_adhoc "pcmp"]]

begin

  thm pcmp_aux_hnr

  term pcmpo_v_idx2

  sepref_register pcmpo_idxs2 pcmpo_v_idx2 pcmpo_idx_v2 pcmp_idxs2

  sepref_def pcmpo_idxs_impl [llvm_inline] is "uncurry3 (PR_CONST pcmpo_idxs2)" ::
    "cparam_assn\<^sup>k *\<^sub>a eo_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding pcmpo_idxs2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_def pcmpo_v_idx_impl [llvm_inline] is "uncurry3 (PR_CONST pcmpo_v_idx2)" ::
    "cparam_assn\<^sup>k *\<^sub>a eo_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding pcmpo_v_idx2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_def pcmpo_idx_v_impl [llvm_inline] is "uncurry3 (PR_CONST pcmpo_idx_v2)" ::
    "cparam_assn\<^sup>k *\<^sub>a eo_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding pcmpo_idx_v2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

  sepref_def pcmp_idxs_impl [llvm_inline] is "uncurry3 (PR_CONST pcmp_idxs2)" ::
    "cparam_assn\<^sup>k *\<^sub>a wo_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    unfolding pcmp_idxs2_def PR_CONST_def
    supply [sepref_fr_rules] = eo_hnr_dep
    by sepref

end

end


theory Kyber_spec
imports Main "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
  "Berlekamp_Zassenhaus.Poly_Mod"
  "Berlekamp_Zassenhaus.Poly_Mod_Finite_Field"

begin
hide_type Matrix.vec
hide_const Matrix.vec_index

section \<open>Type Class for Factorial Ring $\mathbb{Z}_q[x]/(x^n+1)$.\<close>
text \<open>The Kyber algorithms work over the quotient ring $\mathbb{Z}_q[x]/(x^n+1)$
where $q$ is a prime with $q\equiv 1 \mod 4$ and $n$ is a power of $2$.
We encode this quotient ring as a type. In order to do so, we first look at the
finite field $\mathbb{Z}_q$ implemented by \<open>('a::prime_card) mod_ring\<close>.
Then we define polynomials using the constructor \<open>poly\<close>.
For factoring out $x^n+1$, we define an equivalence relation on the polynomial ring
$\mathbb{Z}_q[x]$ via the modulo operation with modulus $x^n+1$.
Finally, we build the quotient of the equivalence relation using the construction
\<open>quotient_type\<close>.\<close>
text \<open>The module $\mathbb{Z}_q[x]/(x^n+1)$ was formalized with help from Manuel Eberl.\<close>

text \<open>Modulo relation between two polynomials. \<close>
lemma of_int_mod_ring_eq_0_iff:
  "(of_int n :: ('n :: {finite, nontriv} mod_ring)) = 0 \<longleftrightarrow>
    int (CARD('n)) dvd n"
  by transfer auto

lemma of_int_mod_ring_eq_of_int_iff:
  "(of_int n :: ('n :: {finite, nontriv} mod_ring)) = of_int m \<longleftrightarrow>
    [n = m] (mod (int (CARD('n))))"
  by transfer (auto simp: cong_def)

definition mod_poly_rel :: "nat \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_rel m p q \<longleftrightarrow>
    (\<forall>n. [poly.coeff p n = poly.coeff q n] (mod (int m)))"

lemma mod_poly_rel_altdef:
  "mod_poly_rel CARD('n :: nontriv) p q \<longleftrightarrow>
    (of_int_poly p) = (of_int_poly q :: 'n mod_ring poly)"
  by (auto simp: poly_eq_iff mod_poly_rel_def
    of_int_mod_ring_eq_of_int_iff)

definition mod_poly_is_unit :: "nat \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_is_unit m p \<longleftrightarrow> (\<exists>r. mod_poly_rel m (p * r) 1)"

lemma mod_poly_is_unit_altdef:
  "mod_poly_is_unit CARD('n :: nontriv) p \<longleftrightarrow>
    (of_int_poly p :: 'n mod_ring poly) dvd 1"
proof
  assume "mod_poly_is_unit CARD('n) p"
  thus "(of_int_poly p :: 'n mod_ring poly) dvd 1"
    by (auto simp: mod_poly_is_unit_def dvd_def mod_poly_rel_altdef
      of_int_poly_hom.hom_mult)
next
  assume "(of_int_poly p :: 'n mod_ring poly) dvd 1"
  then obtain q where q: "(of_int_poly p :: 'n mod_ring poly) * q = 1"
    by auto
  also have "q = of_int_poly (map_poly to_int_mod_ring q)"
    by (simp add: of_int_of_int_mod_ring poly_eqI)
  also have "of_int_poly p * \<dots> =
      of_int_poly (p * map_poly to_int_mod_ring q)"
    by (simp add: of_int_poly_hom.hom_mult)
  finally show "mod_poly_is_unit CARD('n) p"
    by (auto simp: mod_poly_is_unit_def mod_poly_rel_altdef)
qed

definition mod_poly_irreducible :: "nat \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_irreducible m Q \<longleftrightarrow>
     \<not>mod_poly_rel m Q 0 \<and>
     \<not>mod_poly_is_unit m Q \<and>
        (\<forall>a b. mod_poly_rel m Q (a * b) \<longrightarrow>
               mod_poly_is_unit m a \<or> mod_poly_is_unit m b)"

lemma of_int_poly_to_int_poly: "of_int_poly (to_int_poly p) = p"
  by (simp add: of_int_of_int_mod_ring poly_eqI)

lemma mod_poly_irreducible_altdef:
  "mod_poly_irreducible CARD('n :: nontriv) p \<longleftrightarrow>
    irreducible (of_int_poly p :: 'n mod_ring poly)"
proof
  assume "irreducible (of_int_poly p :: 'n mod_ring poly)"
  thus "mod_poly_irreducible CARD('n) p"
    by (auto simp: mod_poly_irreducible_def mod_poly_rel_altdef
    mod_poly_is_unit_altdef irreducible_def of_int_poly_hom.hom_mult)
next
  assume *: "mod_poly_irreducible CARD('n) p"
  show "irreducible (of_int_poly p :: 'n mod_ring poly)"
    unfolding irreducible_def
  proof (intro conjI impI allI)
    fix a b assume ab: "(of_int_poly p :: 'n mod_ring poly) = a * b"
    have "of_int_poly (map_poly to_int_mod_ring a *
      map_poly to_int_mod_ring b) =
      of_int_poly (map_poly to_int_mod_ring a) *
      (of_int_poly (map_poly to_int_mod_ring b) :: 'n mod_ring poly)"
      by (simp add: of_int_poly_hom.hom_mult)
    also have "\<dots> = a * b"
      by (simp add: of_int_poly_to_int_poly)
    also have "\<dots> = of_int_poly p"
      using ab by simp
    finally have "(of_int_poly p :: 'n mod_ring poly) =
      of_int_poly (to_int_poly a * to_int_poly b)" ..
    hence "of_int_poly (to_int_poly a) dvd (1 :: 'n mod_ring poly) \<or>
           of_int_poly (to_int_poly b) dvd (1 :: 'n mod_ring poly)"
      using * unfolding mod_poly_irreducible_def mod_poly_rel_altdef
        mod_poly_is_unit_altdef by blast
    thus "(a dvd (1 :: 'n mod_ring poly)) \<or>
      (b dvd (1 :: 'n mod_ring poly))"
      by (simp add: of_int_poly_to_int_poly)
  qed (use * in \<open>auto simp: mod_poly_irreducible_def
    mod_poly_rel_altdef mod_poly_is_unit_altdef\<close>)
qed

text \<open>Type class for quotient ring $\mathbb{Z}_q[x]/(p)$.
  The polynomial p is represented as \<open>qr_poly'\<close> (an polynomial over the integers).\<close>

class qr_spec = prime_card +
  fixes qr_poly' :: "'a itself \<Rightarrow> int poly"
  assumes not_dvd_lead_coeff_qr_poly':
      "\<not>int CARD('a) dvd lead_coeff (qr_poly' TYPE('a))"
  and deg_qr'_pos : "degree (qr_poly' TYPE('a)) > 0"

text \<open>\<open>qr_poly\<close> is the respective polynomial in $\mathbb{Z}_q[x]$.\<close>
definition qr_poly :: "'a :: qr_spec mod_ring poly" where
  "qr_poly = of_int_poly (qr_poly' TYPE('a))"

text \<open>Functions to get the degree of the polynomials to be factored out.\<close>
definition (in qr_spec) deg_qr :: "'a itself \<Rightarrow> nat" where
  "deg_qr _ = degree (qr_poly' TYPE('a))"

lemma degree_qr_poly':
  "degree (qr_poly' TYPE('a :: qr_spec)) = deg_qr (TYPE('a))"
  by (simp add: deg_qr_def)

lemma degree_of_int_poly':
  assumes "of_int (lead_coeff p) \<noteq> (0 :: 'a :: ring_1)"
  shows "degree (of_int_poly p :: 'a poly) = degree p"
proof (intro antisym)
  show "degree (of_int_poly p) \<le> degree p"
    by (intro degree_le) (auto simp: coeff_eq_0)
  show "degree (of_int_poly p :: 'a poly) \<ge> degree p"
    using assms by (intro le_degree) auto
qed

lemma degree_qr_poly:
  "degree (qr_poly :: 'a :: qr_spec mod_ring poly) = deg_qr (TYPE('a))"
  unfolding qr_poly_def
  using not_dvd_lead_coeff_qr_poly'[where ?'a = 'a]
  by (subst degree_of_int_poly')
     (auto simp: of_int_mod_ring_eq_0_iff degree_qr_poly')

lemma deg_qr_pos : "deg_qr TYPE('a :: qr_spec) > 0"
by (metis deg_qr'_pos degree_qr_poly')

text \<open>The factor polynomial is non-zero.\<close>
lemma qr_poly_nz [simp]: "qr_poly \<noteq> 0"
  using deg_qr_pos[where ?'a = 'a] by (auto simp flip: degree_qr_poly)

text \<open>Thus, when factoring out $p$, it has no effect on the neutral element $1$.\<close>
lemma one_mod_qr_poly [simp]:
  "1 mod (qr_poly :: 'a :: qr_spec mod_ring poly) = 1"
proof -
  have "2 ^ 1 \<le> (2 ^ deg_qr TYPE('a) :: nat)"
    using deg_qr_pos[where ?'a = 'a]
    by (intro power_increasing) auto
  thus ?thesis by (metis degree_qr_poly deg_qr_pos degree_1 mod_poly_less)
qed

text \<open>We define a modulo relation for polynomials modulo a polynomial $p=$\<open>qr_poly\<close>.\<close>
definition qr_rel :: "'a :: qr_spec mod_ring poly \<Rightarrow> 'a mod_ring poly \<Rightarrow> bool" where
  "qr_rel P Q \<longleftrightarrow> [P = Q] (mod qr_poly)"

lemma equivp_qr_rel: "equivp qr_rel"
  by (intro equivpI sympI reflpI transpI)
     (auto simp: qr_rel_def cong_sym intro: cong_trans)

text \<open>Using this equivalence relation, we can define the quotient ring as a \<open>quotient_type\<close>.\<close>
quotient_type (overloaded) 'a qr = "'a :: qr_spec mod_ring poly" / qr_rel
  by (rule equivp_qr_rel)

text \<open>Defining the conversion functions.\<close>
lift_definition to_qr :: "'a :: qr_spec mod_ring poly \<Rightarrow> 'a qr"
  is "\<lambda>x. (x :: 'a mod_ring poly)" .

lift_definition of_qr :: "'a qr \<Rightarrow> 'a :: qr_spec mod_ring poly"
  is "\<lambda>P::'a mod_ring poly. P mod qr_poly"
  by (simp add: qr_rel_def cong_def)

text \<open>Simplification lemmas on conversion functions.\<close>
lemma of_qr_to_qr: "of_qr (to_qr (x)) = x mod qr_poly"
  apply (auto simp add: of_qr_def to_qr_def)
  by (metis of_qr.abs_eq of_qr.rep_eq)

lemma to_qr_of_qr: "to_qr (of_qr (x)) = x"
  apply (auto simp add: of_qr_def to_qr_def)
  by (metis (mono_tags, lifting) Quotient3_abs_rep Quotient3_qr
    Quotient3_rel cong_def qr_rel_def mod_mod_trivial)

lemma eq_to_qr: "x = y \<Longrightarrow> to_qr x = to_qr y" by auto

text \<open>Type class instantiation for \<open>qr\<close> (quotient ring).\<close>
instantiation qr :: (qr_spec) comm_ring_1
begin

lift_definition zero_qr :: "'a qr" is "0" .

lift_definition one_qr :: "'a qr" is "1" .

lift_definition plus_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(+)"
  unfolding qr_rel_def using cong_add by blast

lift_definition uminus_qr :: "'a qr \<Rightarrow> 'a qr"
  is "uminus"
  unfolding qr_rel_def  using cong_minus_minus_iff by blast

lift_definition minus_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(-)"
  unfolding qr_rel_def using cong_diff by blast

lift_definition times_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(*)"
  unfolding qr_rel_def using cong_mult by blast

instance
proof
  show "0 \<noteq> (1 :: 'a qr)"
    by transfer (simp add: qr_rel_def cong_def)
qed (transfer; simp add: qr_rel_def algebra_simps; fail)+

end

lemma of_qr_0 [simp]: "of_qr 0 = 0"
  and of_qr_1 [simp]: "of_qr 1 = 1"
  and of_qr_uminus [simp]: "of_qr (-p) = -of_qr p"
  and of_qr_add [simp]: "of_qr (p + q) = of_qr p + of_qr q"
  and of_qr_diff [simp]: "of_qr (p - q) = of_qr p - of_qr q"
  by (transfer; simp add: poly_mod_add_left poly_mod_diff_left; fail)+

lemma to_qr_0 [simp]: "to_qr 0 = 0"
  and to_qr_1 [simp]: "to_qr 1 = 1"
  and to_qr_uminus [simp]: "to_qr (-p) = -to_qr p"
  and to_qr_add [simp]: "to_qr (p + q) = to_qr p + to_qr q"
  and to_qr_diff [simp]: "to_qr (p - q) = to_qr p - to_qr q"
  and to_qr_mult [simp]: "to_qr (p * q) = to_qr p * to_qr q"
  by (transfer'; simp; fail)+

lemma to_qr_of_nat [simp]: "to_qr (of_nat n) = of_nat n"
  by (induction n) auto

lemma to_qr_of_int [simp]: "to_qr (of_int n) = of_int n"
  by (induction n) auto

lemma of_qr_of_nat [simp]: "of_qr (of_nat n) = of_nat n"
  by (induction n) auto

lemma of_qr_of_int [simp]: "of_qr (of_int n) = of_int n"
  by (induction n) auto

lemma of_qr_eq_0_iff [simp]: "of_qr p = 0 \<longleftrightarrow> p = 0"
  by transfer (simp add: qr_rel_def cong_def)

lemma to_qr_eq_0_iff:
  "to_qr p = 0 \<longleftrightarrow> qr_poly dvd p"
  by transfer (auto simp: qr_rel_def cong_def)

text \<open>Some more lemmas that will probably be useful.\<close>

lemma to_qr_eq_iff [simp]:
  "to_qr P = (to_qr Q :: 'a :: qr_spec qr) \<longleftrightarrow> [P = Q] (mod qr_poly)"
  by transfer (auto simp: qr_rel_def)

text \<open>Reduction modulo $x^n + 1$ is injective on polynomials of degree less than $n$
  in particular, this means that \<open>card(QR(q^n)) = q^n\<close>. \<close>
lemma inj_on_to_qr:
  "inj_on
     (to_qr :: 'a :: qr_spec mod_ring poly \<Rightarrow> 'a qr)
     {P. degree P < deg_qr TYPE('a)}"
  by (intro inj_onI) (auto simp: cong_def mod_poly_less
      simp flip: degree_qr_poly)

text \<open>Characteristic of quotient ring is exactly q.\<close>

lemma of_int_qr_eq_0_iff [simp]:
  "of_int n = (0 :: 'a :: qr_spec qr) \<longleftrightarrow> int (CARD('a)) dvd n"
proof -
  have "of_int n = (0 :: 'a qr) \<longleftrightarrow> (of_int n :: 'a mod_ring poly) = 0"
    by (smt (z3) of_qr_eq_0_iff of_qr_of_int)
  also have "\<dots> \<longleftrightarrow> (of_int n :: 'a mod_ring) = 0"
    by (simp add: of_int_poly)
  also have "\<dots> \<longleftrightarrow> int (CARD('a)) dvd n"
    by (simp add: of_int_mod_ring_eq_0_iff)
  finally show ?thesis .
qed

lemma of_int_qr_eq_of_int_iff:
  "of_int n = (of_int m :: 'a :: qr_spec qr) \<longleftrightarrow>
    [n = m] (mod (int (CARD('a))))"
  using of_int_qr_eq_0_iff[of "n - m", where ?'a = 'a]
  by (simp del: of_int_qr_eq_0_iff add: cong_iff_dvd_diff)

lemma of_nat_qr_eq_of_nat_iff:
  "of_nat n = (of_nat m :: 'a :: qr_spec qr) \<longleftrightarrow>
    [n = m] (mod CARD('a))"
  using of_int_qr_eq_of_int_iff[of "int n" "int m"]
  by (simp add: cong_int_iff)

lemma of_nat_qr_eq_0_iff [simp]:
  "of_nat n = (0 :: 'a :: qr_spec qr) \<longleftrightarrow> CARD('a) dvd n"
  using of_int_qr_eq_0_iff[of "int n"] by simp

section \<open>Specification of Kyber\<close>

definition to_module :: "int \<Rightarrow> 'a ::qr_spec qr" where
  "to_module x = to_qr (Poly [of_int_mod_ring x ::'a mod_ring])"

text \<open>Properties in the ring \<open>'a qr\<close>. A good representative has degree up to n.\<close>
lemma deg_mod_qr_poly:
  assumes "degree x < deg_qr TYPE('a::qr_spec)"
  shows "x mod (qr_poly :: 'a mod_ring poly) = x"
using mod_poly_less[of x qr_poly] unfolding deg_qr_def
by (metis assms degree_qr_poly)

lemma of_qr_to_qr':
  assumes "degree x < deg_qr TYPE('a::qr_spec)"
  shows "of_qr (to_qr x) = (x ::'a mod_ring poly)"
using deg_mod_qr_poly[OF assms] of_qr_to_qr[of x] by simp

lemma deg_of_qr:
  "degree (of_qr (x ::'a qr)) < deg_qr TYPE('a::qr_spec)"
by (metis deg_qr_pos degree_0 degree_qr_poly degree_mod_less'
  qr_poly_nz of_qr.rep_eq)

lemma to_qr_smult_to_module:
  "to_qr (Polynomial.smult a p) = (to_qr (Poly [a])) * (to_qr p)"
by (metis Poly.simps(1) Poly.simps(2) mult.left_neutral
  mult_smult_left smult_one to_qr_mult)

lemma of_qr_to_qr_smult:
  "of_qr (to_qr (Polynomial.smult a p)) =
  Polynomial.smult a (of_qr (to_qr p))"
by (simp add: mod_smult_left of_qr_to_qr)

text \<open>The following locale comprehends all variables used in crypto schemes over $R_q$ like
Kyber and Dilithium.\<close>

locale module_spec =
fixes "type_a" :: "('a :: qr_spec) itself"
  and "type_k" :: "('k ::finite) itself"
  and n q::int and k n'::nat
assumes
n_powr_2: "n = 2 ^ n'" and
n'_gr_0: "n' > 0" and
q_gr_two: "q > 2" and
q_prime : "prime q" and
CARD_a: "int (CARD('a :: qr_spec)) = q" and
CARD_k: "int (CARD('k :: finite)) = k" and
qr_poly'_eq: "qr_poly' TYPE('a) = Polynomial.monom 1 (nat n) + 1"

begin
text \<open>Some properties of the modulus q.\<close>

lemma q_nonzero: "q \<noteq> 0"
using module_spec_axioms module_spec_def  by (smt (z3))

lemma q_gt_zero: "q>0"
using module_spec_axioms module_spec_def by (smt (z3))

lemma q_gt_two: "q>2"
using module_spec_axioms module_spec_def by (smt (z3))

lemma q_odd: "odd q"
using module_spec_axioms module_spec_def prime_odd_int by blast

lemma nat_q: "nat q = q"
using q_gt_zero by force

text \<open>Some properties of the degree n.\<close>

lemma n_gt_1: "n > 1"
using module_spec_axioms module_spec_def
  by (simp add: n'_gr_0 n_powr_2)

lemma n_nonzero: "n \<noteq> 0"
using n_gt_1 by auto

lemma n_gt_zero: "n>0"
using n_gt_1 by auto

lemma nat_n: "nat n = n"
using n_gt_zero by force

lemma deg_qr_n:
  "deg_qr TYPE('a) = n"
unfolding deg_qr_def using qr_poly'_eq n_gt_1
by (simp add: degree_add_eq_left degree_monom_eq)

end

text \<open>
We now define a locale for the specification parameters of Kyber as in \cite{kyber}.
The specifications use the parameters:

\begin{tabular}{r l}
$n$ & $=256 = 2^{n'}$\\
$n'$ & $= 8$\\
$q$ & $= 7681$ or $3329$\\
$k$ & $= 3$\\
\end{tabular}

Additionally, we need that $q$ is a prime with the property $q\equiv 1\mod 4$.
\<close>

locale kyber_spec = module_spec "TYPE ('a ::qr_spec)" "TYPE ('k::finite)" +
fixes type_a :: "('a :: qr_spec) itself"
  and type_k :: "('k ::finite) itself"
assumes q_mod_4: "q mod 4 = 1"
begin
end

end


theory StateEventSystems
imports EventSystems
begin

(* structural representation of state event systems *)
record ('s, 'e) SES_rec =
  S_SES ::  "'s set"
  s0_SES :: "'s"
  E_SES ::  "'e set"
  I_SES ::  "'e set"
  O_SES ::  "'e set"
  T_SES ::  "'s \<Rightarrow> 'e \<rightharpoonup> 's"

(* syntax abbreviations for SES_rec *)
abbreviation SESrecSSES :: "('s, 'e) SES_rec \<Rightarrow> 's set"
("S\<^bsub>_\<^esub>" [1000] 1000)
where
"S\<^bsub>SES\<^esub> \<equiv> (S_SES SES)"

abbreviation SESrecs0SES :: "('s, 'e) SES_rec \<Rightarrow> 's"
("s0\<^bsub>_\<^esub>" [1000] 1000)
where
"s0\<^bsub>SES\<^esub> \<equiv> (s0_SES SES)"

abbreviation SESrecESES :: "('s, 'e) SES_rec \<Rightarrow> 'e set"
("E\<^bsub>_\<^esub>" [1000] 1000)
where
"E\<^bsub>SES\<^esub> \<equiv> (E_SES SES)"

abbreviation SESrecISES :: "('s, 'e) SES_rec \<Rightarrow> 'e set"
("I\<^bsub>_\<^esub>" [1000] 1000)
where
"I\<^bsub>SES\<^esub> \<equiv> (I_SES SES)"

abbreviation SESrecOSES :: "('s, 'e) SES_rec \<Rightarrow> 'e set"
("O\<^bsub>_\<^esub>" [1000] 1000)
where
"O\<^bsub>SES\<^esub> \<equiv> (O_SES SES)"

abbreviation SESrecTSES :: "('s, 'e) SES_rec \<Rightarrow> ('s \<Rightarrow> 'e \<rightharpoonup> 's)"
("T\<^bsub>_\<^esub>" [1000] 1000)
where
"T\<^bsub>SES\<^esub> \<equiv> (T_SES SES)"

abbreviation TSESpred :: "'s \<Rightarrow> 'e \<Rightarrow> ('s, 'e) SES_rec \<Rightarrow> 's \<Rightarrow> bool"
("_ _\<longrightarrow>\<^bsub>_\<^esub> _" [100,100,100,100] 100)
where
"s e\<longrightarrow>\<^bsub>SES\<^esub> s' \<equiv> (T\<^bsub>SES\<^esub> s e = Some s')"

(* side conditions for state event systems *)
definition s0_is_state :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"s0_is_state SES \<equiv> s0\<^bsub>SES\<^esub> \<in> S\<^bsub>SES\<^esub>"

definition ses_inputs_are_events :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"ses_inputs_are_events SES \<equiv> I\<^bsub>SES\<^esub> \<subseteq> E\<^bsub>SES\<^esub>"

definition ses_outputs_are_events :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"ses_outputs_are_events SES \<equiv> O\<^bsub>SES\<^esub> \<subseteq> E\<^bsub>SES\<^esub>"

definition ses_inputs_outputs_disjoint :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"ses_inputs_outputs_disjoint SES \<equiv> I\<^bsub>SES\<^esub> \<inter> O\<^bsub>SES\<^esub> = {}"

definition correct_transition_relation :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"correct_transition_relation SES \<equiv>
 \<forall>x y z. x y\<longrightarrow>\<^bsub>SES\<^esub> z \<longrightarrow> ((x \<in> S\<^bsub>SES\<^esub>) \<and> (y \<in> E\<^bsub>SES\<^esub>) \<and> (z \<in> S\<^bsub>SES\<^esub>))"

(* State event systems are instances of SES_rec that satisfy SES_valid. *)
definition SES_valid :: "('s, 'e) SES_rec \<Rightarrow> bool"
where
"SES_valid SES \<equiv>
  s0_is_state SES \<and> ses_inputs_are_events SES
  \<and> ses_outputs_are_events SES \<and> ses_inputs_outputs_disjoint SES \<and>
  correct_transition_relation SES"

(* auxiliary definitions for state event systems *)

(* Paths in state event systems *)
primrec path :: "('s, 'e) SES_rec \<Rightarrow> 's \<Rightarrow> 'e list \<rightharpoonup> 's"
where
path_empt: "path SES s1 [] = (Some s1)" |
path_nonempt: "path SES s1 (e # t) =
  (if (\<exists>s2. s1 e\<longrightarrow>\<^bsub>SES\<^esub> s2)
  then (path SES (the (T\<^bsub>SES\<^esub> s1 e)) t)
  else None)"

abbreviation pathpred :: "'s \<Rightarrow> 'e list \<Rightarrow> ('s, 'e) SES_rec \<Rightarrow> 's \<Rightarrow> bool"
("_ _\<Longrightarrow>\<^bsub>_\<^esub> _" [100, 100, 100, 100] 100)
where
"s t\<Longrightarrow>\<^bsub>SES\<^esub> s' \<equiv> path SES s t = Some s'"

(* A state s is reachable in a state event system if there is a path from the initial state
of the state event system to state s. *)
definition reachable :: "('s, 'e) SES_rec \<Rightarrow> 's \<Rightarrow> bool"
where
"reachable SES s \<equiv> (\<exists>t. s0\<^bsub>SES\<^esub> t\<Longrightarrow>\<^bsub>SES\<^esub> s)"

(* A trace t is enabled in a state s if there is a path t from s to some other state.*)
definition enabled :: "('s, 'e) SES_rec \<Rightarrow> 's \<Rightarrow> 'e list \<Rightarrow> bool"
where
"enabled SES s t \<equiv> (\<exists>s'. s t\<Longrightarrow>\<^bsub>SES\<^esub> s')"

(* The set of possible traces in a state event system SES is the set of traces that are enabled in
the initial state of SES. *)
definition possible_traces :: "('s, 'e) SES_rec \<Rightarrow> ('e list) set"
where
"possible_traces SES \<equiv> {t. (enabled SES s0\<^bsub>SES\<^esub> t)}"

(* structural representation of the event system induced by a state event system *)
definition induceES :: "('s, 'e) SES_rec \<Rightarrow> 'e ES_rec"
where
"induceES SES \<equiv>
 \<lparr>
  E_ES = E\<^bsub>SES\<^esub>,
  I_ES = I\<^bsub>SES\<^esub>,
  O_ES  = O\<^bsub>SES\<^esub>,
  Tr_ES = possible_traces SES
 \<rparr>"
(* auxiliary lemmas for state event systems *)

(* If some event sequence is not enabled in a state,
  then it will not become possible by appending events. *)
lemma none_remains_none : "\<And> s e. (path SES s t) = None
  \<Longrightarrow> (path SES s (t @ [e])) = None"
  by (induct t, auto)

(* If some event sequence t is enabled in a state s in which
 some event e is not enabled, then the event sequence
 obtained by appending e to t is not enabled in s. *)
lemma path_trans_single_neg: "\<And> s1. \<lbrakk>s1 t\<Longrightarrow>\<^bsub>SES\<^esub> s2; \<not> (s2 e\<longrightarrow>\<^bsub>SES\<^esub> sn)\<rbrakk>
     \<Longrightarrow> \<not> (s1 (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> sn)"
    by (induct t, auto)

(* If the event sequence t:e is enabled in some state, then
  the event sequence t is also enabled and results in some state t' *)
lemma path_split_single: "s1 (t@[e])\<Longrightarrow>\<^bsub>SES\<^esub> sn
  \<Longrightarrow> \<exists>s'. s1 t\<Longrightarrow>\<^bsub>SES\<^esub> s'  \<and> s' e\<longrightarrow>\<^bsub>SES\<^esub> sn"
  by (cases "path SES s1 t", simp add: none_remains_none,
    simp, rule ccontr, auto simp add: path_trans_single_neg)

(* If an event sequence results in a state s', from which the event e results in sn,
  then the combined event sequence also results in sn *)
lemma path_trans_single: "\<And>s. \<lbrakk> s t\<Longrightarrow>\<^bsub>SES\<^esub> s'; s' e\<longrightarrow>\<^bsub>SES\<^esub> sn \<rbrakk>
  \<Longrightarrow> s (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
proof (induct t)
  case Nil thus ?case by auto
next
  case (Cons a t) thus ?case
  proof -
    from Cons obtain s1' where trans_s_a_s1': "s a\<longrightarrow>\<^bsub>SES\<^esub> s1'"
      by (simp, split if_split_asm, auto)
    with Cons have "s1' (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by auto
    with trans_s_a_s1' show ?thesis
      by auto
  qed
qed

(* We can split a path from s1 to sn via the event sequence t1:t2
 into two paths from s1 to s2 via t1 and from s2 to sn via t2  *)
lemma path_split: "\<And> sn. \<lbrakk> s1 (t1 @ t2)\<Longrightarrow>\<^bsub>SES\<^esub> sn \<rbrakk>
  \<Longrightarrow> (\<exists>s2. (s1 t1\<Longrightarrow>\<^bsub>SES\<^esub> s2 \<and> s2 t2\<Longrightarrow>\<^bsub>SES\<^esub> sn))"
proof (induct t2 rule: rev_induct)
  case Nil thus ?case by auto
next
  case (snoc a t) thus ?case
  proof -
    from snoc have "s1 (t1 @ t @ [a])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by auto
    hence "\<exists>sn'. s1 (t1 @ t)\<Longrightarrow>\<^bsub>SES\<^esub> sn' \<and> sn' a\<longrightarrow>\<^bsub>SES\<^esub> sn"
      by (simp add: path_split_single)
    then obtain sn' where path_t1_t_trans_a:
      "s1 (t1 @ t)\<Longrightarrow>\<^bsub>SES\<^esub> sn' \<and> sn' a\<longrightarrow>\<^bsub>SES\<^esub> sn"
      by auto
    with snoc obtain s2 where path_t1_t:
      "s1 t1\<Longrightarrow>\<^bsub>SES\<^esub> s2 \<and> s2 t\<Longrightarrow>\<^bsub>SES\<^esub> sn'"
      by auto
    with path_t1_t_trans_a have "s2 (t @ [a])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by (simp add: path_trans_single)
    with path_t1_t show ?thesis by auto
  qed
qed

(* Two paths can be concatenated. *)
lemma path_trans:
"\<And>sn. \<lbrakk> s1 l1\<Longrightarrow>\<^bsub>SES\<^esub> s2; s2 l2\<Longrightarrow>\<^bsub>SES\<^esub> sn \<rbrakk> \<Longrightarrow> s1 (l1 @ l2)\<Longrightarrow>\<^bsub>SES\<^esub> sn"
proof (induct l2 rule: rev_induct)
  case Nil thus ?case by auto
next
  case (snoc a l) thus ?case
  proof -
    assume path_l1: "s1 l1\<Longrightarrow>\<^bsub>SES\<^esub> s2"
    assume "s2 (l@[a])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
    hence "\<exists>sn'. s2 l\<Longrightarrow>\<^bsub>SES\<^esub> sn' \<and> sn' [a]\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by (simp add: path_split del: path_nonempt)
    then obtain sn' where path_l_a: "s2 l\<Longrightarrow>\<^bsub>SES\<^esub> sn' \<and> sn' [a]\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by auto
    with snoc path_l1 have path_l1_l: "s1 (l1@l)\<Longrightarrow>\<^bsub>SES\<^esub> sn'"
      by auto
    with path_l_a have "sn' a\<longrightarrow>\<^bsub>SES\<^esub> sn"
      by (simp, split if_split_asm, auto)
    with path_l1_l show "s1 (l1 @ l @ [a])\<Longrightarrow>\<^bsub>SES\<^esub> sn"
      by (subst append_assoc[symmetric], rule_tac s'="sn'" in path_trans_single, auto)
  qed
qed

(* The prefix of an enabled trace is also enabled. (This lemma cuts of the last element.) *)
lemma enabledPrefixSingle : "\<lbrakk> enabled SES s (t@[e]) \<rbrakk> \<Longrightarrow> enabled SES s t"
unfolding enabled_def
proof -
  assume ass: "\<exists>s'. s (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> s'"
  from ass obtain s' where "s (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> s'" ..
  hence "\<exists>t'. (s t\<Longrightarrow>\<^bsub>SES\<^esub> t') \<and> (t' e\<longrightarrow>\<^bsub>SES\<^esub> s')"
    by (rule path_split_single)
  then obtain t' where "s t\<Longrightarrow>\<^bsub>SES\<^esub> t'"
    by (auto)
  thus "\<exists>s'. s t\<Longrightarrow>\<^bsub>SES\<^esub> s'" ..
qed

(* The prefix of an enabled trace is also enabled.
    (This lemma cuts of a suffix trace.) *)
lemma enabledPrefix : "\<lbrakk> enabled SES s (t1 @ t2) \<rbrakk> \<Longrightarrow> enabled SES s t1"
  unfolding enabled_def
proof -
  assume ass: "\<exists>s'. s (t1 @ t2)\<Longrightarrow>\<^bsub>SES\<^esub> s'"
  from ass obtain s' where "s (t1 @ t2)\<Longrightarrow>\<^bsub>SES\<^esub> s'" ..
  hence "\<exists>t. (s t1\<Longrightarrow>\<^bsub>SES\<^esub> t \<and> t t2\<Longrightarrow>\<^bsub>SES\<^esub> s')"
    by (rule path_split)
  then obtain t where "s t1\<Longrightarrow>\<^bsub>SES\<^esub> t"
    by (auto)
  then show "\<exists>s'. s t1\<Longrightarrow>\<^bsub>SES\<^esub> s'" ..
qed

(* The last element of an enabled trace makes a transition between two states. *)
lemma enabledPrefixSingleFinalStep : "\<lbrakk> enabled SES s (t@[e]) \<rbrakk> \<Longrightarrow> \<exists> t' t''. t' e\<longrightarrow>\<^bsub>SES\<^esub> t''"
  unfolding enabled_def
proof -
  assume ass: "\<exists>s'. s (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> s'"
  from ass obtain s' where "s (t @ [e])\<Longrightarrow>\<^bsub>SES\<^esub> s'" ..
  hence "\<exists>t'. (s t\<Longrightarrow>\<^bsub>SES\<^esub> t')  \<and> (t' e\<longrightarrow>\<^bsub>SES\<^esub> s')"
    by (rule path_split_single)
  then obtain t' where "t' e\<longrightarrow>\<^bsub>SES\<^esub> s'"
    by (auto)
  thus "\<exists>t' t''. t' e\<longrightarrow>\<^bsub>SES\<^esub> t''"
    by (auto)
qed

(* applying induceES on a state event system yields an event system *)
lemma induceES_yields_ES:
  "SES_valid SES \<Longrightarrow> ES_valid (induceES SES)"
proof (simp add: SES_valid_def ES_valid_def, auto)
  assume SES_inputs_are_events: "ses_inputs_are_events SES"
  thus "es_inputs_are_events (induceES SES)"
    by (simp add: induceES_def ses_inputs_are_events_def es_inputs_are_events_def)
next
  assume SES_outputs_are_events: "ses_outputs_are_events SES"
  thus "es_outputs_are_events (induceES SES)"
    by (simp add: induceES_def ses_outputs_are_events_def es_outputs_are_events_def)
next
  assume SES_inputs_outputs_disjoint: "ses_inputs_outputs_disjoint SES"
  thus "es_inputs_outputs_disjoint (induceES SES)"
    by (simp add: induceES_def ses_inputs_outputs_disjoint_def es_inputs_outputs_disjoint_def)
next
  assume SES_correct_transition_relation: "correct_transition_relation SES"
  thus "traces_contain_events (induceES SES)"
      unfolding induceES_def traces_contain_events_def possible_traces_def
    proof (auto)
    fix l e
    assume enabled_l: "enabled SES s0\<^bsub>SES\<^esub> l"
    assume e_in_l: "e \<in> set l"
    from enabled_l e_in_l show "e \<in> E\<^bsub>SES\<^esub>"
    proof (induct l rule: rev_induct)
      case Nil
        assume e_in_empty_list: "e \<in> set []"
        hence f: "False"
          by (auto)
        thus ?case
          by auto
      next
      case (snoc a l)
      from snoc.prems have l_enabled: "enabled SES s0\<^bsub>SES\<^esub> l"
        by (simp add: enabledPrefixSingle)
        show ?case
          proof  (cases "e \<in> (set l)")
            from snoc.hyps l_enabled show "e \<in> set l \<Longrightarrow> e \<in> E\<^bsub>SES\<^esub>"
              by auto
            show "e \<notin> set l \<Longrightarrow> e \<in> E\<^bsub>SES\<^esub>"
              proof -
                assume "e \<notin> set l"
                with snoc.prems have e_eq_a : "e=a"
                  by auto
                from snoc.prems have "\<exists> t t'. t a\<longrightarrow>\<^bsub>SES\<^esub> t'"
                  by (auto simp add: enabledPrefixSingleFinalStep)
                then obtain t t' where "t a\<longrightarrow>\<^bsub>SES\<^esub> t'"
                  by auto
                with e_eq_a SES_correct_transition_relation show "e \<in> E\<^bsub>SES\<^esub>"
                  by (simp add: correct_transition_relation_def)
             qed
         qed
      qed
   qed
next
  show "traces_prefixclosed (induceES SES)"
    unfolding traces_prefixclosed_def prefixclosed_def induceES_def possible_traces_def prefix_def
    by (clarsimp simp add: enabledPrefix)
qed

end