From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq path.
From mathcomp Require Import finmap choice eqtype order zify.
From eventstruct Require Import utils inhtype order wftype.

(******************************************************************************)
(* This file contains a theory of types that can be used as identifiers.      *)
(* Essentially, a type of identifiers is an infinite countable type.          *)
(*                                                                            *)
(*  identType  == interface for types which behave as identifiers.            *)
(*    \i0, \i1 == some distinguished identifiers.                             *)
(*     fresh i == allocates a fresh identifier which is guaranteed to         *)
(*                differ from i.                                              *)
(*  nfresh i n == allocates n fresh identifier which are guaranteed to        *)
(*                differ from i.                                              *)
(* fresh_seq s == allocates a fresh identifier which is guaranteed to         *)
(*                differ from all identifiers from the list s                 *)
(*                                                                            *)
(* Elements of identType also can be converted to natural numbers and back    *)
(* from natural numbers. This conversion also induces a total well-founded    *)
(* order on identifiers.                                                      *)
(*    encode i == converts the identifier i into a natural number.            *)
(*    decode n == converts the natural number n into an identifier.           *)
(*    x <=^i y == a total well-founded order on identifiers induced           *)
(*                by the conversion to natural numbers.                       *)
(*                That is x <=^i y iff encode x <= encode y.                  *)
(*                All conventional order notations are defined with           *)
(*                the suffix _^i as well.                                     *)
(*                                                                            *)
(* This file also contains canonical instance of identType for nat.           *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.LTheory.
Import Order.Theory.
Import Order.TTheory.
Open Scope order_scope.

Declare Scope ident_scope.
Delimit Scope ident_scope with ident.

Local Open Scope ident_scope.

(* Notation for initial identifier *)
Reserved Notation "\i0" (at level 0).
Reserved Notation "\i1" (at level 0).

(* Notations for canonical order on identifiers *)
Reserved Notation "x <=^i y" (at level 70, y at next level).
Reserved Notation "x >=^i y" (at level 70, y at next level).
Reserved Notation "x <^i y" (at level 70, y at next level).
Reserved Notation "x >^i y" (at level 70, y at next level).
Reserved Notation "x <=^i y :> T" (at level 70, y at next level).
Reserved Notation "x >=^i y :> T" (at level 70, y at next level).
Reserved Notation "x <^i y :> T" (at level 70, y at next level).
Reserved Notation "x >^i y :> T" (at level 70, y at next level).
Reserved Notation "<=^i y" (at level 35).
Reserved Notation ">=^i y" (at level 35).
Reserved Notation "<^i y" (at level 35).
Reserved Notation ">^i y" (at level 35).
Reserved Notation "<=^i y :> T" (at level 35, y at next level).
Reserved Notation ">=^i y :> T" (at level 35, y at next level).
Reserved Notation "<^i y :> T" (at level 35, y at next level).
Reserved Notation ">^i y :> T" (at level 35, y at next level).
Reserved Notation "x >=<^i y" (at level 70, no associativity).
Reserved Notation ">=<^i y" (at level 35).
Reserved Notation ">=<^i y :> T" (at level 35, y at next level).
Reserved Notation "x ><^i y" (at level 70, no associativity).
Reserved Notation "><^i x" (at level 35).
Reserved Notation "><^i y :> T" (at level 35, y at next level).
Reserved Notation "x <=^i y <=^i z" (at level 70, y, z at next level).
Reserved Notation "x <^i y <=^i z" (at level 70, y, z at next level).
Reserved Notation "x <=^i y <^i z" (at level 70, y, z at next level).
Reserved Notation "x <^i y <^i z" (at level 70, y, z at next level).
Reserved Notation "x <=^i y ?= 'iff' c" (at level 70, y, c at next level,
  format "x '[hv'  <=^i  y '/'  ?=  'iff'  c ']'").
Reserved Notation "x <=^i y ?= 'iff' c :> T" (at level 70, y, c at next level,
  format "x '[hv'  <=^i  y '/'  ?=  'iff'  c  :> T ']'").
Reserved Notation "x <^i y ?<= 'if' c" (at level 70, y, c at next level,
  format "x '[hv'  <^i  y '/'  ?<=  'if'  c ']'").
Reserved Notation "x <^i y ?<= 'if' c :> T" (at level 70, y, c at next level,
  format "x '[hv'  <^i  y '/'  ?<=  'if'  c  :> T ']'").

Module Ident.
Section ClassDef.

Record mixin_of T0 (b : Countable.class_of T0)
  (T := Countable.Pack b) := Mixin {
  _ : forall n, @unpickle T n;
  _ : injective (@unpickle T)
}.

Set Primitive Projections.
Record class_of (T : Type) := Class {
  base  : Countable.class_of T;
  mixin : mixin_of base;
}.
Unset Primitive Projections.

Local Coercion base : class_of >-> Countable.class_of.

Structure type := Pack { sort; _ : class_of sort }.

Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).

Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c.

Definition pack :=
  fun bT b & phant_id (@Countable.class bT) b =>
  fun m => Pack (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition countType := @Countable.Pack cT class.

End ClassDef.

Module Export Exports.
Coercion base : class_of >-> Countable.class_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion countType : type >-> Countable.type.
Canonical eqType.
Canonical choiceType.
Canonical countType.
Notation identType := type.
Notation IdentType T m := (@pack T _ _ id m).
Notation "[ 'identType' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'identType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'identType' 'of' T ]" := [identType of T for _]
  (at level 0, format "[ 'identType'  'of'  T ]") : form_scope.
End Exports.

Module Export Def.

Definition unpickle_tot {T : identType} n : @unpickle T n.
Proof. by case: T=> ? [? []]. Defined.

Notation encode (* : T -> nat *) := (pickle).
Notation decode (* : nat -> T *) := (mk_total unpickle_tot).

Section Def.
Context {T : identType}.

Definition ident0 : T :=
  decode 0%nat.

Definition ident1 : T :=
  decode 1%nat.

Definition fresh : T -> T :=
  fun x => decode (1 + encode x).

Definition nfresh : T -> nat -> seq T :=
  fun i n => traject fresh i n.

Definition ident_le : rel T :=
  fun x y => encode x <= encode y.

Definition ident_lt : rel T :=
  fun x y => encode x < encode y.

Definition ident_min : T -> T -> T :=
  fun x y => decode (minn (encode x) (encode y)).

Definition ident_max : T -> T -> T :=
  fun x y => decode (maxn (encode x) (encode y)).

End Def.
End Def.

Prenex Implicits fresh ident_le ident_lt.

Arguments nfresh : simpl never.

(* basic properties required by canonical instances *)
Module Export Props.
Section Props.

Context {T : identType}.
Implicit Types (x : T) (s : seq T).

Lemma unpickle_inj :
  injective (@unpickle T).
Proof. by case: T=> ? [/= ? []]. Qed.

Lemma decode_inj :
  injective (decode : nat -> T).
Proof. by apply /mk_total_inj /unpickle_inj. Qed.

Lemma encodeK :
  cancel encode (decode : nat -> T).
Proof. by apply /mk_totalK /pickleK. Qed.

Lemma decodeK :
  cancel decode (encode : T -> nat).
Proof. by apply/inj_can_sym; [exact/encodeK | exact/decode_inj]. Qed.

Lemma encode0 :
  encode (ident0 : T) = 0%nat.
Proof. by rewrite /ident0; exact/decodeK. Qed.

Lemma encode1 :
  encode (ident1 : T) = 1%nat.
Proof. by rewrite /ident1; exact/decodeK. Qed.

Lemma encode_fresh (e : T) : encode (fresh e) = (encode e).+1.
Proof. rewrite /fresh decodeK; lia. Qed.

Lemma encode_iter (e : T) n :
  encode (iter n fresh e) = (encode e) + n.
Proof.
  elim: n=> //= [|?]; first lia.
  rewrite encode_fresh; lia.
Qed.

Lemma encode_inj : injective (@encode T).
Proof. exact/pickle_inj. Qed.

End Props.
End Props.

Module Export Inh.
Section Inh.
Context (T : identType).
Implicit Types (x y z : T).

Lemma disp : unit.
Proof. exact: tt. Qed.

Definition inhMixin := @Inhabited.Mixin T _ ident0.
Definition inhType := Eval hnf in InhType T disp inhMixin.

End Inh.

Module Export Exports.
Canonical inhType.
Coercion inhType : type >-> Inhabited.type.
End Exports.

End Inh.

Module Export Order.
Section Order.
Context (T : identType).
Implicit Types (x y z : T).

Lemma disp : unit.
Proof. exact: tt. Qed.

Lemma lt_def x y : (ident_lt x y) = (y != x) && (ident_le x y).
Proof.
  rewrite /ident_lt /ident_le.
  have ->: (y != x) = (pickle y != pickle x); last exact /lt_def.
  case H: (y == x); first by (move: H=> /eqP->; rewrite eq_refl).
  move=> /=; apply esym.
  move: H=> /eqP /eqP /=.
  by apply /contra_neq /pickle_inj.
Qed.

Lemma meet_def x y : ident_min x y = (if ident_lt x y then x else y).
Proof.
  rewrite /ident_min /ident_lt /minn /Order.lt=> /=.
  rewrite (mk_totalE ident0).
  by case: ifP=> ?; rewrite pickleK /=.
Qed.

Lemma join_def x y : ident_max x y = (if ident_lt x y then y else x).
Proof.
  rewrite /ident_max /ident_lt /maxn /Order.lt=> /=.
  rewrite (mk_totalE ident0).
  by case: ifP=> ?; rewrite pickleK /=.
Qed.

Lemma le_anti : antisymmetric (@ident_le T).
Proof.
  move=> x y /andP []; rewrite /ident_le=> ??.
  by apply /pickle_inj /anti_leq /andP.
Qed.

Lemma le_trans : transitive (@ident_le T).
Proof. by move=> z x y; rewrite /ident_le; apply leq_trans. Qed.

Lemma le_total : total (@ident_le T).
Proof. by move=> x y; rewrite /ident_le; apply leq_total. Qed.

Lemma le0x x : ident_le ident0 x.
Proof. rewrite /ident_le encode0; exact /leq0n. Qed.

Lemma wfb : well_founded_bool (@ident_lt T).
Proof.
  move=> x; rewrite /ident_lt.
  rewrite -(encodeK x).
  elim/(@wfb_ind _ nat_wfType): (encode x).
  constructor=> y.
  rewrite decodeK -{2}(encodeK y).
  by apply /X.
Qed.

Definition mixin :=
  LeOrderMixin lt_def meet_def join_def le_anti le_trans le_total.

End Order.

Module Export Exports.

Implicit Types (T : identType).

Canonical porderType T := POrderType disp T (@Order.mixin T).
Canonical latticeType T := LatticeType T (@Order.mixin T).
Canonical bLatticeType T := BLatticeType T (BottomMixin (@Order.le0x T)).
Canonical distrLatticeType T := DistrLatticeType T (@Order.mixin T).
Canonical bDistrLatticeType T := [bDistrLatticeType of T].
Canonical orderType T := OrderType T (@Order.mixin T).

Canonical wfType T :=
  let wf_mixin := @WellFounded.Mixin T
     (Order.POrder.class (porderType T)) (@Order.wfb T)
  in WfType disp T wf_mixin.

Coercion porderType : type >-> Order.POrder.type.
Coercion latticeType : type >-> Order.Lattice.type.
Coercion bLatticeType : type >-> Order.BLattice.type.
Coercion distrLatticeType : type >-> Order.DistrLattice.type.
Coercion bDistrLatticeType : type >-> Order.BDistrLattice.type.
Coercion wfType : type >-> WellFounded.type.
Coercion orderType : type >-> Order.Total.type.

End Exports.

End Order.

Module Export Syntax.

Notation "'\i0'" := (ident0) : ident_scope.
Notation "'\i1'" := (ident1) : ident_scope.

Notation ident_le := (@Order.le (Order.disp) _).
Notation ident_lt := (@Order.lt (Order.disp) _).
Notation ident_comparable := (@Order.comparable (Order.disp) _).
Notation ident_ge := (@Order.ge (Order.disp) _).
Notation ident_gt := (@Order.gt (Order.disp) _).
Notation ident_leif := (@Order.leif (Order.disp) _).
Notation ident_lteif := (@Order.lteif (Order.disp) _).
Notation ident_max := (@Order.max (Order.disp) _).
Notation ident_min := (@Order.min (Order.disp) _).
Notation ident_meet := (@Order.meet (Order.disp) _).
Notation ident_join := (@Order.join (Order.disp) _).
Notation ident_bottom := (@Order.bottom (Order.disp) _).
Notation ident_top := (@Order.top (Order.disp) _).

Notation "<=^i%O" := ident_le : fun_scope.
Notation ">=^i%O" := ident_ge : fun_scope.
Notation "<^i%O" := ident_lt : fun_scope.
Notation ">^i%O" := ident_gt : fun_scope.
Notation "<?=^i%O" := ident_leif : fun_scope.
Notation "<?<=^i%O" := ident_lteif : fun_scope.
Notation ">=<^i%O" := ident_comparable : fun_scope.
Notation "><^i%O" := (fun x y => ~~ ident_comparable x y) : fun_scope.

Notation "<=^i y" := (>=^i%O y) : order_scope.
Notation "<=^i y :> T" := (<=^i (y : T)) (only parsing) : order_scope.
Notation ">=^i y" := (<=^i%O y) : order_scope.
Notation ">=^i y :> T" := (>=^i (y : T)) (only parsing) : order_scope.

Notation "<^i y" := (>^i%O y) : order_scope.
Notation "<^i y :> T" := (<^i (y : T)) (only parsing) : order_scope.
Notation ">^i y" := (<^i%O y) : order_scope.
Notation ">^i y :> T" := (>^i (y : T)) (only parsing) : order_scope.

Notation "x <=^i y" := (<=^i%O x y) : order_scope.
Notation "x <=^i y :> T" := ((x : T) <=^i (y : T)) (only parsing) : order_scope.
Notation "x >=^i y" := (y <=^i x) (only parsing) : order_scope.
Notation "x >=^i y :> T" := ((x : T) >=^i (y : T)) (only parsing) : order_scope.

Notation "x <^i y" := (<^i%O x y) : order_scope.
Notation "x <^i y :> T" := ((x : T) <^i (y : T)) (only parsing) : order_scope.
Notation "x >^i y" := (y <^i x) (only parsing) : order_scope.
Notation "x >^i y :> T" := ((x : T) >^i (y : T)) (only parsing) : order_scope.

Notation "x <=^i y <=^i z" := ((x <=^i y) && (y <=^i z)) : order_scope.
Notation "x <^i y <=^i z" := ((x <^i y) && (y <=^i z)) : order_scope.
Notation "x <=^i y <^i z" := ((x <=^i y) && (y <^i z)) : order_scope.
Notation "x <^i y <^i z" := ((x <^i y) && (y <^i z)) : order_scope.

Notation "x <=^i y ?= 'iff' C" := (<?=^i%O x y C) : order_scope.
Notation "x <=^i y ?= 'iff' C :> T" := ((x : T) <=^i (y : T) ?= iff C)
  (only parsing) : order_scope.

Notation "x <^i y ?<= 'if' C" := (<?<=^i%O x y C) : order_scope.
Notation "x <^i y ?<= 'if' C :> T" := ((x : T) <^i (y : T) ?<= if C)
  (only parsing) : order_scope.

Notation ">=<^i x" := (>=<^i%O x) : order_scope.
Notation ">=<^i y :> T" := (>=<^i (y : T)) (only parsing) : order_scope.
Notation "x >=<^i y" := (>=<^i%O x y) : order_scope.

Notation "><^i y" := [pred x | ~~ ident_comparable x y] : order_scope.
Notation "><^i y :> T" := (><^i (y : T)) (only parsing) : order_scope.
Notation "x ><^i y" := (~~ (><^i%O x y)) : order_scope.

End Syntax.

Module Export Theory.
Section Theory.

Lemma foldr_monoid {S : Type} {f : S -> S -> S} {n s1 s2}:
  associative f ->
  (forall a, f n a = a) ->
  (forall a, f a n = a) ->
  f (foldr f n s1) (foldr f n s2) =
  foldr f n (s1 ++ s2).
Proof. by move=> A L R; elim: s1=> //= ??; rewrite -A=>->. Qed.

Context {T : identType}.
Implicit Types (x : T) (s : seq T).

Lemma ident_leE x y :
  x <=^i y = (encode x <= encode y).
Proof. done. Qed.

Lemma ident_ltE x y :
  x <^i y = (encode x < encode y).
Proof. done. Qed.

Lemma fresh0 :
  fresh (\i0 : T) = \i1.
Proof. by rewrite /fresh encode0. Qed.

Lemma fresh_lt x :
  x <^i fresh x.
Proof.
  rewrite /fresh /ident_lt /= /Def.ident_lt decodeK.
  exact /ltnSn.
Qed.

Lemma fresh_inj :
  injective (@fresh T).
Proof. by rewrite /fresh=> x y /decode_inj [] /pickle_inj. Qed.

Lemma fresh_mon :
  { mono (fresh : T -> T) : x y / x <=^i y }.
Proof. move=> x y; rewrite !ident_leE /fresh !decodeK; lia. Qed.

Lemma size_nfresh x n :
  size (nfresh x n) = n.
Proof. by rewrite /nfresh size_traject. Qed.

Lemma nth_nfresh x n i :
  i < n -> nth x (nfresh x n) i = iter i fresh x.
Proof. by rewrite /nfresh=> ?; apply /nth_traject. Qed.

Lemma nfresh_head x y n :
  head x (nfresh y n) = if n == 0 then x else y.
Proof. by case: n=> //=. Qed.

Lemma nfresh_sorted x n :
  sorted (<%O) (nfresh x n).
Proof.
  rewrite /nfresh; case: n=> //= n.
  apply /sub_path; last exact/fpath_traject.
  move=> ?? /= /eqP <-; exact/fresh_lt.
Qed.

Lemma nfresh0 x :
  nfresh x 0 = [::].
Proof. by rewrite /nfresh. Qed.

Lemma nfreshS x n :
  nfresh x n.+1 = x :: nfresh (fresh x) n.
Proof. by rewrite /nfresh; exact/trajectS. Qed.

Lemma nfreshSr x n :
  nfresh x n.+1 = rcons (nfresh x n) (iter n fresh x).
Proof. by rewrite /nfresh; exact/trajectSr. Qed.

Lemma in_nfresh x n y :
  y \in nfresh x n = (encode x <= encode y < n + encode x)%N.
Proof.
  elim: n x=> //= [? |?/[swap] ?]; rewrite ?(inE, in_nil); first lia.
  move=>->; rewrite encode_fresh -(inj_eq encode_inj); lia.
Qed.

Definition fresh_seq : seq T -> T := fun t =>
  max_seq (\i0 : T) (map fresh t).

Lemma fresh_seq_nil :
  fresh_seq [::] = (\i0 : T).
Proof. by rewrite /fresh_seq /=. Qed.

Lemma maxx0 x : Order.max x \i0 = x.
Proof. exact/max_idPl/le0x. Qed.

Lemma max0x x : Order.max \i0 x = x.
Proof. exact/max_idPr/le0x. Qed.

Lemma max_fresh x y:
  Order.max (fresh x) (fresh y) = fresh (Order.max x y).
Proof. rewrite ?maxEle fresh_mon; by case: ifP. Qed.

Lemma fresh_seq_mem x s :
  x \in s -> x <^i fresh_seq s.
Proof.
  rewrite /fresh_seq.
  elim: s=> [|y {}s IH] => //=.
  rewrite inE maxElt.
  case: ifP=> /[swap] /orP[/eqP<-|/IH] //.
  - by move=> H; apply/(lt_trans _ H)/fresh_lt.
  - by move: (fresh_lt x).
  move=> /[swap]/negbT; rewrite -leNgt.
  by move=> /[swap]/lt_le_trans; apply.
Qed.

Lemma fresh_seq_nmem s : fresh_seq s \notin s.
Proof. by apply/memPn => x /fresh_seq_mem; rewrite lt_neqAle=> /andP[]. Qed.

Lemma fresh_seq_nfresh x n :
  n != 0 -> fresh_seq (nfresh x n) = iter n fresh x.
Proof.
  case: n=> //= n _; rewrite /fresh_seq; apply/eqP.
  rewrite -is_sup_NnilE=> //; last exact/le0x.
  rewrite is_sup_mon; last first.
  - exact/fresh_mon.
  - exact/fresh_inj.
  apply/is_supP; split=>>.
  - by apply/path.trajectP; exists n.
  rewrite in_nfresh ident_leE encode_iter; lia.
Qed.

Lemma fresh_seq_subset s1 s2 :
  {subset s1 <= s2} -> fresh_seq s1 <=^i fresh_seq s2.
Proof.
  rewrite /fresh_seq.
  elim: s1 s2=> [?? |] //=; first exact/le0x.
  move=> a s1 IH s2 subs.
  rewrite le_maxl; apply/andP; split.
  - apply/max_seq_in_le; rewrite (mem_map fresh_inj).
    exact/(subs a)/mem_head.
  by apply/IH=> ? I; apply/subs; rewrite inE I orbT.
Qed.

Lemma fresh_seq_eq s1 s2 :
  s1 =i s2 -> fresh_seq s1 = fresh_seq s2.
Proof.
  rewrite /fresh_seq=> eqm.
  apply/(max_set_eq); first exact/le0x.
  by apply/eq_mem_map.
Qed.

Lemma fresh_seqU (s1 s2 : {fset T}):
  fresh_seq (s1 `|` s2)%fset = Order.max (fresh_seq s1) (fresh_seq s2).
Proof.
  have->: Order.max (fresh_seq s1) (fresh_seq s2) = fresh_seq (s1 ++ s2).
  - apply/eqP; rewrite /fresh_seq /=.
    by rewrite (foldr_monoid maxA max0x maxx0) ?map_cat.
  have/andP/(le_anti) //:
    ((fresh_seq (s1 `|` s2)%fset <=^i fresh_seq (s1 ++ s2)) /\
    (fresh_seq (s1 ++ s2) <=^i fresh_seq (s1 `|` s2)%fset)).
  split; apply/fresh_seq_subset=> ?; by rewrite ?inE mem_cat.
Qed.

Lemma fresh_seq_add x (s : {fset T}) :
  fresh_seq (x |` s)%fset = Order.max (fresh x) (fresh_seq s).
Proof.
  rewrite fresh_seqU.
  under (@fresh_seq_eq _ [:: x]) do rewrite ?inE //.
  by rewrite {1}/fresh_seq /= maxx0.
Qed.

End Theory.
End Theory.

End Ident.

Export Ident.Exports.
Export Ident.Inh.Exports.
Export Ident.Order.Exports.
Export Ident.Def.
Export Ident.Props.
Export Ident.Syntax.
Export Ident.Theory.

(* Context {T : identType}. *)
(* Variable (x y : T). *)
(* Check (x <=^i y : bool). *)

Lemma nat_unpickle_tot (n : nat) : (unpickle n : option nat).
Proof. done. Qed.

Lemma nat_unpickle_inj : injective (unpickle : nat -> option nat).
Proof. exact/Some_inj. Qed.

Definition nat_identMixin :=
  @Ident.Mixin nat (Countable.class nat_countType)
               nat_unpickle_tot nat_unpickle_inj.

Canonical nat_identType :=
  Eval hnf in IdentType nat nat_identMixin.


Require Import Morphisms Relations Wellfounded Base BaseProps.

Definition transitive_set (x : V) := forall z, z ∈ x -> z ⊆ x.

Definition transitive_set_alt : forall x y z, transitive_set x -> z ∈ y -> y ∈ x -> z ∈ x.
Proof.
intros x y z Ht Hl Hr.
apply (mem_included_compat _ y); auto.
Qed.

Record ordinal (x : V) : Prop := {
  ordinal_trans : transitive_set x;
  ordinal_trans_trans : forall z, z ∈ x -> transitive_set z
}.

Lemma ordinal_mem_compat : forall x y, ordinal x -> y ∈ x -> ordinal y.
Proof.
intros x y [Hxl Hxr] Hm; split.
+ apply Hxr; assumption.
+ intros z Hz; apply Hxr; eapply transitive_set_alt; eassumption.
Qed.

Lemma ordinal_empty : ordinal empty.
Proof.
split.
+ intros z Hz; exfalso; eapply empty_spec; eassumption.
+ intros z Hz; exfalso; eapply empty_spec; eassumption.
Qed.

Lemma ordinal_max : forall x, (forall y, y ∈ x -> ordinal y) -> ordinal (union x).
Proof.
intros x Hx; split.
+ intros z Hz; apply included_spec; intros u Hu.
  apply union_spec in Hz; destruct Hz as [v [Hv Hz]].
  assert (Hzo := Hx _ Hz); destruct Hzo as [Hzo _].
  specialize (Hzo _ Hv).
  apply union_spec; exists v; split; [|assumption].
  eapply mem_included_compat; eassumption.
+ intros z Hz u Hu.
  apply union_spec in Hz; destruct Hz as [w [Hz Hw]].
  apply Hx in Hw; destruct Hw as [Hwl Hwr].
  apply Hwr; eassumption.
Qed.

Lemma ordinal_union : forall x, ordinal x -> ordinal (union x).
Proof.
intros x Hx; apply ordinal_max.
intros; eapply ordinal_mem_compat; eassumption.
Qed.

Definition successor (x : V) := cup x (singleton x).

Lemma ordinal_successor : forall x, ordinal x -> ordinal (successor x).
Proof.
intros x [Hxl Hxr]; split.
+ intros y Hy; apply -> cup_spec in Hy; destruct Hy as [?|Hy].
  - intros z Hz; apply <- cup_spec.
    left; apply (Hxl y); assumption.
  - intros z Hz; apply <- cup_spec.
    apply -> singleton_spec in Hy.
    left; rewrite <- Hy; apply subrelation_mem_rel; assumption.
+ intros y Hy; apply -> cup_spec in Hy; destruct Hy as [?|Hy].
  - now auto.
  - apply -> singleton_spec in Hy; intros z Hz.
    rewrite Hy; apply Hxl; rewrite <- Hy; assumption.
Qed.

Lemma wf_irrefl : forall A R (x : A), well_founded R -> ~ R x x.
Proof.
intros A R x H; specialize (H x); induction H as [x H IH]; intros Hc.
eapply IH; eassumption.
Qed.

Lemma successor_inj : forall x y, successor x ≅ successor y -> x ≅ y.
Proof.
intros x; intros y Heq.
unfold successor in Heq.
assert (Hx : x ∈ cup y (singleton y)).
{ rewrite <- Heq; apply cup_spec; right; apply singleton_spec; reflexivity. }
assert (Hy : y ∈ cup x (singleton x)).
{ rewrite Heq; apply cup_spec; right; apply singleton_spec; reflexivity. }
apply cup_spec in Hx; apply cup_spec in Hy.
destruct Hx as [Hx|Hx]; [|apply singleton_spec in Hx; assumption].
destruct Hy as [Hy|Hy]; [|apply singleton_spec in Hy; symmetry; assumption].
assert (HR : clos_trans _ mem x x).
{ eright; [left|left]; eassumption. }
exfalso; eapply (wf_irrefl _ _ x); [|eexact HR].
apply wf_clos_trans; apply wf_mem.
Qed.

Fixpoint ordinal_of_nat (n : nat) : V :=
match n with
| 0 => empty
| S n => successor (ordinal_of_nat n)
end.

Lemma ordinal_of_nat_inj : forall m n,
  ordinal_of_nat m ≅ ordinal_of_nat n -> m = n.
Proof.
intros m; induction m as [|m]; intros n Heq; simpl in *.
+ destruct n; [reflexivity|exfalso]; simpl in *.
  apply (empty_spec (ordinal_of_nat n)); rewrite Heq.
  apply cup_spec; right; apply singleton_spec; reflexivity.
+ destruct n; [exfalso|]; simpl in *.
  - apply (empty_spec (ordinal_of_nat m)); rewrite <- Heq; simpl.
    apply cup_spec; right; apply singleton_spec; reflexivity.
  - f_equal; apply IHm; apply successor_inj; assumption.
Qed.

Definition omega : V := @V_const nat ordinal_of_nat.

Lemma omega_spec : forall x, x ∈ omega <-> (exists n, x ≅ ordinal_of_nat n).
Proof.
intros x; split; intros H.
+ destruct H as [e Heq He].
  cut (exists n, e ≅ ordinal_of_nat n).
  - intros [n Hn]; exists n; rewrite <- Heq; assumption.
  - clear x Heq; pattern e.
    let P := match goal with [|- ?P e] => P end in
    revert He; eapply (@V_rel_inv _ _ P).
    intros n; exists n; reflexivity.
+ destruct H as [n Hn].
  exists (ordinal_of_nat n); [symmetry; assumption|constructor].
Qed.

Fixpoint Vfix (f : V -> V -> V) (x : V) : V :=
match x with
| V_const X Xf => @V_const X (fun e => f (Xf e) (Vfix f (Xf e)))
end.

Lemma Vfix_spec : forall f x, Vfix f x ≅ collection x (fun y => f y (Vfix f y)).
Proof.
intros f x; destruct x; reflexivity.
Qed.

Instance Proper_Vfix : Proper ((V_eq ==> V_eq ==> V_eq) ==> V_eq ==> V_eq) Vfix.
Proof.
assert (HP : forall X1 Xf1 X2 Xf2 (Hx : @V_const X1 Xf1 ≅ @V_const X2 Xf2)
  f1 f2 (Hf : (V_eq ==> V_eq ==> V_eq)%signature f1 f2)
  (Heq : forall e1 e2, Xf1 e1 ≅ Xf2 e2 -> Vfix f1 (Xf1 e1) ≅ Vfix f2 (Xf2 e2)),
  Vfix f1 (V_const Xf1) ⊆ Vfix f2 (V_const Xf2)).
{
  intros X1 Xf1 X2 Xf2 Hx f1 f2 Hf Heq xs Hxs.
  assert (Hrw : exists α, xs = f1 (Xf1 α) (Vfix f1 (Xf1 α))).
  { clear - Hxs; simpl in Hxs.
    let T := type of Hxs in
    let f := match T with V_rel _ (V_const ?f) => f end in
    set (F := f) in *; change (exists e, xs = F e).
    clearbody F; clear - Hxs; pattern xs.
    eapply (V_rel_inv _ F); [intuition eauto|assumption]. }
  destruct Hrw as [α Hrw]; rewrite Hrw in *; clear xs Hxs Hrw.
  pose (Hα := Hx); destruct Hα as [Hα _].
  specialize (Hα (Xf1 α) (V_rel_def _ _)); destruct Hα as [ys [Hyl Hyr]].
  assert (Hrw : exists β, ys = Xf2 β).
  { clear - Hyl; simpl in Hyl.
    pattern ys; eapply (V_rel_inv _ Xf2); intuition eauto. }
  destruct Hrw as [β Hrw]; rewrite Hrw in *; clear ys Hrw Hyl.
  specialize (Heq _ _ Hyr).
  exists (f2 (Xf2 β) (Vfix f2 (Xf2 β))).
  - symmetry; apply Hf; assumption.
  - simpl.
    let f := match goal with [ |- ?t ε V_const ?f ] => f end in
    change (f β ε V_const f); constructor.
}
intros f1 f2 Hf x1; induction x1 as [X1 X1f IH]; intros [X2 X2f] Hx.
apply extensionality; apply HP; try assumption.
+ intros; apply IH; assumption.
+ symmetry; assumption.
+ symmetry; assumption.
+ intros; symmetry; apply IH; symmetry; assumption.
Qed.

(* Definition collection_dep x (f : forall y, y ∈ x -> V) :=
match x return (forall y, y ∈ x -> V) -> V with
| V_const X Xf => fun f => @V_const X (fun y => f (Xf y) (subrelation_mem_rel _ _ (V_rel_def Xf y)))
end f.

Lemma collection_dep_spec : forall x y f,
  y ∈ collection_dep x f <-> exists z, exists (H : z ∈ x), y ≅ f z H.
Proof.
Admitted.

Lemma transitive_closure : forall x, {y | forall z, z ∈ y <-> clos_trans _ mem z x}.
Proof.
intros x; induction (wf_mem x) as [x _ IH].
pose (R := collection_dep x (fun y Hy => proj1_sig (IH _ Hy))).
exists (cup R x); intros z; split; intros Hz.
+ apply cup_spec in Hz; destruct Hz as [Hz|Hz].
  - apply collection_dep_spec in Hz; destruct Hz as [u [Hm Hu]].
    destruct (IH u Hm) as [v Hv]; simpl in Hu.
    replace z with v; [|admit]; clear z Hu.
    admit.
  - admit.
+ admit.
Defined.

Extraction transitive_closure.

Fixpoint transitive_closure x :=
match x with
| V_const X Xf =>
end.

Definition Vω := F (fun _ y => collection y powerset) omega.

Lemma Vω_empty : empty ∈ Vω.
Proof.
unfold Vω; rewrite F_spec; apply collection_spec; [admit|].
exists (ordinal_of_nat 0); split; [apply omega_spec; exists 0; reflexivity|].
apply extensionality; apply included_spec; intros z Hz.
+ apply empty_spec in Hz; contradiction.
+
  rewrite F_spec in Hz.
exfalso; apply collection_spec in Hz; [|admit].
  destruct Hz as [x [Hz _]].
  apply collection_spec in Hz; [|admit].
  destruct Hz as [? [Hz _]]; apply empty_spec in Hz; contradiction.
Qed.

Lemma Vω_powerset : forall x, x ∈ Vω -> powerset x ∈ Vω.
Proof.
intros x Hx; unfold Vω in *.
rewrite F_spec in Hx; apply collection_spec in Hx; [|admit].
rewrite F_spec; apply collection_spec; [admit|].

Lemma ordinal_rect : forall P,
  (forall x, ordinal x -> (forall y, y ∈ x -> P y) -> P x) -> forall x, ordinal x -> P x.
Proof.
intros P IH x Hx.
induction (wf_mem x) as [x H IHx].
apply IH; [assumption|].
intros y Hy; apply IHx; [assumption|eapply ordinal_mem_compat; eassumption].
Qed.
*)


Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Import
  Basics List Plus Program Morphisms Wf Wf_nat Omega
  qs_definitions monoid_monad_trans util list_utils sort_order nat_seqs
  insertion_sort arith_lems.
Require qs_det_parts.

(* We take as given an arbitrary decidable order: *)

Variable X: E.

(* The Quicksort we'll use is the monadic determinstic one that uses a partition pass, instantiated with the SimplyProfiled monad: *)

Definition counted_cmp (x y: X): SimplyProfiled comparison := (1%nat, Ecmp _ x y).

Let qs := mon_det_partition.qs _ counted_cmp.
Let part := mon_det_partition.partition _ counted_cmp.

(* By unfolding the (monadic) definition, we can characterize the cost and result of partitioning, and the cost of sorting: *)

Lemma partition_cost p l: cost (part p l) = length l.
Proof with auto.
  unfold cost.
  induction l...
  simpl.
  omega.
Qed.

Lemma partition_result c p l: proj1_sig (result (part p l)) c = filter (fun x => unsumbool (cmp_cmp (Ecmp _ x p) c)) l.
Proof with auto.
  induction l.
    simpl...
  simpl...
  destruct (cmp_cmp (Ecmp _ a p) c)...
  simpl.
  rewrite <- IHl...
Qed.

Lemma cost_qs l: cost (qs l) =
  match l with
  | nil => 0
  | h :: t => length t + cost (qs (filter (Egtb h) t)) + cost (qs (filter (Eltb h) t))
  end.
Proof with auto.
  pattern l, (qs l).
  apply (qs_det_parts.rect counted_cmp SimplyProfiled_ext)...
  intros.
  unfold qs_det_parts.partitionPart.
  rewrite bind_cost.
  rewrite partition_cost.
  unfold qs_det_parts.lowRecPart.
  repeat rewrite bind_cost.
  rewrite return_cost.
  rewrite <- plus_assoc.
  f_equal.
  do 2 rewrite partition_result.
  rewrite plus_0_r.
  unfold qs.
  do 3 f_equal; apply filter_eq_morphism...
    intro...
    rewrite Ecmp_sym.
    unfold Egtb.
    destruct (Ecmp X h a)...
  intro...
  unfold Eltb.
  rewrite Ecmp_sym.
  destruct (Ecmp X h a)...
Qed.

(* Since cost_qs tells us all we need to know about qs (for the purposes of proving its average case complexity),
 we will not need any further monad reasoning. We will need some R stuff: *)

Require Import sums_and_averages Rdefinitions Fourier Exp_prop.
Coercion INR: nat >-> R.
Hint Resolve Rmult_lt_0_compat Rmult_lt_0_compat Rinv_0_lt_compat Rle_Rinv: real.

(* We now define the recurrence relation *)

Inductive CR: nat -> R -> Prop :=
  | C0: CR 0 0
  | Cn n (l: list R): elemsR CR (nats 0 (S n)) l -> CR (S n) (n + 2 * Ravg l).

Hint Constructors CR.

(* .. and note that it is a function: *)

Lemma CRuniq: forall n r, CR n r -> forall r', CR n r' -> r = r'.
Proof with auto.
  intro n. pattern n.
  apply (well_founded_ind lt_wf).
  intros.
  destruct x. inversion_clear H0. inversion_clear H1...
  inversion_clear H0.
  inversion_clear H1.
  rewrite (@elemsRuniq _ _ CR (nats 0 (S x))) with l l0...
  intros.
  apply H with x0...
  destruct (In_nats_inv _ _ _ H1)...
Qed.

(* .. which is even computable: *)

Lemma CRimpl: forall n (a: Acc lt n), sig (CR n).
Proof with eauto.
  refine (fix F n (a: Acc lt n) {struct a} :=
    match a with
    | Acc_intro x =>
      let Re := fun m (p: lt m n) => F m (x m p)  in _
    end).
  clearbody Re. clear F.
  destruct n...
  destruct (elemsRimpl CR (nats 0 (S n)))...
  intros.
  destruct (In_nats_inv _ _ _ H)...
Qed.

Definition C n: R := proj1_sig (CRimpl (lt_wf n)).

(* .. and which satisfies the following recursive equation: *)

Lemma Ceq n: C n =
  match n with
  | 0 => 0
  | _ => pred n + 2 * Ravg (map C (nats 0 n))
  end.
Proof with auto.
  unfold C at 1.
  destruct CRimpl.
  simpl proj1_sig.
  induction c...
  simpl pred.
  f_equal.
  f_equal.
  f_equal.
  generalize H. clear H.
  generalize (nats 0 (S n)). intro.
  generalize l0. clear n l0.
  induction l; intros; inversion_clear H...
  simpl.
  rewrite <- IHl...
  unfold C.
  destruct CRimpl.
  f_equal.
  apply (CRuniq H0 c).
Qed.

(* .. as well as some other properties: *)

Lemma C_nonneg n: 0 <= C n.
Proof with auto with real.
  pattern n.
  apply (well_founded_ind lt_wf).
  intros.
  rewrite Ceq.
  destruct x...
  simpl pred.
  apply Rplus_le_le_0_compat...
  apply Rmult_le_pos...
  apply Rmult_le_pos...
    apply Rsum_nonneg.
    intros.
    apply in_map_iff in H0. destruct H0. destruct H0. subst.
    apply H.
    destruct (In_nats_inv _ _ _ H1)...
  rewrite map_length. rewrite nats_length...
Qed.

Lemma C_S n: C n = 2 * pred n / n + S n / n * C (pred n).
Proof with auto with real.
  assert (forall n, C (S n) = n + 2 * Ravg (map C (nats 0 (S n)))).
    intros.
    rewrite Ceq.
    simpl pred...
  assert (forall n, C n * n = n * pred n + 2 * Rsum (map C (nats 0 n))).
    destruct n0.
      simpl. field.
    rewrite H.
    unfold Ravg.
    rewrite map_length, nats_length.
    unfold Rdiv.
    rewrite Rmult_plus_distr_r.
    rewrite Rmult_assoc.
    rewrite Rmult_assoc.
    rewrite Rinv_l...
    rewrite Rmult_1_r...
  assert (forall n, C (S n) * S n = S n * n + 2 * C n - n * pred n + C n * n).
    intros.
    rewrite H0.
    rewrite H0.
    simpl pred.
    rewrite nats_Sw'.
    rewrite map_app.
    rewrite Rsum_app.
    simpl Rsum at 2.
    rewrite Rplus_0_r.
    rewrite plus_0_r.
    field.
  assert (forall n, C (S n) * S n = (2+n) * C n + 2 * n).
    destruct n0.
      simpl.
      rewrite Ceq.
      simpl.
      rewrite Ravg_single.
      rewrite Ceq.
      field.
    rewrite H1.
    simpl pred.
    repeat rewrite S_INR.
    field.
  destruct n.
    simpl.
    rewrite Ceq.
    repeat rewrite Rmult_0_r.
    unfold Rdiv.
    rewrite Rmult_0_l...
  simpl pred.
  apply Rmult_eq_reg_l with (S n)...
  rewrite Rmult_comm.
  rewrite H2.
  repeat rewrite S_INR.
  field...
Qed. (* todo: get rid of ugly asserts *)

Lemma C_le_compat n m: le n m -> C n <= C m.
Proof with auto with real.
  intros H.
  induction H...
  apply Rle_trans with (C m)...
  rewrite (C_S (S m)).
  simpl pred.
  rewrite <- (Rplus_0_l (C m)) at 1.
  apply Rplus_le_compat.
    unfold Rdiv.
    rewrite S_INR...
    apply Rmult_le_pos...
    apply Rmult_le_pos...
  rewrite <- (Rmult_1_l (C m)) at 1.
  apply Rmult_le_compat_r...
    apply C_nonneg.
  rewrite S_INR.
  apply Rdiv_le_1...
Qed.

(* C is bounded by prefixes of the harmonic series: *)

Hint Resolve Rplus_le_le_0_compat.

Lemma C_bounded_by_harmonic n: C n <= n * 2 * Rsum (map (Rinv ∘ INR) (nats 2 (pred n))).
Proof with try field; auto with real.
  induction n.
    rewrite Ceq...
  apply Rmult_le_reg_l with (/ S n)...
  repeat rewrite <- Rmult_assoc.
  rewrite Rinv_l...
  rewrite Rmult_1_l.
  destruct n.
    simpl.
    rewrite Ceq.
    simpl.
    rewrite Ravg_single.
    rewrite Ceq.
    fourier.
  simpl pred in *.
  rewrite nats_Sw'.
  rewrite map_app, Rsum_app, map_single, Rsum_single.
  set (bla := S n) in *.
  rename n into m. rename bla into n.
  assert (0 < n). subst n. replace 0 with (INR O)...
  apply Rmult_le_reg_l with n...
  rewrite Rmult_plus_distr_l.
  rewrite Rmult_plus_distr_l.
  rewrite plus_comm...
  simpl plus...
  unfold compose at 2.
  rewrite <- (Rmult_assoc n 2).
  fold n.
  apply Rle_trans with (C n + n * (2 * / S n))...
  rewrite (C_S (S n)).
  simpl pred.
  repeat rewrite <- Rmult_assoc.
  rewrite Rmult_plus_distr_l.
  unfold Rdiv.
  repeat rewrite <- Rmult_assoc.
  rewrite Rplus_comm.
  apply Rplus_le_compat.
    rewrite <- (Rmult_1_l (C n)) at 2.
    apply Rmult_le_compat_r...
      apply C_nonneg.
    repeat rewrite S_INR.
    replace (n * / (n + 1) * (n + 1 + 1) * / (n + 1)) with ((n * n + n + n) * / (n * n + n + n + 1)).
      apply Rlt_le.
      apply Rdiv_lt_1...
    field...
    split...
    apply Rgt_not_eq.
    unfold Rgt.
    apply Rle_lt_trans with (n * n + n + n)...
  apply Rmult_le_compat_r...
  rewrite (Rmult_comm n 2).
  apply Rmult_le_compat_r...
  rewrite <- (Rmult_1_l 2) at 2.
  apply Rmult_le_compat_r...
  apply Rlt_le...
  apply Rdiv_lt_1...
Qed.

(* Consequently, we can use an existing result about the harmonic series to get
 the n*log(n) bound for C: *)

Require harmonic.

Lemma C_log_bound n: C n <= n * 2 * log2ceil n.
Proof with auto with real.
  intros.
  apply Rle_trans with (n * 2 * Rsum (map (Rinv ∘ INR) (nats 2 (pred n)))).
    apply C_bounded_by_harmonic.
  apply Rmult_le_compat_l.
    apply Rmult_le_pos...
  destruct n.
    simpl...
  simpl pred.
  replace (Rsum (map (Rinv ∘ INR) (nats 2 n))) with (Rsum (map (Rinv ∘ INR) (nats 1 (S n))) - 1).
    Focus 2.
    simpl.
    unfold compose at 1.
    simpl.
    rewrite Rinv_1.
    field.
  replace (INR (log2ceil (S n))) with (S (log2ceil (S n)) - 1).
    unfold Rminus.
    apply Rplus_le_compat_r.
    apply harmonic.upper_bound.
  rewrite S_INR.
  field.
Qed.

(* What remains is to show that the average cost of qs is bounded by C: *)

Lemma C_bounds_avg_qs_cost: forall l, Ravg (map (INR ∘ cost ∘ qs) (perms l)) <= C (length l).
Proof with auto with real.
  apply (well_founded_induction_type (Wf_nat.well_founded_ltof _ (@length X))).
  intros.
  unfold ltof in H.
  destruct x.
    unfold Basics.compose.
    simpl.
    rewrite Ravg_single...
    rewrite Ceq...
  rewrite (Ravg_Permutation (Permutation.Permutation_map (INR ∘ cost ∘ qs) (perms_alt_perms (e :: x)))).
  unfold alt_perms.
  set (e :: x) in *.
  rename x into t. rename e into h.
  rewrite map_concat.
  rewrite map_map.
  rewrite (@Ravg_concat (fact (pred (length l)))).
    Focus 2.
    intros.
    destruct (fst (conj_prod (in_map_iff _ _ _)) H0).
    destruct H1.
    subst.
    rewrite map_length.
    rewrite map_length.
    rewrite length_perms.
    replace (length (snd x)) with (pred (S (length (snd x))))...
    rewrite (length_in_splits _ _ H2)...
  rewrite map_map.
  replace (map
       (fun x =>
        Ravg (map (INR ∘ cost ∘ qs) (map (cons (fst x)) (perms (snd x)))))
       (splits l))
     with (map (fun x =>
        Ravg (map (INR ∘ @length _) (perms (snd x))) +
        Ravg (map (INR ∘ cost ∘ qs ∘ filter (Egtb (fst x))) (perms (snd x))) +
        Ravg (map (INR ∘ cost ∘ qs ∘ filter (Eltb (fst x))) (perms (snd x)))
         ) (splits l)).
    Focus 2.
    apply map_ext.
    intros.
    rewrite map_map.
    unfold Basics.compose.
    replace (map (fun x => INR (cost (qs (fst a :: x)))) (perms (snd a))) with
     (map (fun x => length x + cost (qs (filter (Egtb (fst a)) x)) + cost (qs (filter (Eltb (fst a)) x))) (perms (snd a))).
      rewrite Ravg_map_plus.
      rewrite Ravg_map_plus...
    apply map_ext. intros.
    rewrite (cost_qs (fst a :: a0)).
    repeat rewrite plus_INR...
  rewrite Ravg_map_plus.
  rewrite Ravg_map_plus.
  setoid_rewrite (avg_filter_perms (cost ∘ qs)).
  replace (Ravg
    (map (fun x => Ravg (map (INR ∘ @length _) (perms (snd x))))
     (splits l))) with (INR (pred (length l))).
    Focus 2.
    symmetry.
    apply Ravg_constant.
      apply length_ne_0_ne_nil.
      rewrite map_length, length_splits.
      discriminate.
    intros.
    destruct (fst (conj_prod (in_map_iff _ _ _)) H0).
    destruct H1.
    subst.
    apply Ravg_constant.
      apply length_ne_0_ne_nil.
      rewrite map_length, length_perms.
      apply fact_neq_0.
    intros.
    destruct (fst (conj_prod (in_map_iff _ _ _)) H1).
    destruct H3. subst.
    unfold Basics.compose.
    rewrite <- (length_in_splits _ _ H2).
    rewrite (perms_are_perms _ _ H4)...
  apply Rle_trans with
     (pred (length l) +
     Ravg (map (fun x => C (length (filter (Egtb (fst x)) (snd x)))) (splits l)) +
     Ravg (map (fun x => C (length (filter (Eltb (fst x)) (snd x)))) (splits l))).
    apply Rplus_le_compat...
      apply Rplus_le_compat...
      apply Ravg_map_le.
      intros.
      apply H...
      apply le_lt_trans with (length (snd x)).
        apply list_utils.length_filter_le.
      rewrite <- (length_in_splits _ _ H0)...
    apply Ravg_map_le.
    intros.
    apply H...
    apply le_lt_trans with (length (snd x)).
      apply list_utils.length_filter_le.
    rewrite <- (length_in_splits _ _ H0)...
  clear H.
  rewrite Rplus_assoc.
  rewrite <- (map_map (fun x => length (filter (Egtb (fst x)) (snd x))) C (splits l)).
  rewrite <- (map_map (fun x => length (filter (Eltb (fst x)) (snd x))) C (splits l)).
  rewrite <- (map_length_filter_permuted_splits (plain.isort_permutes Eleb l)).
  rewrite <- (map_length_filter_permuted_splits (plain.isort_permutes Egeb l)).
  unfold Ravg.
  repeat rewrite map_length.
  repeat rewrite length_splits.
  rewrite (Permutation.Permutation_length (plain.isort_permutes Egeb l)).
  rewrite (Permutation.Permutation_length (plain.isort_permutes Eleb l)).
  unfold Rdiv.
  rewrite <- Rmult_plus_distr_r.
  apply Rle_trans with (pred (length l) +
      (Rsum (map C (nats 0 (length l))) + Rsum (map C (nats 0 (length l)))) / length l).
    apply Rplus_le_compat_l.
    unfold Rdiv.
    apply Rmult_le_compat_r...
      apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0 (S (length t)))...
    apply Rplus_le_compat.
      apply elemsR_le_Rsum.
      apply elemsR_map' with le...
        apply C_le_compat.
      rewrite <- (Permutation.Permutation_length (plain.isort_permutes Eleb l)).
      apply (@filtered_sort X Ele EO).
        unfold Egtb, Ele.
        intros.
        destruct (Ecmp _ y x); try discriminate...
      apply plain.isort_sorts'.
          unfold Eleb. intros. rewrite Ecmp_sym. destruct Ecmp...
        apply Eleb_preorder.
      intros. apply <- (Eleb_true x y)...
    apply elemsR_le_Rsum.
    apply elemsR_map' with le...
      apply C_le_compat.
    rewrite <- (Permutation.Permutation_length (plain.isort_permutes Egeb l)).
    apply (@filtered_sort X Ege Ege_preorder).
      unfold Eltb, Ege.
      intros.
      destruct (Ecmp _ y x); try discriminate...
    apply plain.isort_sorts'.
        unfold Egeb.
        intros. rewrite Ecmp_sym. destruct Ecmp...
      apply Egeb_preorder.
    intros. apply <- (Egeb_true x y)...
  rewrite <- (Rmult_1_l (Rsum (map C (nats 0 (length l))))).
  rewrite <- Rmult_plus_distr_r.
  unfold Rdiv.
  rewrite Rmult_assoc.
  rewrite Ceq.
  destruct (length l).
    simpl.
    rewrite Rmult_0_l.
    fourier.
  simpl pred.
  unfold Rdiv.
  apply Rplus_le_compat_l.
  unfold Ravg. rewrite map_length. rewrite nats_length.
  unfold Rdiv...
Qed.

(* The main result is now just a matter of sequencing the previous two lemmas. *)

Theorem qs_avg l: Ravg (map (INR ∘ cost ∘ qs) (perms l)) <= length l * 2 * log2ceil (length l).
Proof with auto with real.
  intros.
  apply Rle_trans with (C (length l)).
    apply C_bounds_avg_qs_cost.
  apply C_log_bound.
Qed.

Corollary qs_avg_bigO: over (@length (_ : Set)), Ravg ∘ map (INR ∘ cost ∘ qs) ∘ perms =O(fun n => n * log2ceil n).
Proof with auto with real.
  unfold measured_bigO.
  exists 2.
  exists 0%nat.
  intros.
  unfold compose at 1.
  unfold compose at 1.
  apply Rle_trans with (length x * 2 * log2ceil (length x)).
    apply qs_avg.
  rewrite (Rmult_comm (length x))...
Qed.

Print Assumptions qs_avg_bigO.

(* one gotcha: perms [x; x] = [[x; x]; [x; x]] *)


Require Import chap13.

Section counter_example.
 Let A : Set := nat.
 Let P l := match l with (LCons 0 _) => True
                        | _       => False
                    end.
 Let u := omega_repeat 1.
 Let v := LCons 0 LNil.

 Lemma L1 : satisfies v (Eventually P).
 Proof.
  unfold v, P;  left ; trivial.
 Qed.

 Lemma L2 : u = (LCons 1 u).
 Proof.
  unfold u; apply omega_repeat_unfold.
 Qed.

 Lemma L3 : forall (w: LList nat), satisfies w (Eventually P) ->
                                   exists n : nat, LNth n w = Some 0.
 Proof.
  induction 1.
  -   generalize H; case a;  simpl in H.
      + now  exists 0.
      +  contradiction.
  -  case IHEventually; intros p Hp; exists (S p); cbn ; auto.
 Qed.

 Lemma L4 : bisimilar u (LAppend u v).
 Proof.
   apply LAppend_of_Infinite_eq.
   -    unfold u;  apply omega_repeat_infinite.
 Qed.

 Lemma L5 : forall n, LNth n u = Some 1.
 Proof.
  simple induction n.
  -   now rewrite L2.
  -   intros n0 H0; rewrite L2; simpl; auto.
 Qed.

 Lemma L6 : forall n, LNth n (LAppend u v) = Some 1.
 Proof.
  intro n;  transitivity (LNth n u).
  -  apply bisimilar_LNth.
     generalize (bisimilar_sym (A:=nat));intro H;apply H.
     apply L4.
  -  apply L5.
 Qed.

 Lemma L7 : ~ satisfies (LAppend u v) (Eventually P).
 Proof.
  intro H; case (L3  _ H);  intros n  H1.
  generalize (L6 n); rewrite  H1;  discriminate 1.
 Qed.

End counter_example.

(** Now we can prove that, if we remove the hypothesis (Finite u)
   from its statement, Eventually_of_Lappend is false *)

Definition Eventually_of_LAppend' :=
 forall (A:Type)(P:LList A -> Prop) (u v:LList A),
    satisfies v (Eventually P) -> satisfies (LAppend u v) (Eventually P).

Lemma Conclusion :
  ~ Eventually_of_LAppend'.
Proof.
 intro H; generalize L7;intro H0;apply H0.
 apply H.
 apply L1.
Qed.