(*
    File:        MonoInj.thy
    Time-stamp:  <2015-12-12T08:36:39Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory MonoInj imports Fixedpt Finite begin

definition mono_inj_pair :: "[i,i=>i,i=>i]=>o" where
 "mono_inj_pair(D,F,G) == (ALL x. x <= D --> G(F(x)) = x) &
        (ALL x y. x <= y & y <= D --> F(x) <= F(y)) &
        (ALL x y. x <= y & y <= F(D) --> G(x) <= G(y))"

lemma lfpI:
  assumes hmono: "bnd_mono(D,h)"
      and lb: "!!X. [| X <= D;  h(X) <= X |] ==> A <= X"
      and pfp: "h(A) <= A"
  shows "lfp(D,h) = A"
apply (rule equalityI)
apply (rule lfp_lowerbound)
apply (rule pfp)
apply (rule lb)
apply (rule subset_refl)
apply (rule hmono [THEN bnd_monoD1])
apply (rule lfp_greatest)
apply (rule hmono [THEN bnd_monoD1])
apply (rule lb)
apply assumption+
done

lemma mono_inj_pairI:
    "[| !!x. x <= D ==> G(F(x)) = x;
        !!x y. [| x <= y; y <= D |] ==> F(x) <= F(y);
        !!x y. [| x <= y; y <= F(D) |] ==> G(x) <= G(y)
    |] ==> mono_inj_pair(D,F,G)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD1:
    "[| mono_inj_pair(D,F,G); x <= D |] ==> G(F(x)) = x"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD2:
    "[| mono_inj_pair(D,F,G); x <= y; y <= D |] ==> F(x) <= F(y)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD3:
    "[| mono_inj_pair(D,F,G); x <= y; y <= F(D) |] ==> G(x) <= G(y)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pair_lfp_subset:
    "mono_inj_pair(D,F,G) ==> F(lfp(D,h)) <= F(D)"
apply (erule mono_inj_pairD2)
apply (rule lfp_subset)
apply (rule subset_refl)
done

lemma mono_inj_pair_bnd_mono:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "bnd_mono(F(D), %X. F(h(G(X))))"
apply (rule bnd_monoI)
apply (rule hinj [THEN mono_inj_pairD1, THEN ssubst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hmono [THEN bnd_monoD1])
apply (rule subset_refl)
apply (frule_tac x="X" in hinj [THEN mono_inj_pairD3])
apply (rule subset_refl)
apply (subst (asm) hinj [THEN mono_inj_pairD1])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hmono [THEN bnd_monoD2])
apply (rule hinj [THEN mono_inj_pairD3])
apply assumption+
apply (rule hmono [THEN bnd_mono_subset])
apply assumption
done

lemma mono_inj_pair_pre_fixedpt:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "F(h(G(F(lfp(D,h))))) <= F(lfp(D,h))"
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hinj [THEN mono_inj_pairD1, THEN ssubst])
apply (rule lfp_subset)
apply (rule hmono [THEN lfp_lemma2])
apply (rule lfp_subset)
done

lemma mono_inj_pair_lfp_lemma1:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
      and dom_x: "X <= F(D)"
      and x_is_pfp: "F(h(G(X))) <= X"
    shows "h(h(G(X))) <= h(G(X))"
apply (subgoal_tac "G(X) <= D")
prefer 2
apply (rule hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule dom_x)
apply (rule subset_refl)
apply (rule_tac P="%x. h(x) <= h(G(X))" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule hmono [THEN bnd_mono_subset])
apply assumption
apply (rule hmono [THEN bnd_monoD2])
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule x_is_pfp)
apply (rule dom_x)
apply assumption
done

lemma mono_inj_pair_lfp_lowerbound:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
      and dom_x: "X <= F(D)"
      and x_is_pfp: "F(h(G(X))) <= X"
    shows "F(lfp(D,h)) <= X"
apply (subgoal_tac "h(G(X)) <= D")
prefer 2
apply (rule hmono [THEN bnd_mono_subset])
apply (rule hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule dom_x)
apply (rule subset_refl)
apply (rule subset_trans [OF _ x_is_pfp])
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule lfp_lowerbound)
apply (rule hinj [THEN mono_inj_pair_lfp_lemma1])
apply (rule hmono)
apply ((rule dom_x x_is_pfp) | assumption)+
done

lemma mono_inj_pair_lfp_eq:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "lfp(F(D), %X. F(h(G(X)))) = F(lfp(D,h))"
apply (rule lfpI)
apply (rule mono_inj_pair_bnd_mono [OF hinj hmono])
apply (rule mono_inj_pair_lfp_lowerbound [OF hinj hmono])
apply assumption+
apply (rule mono_inj_pair_pre_fixedpt [OF hinj hmono])
done

lemma trivial_mono_inj_pair:
    "mono_inj_pair(D, %x. x, %x. x)"
apply (rule mono_inj_pairI)
apply (rule refl)
apply assumption+
done

lemma Pow_Union_mono_inj_pair:
    "mono_inj_pair(D, Pow, Union)"
apply (rule mono_inj_pairI)
apply (rule Union_Pow_eq)
apply (rule Pow_mono)
apply assumption
apply (rule Union_mono)
apply assumption
done

lemma Prod_range_mono_inj_pair:
    "b: B ==> mono_inj_pair(D, %X. B * X, range)"
apply (rule mono_inj_pairI)
apply (erule range_of_prod)
apply (rule Sigma_mono)
apply (rule_tac [3] range_mono)
apply (rule subset_refl)
apply assumption+
done

lemma Prod_domain_mono_inj_pair:
    "b: B ==> mono_inj_pair(D, %X. X * B, domain)"
apply (rule mono_inj_pairI)
apply (erule domain_of_prod)
apply (rule Sigma_mono)
apply (rule_tac [3] domain_mono)
apply ((rule subset_refl) | assumption)+
done

end


(*  Title:      HOL/Induct/SList.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory

This theory is strictly of historical interest. It illustrates how
recursive datatypes can be constructed in higher-order logic from
first principles. Isabelle's datatype package automates a
construction of this sort.

Enriched theory of lists; mutual indirect recursive data-types.

Definition of type 'a list (strict lists) by a least fixed point

We use          list(A) == lfp(%Z. {NUMB(0)} <+> A <*> Z)
and not         list    == lfp(%Z. {NUMB(0)} <+> range(Leaf) <*> Z)

so that list can serve as a "functor" for defining other recursive types.

This enables the conservative construction of mutual recursive datatypes
such as

datatype 'a m = Node 'a * 'a m list
*)

section {* Extended List Theory (old) *}

theory SList
imports Sexp
begin

(*Hilbert_Choice is needed for the function "inv"*)

(* *********************************************************************** *)
(*                                                                         *)
(* Building up data type                                                   *)
(*                                                                         *)
(* *********************************************************************** *)

(* Defining the Concrete Constructors *)
definition
  NIL  :: "'a item" where
  "NIL = In0(Numb(0))"

definition
  CONS :: "['a item, 'a item] => 'a item" where
  "CONS M N = In1(Scons M N)"

inductive_set
  list :: "'a item set => 'a item set"
  for A :: "'a item set"
  where
    NIL_I:  "NIL: list A"
  | CONS_I: "[| a: A;  M: list A |] ==> CONS a M : list A"

definition "List = list (range Leaf)"

typedef 'a list = "List :: 'a item set"
  morphisms Rep_List Abs_List
  unfolding List_def by (blast intro: list.NIL_I)

abbreviation "Case == Old_Datatype.Case"
abbreviation "Split == Old_Datatype.Split"

definition
  List_case :: "['b, ['a item, 'a item]=>'b, 'a item] => 'b" where
  "List_case c d = Case(%x. c)(Split(d))"

definition
  List_rec  :: "['a item, 'b, ['a item, 'a item, 'b]=>'b] => 'b" where
  "List_rec M c d = wfrec (pred_sexp^+)
                           (%g. List_case c (%x y. d x y (g y))) M"

(* *********************************************************************** *)
(*                                                                         *)
(* Abstracting data type                                                   *)
(*                                                                         *)
(* *********************************************************************** *)

(*Declaring the abstract list constructors*)

no_translations
  "[x, xs]" == "x#[xs]"
  "[x]" == "x#[]"
no_notation
  Nil  ("[]") and
  Cons (infixr "#" 65)

definition
  Nil       :: "'a list"                               ("[]") where
   "Nil  = Abs_List(NIL)"

definition
  "Cons"       :: "['a, 'a list] => 'a list"           (infixr "#" 65) where
   "x#xs = Abs_List(CONS (Leaf x)(Rep_List xs))"

definition
  (* list Recursion -- the trancl is Essential; see list.ML *)
  list_rec  :: "['a list, 'b, ['a, 'a list, 'b]=>'b] => 'b" where
   "list_rec l c d =
      List_rec(Rep_List l) c (%x y r. d(inv Leaf x)(Abs_List y) r)"

definition
  list_case :: "['b, ['a, 'a list]=>'b, 'a list] => 'b" where
   "list_case a f xs = list_rec xs a (%x xs r. f x xs)"

(* list Enumeration *)
translations
  "[x, xs]" == "x#[xs]"
  "[x]"     == "x#[]"

  "case xs of [] => a | y#ys => b" == "CONST list_case(a, %y ys. b, xs)"

(* *********************************************************************** *)
(*                                                                         *)
(* Generalized Map Functionals                                             *)
(*                                                                         *)
(* *********************************************************************** *)

(* Generalized Map Functionals *)

definition
  Rep_map   :: "('b => 'a item) => ('b list => 'a item)" where
   "Rep_map f xs = list_rec xs  NIL(%x l r. CONS(f x) r)"

definition
  Abs_map   :: "('a item => 'b) => 'a item => 'b list" where
   "Abs_map g M  = List_rec M Nil (%N L r. g(N)#r)"

definition
  map       :: "('a=>'b) => ('a list => 'b list)" where
  "map f xs = list_rec xs [] (%x l r. f(x)#r)"

primrec take :: "['a list,nat] => 'a list" where
  take_0:  "take xs 0 = []"
| take_Suc: "take xs (Suc n) = list_case [] (%x l. x # take l n) xs"

lemma ListI: "x : list (range Leaf) ==> x : List"
by (simp add: List_def)

lemma ListD: "x : List ==> x : list (range Leaf)"
by (simp add: List_def)

lemma list_unfold: "list(A) = usum {Numb(0)} (uprod A (list(A)))"
  by (fast intro!: list.intros [unfolded NIL_def CONS_def]
           elim: list.cases [unfolded NIL_def CONS_def])

(*This justifies using list in other recursive type definitions*)
lemma list_mono: "A<=B ==> list(A) <= list(B)"
apply (rule subsetI)
apply (erule list.induct)
apply (auto intro!: list.intros)
done

(*Type checking -- list creates well-founded sets*)
lemma list_sexp: "list(sexp) <= sexp"
apply (rule subsetI)
apply (erule list.induct)
apply (unfold NIL_def CONS_def)
apply (auto intro: sexp.intros sexp_In0I sexp_In1I)
done

(* A <= sexp ==> list(A) <= sexp *)
lemmas list_subset_sexp = subset_trans [OF list_mono list_sexp]

(*Induction for the type 'a list *)
lemma list_induct:
    "[| P(Nil);
        !!x xs. P(xs) ==> P(x # xs) |]  ==> P(l)"
apply (unfold Nil_def Cons_def)
apply (rule Rep_List_inverse [THEN subst])
(*types force good instantiation*)
apply (rule Rep_List [unfolded List_def, THEN list.induct], simp)
apply (erule Abs_List_inverse [unfolded List_def, THEN subst], blast)
done

(*** Isomorphisms ***)

lemma inj_on_Abs_list: "inj_on Abs_List (list(range Leaf))"
apply (rule inj_on_inverseI)
apply (erule Abs_List_inverse [unfolded List_def])
done

(** Distinctness of constructors **)

lemma CONS_not_NIL [iff]: "CONS M N ~= NIL"
by (simp add: NIL_def CONS_def)

lemmas NIL_not_CONS [iff] = CONS_not_NIL [THEN not_sym]
lemmas CONS_neq_NIL = CONS_not_NIL [THEN notE]
lemmas NIL_neq_CONS = sym [THEN CONS_neq_NIL]

lemma Cons_not_Nil [iff]: "x # xs ~= Nil"
apply (unfold Nil_def Cons_def)
apply (rule CONS_not_NIL [THEN inj_on_Abs_list [THEN inj_on_contraD]])
apply (simp_all add: list.intros rangeI Rep_List [unfolded List_def])
done

lemmas Nil_not_Cons = Cons_not_Nil [THEN not_sym]
declare Nil_not_Cons [iff]
lemmas Cons_neq_Nil = Cons_not_Nil [THEN notE]
lemmas Nil_neq_Cons = sym [THEN Cons_neq_Nil]

(** Injectiveness of CONS and Cons **)

lemma CONS_CONS_eq [iff]: "(CONS K M)=(CONS L N) = (K=L & M=N)"
by (simp add: CONS_def)

(*For reasoning about abstract list constructors*)
declare Rep_List [THEN ListD, intro] ListI [intro]
declare list.intros [intro,simp]
declare Leaf_inject [dest!]

lemma Cons_Cons_eq [iff]: "(x#xs=y#ys) = (x=y & xs=ys)"
apply (simp add: Cons_def)
apply (subst Abs_List_inject)
apply (auto simp add: Rep_List_inject)
done

lemmas Cons_inject2 = Cons_Cons_eq [THEN iffD1, THEN conjE]

lemma CONS_D: "CONS M N: list(A) ==> M: A & N: list(A)"
  by (induct L == "CONS M N" rule: list.induct) auto

lemma sexp_CONS_D: "CONS M N: sexp ==> M: sexp & N: sexp"
apply (simp add: CONS_def In1_def)
apply (fast dest!: Scons_D)
done

(*Reasoning about constructors and their freeness*)

lemma not_CONS_self: "N: list(A) ==> !M. N ~= CONS M N"
apply (erule list.induct) apply simp_all done

lemma not_Cons_self2: "\<forall>x. l ~= x#l"
by (induct l rule: list_induct) simp_all

lemma neq_Nil_conv2: "(xs ~= []) = (\<exists>y ys. xs = y#ys)"
by (induct xs rule: list_induct) auto

(** Conversion rules for List_case: case analysis operator **)

lemma List_case_NIL [simp]: "List_case c h NIL = c"
by (simp add: List_case_def NIL_def)

lemma List_case_CONS [simp]: "List_case c h (CONS M N) = h M N"
by (simp add: List_case_def CONS_def)

(*** List_rec -- by wf recursion on pred_sexp ***)

(* The trancl(pred_sexp) is essential because pred_sexp_CONS_I1,2 would not
   hold if pred_sexp^+ were changed to pred_sexp. *)

lemma List_rec_unfold_lemma:
     "(%M. List_rec M c d) ==
      wfrec (pred_sexp^+) (%g. List_case c (%x y. d x y (g y)))"
by (simp add: List_rec_def)

lemmas List_rec_unfold =
    def_wfrec [OF List_rec_unfold_lemma wf_pred_sexp [THEN wf_trancl]]

(** pred_sexp lemmas **)

lemma pred_sexp_CONS_I1:
    "[| M: sexp;  N: sexp |] ==> (M, CONS M N) : pred_sexp^+"
by (simp add: CONS_def In1_def)

lemma pred_sexp_CONS_I2:
    "[| M: sexp;  N: sexp |] ==> (N, CONS M N) : pred_sexp^+"
by (simp add: CONS_def In1_def)

lemma pred_sexp_CONS_D:
    "(CONS M1 M2, N) : pred_sexp^+ ==>
     (M1,N) : pred_sexp^+ & (M2,N) : pred_sexp^+"
apply (frule pred_sexp_subset_Sigma [THEN trancl_subset_Sigma, THEN subsetD])
apply (blast dest!: sexp_CONS_D intro: pred_sexp_CONS_I1 pred_sexp_CONS_I2
                    trans_trancl [THEN transD])
done

(** Conversion rules for List_rec **)

lemma List_rec_NIL [simp]: "List_rec NIL c h = c"
apply (rule List_rec_unfold [THEN trans])
apply (simp add: List_case_NIL)
done

lemma List_rec_CONS [simp]:
     "[| M: sexp;  N: sexp |]
      ==> List_rec (CONS M N) c h = h M N (List_rec N c h)"
apply (rule List_rec_unfold [THEN trans])
apply (simp add: pred_sexp_CONS_I2)
done

(*** list_rec -- by List_rec ***)

lemmas Rep_List_in_sexp =
    subsetD [OF range_Leaf_subset_sexp [THEN list_subset_sexp]
                Rep_List [THEN ListD]]

lemma list_rec_Nil [simp]: "list_rec Nil c h = c"
by (simp add: list_rec_def ListI [THEN Abs_List_inverse] Nil_def)

lemma list_rec_Cons [simp]: "list_rec (a#l) c h = h a l (list_rec l c h)"
by (simp add: list_rec_def ListI [THEN Abs_List_inverse] Cons_def
              Rep_List_inverse Rep_List [THEN ListD] inj_Leaf Rep_List_in_sexp)

(*Type checking.  Useful?*)
lemma List_rec_type:
     "[| M: list(A);
         A<=sexp;
         c: C(NIL);
         !!x y r. [| x: A;  y: list(A);  r: C(y) |] ==> h x y r: C(CONS x y)
      |] ==> List_rec M c h : C(M :: 'a item)"
apply (erule list.induct, simp)
apply (insert list_subset_sexp)
apply (subst List_rec_CONS, blast+)
done

(** Generalized map functionals **)

lemma Rep_map_Nil [simp]: "Rep_map f Nil = NIL"
by (simp add: Rep_map_def)

lemma Rep_map_Cons [simp]:
    "Rep_map f(x#xs) = CONS(f x)(Rep_map f xs)"
by (simp add: Rep_map_def)

lemma Rep_map_type: "(!!x. f(x): A) ==> Rep_map f xs: list(A)"
apply (simp add: Rep_map_def)
apply (rule list_induct, auto)
done

lemma Abs_map_NIL [simp]: "Abs_map g NIL = Nil"
by (simp add: Abs_map_def)

lemma Abs_map_CONS [simp]:
    "[| M: sexp;  N: sexp |] ==> Abs_map g (CONS M N) = g(M) # Abs_map g N"
by (simp add: Abs_map_def)

(*Eases the use of primitive recursion.*)
lemma def_list_rec_NilCons:
    "[| !!xs. f(xs) = list_rec xs c h  |]
     ==> f [] = c & f(x#xs) = h x xs (f xs)"
by simp

lemma Abs_map_inverse:
     "[| M: list(A);  A<=sexp;  !!z. z: A ==> f(g(z)) = z |]
      ==> Rep_map f (Abs_map g M) = M"
apply (erule list.induct, simp_all)
apply (insert list_subset_sexp)
apply (subst Abs_map_CONS, blast)
apply blast
apply simp
done

(*Rep_map_inverse is obtained via Abs_Rep_map and map_ident*)

(** list_case **)

(* setting up rewrite sets *)

text{*Better to have a single theorem with a conjunctive conclusion.*}
declare def_list_rec_NilCons [OF list_case_def, simp]

(** list_case **)

lemma expand_list_case:
 "P(list_case a f xs) = ((xs=[] --> P a ) & (!y ys. xs=y#ys --> P(f y ys)))"
by (induct xs rule: list_induct) simp_all

(**** Function definitions ****)

declare def_list_rec_NilCons [OF map_def, simp]

(** The functional "map" and the generalized functionals **)

lemma Abs_Rep_map:
     "(!!x. f(x): sexp) ==>
        Abs_map g (Rep_map f xs) = map (%t. g(f(t))) xs"
apply (induct xs rule: list_induct)
apply (simp_all add: Rep_map_type list_sexp [THEN subsetD])
done

(** Additional mapping lemmas **)

lemma map_ident [simp]: "map(%x. x)(xs) = xs"
by (induct xs rule: list_induct) simp_all

lemma map_compose: "map(f o g)(xs) = map f (map g xs)"
apply (simp add: o_def)
apply (induct xs rule: list_induct)
apply simp_all
done

(** take **)

lemma take_Suc1 [simp]: "take [] (Suc x) = []"
by simp

lemma take_Suc2 [simp]: "take(a#xs)(Suc x) = a#take xs x"
by simp

lemma take_Nil [simp]: "take [] n = []"
by (induct n) simp_all

lemma take_take_eq [simp]: "\<forall>n. take (take xs n) n = take xs n"
apply (induct xs rule: list_induct)
apply simp_all
apply (rule allI)
apply (induct_tac n)
apply auto
done

end


(*  Title:      HOL/Library/Old_Datatype.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
*)

section \<open>Old Datatype package: constructing datatypes from Cartesian Products and Disjoint Sums\<close>

theory Old_Datatype
imports Main
begin

subsection \<open>The datatype universe\<close>

definition "Node = {p. \<exists>f x k. p = (f :: nat => 'b + nat, x ::'a + nat) \<and> f k = Inr 0}"

typedef ('a, 'b) node = "Node :: ((nat => 'b + nat) * ('a + nat)) set"
  morphisms Rep_Node Abs_Node
  unfolding Node_def by auto

text\<open>Datatypes will be represented by sets of type \<open>node\<close>\<close>

type_synonym 'a item        = "('a, unit) node set"
type_synonym ('a, 'b) dtree = "('a, 'b) node set"

definition Push :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
  (*crude "lists" of nats -- needed for the constructions*)
  where "Push == (%b h. case_nat b h)"

definition Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
  where "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"

(** operations on S-expressions -- sets of nodes **)

(*S-expression constructors*)
definition Atom :: "('a + nat) => ('a, 'b) dtree"
  where "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
definition Scons :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"

(*Leaf nodes, with arbitrary or nat labels*)
definition Leaf :: "'a => ('a, 'b) dtree"
  where "Leaf == Atom \<circ> Inl"
definition Numb :: "nat => ('a, 'b) dtree"
  where "Numb == Atom \<circ> Inr"

(*Injections of the "disjoint sum"*)
definition In0 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In0(M) == Scons (Numb 0) M"
definition In1 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In1(M) == Scons (Numb 1) M"

(*Function spaces*)
definition Lim :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
  where "Lim f == \<Union>{z. \<exists>x. z = Push_Node (Inl x) ` (f x)}"

(*the set of nodes with depth less than k*)
definition ndepth :: "('a, 'b) node => nat"
  where "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
definition ntrunc :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "ntrunc k N == {n. n\<in>N \<and> ndepth(n)<k}"

(*products and sums for the "universe"*)
definition uprod :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "uprod A B == UN x:A. UN y:B. { Scons x y }"
definition usum :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "usum A B == In0`A Un In1`B"

(*the corresponding eliminators*)
definition Split :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Split c M == THE u. \<exists>x y. M = Scons x y \<and> u = c x y"

definition Case :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Case c d M == THE u. (\<exists>x . M = In0(x) \<and> u = c(x)) \<or> (\<exists>y . M = In1(y) \<and> u = d(y))"

(** equality for the "universe" **)

definition dprod :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"

definition dsum :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un (UN (y,y'):s. {(In1(y),In1(y'))})"

lemma apfst_convE:
    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R
     |] ==> R"
by (force simp add: apfst_def)

(** Push -- an injection, analogous to Cons on lists **)

lemma Push_inject1: "Push i f = Push j g  ==> i=j"
apply (simp add: Push_def fun_eq_iff)
apply (drule_tac x=0 in spec, simp)
done

lemma Push_inject2: "Push i f = Push j g  ==> f=g"
apply (auto simp add: Push_def fun_eq_iff)
apply (drule_tac x="Suc x" in spec, simp)
done

lemma Push_inject:
    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P |] ==> P"
by (blast dest: Push_inject1 Push_inject2)

lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"
by (auto simp add: Push_def fun_eq_iff split: nat.split_asm)

lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1]

(*** Introduction rules for Node ***)

lemma Node_K0_I: "(\<lambda>k. Inr 0, a) \<in> Node"
by (simp add: Node_def)

lemma Node_Push_I: "p \<in> Node \<Longrightarrow> apfst (Push i) p \<in> Node"
apply (simp add: Node_def Push_def)
apply (fast intro!: apfst_conv nat.case(2)[THEN trans])
done

subsection\<open>Freeness: Distinctness of Constructors\<close>

(** Scons vs Atom **)

lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
unfolding Atom_def Scons_def Push_Node_def One_nat_def
by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]
         dest!: Abs_Node_inj
         elim!: apfst_convE sym [THEN Push_neq_K0])

lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym]

(*** Injectiveness ***)

(** Atomic nodes **)

lemma inj_Atom: "inj(Atom)"
apply (simp add: Atom_def)
apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)
done
lemmas Atom_inject = inj_Atom [THEN injD]

lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"
by (blast dest!: Atom_inject)

lemma inj_Leaf: "inj(Leaf)"
apply (simp add: Leaf_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inl_inject])
done

lemmas Leaf_inject [dest!] = inj_Leaf [THEN injD]

lemma inj_Numb: "inj(Numb)"
apply (simp add: Numb_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inr_inject])
done

lemmas Numb_inject [dest!] = inj_Numb [THEN injD]

(** Injectiveness of Push_Node **)

lemma Push_Node_inject:
    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P
     |] ==> P"
apply (simp add: Push_Node_def)
apply (erule Abs_Node_inj [THEN apfst_convE])
apply (rule Rep_Node [THEN Node_Push_I])+
apply (erule sym [THEN apfst_convE])
apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)
done

(** Injectiveness of Scons **)

lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma1)
done

lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma2)
done

lemma Scons_inject:
    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P |] ==> P"
by (iprover dest: Scons_inject1 Scons_inject2)

lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' \<and> N=N')"
by (blast elim!: Scons_inject)

(*** Distinctness involving Leaf and Numb ***)

(** Scons vs Leaf **)

lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
unfolding Leaf_def o_def by (rule Scons_not_Atom)

lemmas Leaf_not_Scons  [iff] = Scons_not_Leaf [THEN not_sym]

(** Scons vs Numb **)

lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
unfolding Numb_def o_def by (rule Scons_not_Atom)

lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym]

(** Leaf vs Numb **)

lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"
by (simp add: Leaf_def Numb_def)

lemmas Numb_not_Leaf [iff] = Leaf_not_Numb [THEN not_sym]

(*** ndepth -- the depth of a node ***)

lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"
by (simp add: ndepth_def  Node_K0_I [THEN Abs_Node_inverse] Least_equality)

lemma ndepth_Push_Node_aux:
     "case_nat (Inr (Suc i)) f k = Inr 0 \<longrightarrow> Suc(LEAST x. f x = Inr 0) \<le> k"
apply (induct_tac "k", auto)
apply (erule Least_le)
done

lemma ndepth_Push_Node:
    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"
apply (insert Rep_Node [of n, unfolded Node_def])
apply (auto simp add: ndepth_def Push_Node_def
                 Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])
apply (rule Least_equality)
apply (auto simp add: Push_def ndepth_Push_Node_aux)
apply (erule LeastI)
done

(*** ntrunc applied to the various node sets ***)

lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
by (simp add: ntrunc_def)

lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"
by (auto simp add: Atom_def ntrunc_def ndepth_K0)

lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
unfolding Leaf_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
unfolding Numb_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Scons [simp]:
    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
unfolding Scons_def ntrunc_def One_nat_def
by (auto simp add: ndepth_Push_Node)

(** Injection nodes **)

lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
apply (simp add: In0_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"
by (simp add: In0_def)

lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
apply (simp add: In1_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"
by (simp add: In1_def)

subsection\<open>Set Constructions\<close>

(*** Cartesian Product ***)

lemma uprodI [intro!]: "\<lbrakk>M\<in>A; N\<in>B\<rbrakk> \<Longrightarrow> Scons M N \<in> uprod A B"
by (simp add: uprod_def)

(*The general elimination rule*)
lemma uprodE [elim!]:
    "\<lbrakk>c \<in> uprod A B;
        \<And>x y. \<lbrakk>x \<in> A; y \<in> B; c = Scons x y\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*Elimination of a pair -- introduces no eigenvariables*)
lemma uprodE2: "\<lbrakk>Scons M N \<in> uprod A B; \<lbrakk>M \<in> A; N \<in> B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*** Disjoint Sum ***)

lemma usum_In0I [intro]: "M \<in> A \<Longrightarrow> In0(M) \<in> usum A B"
by (simp add: usum_def)

lemma usum_In1I [intro]: "N \<in> B \<Longrightarrow> In1(N) \<in> usum A B"
by (simp add: usum_def)

lemma usumE [elim!]:
    "\<lbrakk>u \<in> usum A B;
        \<And>x. \<lbrakk>x \<in> A; u=In0(x)\<rbrakk> \<Longrightarrow> P;
        \<And>y. \<lbrakk>y \<in> B; u=In1(y)\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: usum_def)

(** Injection **)

lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
unfolding In0_def In1_def One_nat_def by auto

lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym]

lemma In0_inject: "In0(M) = In0(N) ==>  M=N"
by (simp add: In0_def)

lemma In1_inject: "In1(M) = In1(N) ==>  M=N"
by (simp add: In1_def)

lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"
by (blast dest!: In0_inject)

lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"
by (blast dest!: In1_inject)

lemma inj_In0: "inj In0"
by (blast intro!: inj_onI)

lemma inj_In1: "inj In1"
by (blast intro!: inj_onI)

(*** Function spaces ***)

lemma Lim_inject: "Lim f = Lim g ==> f = g"
apply (simp add: Lim_def)
apply (rule ext)
apply (blast elim!: Push_Node_inject)
done

(*** proving equality of sets and functions using ntrunc ***)

lemma ntrunc_subsetI: "ntrunc k M <= M"
by (auto simp add: ntrunc_def)

lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"
by (auto simp add: ntrunc_def)

(*A generalized form of the take-lemma*)
lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"
apply (rule equalityI)
apply (rule_tac [!] ntrunc_subsetD)
apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto)
done

lemma ntrunc_o_equality:
    "[| !!k. (ntrunc(k) \<circ> h1) = (ntrunc(k) \<circ> h2) |] ==> h1=h2"
apply (rule ntrunc_equality [THEN ext])
apply (simp add: fun_eq_iff)
done

(*** Monotonicity ***)

lemma uprod_mono: "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'"
by (simp add: uprod_def, blast)

lemma usum_mono: "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'"
by (simp add: usum_def, blast)

lemma Scons_mono: "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'"
by (simp add: Scons_def, blast)

lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
by (simp add: In0_def Scons_mono)

lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
by (simp add: In1_def Scons_mono)

(*** Split and Case ***)

lemma Split [simp]: "Split c (Scons M N) = c M N"
by (simp add: Split_def)

lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"
by (simp add: Case_def)

lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"
by (simp add: Case_def)

(**** UN x. B(x) rules ****)

lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"
by (simp add: ntrunc_def, blast)

lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"
by (simp add: Scons_def, blast)

lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"
by (simp add: Scons_def, blast)

lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"
by (simp add: In0_def Scons_UN1_y)

lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"
by (simp add: In1_def Scons_UN1_y)

(*** Equality for Cartesian Product ***)

lemma dprodI [intro!]:
    "\<lbrakk>(M,M') \<in> r; (N,N') \<in> s\<rbrakk> \<Longrightarrow> (Scons M N, Scons M' N') \<in> dprod r s"
by (auto simp add: dprod_def)

(*The general elimination rule*)
lemma dprodE [elim!]:
    "\<lbrakk>c \<in> dprod r s;
        \<And>x y x' y'. \<lbrakk>(x,x') \<in> r; (y,y') \<in> s;
                        c = (Scons x y, Scons x' y')\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dprod_def)

(*** Equality for Disjoint Sum ***)

lemma dsum_In0I [intro]: "(M,M') \<in> r \<Longrightarrow> (In0(M), In0(M')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsum_In1I [intro]: "(N,N') \<in> s \<Longrightarrow> (In1(N), In1(N')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsumE [elim!]:
    "\<lbrakk>w \<in> dsum r s;
        \<And>x x'. \<lbrakk> (x,x') \<in> r;  w = (In0(x), In0(x')) \<rbrakk> \<Longrightarrow> P;
        \<And>y y'. \<lbrakk> (y,y') \<in> s;  w = (In1(y), In1(y')) \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dsum_def)

(*** Monotonicity ***)

lemma dprod_mono: "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'"
by blast

lemma dsum_mono: "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'"
by blast

(*** Bounding theorems ***)

lemma dprod_Sigma: "(dprod (A \<times> B) (C \<times> D)) <= (uprod A C) \<times> (uprod B D)"
by blast

lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma]

(*Dependent version*)
lemma dprod_subset_Sigma2:
    "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
by auto

lemma dsum_Sigma: "(dsum (A \<times> B) (C \<times> D)) <= (usum A C) \<times> (usum B D)"
by blast

lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma]

(*** Domain theorems ***)

lemma Domain_dprod [simp]: "Domain (dprod r s) = uprod (Domain r) (Domain s)"
  by auto

lemma Domain_dsum [simp]: "Domain (dsum r s) = usum (Domain r) (Domain s)"
  by auto

text \<open>hides popular names\<close>
hide_type (open) node item
hide_const (open) Push Node Atom Leaf Numb Lim Split Case

ML_file \<open>~~/src/HOL/Tools/Old_Datatype/old_datatype.ML\<close>

end


(*  Title:       Executable Transitive Closures
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2012 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>A work-list algorithm for reflexive-transitive closures\<close>

theory RTrancl
imports "Regular-Sets.Regexp_Method"
begin

text \<open>In previous work \cite{rtrancl_fin} we described a generic work-list
algorithm to compute reflexive-transitive closures for \emph{finite} relations:
given a finite relation $r$, it computed $@{term "r^*"}$.

In the following, we develop a similar, though different work-list algorithm
for reflexive-transitive closures, it computes @{term "r^* `` init"} for a given
relation $r$ and finite set @{term "init"}.
The main differences are that
\begin{itemize}
\item The relation $r$ does not have to be finite, only @{term "{b. (a,b) \<in> r^* }"} has to be finite
  for each $a$. Moreover, it is no longer required that $r$ is given
  explicitly as a list of pairs.
 Instead $r$ must be provided in the form of a function which computes
  for each element the
  set of one-step successors.
\item One can use a subsumption relation to indicate which elements to no longer
  have to be explored.
\end{itemize}

These new features have been essential to certify size-change termination
proofs \cite{sct} where the transitive closure of all size-change graphs
has to be computed. Here, the relation is size-change graph composition.
\begin{itemize}
\item Given an initial set of size-change graphs with $n$ arguments,
  there are roughly $N := 3^{n^2}$ many potential size-change graphs that
  have to be considered as left-hand sides of the composition relation.
  Since the composition relation is even larger than $N$,
  an explicit representation of the composition relation would have been
  too expensive. However, using the new algorithm the number of generated
  graphs is usually far below the theoretical upper bound.
\item Subsumption was useful to generate even fewer elements.
\end{itemize}

\<close>

subsection \<open>The generic case\<close>

text \<open>
  Let $r$ be some finite relation.

  We present a standard work-list algorithm to compute all elements
  that are reachable from some initial set.
  The algorithm is generic in the sense that the
  underlying data structure can freely be chosen, you just have to provide
  certain operations like union, selection of an element.

  In contrast to \cite{rtrancl_fin}, the algorithm does not demand that $r$ is finite
  and that $r$ is explicitly provided (e.g., as a list of pairs).
  Instead, it suffices that for every element, only finitely many
  elements can be reached via $r$, and $r$ can be provided as a function which
  computes for every element $a$ all one-step successors w.r.t.\ $r$.
  Hence, $r$ can in particular be any
  well-founded and finitely branching relation.

  The algorithm can further be parametrized by a subsumption relation
  which allows for early pruning.
\<close>

text \<open>In the following locales, $r$ is a relation of type @{typ "'a \<Rightarrow> 'a"},
  the successors of an element are represented by some collection
  type @{typ 'b} which size can be measured using the @{term size} function.
  The selection function @{term sel} is used to meant to split a non-empty
  collection into one element and a remaining collection. The union on
  @{typ 'b} is given by @{term un}.
\<close>

locale subsumption =
  fixes r :: "'a \<Rightarrow> 'b"
   and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   and set_of :: "'b \<Rightarrow> 'a set"
  assumes
       subsumes_refl: "\<And> a. subsumes a a"
   and subsumes_trans: "\<And> a b c. subsumes a b \<Longrightarrow> subsumes b c \<Longrightarrow> subsumes a c"
   and subsumes_step: "\<And> a b c. subsumes a b \<Longrightarrow> c \<in> set_of (r b) \<Longrightarrow> \<exists> d \<in> set_of (r a). subsumes d c"
begin
abbreviation R where "R \<equiv> { (a,b). b \<in> set_of (r a) }"
end

locale subsumption_impl = subsumption r subsumes set_of
  for r :: "'a \<Rightarrow> 'b"
  and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and set_of :: "'b \<Rightarrow> 'a set" +
  fixes
      sel :: "'b \<Rightarrow> 'a \<times> 'b"
   and un :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
   and size :: "'b \<Rightarrow> nat"
  assumes set_of_fin: "\<And> b. finite (set_of b)"
   and sel: "\<And> b a c. set_of b \<noteq> {} \<Longrightarrow> sel b = (a,c) \<Longrightarrow> set_of b = insert a (set_of c) \<and> size b > size c"
   and un: "set_of (un a b) = set_of a \<union> set_of b"

locale relation_subsumption_impl = subsumption_impl r subsumes set_of sel un size
  for r subsumes set_of sel un size +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set_of (r a)}^*}"
begin

lemma finite_Rs: assumes init: "finite init"
  shows "finite (R^* `` init)"
proof -
  let ?R = "\<lambda> a. {b . (a,b) \<in> R^*}"
  let ?S = "{ ?R a | a . a \<in> init}"
  have id: "R^* `` init = \<Union> ?S" by auto
  show ?thesis unfolding id
  proof (rule)
    fix M
    assume "M \<in> ?S"
    then obtain a where M: "M = ?R a" by auto
    show "finite M" unfolding M by (rule rtrancl_fin)
  next
    show "finite {{b. (a, b) \<in> R^*} | a. a \<in> init}"
      using init by auto
  qed
qed

text \<open>a standard work-list algorithm with subsumption\<close>
function mk_rtrancl_main where
  "mk_rtrancl_main todo fin = (if set_of todo = {} then fin
      else (let (a,tod) = sel todo
             in (if (\<exists> b \<in> fin. subsumes b a) then mk_rtrancl_main tod fin
                 else mk_rtrancl_main (un (r a) tod) (insert a fin))))"
  by pat_completeness auto

termination mk_rtrancl_main
proof -
  let ?r1 = "\<lambda> (todo, fin). card (R^* `` (set_of todo) - fin)"
  let ?r2 = "\<lambda> (todo, fin). size todo"
  show ?thesis
  proof
    show "wf (measures [?r1,?r2])" by simp
  next
    fix todo fin pair tod a
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by simp
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((tod,fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_lesseq[OF _ measures_less], unfold split)
      from sel
      show "size tod < size todo" by simp
    next
      from sel have subset: "R^* `` set_of tod - fin \<subseteq> R^* `` set_of todo - fin" (is "?l \<subseteq> ?r") by auto
      show "card ?l \<le> card ?r"
        by (rule card_mono[OF _ subset], rule finite_Diff, rule finite_Rs[OF fin])
    qed
  next
    fix todo fin a tod pair
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair" and nmem: "\<not> (\<exists> b \<in> fin. subsumes b a)"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by auto
    from nmem subsumes_refl[of a] have nmem: "a \<notin> fin" by auto
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((un (r a) tod,insert a fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_less, unfold split,
        rule psubset_card_mono[OF finite_Diff[OF finite_Rs[OF fin]]])
      let ?l = "R^* `` set_of (un (r a) tod) - insert a fin"
      let ?r = "R^* `` set_of todo - fin"
      from sel have at: "a \<in> set_of todo" by auto
      have ar: "a \<in> ?r" using nmem at by auto
      show "?l \<subset> ?r"
      proof
        show "?l \<noteq> ?r" using ar by auto
      next
        have "R^* `` set_of (r a) \<subseteq> R^* `` set_of todo"
        proof
          fix b
          assume "b \<in> R^* `` set_of (r a)"
          then obtain c where cb: "(c,b) \<in> R^*" and ca: "c \<in> set_of (r a)" by blast
          hence ab: "(a,b) \<in> R O R^*" by auto
          have "(a,b) \<in> R^*"
            by (rule subsetD[OF _ ab], regexp)
          with at show "b \<in> R^* `` set_of todo" by auto
        qed
        thus "?l \<subseteq> ?r" using sel unfolding un by auto
      qed
    qed
  qed
qed

declare mk_rtrancl_main.simps[simp del]

lemma mk_rtrancl_main_sound: "set_of todo \<union> fin \<subseteq> R^* `` init \<Longrightarrow> mk_rtrancl_main todo fin \<subseteq> R^* `` init"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    show ?thesis unfolding simp using True 1(3) by auto
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by auto
    obtain a tod where selt: "sel todo = (a,tod)" by force
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric]]
    note IH2 = 1(2)[OF False refl selt[symmetric]]
    note simp = simp nempty if_False Let_def selt
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      hence "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      with IH1[OF True] 1(3) show ?thesis using sel by auto
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r a) tod) (insert a fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        from sel 1(3) have subset: "set_of todo \<union> insert a fin \<subseteq> R^* `` init" by auto
        {
          fix b
          assume b: "b \<in> set_of (r a)"
          hence ab: "(a,b) \<in> R" by auto
          from sel 1(3) have "a \<in> R^* `` init" by auto
          then obtain c where c: "c \<in> init" and ca: "(c,a) \<in> R^*" by blast
          from ca ab have cb: "(c,b) \<in> R^* O R" by auto
          have "(c,b) \<in> R^*"
            by (rule subsetD[OF _ cb], regexp)
          with c have "b \<in> R^* `` init" by auto
        }
        with subset
        show "set_of (un (r a) tod) \<union> (insert a fin) \<subseteq> R^* `` init"
          unfolding un using sel by auto
      qed
    qed
  qed
qed

lemma mk_rtrancl_main_complete:
  "\<lbrakk>\<And> a. a \<in> init \<Longrightarrow> \<exists> b. b \<in> set_of todo \<union> fin \<and> subsumes b a\<rbrakk>
  \<Longrightarrow> \<lbrakk> \<And> a b . a \<in> fin \<Longrightarrow> b \<in> set_of (r a) \<Longrightarrow> \<exists> c. c \<in> set_of todo \<union> fin \<and> subsumes c b\<rbrakk>
  \<Longrightarrow> c \<in> R^* `` init
  \<Longrightarrow> \<exists> b. b \<in> mk_rtrancl_main todo fin \<and> subsumes b c"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  from 1(5) have c: "c \<in> R^* `` init" .
  note finr = 1(4)
  note init = 1(3)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    hence id: "mk_rtrancl_main todo fin = fin" unfolding simp by simp
    from c obtain a where a: "a \<in> init" and ac: "(a,c) \<in> R^*" by blast
    show ?thesis unfolding id using ac
    proof (induct rule: rtrancl_induct)
      case base
      from init[OF a] show ?case unfolding True by auto
    next
      case (step b c)
      from step(3) obtain d where d: "d \<in> fin" and db: "subsumes d b" by auto
      from step(2) have cb: "c \<in> set_of (r b)" by auto
      from subsumes_step[OF db cb] obtain a where a: "a \<in> set_of (r d)" and ac: "subsumes a c" by auto
      from finr[OF d a] obtain e where e: "e \<in> fin" and ea: "subsumes e a" unfolding True by auto
      from subsumes_trans[OF ea ac] e
      show ?case by auto
    qed
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by simp
    obtain A tod where selt: "sel todo = (A,tod)" by force
    note simp = nempty simp if_False Let_def selt
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric] _ _ _ c]
    note IH2 = 1(2)[OF False refl selt[symmetric] _ _ _ c]
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b A")
      case True note oTrue = this
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      from True obtain b where b: "b \<in> fin" and ba: "subsumes b A" by auto
      show ?thesis unfolding id
      proof (rule IH1[OF True])
        fix a
        assume a: "a \<in> init"
        from init[OF a] obtain c where c: "c \<in> set_of todo \<union> fin" and ca: "subsumes c a" by blast
        show "\<exists> b. b \<in> set_of tod \<union> fin \<and> subsumes b a"
        proof (cases "c = A")
          case False
          thus ?thesis using c ca sel by auto
        next
          case True
          show ?thesis using b subsumes_trans[OF ba, of a] ca unfolding True[symmetric] by auto
        qed
      next
        fix a c
        assume a: "a \<in> fin" and c: "c \<in> set_of (r a)"
        from finr[OF a c] obtain e where e: "e \<in> set_of todo \<union> fin" and ec: "subsumes e c" by auto
        show "\<exists> d. d \<in> set_of tod \<union> fin \<and> subsumes d c"
        proof (cases "A = e")
          case False
          with e ec show ?thesis using sel by auto
        next
          case True
          from subsumes_trans[OF ba[unfolded True] ec]
          show ?thesis using b by auto
        qed
      qed
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r A) tod) (insert A fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        fix a
        assume a: "a \<in> init"
        from init[OF a]
        show "\<exists> b. b \<in> set_of (un (r A) (tod)) \<union> insert A fin \<and> subsumes b a"
          using sel unfolding un by auto
      next
        fix a b
        assume a: "a \<in> insert A fin" and b: "b \<in> set_of (r a)"
        show "\<exists> c. c \<in> set_of (un (r A) tod) \<union> insert A fin \<and> subsumes c b"
        proof (cases "a \<in> fin")
          case True
          from finr[OF True b] show ?thesis using sel unfolding un by auto
        next
          case False
          with a have a: "A = a" by simp
          show ?thesis unfolding a un using b subsumes_refl[of b] by blast
        qed
      qed
    qed
  qed
qed

definition mk_rtrancl where "mk_rtrancl init \<equiv> mk_rtrancl_main init {}"

lemma mk_rtrancl_complete: assumes a: "a \<in> R^* `` set_of init"
  shows "\<exists> b. b \<in> mk_rtrancl init \<and> subsumes b a"
  unfolding mk_rtrancl_def
proof (rule mk_rtrancl_main_complete[OF _ _ a])
  fix a
  assume a: "a \<in> set_of init"
  thus "\<exists> b. b \<in> set_of init \<union> {} \<and> subsumes b a" using subsumes_refl[of a] by blast
qed auto

lemma mk_rtrancl_no_subsumption: assumes "subsumes = (=)"
  shows "mk_rtrancl init = R^* `` set_of init"
  using mk_rtrancl_sound[of init] mk_rtrancl_complete[of _ init] assms
  by auto
end

subsection \<open>Instantiation using list operations\<close>

text \<open>It follows an implementation based on lists.
 Here, the working list algorithm is implemented outside the locale so that
 it can be used for code generation. In general, it is not terminating,
 therefore we use partial\_function instead of function.\<close>

partial_function(tailrec) mk_rtrancl_list_main where
 [code]:  "mk_rtrancl_list_main subsumes r todo fin = (case todo of [] \<Rightarrow> fin
     | Cons a tod \<Rightarrow>
             (if (\<exists> b \<in> set fin. subsumes b a) then mk_rtrancl_list_main subsumes r tod fin
                 else mk_rtrancl_list_main subsumes r (r a @ tod) (a # fin)))"

definition mk_rtrancl_list where
  "mk_rtrancl_list subsumes r init \<equiv> mk_rtrancl_list_main subsumes r init []"

locale subsumption_list = subsumption r subsumes set
  for r :: "'a \<Rightarrow> 'a list" and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

locale relation_subsumption_list = subsumption_list r subsumes for r subsumes +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set (r a)}^*}"

abbreviation(input) sel_list where "sel_list x \<equiv> case x of Cons h t \<Rightarrow> (h,t)"

sublocale subsumption_list \<subseteq> subsumption_impl r subsumes set sel_list append length
proof(unfold_locales, rule finite_set)
  fix b a c
  assume "set b \<noteq> {}" and "sel_list b = (a,c)"
  thus "set b = insert a (set c) \<and> length c < length b"
    by (cases b, auto)
qed auto

sublocale relation_subsumption_list \<subseteq> relation_subsumption_impl r subsumes set sel_list append length
  by (unfold_locales, rule rtrancl_fin)

context relation_subsumption_list
begin

text \<open>The main equivalence proof between the generic work list algorithm
and the one operating on lists\<close>
lemma mk_rtrancl_list_main: "fin = set finl \<Longrightarrow> set (mk_rtrancl_list_main subsumes r todo finl) = mk_rtrancl_main todo fin"
proof (induct todo fin arbitrary: finl rule: mk_rtrancl_main.induct)
  case (1 todo fin finl)
  note simp = mk_rtrancl_list_main.simps[of _ _ todo finl] mk_rtrancl_main.simps[of todo fin]
  show ?case (is "?l = ?r")
  proof (cases todo)
    case Nil
    show ?thesis unfolding simp unfolding Nil 1(3) by simp
  next
    case (Cons a tod)
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      from True have l: "?l = set (mk_rtrancl_list_main subsumes r tod finl)"
        unfolding simp unfolding Cons 1(3) by simp
      from True have r: "?r = mk_rtrancl_main tod fin"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(1)[OF _ refl _ True], insert 1(3) Cons, auto)
    next
      case False
      from False have l: "?l = set (mk_rtrancl_list_main subsumes r (r a @ tod) (a # finl))"
        unfolding simp unfolding Cons 1(3) by simp
      from False have r: "?r = mk_rtrancl_main (r a @ tod) (insert a fin)"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(2)[OF _ refl _ False], insert 1(3) Cons, auto)
    qed
  qed
qed

lemma mk_rtrancl_list: "set (mk_rtrancl_list subsumes r init) = mk_rtrancl init"
  unfolding mk_rtrancl_list_def mk_rtrancl_def
  by (rule mk_rtrancl_list_main, simp)

end

end


theory "Woo_Lam_Pi_cert_auto"
imports
  "../ESPLogic"
begin

(* section:  Woo and Lam Pi 3  *)

(* text:
  Modelled after SPORE.

  Notable differences:
    1. We use explicit global constants instead of implicit typing to discern
       the different messages.

    2. We prove non-injective synchronization, which is stronger than the
       authenticatino requirement stated in the description.

    3. We added the identity B to the plaintext of the fourth message, as the
       server must know it for looking up the key k(B,S).

 *)

role A
where "A =
  [ Send ''1'' ( sAV ''A'' )
  , Recv ''2'' ( sMV ''Nb'' )
  , Send ''3'' ( PEnc <| sC ''3'', sMV ''Nb'' |> ( sK ''A'' ''S'' ) )
  ]"

role B
where "B =
  [ Recv ''1'' ( sMV ''A'' )
  , Send ''2'' ( sN ''Nb'' )
  , Recv ''3'' ( sMV ''Ticket'' )
  , Send ''4'' <| sAV ''B'',
                  PEnc <| sC ''4'', sMV ''A'', sMV ''Ticket'' |> ( sK ''B'' ''S'' )
               |>
  , Recv ''5'' ( PEnc <| sC ''5'', sMV ''A'', sN ''Nb'' |>
                      ( sK ''B'' ''S'' )
               )
  ]"

role S
where "S =
  [ Recv ''4'' <| sMV ''B'',
                  PEnc <| sC ''4'', sMV ''A'',
                          PEnc <| sC ''3'', sMV ''Nb'' |> ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) )
                       |>
                       ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               |>
  , Send ''5'' ( PEnc <| sC ''5'', sMV ''A'', sMV ''Nb'' |>
                      ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               )
  ]"

protocol WooLamPi
where "WooLamPi = { A, B, S }"

locale restricted_WooLamPi_state = WooLamPi_state

type_invariant WooLamPi_msc_typing for WooLamPi
where "WooLamPi_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((S, ''A''), (SumT (KnownT S_4) AgentT))
  , ((S, ''B''), (KnownT S_4))
  , ((A, ''Nb''), (KnownT A_2))
  , ((S, ''Nb''), (SumT (KnownT S_4) (NonceT B ''Nb'')))
  , ((B, ''Ticket''), (KnownT B_3))
  ]"

sublocale WooLamPi_state < WooLamPi_msc_typing_state
proof -
  have "(t,r,s) : approx WooLamPi_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WooLamPi_msc_typing.monoTyp, completeness_cases_rule])
    case (S_4_A t r s tid0) note facts = this
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''4'', s(MV ''A'' tid0),
               Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                   ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) )
            |}
            ( K ( s(MV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
  next
    case (S_4_B t r s tid0) note facts = this
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    by (fastsimp intro: event_predOrdI split: if_splits)
  next
    case (S_4_Nb t r s tid0) note facts = this
    then interpret state: WooLamPi_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''4'', s(MV ''A'' tid0),
               Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                   ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) )
            |}
            ( K ( s(MV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                           ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
    next
      case (B_4_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', s(MV ''Nb'' tid0) |}
                           ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
      qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
    qed (insert facts, fastsimp+)?
  qed
  thus "WooLamPi_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WooLamPi_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Security Properties  *)

lemma (in restricted_WooLamPi_state) B_noninjective_agreement:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_5 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some A &
        s(AV ''A'' tid1) = s(MV ''A'' tid2) &
        s(AV ''S'' tid1) = s(AV ''S'' tid2) &
        s(MV ''Nb'' tid1) = LN ''Nb'' tid2)"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''5'', s(MV ''A'' tid2), LN ''Nb'' tid2 |}
                       ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  next
    case (S_5_enc tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''4'', s(MV ''A'' tid2),
                            Enc {| LC ''3'', LN ''Nb'' tid2 |}
                                ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) )
                         |}
                         ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastsimp dest!: ltk_secrecy)
    next
      case (B_4_enc tid4) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', LN ''Nb'' tid2 |}
                           ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastsimp dest!: ltk_secrecy)
      next
        case (A_3_enc tid5) note_unified facts = this facts
        thus ?thesis by (fastsimp intro: event_predOrdI split: if_splits)
      qed (insert facts, fastsimp+)?
    qed (insert facts, fastsimp+)?
  qed (insert facts, fastsimp+)?
qed

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Set Implementation by List} *}
theory ListSetImpl
imports "../spec/SetSpec" "../gen_algo/SetGA" "../../Lib/Dlist_add"
begin
text_raw {*\label{thy:ListSetImpl}*}

(*@impl Set
  @type 'a ls
  @abbrv ls,l
  Sets implemented by distinct lists. For efficient
  @{text "insert_dj"}-operations, use the version with explicit invariant (lsi).
*)

type_synonym
  'a ls = "'a dlist"

subsection "Definitions"

definition ls_\<alpha> :: "'a ls \<Rightarrow> 'a set" where "ls_\<alpha> l == set (list_of_dlist l)"

definition ls_basic_ops :: "('a,'a ls) set_basic_ops" where
  [icf_rec_def]: "ls_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = ls_\<alpha>,
    bset_op_invar = \<lambda>_. True,
    bset_op_empty = \<lambda>_. Dlist.empty,
    bset_op_memb = (\<lambda>x s. Dlist.member s x),
    bset_op_ins = Dlist.insert,
    bset_op_ins_dj = Dlist.insert,
    bset_op_delete = dlist_remove',
    bset_op_list_it = dlist_iteratei
    \<rparr>"

setup Locale_Code.open_block
interpretation ls_basic: StdBasicSet ls_basic_ops
  apply unfold_locales
  unfolding ls_basic_ops_def ls_\<alpha>_def[abs_def]
  apply (auto simp: dlist_member_empty Dlist.member_def List.member_def
    dlist_iteratei_correct
    dlist_remove'_correct set_dlist_remove1'
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ls_ops \<equiv> ls_basic.dflt_ops\<lparr>
  set_op_to_list := list_of_dlist
  \<rparr>"

setup Locale_Code.open_block
interpretation ls: StdSetDefs ls_ops .
interpretation ls: StdSet ls_ops
proof -
  interpret aux: StdSet ls_basic.dflt_ops
    by (rule ls_basic.dflt_ops_impl)

  show "StdSet ls_ops"
    unfolding ls_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales)
    apply (simp_all add: ls_\<alpha>_def)
    done
qed

interpretation ls: StdSet_no_invar ls_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ls"*}

lemma pi_ls[proper_it]:
  "proper_it' dlist_iteratei dlist_iteratei"
  apply (rule proper_it'I)
  unfolding dlist_iteratei_def
  by (intro icf_proper_iteratorI)

lemma pi_ls'[proper_it]:
  "proper_it' ls.iteratei ls.iteratei"
  apply (rule proper_it'I)
  unfolding ls.iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_ls: proper_it_loc dlist_iteratei dlist_iteratei
  apply unfold_locales by (rule pi_ls)

interpretation pi_ls': proper_it_loc ls.iteratei ls.iteratei
  apply unfold_locales by (rule pi_ls')

definition test_codegen where "test_codegen \<equiv> (
  ls.empty,
  ls.memb,
  ls.ins,
  ls.delete,
  ls.list_it,
  ls.sng,
  ls.isEmpty,
  ls.isSng,
  ls.ball,
  ls.bex,
  ls.size,
  ls.size_abort,
  ls.union,
  ls.union_dj,
  ls.diff,
  ls.filter,
  ls.inter,
  ls.subset,
  ls.equal,
  ls.disjoint,
  ls.disjoint_witness,
  ls.sel,
  ls.to_list,
  ls.from_list
)"

export_code test_codegen in SML

end


theory Sorting_Quicksort_Partition
imports Sorting_Quicksort_Scheme
begin

(* TODO: Move. Found useful for ATPs *)
lemma strict_itrans: "a < c \<Longrightarrow> a < b \<or> b < c" for a b c :: "_::linorder"
  by auto

context weak_ordering begin

subsection \<open>Find Median\<close>

definition "move_median_to_first ri ai bi ci (xs::'a list) \<equiv> doN {
    ASSERT (ai\<noteq>bi \<and> ai\<noteq>ci \<and> bi\<noteq>ci \<and> ri\<noteq>ai \<and> ri\<noteq>bi \<and> ri\<noteq>ci);
    a \<leftarrow> mop_list_get xs ai;
    b \<leftarrow> mop_list_get xs bi;
    c \<leftarrow> mop_list_get xs ci;

    if a\<^bold><b then (
      if b\<^bold><c then
        mop_list_swap xs ri bi
      else if a\<^bold><c then
        mop_list_swap xs ri ci
      else
        mop_list_swap xs ri ai
    )
    else if a\<^bold><c then
      mop_list_swap xs ri ai
    else if b\<^bold><c then
      mop_list_swap xs ri ci
    else
      mop_list_swap xs ri bi
  }"

lemma move_median_to_first_alt: "move_median_to_first ri ai bi ci (xs::'a list) = doN {
    ASSERT (ai\<noteq>bi \<and> ai\<noteq>ci \<and> bi\<noteq>ci \<and> ri\<noteq>ai \<and> ri\<noteq>bi \<and> ri\<noteq>ci);

    if\<^sub>N mop_cmp_idxs xs ai bi then (
      if\<^sub>N mop_cmp_idxs xs bi ci then
        mop_list_swap xs ri bi
      else if\<^sub>N mop_cmp_idxs xs ai ci then
        mop_list_swap xs ri ci
      else
        mop_list_swap xs ri ai
    )
    else if\<^sub>N mop_cmp_idxs xs ai ci then
      mop_list_swap xs ri ai
    else if\<^sub>N mop_cmp_idxs xs bi ci then
      mop_list_swap xs ri ci
    else
      mop_list_swap xs ri bi
  }"
  unfolding move_median_to_first_def
  by (auto simp: pw_eq_iff refine_pw_simps split!: if_splits)

lemma move_median_to_first_correct:
  "\<lbrakk> ri<ai; ai<bi; bi<ci; ci<length xs \<rbrakk> \<Longrightarrow>
  move_median_to_first ri ai bi ci xs
    \<le> SPEC (\<lambda>xs'. \<exists>i\<in>{ai,bi,ci}.
        xs' = swap xs ri i
      \<and> (\<exists>j\<in>{ai,bi,ci}-{i}. xs!i\<^bold>\<le>xs!j)
      \<and> (\<exists>j\<in>{ai,bi,ci}-{i}. xs!i\<^bold>\<ge>xs!j)
      )"
  unfolding move_median_to_first_def
  apply refine_vcg
  supply aux = bexI[where P="\<lambda>x. _=_ x \<and> _ x", OF conjI[OF refl]]
  apply ((rule aux)?; insert connex,auto simp: unfold_lt_to_le)+
  done

lemma move_median_to_first_correct':
  "\<lbrakk> ri<ai; ai<bi; bi<ci; ci<length xs \<rbrakk> \<Longrightarrow>
  move_median_to_first ri ai bi ci xs
    \<le> SPEC (\<lambda>xs'. slice_eq_mset ri (ci+1) xs' xs
      \<and> (\<exists>i\<in>{ai,bi,ci}. xs'!i\<^bold>\<le>xs'!ri)
      \<and> (\<exists>i\<in>{ai,bi,ci}. xs'!i\<^bold>\<ge>xs'!ri)
      )"
  apply (rule order_trans[OF move_median_to_first_correct])
  by auto

(* TODO: Clean up prove below, to use more concise aux-lemma! *)
lemma move_median_to_first_correct'':
  "\<lbrakk> ri<ai; ai<bi; bi<ci; ci<length xs \<rbrakk> \<Longrightarrow>
  move_median_to_first ri ai bi ci xs
    \<le> SPEC (\<lambda>xs'. slice_eq_mset ri (ci+1) xs' xs
      \<and> (\<exists>i\<in>{ai..ci}. xs'!i\<^bold>\<le>xs'!ri)
      \<and> (\<exists>i\<in>{ai..ci}. xs'!i\<^bold>\<ge>xs'!ri)
      )"
  apply (rule order_trans[OF move_median_to_first_correct'])
  by auto

end

context sort_impl_context begin

sepref_register move_median_to_first

sepref_def move_median_to_first_impl [llvm_inline] is "uncurry4 (PR_CONST move_median_to_first)" :: "size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d \<rightarrow>\<^sub>a arr_assn"
  unfolding move_median_to_first_alt PR_CONST_def
  by sepref

end

context weak_ordering begin

subsection \<open>Hoare Partitioning Scheme\<close>

definition "ungrd_qsp_next_l_spec xs pi li hi \<equiv>
  doN {
    ASSERT (pi<li \<and> pi<hi \<and> hi\<le>length xs);
    ASSERT (\<exists>i\<in>{li..<hi}. xs!i \<^bold>\<ge> xs!pi);
    SPEC (\<lambda>li'. li\<le>li' \<and> li'<hi \<and> (\<forall>i\<in>{li..<li'}. xs!i\<^bold><xs!pi) \<and> xs!li'\<^bold>\<ge>xs!pi)
  }"

definition "ungrd_qsp_next_h_spec xs pi hi \<equiv>
  doN {
    ASSERT (pi<length xs \<and> hi\<le>length xs \<and> (\<exists>i\<in>{pi<..<hi}. (xs!i) \<^bold>\<le> xs!pi));
    SPEC (\<lambda>hi'. hi'<hi \<and> (\<forall>i\<in>{hi'<..<hi}. xs!i\<^bold>>xs!pi) \<and> xs!hi'\<^bold>\<le>xs!pi)
  }"

definition qsp_next_l :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat nres" where
  "qsp_next_l xs pi li hi \<equiv> doN {
    monadic_WHILEIT (\<lambda>li'. (\<exists>i\<in>{li'..<hi}. xs!i\<^bold>\<ge>xs!pi) \<and> li\<le>li' \<and> (\<forall>i\<in>{li..<li'}. xs!i\<^bold><xs!pi))
      (\<lambda>li. doN {ASSERT (li\<noteq>pi); mop_cmp_idxs xs li pi}) (\<lambda>li. RETURN (li + 1)) li
  }"

lemma qsp_next_l_refine: "(qsp_next_l,PR_CONST ungrd_qsp_next_l_spec)\<in>Id\<rightarrow>Id\<rightarrow>Id\<rightarrow>Id\<rightarrow>\<langle>Id\<rangle>nres_rel"
  unfolding qsp_next_l_def ungrd_qsp_next_l_spec_def PR_CONST_def
  apply (intro fun_relI; clarsimp)
  subgoal for xs p li hi
    apply (refine_vcg monadic_WHILEIT_rule[where R="measure (\<lambda>li. hi - li)"])
    apply simp_all
    subgoal by auto
    apply safe
    subgoal by (metis atLeastLessThan_iff leI le_less_Suc_eq wo_leD)
    subgoal by (metis atLeastLessThan_iff leI le_less_Suc_eq)
    subgoal using less_eq_Suc_le by force
    subgoal by auto
    subgoal by (auto simp: unfold_le_to_lt)
    done
  done

definition qsp_next_h :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat nres" where
  "qsp_next_h xs pi hi \<equiv> doN {
    ASSERT (hi>0);
    let hi = hi - 1;
    ASSERT (hi<length xs);
    monadic_WHILEIT (\<lambda>hi'. hi'\<le>hi \<and> (\<exists>i\<le>hi'. xs!i\<^bold>\<le>xs!pi) \<and> (\<forall>i\<in>{hi'<..hi}. xs!i\<^bold>>xs!pi))
      (\<lambda>hi. doN {ASSERT(pi\<noteq>hi); mop_cmp_idxs xs pi hi}) (\<lambda>hi. doN { ASSERT(hi>0); RETURN (hi - 1)}) hi
  }"

lemma qsp_next_h_refine: "(qsp_next_h,PR_CONST (ungrd_qsp_next_h_spec)) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding qsp_next_h_def ungrd_qsp_next_h_spec_def PR_CONST_def
  apply (refine_vcg monadic_WHILEIT_rule[where R="measure id"] split_ifI)
  apply (all \<open>(determ \<open>elim conjE exE\<close>)?\<close>)
  apply simp_all
  subgoal by force
  subgoal by (meson greaterThanLessThan_iff nat_le_Suc_less_imp)
  subgoal by (meson greaterThanAtMost_iff greaterThanLessThan_iff nat_le_Suc_less_imp wo_leD)
  subgoal by (metis gr0I le_zero_eq unfold_lt_to_le)
  subgoal by (metis One_nat_def le_step_down_nat wo_leD)
  subgoal by (metis Suc_pred greaterThanAtMost_iff linorder_neqE_nat not_less_eq)
  subgoal by (meson greaterThanAtMost_iff greaterThanLessThan_iff nat_le_Suc_less_imp)
  subgoal using wo_leI by blast
  done

definition "qs_partition li\<^sub>0 hi\<^sub>0 pi xs\<^sub>0 \<equiv> doN {
  ASSERT (pi < li\<^sub>0 \<and> li\<^sub>0<hi\<^sub>0 \<and> hi\<^sub>0\<le>length xs\<^sub>0);

  \<comment> \<open>Initialize\<close>
  li \<leftarrow> ungrd_qsp_next_l_spec xs\<^sub>0 pi li\<^sub>0 hi\<^sub>0;
  hi \<leftarrow> ungrd_qsp_next_h_spec xs\<^sub>0 pi hi\<^sub>0;

  ASSERT (li\<^sub>0\<le>hi);

  (xs,li,hi) \<leftarrow> WHILEIT
    (\<lambda>(xs,li,hi).
        li\<^sub>0\<le>li \<and> hi<hi\<^sub>0
      \<and> li<hi\<^sub>0 \<and> hi\<ge>li\<^sub>0
      \<and> slice_eq_mset li\<^sub>0 hi\<^sub>0 xs xs\<^sub>0
      \<and> xs!pi = xs\<^sub>0!pi
      \<and> (\<forall>i\<in>{li\<^sub>0..<li}. xs!i \<^bold>\<le> xs\<^sub>0!pi)
      \<and> xs!li \<^bold>\<ge> xs\<^sub>0!pi
      \<and> (\<forall>i\<in>{hi<..<hi\<^sub>0}. xs!i \<^bold>\<ge> xs\<^sub>0!pi)
      \<and> xs!hi \<^bold>\<le> xs\<^sub>0!pi
    )
    (\<lambda>(xs,li,hi). li<hi)
    (\<lambda>(xs,li,hi). doN {
      ASSERT(li<hi \<and> li<length xs \<and> hi<length xs \<and> li\<noteq>hi);
      xs \<leftarrow> mop_list_swap xs li hi;
      let li = li + 1;
      li \<leftarrow> ungrd_qsp_next_l_spec xs pi li hi\<^sub>0;
      hi \<leftarrow> ungrd_qsp_next_h_spec xs pi hi;
      RETURN (xs,li,hi)
    })
    (xs\<^sub>0,li,hi);

  RETURN (xs,li)
}"

lemma qs_partition_correct:
  "\<lbrakk> pi<li; li<hi; hi\<le>length xs\<^sub>0; \<exists>i\<in>{li..<hi}. xs\<^sub>0!pi\<^bold>\<le>xs\<^sub>0!i; \<exists>i\<in>{li..<hi}. xs\<^sub>0!i\<^bold>\<le>xs\<^sub>0!pi \<rbrakk> \<Longrightarrow> qs_partition li hi pi xs\<^sub>0
  \<le> SPEC (\<lambda>(xs,i). slice_eq_mset li hi xs xs\<^sub>0 \<and> li\<le>i \<and> i<hi \<and> (\<forall>i\<in>{li..<i}. xs!i\<^bold>\<le>xs\<^sub>0!pi) \<and> (\<forall>i\<in>{i..<hi}. xs!i\<^bold>\<ge>xs\<^sub>0!pi) )"
  unfolding qs_partition_def ungrd_qsp_next_l_spec_def ungrd_qsp_next_h_spec_def
  apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(_,_,hi). hi)"])
  supply [[put_named_ss HOL_ss]]
  apply (all \<open>(clarsimp;fail)?\<close>)
  apply clarsimp_all
  supply [[put_named_ss Main_ss]]
  apply (simp_all add: slice_eq_mset_eq_length unfold_lt_to_le)

  subgoal by fastforce
  subgoal by auto
  subgoal
    by (metis le_trans order.strict_implies_order slice_eq_mset_eq_length swap_length)
  subgoal apply (clarsimp simp: swap_def)
    by (metis (full_types) More_List.swap_def atLeastSucLessThan_greaterThanLessThan greaterThanLessThan_iff less_le_trans swap_nth2)
  subgoal
    by (metis (mono_tags) greaterThanLessThan_iff leD le_less_trans less_le_trans nat_le_linear not_less_eq_eq slice_eq_mset_eq_length swap_indep swap_nth1)
  subgoal
    by (smt Suc_le_lessD dual_order.trans greaterThanLessThan_iff leI less_imp_le_nat swap_indep swap_length swap_nth1)
  subgoal
    by (smt Suc_le_lessD atLeastLessThan_iff le_less_trans less_imp_le_nat slice_eq_mset_eq_length slice_eq_mset_swap(2))

  subgoal apply clarsimp
    by (metis less_irrefl less_imp_not_less less_le_trans swap_indep)

  subgoal apply clarsimp
    by (smt Suc_leI atLeastLessThan_iff le_def less_le_trans less_Suc_eq swap_indep swap_length swap_nth1)
  subgoal apply clarsimp
    by (metis le_def less_trans swap_indep)

  subgoal apply clarsimp
    by (smt greaterThanLessThan_iff le_def less_le_trans le_neq_implies_less less_imp_le_nat slice_eq_mset_eq_length swap_indep swap_nth2)

  subgoal
    by (metis le_def less_trans swap_indep)
  subgoal
    by (metis greaterThanLessThan_iff strict_itrans le_neq_implies_less)
  done

definition "partition_pivot xs\<^sub>0 l h \<equiv> doN {
  ASSERT (l\<le>h \<and> h\<le>length xs\<^sub>0 \<and> h-l\<ge>4);
  let m = l + (h-l) div 2;
  xs\<^sub>1 \<leftarrow> move_median_to_first l (l+1) m (h-1) xs\<^sub>0;
  ASSERT (l<length xs\<^sub>1 \<and> length xs\<^sub>1 = length xs\<^sub>0);
  (xs,m) \<leftarrow> qs_partition (l+1) h l xs\<^sub>1;

  \<comment> \<open>TODO: Use an auxiliary lemma, instead of this assertion chain! \<close>
  ASSERT (l<m \<and> m<h);
  ASSERT ((\<forall>i\<in>{l+1..<m}. xs!i\<^bold>\<le>xs\<^sub>1!l) \<and> xs!l\<^bold>\<le>xs\<^sub>1!l);
  ASSERT (\<forall>i\<in>{l..<m}. xs!i\<^bold>\<le>xs\<^sub>1!l);
  ASSERT (\<forall>i\<in>{m..<h}. xs\<^sub>1!l\<^bold>\<le>xs!i);

  RETURN (xs,m)
}"

lemma slice_LT_I_aux:
  assumes B: "l<m" "m<h" "h\<le>length xs"
  assumes BND: "\<forall>i\<in>{l..<m}. xs!i\<^bold>\<le>p" "\<forall>i\<in>{m..<h}. p\<^bold>\<le>xs!i"
  shows "slice_LT (\<^bold>\<le>) (slice l m xs) (slice m h xs)"
  unfolding slice_LT_def
  using B apply (clarsimp simp: in_set_conv_nth slice_nth)
  subgoal for i j
    apply (rule trans[OF BND(1)[THEN bspec, of "l+i"] BND(2)[THEN bspec, of "m+j"]])
    by auto
  done

lemma partition_pivot_correct: "\<lbrakk>(xs,xs')\<in>Id; (l,l')\<in>Id; (h,h')\<in>Id\<rbrakk>
  \<Longrightarrow> partition_pivot xs l h \<le> \<Down>Id (partition3_spec xs' l' h')"
  unfolding partition_pivot_def partition3_spec_def
  apply (refine_vcg move_median_to_first_correct'' qs_partition_correct)
  apply (all \<open>auto 0 3 dest: slice_eq_mset_eq_length; fail\<close>) [17]
  apply clarsimp
  subgoal for xs\<^sub>1 xs\<^sub>2 i m j
    apply (subst slice_eq_mset_nth_outside, assumption)
    apply (auto dest: slice_eq_mset_eq_length)
    done
  subgoal apply clarsimp by (metis (full_types) Suc_leI atLeastLessThan_iff le_neq_implies_less)
  subgoal by auto
  subgoal
    apply simp
    by (metis Suc_le_eq le_add2 le_refl order.strict_trans plus_1_eq_Suc slice_eq_mset_subslice slice_eq_mset_trans)
  apply (all \<open>auto; fail\<close>) [2]
  subgoal by (auto dest: slice_eq_mset_eq_length intro!: slice_LT_I_aux)
  done

end

context sort_impl_context begin

sepref_register ungrd_qsp_next_l_spec ungrd_qsp_next_h_spec

(* TODO: We can get rid of the length xs restriction: the stopper element will always lie within <h, which is size_t representable! *)
sepref_definition qsp_next_l_impl [llvm_inline] is "uncurry3 (qsp_next_l)" :: "(arr_assn)\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn"
  unfolding qsp_next_l_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

lemmas [sepref_fr_rules] = qsp_next_l_impl.refine[FCOMP qsp_next_l_refine]

sepref_definition qsp_next_h_impl [llvm_inline] is "uncurry2 (qsp_next_h)" :: "(arr_assn)\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn"
  unfolding qsp_next_h_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

lemmas [sepref_fr_rules] = qsp_next_h_impl.refine[FCOMP qsp_next_h_refine]

sepref_register qs_partition
sepref_def qs_partition_impl (*[llvm_inline]*) is "uncurry3 (PR_CONST qs_partition)" :: "size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d \<rightarrow>\<^sub>a arr_assn \<times>\<^sub>a size_assn"
  unfolding qs_partition_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  supply [dest] = slice_eq_mset_eq_length
  by sepref

(*sepref_register qs_partitionXXX
sepref_def qs_partitionXXX_impl (*[llvm_inline]*) is "uncurry3 (PR_CONST qs_partitionXXX)" :: "[\<lambda>(((l,h),p),xs). length xs < max_snat LENGTH(size_t)]\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d \<rightarrow> arr_assn \<times>\<^sub>a size_assn"
  unfolding qs_partitionXXX_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  supply [dest] = slice_eq_mset_eq_length
  by sepref
*)

sepref_register partition_pivot
sepref_def partition_pivot_impl [llvm_inline] is "uncurry2 (PR_CONST partition_pivot)" :: "arr_assn\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn \<times>\<^sub>a size_assn"
  unfolding partition_pivot_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

end

subsection \<open>Parameterization\<close>

context parameterized_weak_ordering begin
  thm WO.qsp_next_l_def

  definition qsp_next_l_param :: "'cparam \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat nres" where
    "qsp_next_l_param cparam xs pi li hi \<equiv> doN {
      monadic_WHILEIT (\<lambda>_. True)
        (\<lambda>li. doN {ASSERT (li\<noteq>pi); pcmp_idxs2 cparam xs li pi})
        (\<lambda>li. doN {ASSERT (li<hi); RETURN (li + 1)}) li
    }"

  lemma qsp_next_l_param_refine[refine]: "\<lbrakk>
    (xs',xs)\<in>cdom_list_rel cparam; (p',p)\<in>Id; (i',i)\<in>Id; (h',h)\<in>Id
  \<rbrakk> \<Longrightarrow> qsp_next_l_param cparam xs' p' i' h' \<le>\<Down>nat_rel (WO.ungrd_qsp_next_l_spec cparam xs p i h)"
  proof (goal_cases)
    case 1
    then have "qsp_next_l_param cparam xs' p' i' h' \<le>\<Down>nat_rel (WO.qsp_next_l cparam xs p i h)"
      unfolding qsp_next_l_param_def WO.qsp_next_l_def
      apply refine_rcg
      by auto
    also note WO.qsp_next_l_refine[param_fo, OF IdI IdI IdI IdI, of cparam xs p i h, THEN nres_relD]
    finally show ?case unfolding PR_CONST_def .
  qed

  definition qsp_next_h_param :: "'cparam \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat nres" where
    "qsp_next_h_param cparam xs pi hi \<equiv> doN {
      ASSERT (hi>0);
      let hi = hi - 1;
      ASSERT (hi<length xs);
      monadic_WHILEIT (\<lambda>_. True)
        (\<lambda>hi. doN {ASSERT(pi\<noteq>hi); pcmp_idxs2 cparam xs pi hi})
        (\<lambda>hi. doN { ASSERT(hi>0); RETURN (hi - 1)}) hi
    }"

  lemma qsp_next_h_param_refine[refine]: "\<lbrakk>
    (xs',xs)\<in>cdom_list_rel cparam; (p',p)\<in>Id; (h',h)\<in>Id
  \<rbrakk> \<Longrightarrow> qsp_next_h_param cparam xs' p' h' \<le>\<Down>nat_rel (WO.ungrd_qsp_next_h_spec cparam xs p h)"
  proof goal_cases
    case 1
    then have "qsp_next_h_param cparam xs' p' h' \<le>\<Down>nat_rel (WO.qsp_next_h cparam xs p h)"
      unfolding qsp_next_h_param_def WO.qsp_next_h_def
      apply refine_rcg
      by (auto simp: cdom_list_rel_alt in_br_conv)
    also note WO.qsp_next_h_refine[param_fo, THEN nres_relD]
    finally show ?thesis by simp
  qed

  definition "qs_partition_param cparam li\<^sub>0 hi\<^sub>0 pi xs\<^sub>0 \<equiv> doN {
    ASSERT (pi < li\<^sub>0 \<and> li\<^sub>0<hi\<^sub>0 \<and> hi\<^sub>0\<le>length xs\<^sub>0);

    \<comment> \<open>Initialize\<close>
    li \<leftarrow> qsp_next_l_param cparam xs\<^sub>0 pi li\<^sub>0 hi\<^sub>0;
    hi \<leftarrow> qsp_next_h_param cparam xs\<^sub>0 pi hi\<^sub>0;

    ASSERT (li\<^sub>0\<le>hi);

    (xs,li,hi) \<leftarrow> WHILEIT
      (\<lambda>_. True)
      (\<lambda>(xs,li,hi). li<hi)
      (\<lambda>(xs,li,hi). doN {
        ASSERT(li<hi \<and> li<length xs \<and> hi<length xs \<and> li\<noteq>hi);
        xs \<leftarrow> mop_list_swap xs li hi;
        let li = li + 1;
        li \<leftarrow> qsp_next_l_param cparam xs pi li hi\<^sub>0;
        hi \<leftarrow> qsp_next_h_param cparam xs pi hi;
        RETURN (xs,li,hi)
      })
      (xs\<^sub>0,li,hi);

    RETURN (xs,li)
  }"

  lemma qs_partition_param_refine[refine]: "\<lbrakk>
    (li',li)\<in>Id; (hi',hi)\<in>Id; (pi',pi)\<in>Id; (xs',xs)\<in>cdom_list_rel cparam
  \<rbrakk> \<Longrightarrow> qs_partition_param cparam li' hi' pi' xs'
    \<le> \<Down>(cdom_list_rel cparam \<times>\<^sub>r nat_rel) (WO.qs_partition cparam li hi pi xs)"
    unfolding qs_partition_param_def WO.qs_partition_def
    supply [refine_dref_RELATES] = RELATESI[of "cdom_list_rel cparam"]
    apply refine_rcg
    apply refine_dref_type
    apply (auto simp: cdom_list_rel_alt in_br_conv)
    done

 definition "move_median_to_first_param cparam ri ai bi ci (xs::'a list) = doN {
    ASSERT (ai \<noteq> bi \<and> ai \<noteq> ci \<and> bi \<noteq> ci \<and> ri \<noteq> ai \<and> ri \<noteq> bi \<and> ri \<noteq> ci);
    if\<^sub>N pcmp_idxs2 cparam xs ai bi then (
      if\<^sub>N pcmp_idxs2 cparam xs bi ci then
        mop_list_swap xs ri bi
      else if\<^sub>N pcmp_idxs2 cparam xs ai ci then
        mop_list_swap xs ri ci
      else
        mop_list_swap xs ri ai
    )
    else if\<^sub>N pcmp_idxs2 cparam xs ai ci then
      mop_list_swap xs ri ai
    else if\<^sub>N pcmp_idxs2 cparam xs bi ci then
      mop_list_swap xs ri ci
    else
      mop_list_swap xs ri bi
  }"

  (* TODO:Move *)
  lemma mop_list_swap_cdom_refine[refine]: "\<lbrakk>
    (xs',xs)\<in>cdom_list_rel cparam; (i',i)\<in>Id; (j',j)\<in>Id
  \<rbrakk> \<Longrightarrow> mop_list_swap xs' i' j' \<le> \<Down> (cdom_list_rel cparam) (mop_list_swap xs i j)"
    apply simp
    apply refine_rcg
    apply (clarsimp_all simp: cdom_list_rel_def list_rel_imp_same_length)
    apply (parametricity)
    by auto

  lemma move_median_to_first_param_refine[refine]: "\<lbrakk>
    (ri',ri)\<in>Id; (ai',ai)\<in>Id; (bi',bi)\<in>Id; (ci',ci)\<in>Id; (xs',xs)\<in>cdom_list_rel cparam
  \<rbrakk> \<Longrightarrow> move_median_to_first_param cparam ri' ai' bi' ci' xs'
    \<le> \<Down>(cdom_list_rel cparam) (WO.move_median_to_first cparam ri ai bi ci xs)"
    unfolding move_median_to_first_param_def WO.move_median_to_first_alt
    apply refine_rcg
    by auto

  definition "partition_pivot_param cparam xs\<^sub>0 l h \<equiv> doN {
    ASSERT (l\<le>h \<and> h\<le>length xs\<^sub>0 \<and> h-l\<ge>4);
    let m = l + (h-l) div 2;
    xs\<^sub>1 \<leftarrow> move_median_to_first_param cparam l (l+1) m (h-1) xs\<^sub>0;
    ASSERT (l<length xs\<^sub>1 \<and> length xs\<^sub>1 = length xs\<^sub>0);
    (xs,m) \<leftarrow> qs_partition_param cparam (l+1) h l xs\<^sub>1;

    RETURN (xs,m)
  }"

  lemma partition_pivot_param_refine[refine]: "\<lbrakk> (xs',xs)\<in>cdom_list_rel cparam; (l',l)\<in>Id; (h',h)\<in>Id
    \<rbrakk> \<Longrightarrow> partition_pivot_param cparam xs' l' h'
        \<le> \<Down>(cdom_list_rel cparam \<times>\<^sub>r nat_rel) (WO.partition_pivot cparam xs l h)"
    unfolding partition_pivot_param_def WO.partition_pivot_def
    apply refine_rcg
    apply (auto simp: cdom_list_rel_alt in_br_conv)
    done

end

context parameterized_sort_impl_context begin

  (* TODO: Move *)
  abbreviation "arr_assn \<equiv> wo_assn"

sepref_register qsp_next_l_param qsp_next_h_param

(* TODO: We can get rid of the length xs restriction: the stopper element will always lie within <h, which is size_t representable! *)
sepref_def qsp_next_l_impl [llvm_inline] is "uncurry4 (PR_CONST qsp_next_l_param)"
  :: "cparam_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn"
  unfolding qsp_next_l_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

sepref_def qsp_next_h_impl [llvm_inline] is "uncurry3 (PR_CONST qsp_next_h_param)" :: "cparam_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn"
  unfolding qsp_next_h_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

sepref_register qs_partition_param
sepref_def qs_partition_impl is "uncurry4 (PR_CONST qs_partition_param)" :: "cparam_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d \<rightarrow>\<^sub>a arr_assn \<times>\<^sub>a size_assn"
  unfolding qs_partition_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  supply [dest] = slice_eq_mset_eq_length
  by sepref

sepref_register move_median_to_first_param

sepref_def move_median_to_first_param_impl (*[llvm_inline] *)
  is "uncurry5 (PR_CONST move_median_to_first_param)"
  :: "cparam_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k *\<^sub>a (arr_assn)\<^sup>d \<rightarrow>\<^sub>a arr_assn"
  unfolding move_median_to_first_param_def PR_CONST_def
  by sepref

sepref_register partition_pivot_param
sepref_def partition_pivot_impl (*[llvm_inline] *)
  is "uncurry3 (PR_CONST partition_pivot_param)"
  :: "cparam_assn\<^sup>k *\<^sub>a arr_assn\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a arr_assn \<times>\<^sub>a size_assn"
  unfolding partition_pivot_param_def PR_CONST_def
  apply (annot_snat_const "TYPE(size_t)")
  by sepref

end

end