From stablesort Require Import mathcomp_ext.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From stablesort Require Import param.

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

(******************************************************************************)
(* The abstract interface for stable (merge)sort algorithms                   *)
(******************************************************************************)

Module StableSort.

Section Traces.

Variables (T : Type) (P : {pred T}) (leT : rel T).

(* One easy way to prove the correctness of highly optimized stable sort      *)
(* algorithms is to prove the equivalence between it and a simpler (but       *)
(* unoptimized) algorithm, e.g., insertion sort. However, such equivalence    *)
(* proof requires the comparison function [leT : rel T] to be total and       *)
(* transitive so that [merge] is associative. These requirements are          *)
(* undesirable since some correctness properties hold without them.           *)
(* Therefore, we present a type of binary trees [trace] representing the      *)
(* divide-and-conquer structure of sort. These trees can also be seen as      *)
(* "traces" of sorting algorithms, and have to be balanced in the case of     *)
(* O(n log n) mergesort. Nevertheless, these trees can also represent rather  *)
(* naive algorithms such as insertion sort, since there is no such formal     *)
(* "balanced" restriction.                                                    *)
Inductive trace :=
  | branch_trace   : bool -> trace -> trace -> trace
  | leaf_trace b s : sorted (fun x y => leT x y == b) s -> trace.

Definition empty_trace := @leaf_trace false [::] erefl.

(* By flattening a trace, the input list can be obtained.                     *)
Fixpoint flatten_trace (t : trace) : seq T :=
  match t with
    | branch_trace _ l r => flatten_trace l ++ flatten_trace r
    | leaf_trace _ s _ => s
  end.

(* By sorting a trace, the output list can be obtained.                       *)
Fixpoint sort_trace (t : trace) : seq T :=
  match t with
    | branch_trace true  l r => merge leT (sort_trace l) (sort_trace r)
    | branch_trace false l r =>
      rev (merge (fun x y => leT y x) (rev (sort_trace r)) (rev (sort_trace l)))
    | leaf_trace true  s _ => s
    | leaf_trace false s _ => rev s
  end.

Lemma all_trace (t : trace) : all P (sort_trace t) = all P (flatten_trace t).
Proof.
elim: t => [b l IHl r IHr|[] s] /=; rewrite ?all_rev //.
by case: b; rewrite ?(all_rev, all_merge) all_cat IHl IHr // andbC.
Qed.

Lemma size_trace (t : trace) : size (sort_trace t) = size (flatten_trace t).
Proof.
elim: t => [b l IHl r IHr|[] s] /=; rewrite ?size_rev //.
by case: b; rewrite ?(size_rev, size_merge, size_cat) IHl IHr // addnC.
Qed.

Lemma trace_nilp (t : trace) : nilp (sort_trace t) = nilp (flatten_trace t).
Proof.
by move: (sort_trace t) (flatten_trace t) (size_trace t) => [|? ?] [].
Qed.

Variant trace_nil_spec (t : trace) : seq T -> seq T -> bool -> bool -> Type :=
  | TraceNil    : flatten_trace t = [::] -> sort_trace t = [::] ->
                  trace_nil_spec t [::] [::] true true
  | TraceNotNil : flatten_trace t <> [::] -> sort_trace t <> [::] ->
                  trace_nil_spec t (flatten_trace t) (sort_trace t) false false.

Lemma trace_nilP (t : trace) :
  trace_nil_spec t (flatten_trace t) (sort_trace t)
                 (nilp (flatten_trace t)) (nilp (sort_trace t)).
Proof.
case: nilP (trace_nilp t); case: nilP => //; last by constructor.
by move=> /[dup] ? -> /[dup] ? ->; constructor.
Qed.

Definition trace_sort sort := forall s,
   {t : trace | s = flatten_trace t & sort s = sort_trace t}.

End Traces.

Lemma perm_trace (T : eqType) (leT : rel T) (t : trace leT) :
  perm_eql (sort_trace t) (flatten_trace t).
Proof.
apply/permPl; elim: t => [b l IHl r IHr|[] s _] //=; rewrite ?perm_rev //.
by case: b; rewrite /= ?perm_rev perm_merge -?rev_cat ?perm_rev perm_cat.
Qed.

Parametricity Translation
  (forall T : Type, rel T -> seq T -> seq T) as sort_ty_R.

Structure function := Pack {
  apply : forall T : Type, rel T -> seq T -> seq T;
  (* Binary parametricity                                                     *)
  (* _ : forall T1 T2 (T_R : T1 -> T2 -> Type)                                *)
  (*            (leT1 : rel T1) (leT2 : rel T2),                              *)
  (*     (forall (x1 : T1) (y1 : T2), T_R x1 y1 ->                            *)
  (*      forall (x2 : T1) (y2 : T2), T_R x2 y2 ->                            *)
  (*        bool_R (leT1 x1 x2) (leT2 y1 y2)) ->                              *)
  (*     forall (xs : seq T1) (ys : seq T2),                                  *)
  (*       list_R T_R xs ys -> list_R T_R (apply leT1 xs) (apply leT2 ys);    *)
  _ : sort_ty_R apply apply;
  (* Characterization by traces *)
  _ : forall (T : Type) (leT : rel T), trace_sort leT (apply leT);
}.

Module Exports.
Arguments leaf_trace {T leT} b s _.
Arguments empty_trace {T leT}.
Arguments flatten_trace {T leT} t.
Arguments sort_trace {T leT} t.
Arguments Pack apply _ _ : clear implicits.
Notation stableSort := function.
Notation StableSort := Pack.
Coercion apply : function >-> Funclass.
End Exports.

End StableSort.
Export StableSort.Exports.

Notation "[ tr]" := StableSort.empty_trace.
Notation "[ 'tr<=' ]" := (StableSort.leaf_trace true [::] erefl)
  (format "[ 'tr<=' ]").
Notation "[ 'tr<=' x ]" := (StableSort.leaf_trace true [:: x] erefl)
  (format "[ 'tr<='  x ]").

Lemma trace2_subproof T (leT : rel T) (x y : T) :
   sorted (fun x' y' => leT x' y' == leT x y) [:: x; y].
Proof. by rewrite /= eqxx. Qed.

Notation "[ 'tr' x1 ; x2 ]" :=
  (StableSort.leaf_trace _ [:: x1; x2] (trace2_subproof _ x1 x2))
  (format "[ 'tr'  x1 ;  x2 ]").

(******************************************************************************)
(* Merge functions                                                            *)
(******************************************************************************)

Module MergeR.
Definition merge_ty := forall (T : Type) (leT : rel T), seq T -> seq T -> seq T.
Parametricity merge_ty.
End MergeR.

(* The [MergeSig] and [RevmergeSig] module types are interfaces for           *)
(* non-tail-recursive and tail-recursive merge functions, respectively.       *)
Module Type MergeSig.
Import MergeR.
Parameter merge : forall (T : Type) (leT : rel T), seq T -> seq T -> seq T.
Parameter mergeE : forall (T : Type) (leT : rel T), merge leT =2 path.merge leT.
Parameter merge_R : merge_ty_R merge merge.
End MergeSig.

Module Type RevmergeSig.
Import MergeR.
Parameter revmerge : forall (T : Type) (leT : rel T), seq T -> seq T -> seq T.
Parameter revmergeE : forall (T : Type) (leT : rel T) (xs ys : seq T),
    revmerge leT xs ys = rev (path.merge leT xs ys).
Parameter revmerge_R : merge_ty_R revmerge revmerge.
End RevmergeSig.

(* The [Merge] module implements a non-tail-recursive merge function using    *)
(* nested recursion. This implementation is suited for computation inside Coq.*)
Module Merge <: MergeSig.

Fixpoint merge (T : Type) (leT : rel T) (xs ys : seq T) : seq T :=
  if xs is x :: xs' then
    (fix merge' (ys : seq T) : seq T :=
       if ys is y :: ys' then
         if leT x y then x :: merge leT xs' ys else y :: merge' ys'
       else xs) ys
  else ys.

Lemma mergeE (T : Type) (leT : rel T) : merge leT =2 path.merge leT.
Proof. by elim=> // x xs IHxs; elim=> //= y ys IHys; rewrite IHxs IHys. Qed.

Parametricity merge.

End Merge.

(* The [MergeAcc] module implements a non-tail-recursive merge function using *)
(* well-founded recursion. This implementation is suited for code extraction. *)
Module MergeAcc <: MergeSig.

Definition mergeord {T : Type} (p1 p2 : seq T * seq T) : Prop :=
  if p2 is (x :: xs, y :: ys) then
    (xs, y :: ys) = p1 \/ (x :: xs, ys) = p1 else False.

Fixpoint wf_mergeord (T : Type) (xs ys : seq T) : Acc mergeord (xs, ys) :=
  if xs is x :: xs' then
    (fix wf_mergeord' (ys : seq T) : Acc mergeord (x :: xs', ys) :=
       if ys is y :: ys' then
         Acc_intro
           (x :: xs', y :: ys')
           (fun _ H =>
              match H with
                | or_introl H0 =>
                  let: erefl in (_ = y1) := H0 return Acc mergeord y1 in
                  wf_mergeord xs' (y :: ys')
                | or_intror H0 =>
                  let: erefl in (_ = y1) := H0 return Acc mergeord y1 in
                  wf_mergeord' ys'
              end)
       else
         Acc_intro (x :: xs', [::]) (fun _ => False_ind _)) ys
  else
    Acc_intro ([::], ys) (fun _ => False_ind _).

Fixpoint merge_rec (T : Type) (leT : rel T)
                   (xs ys : seq T) (fuel : Acc mergeord (xs, ys)) : seq T :=
  match fuel, xs, ys return xs = _ -> ys = _ -> _ with
    | _, [::], ys => fun _ _ => ys
    | _, xs, [::] => fun _ _ => xs
    | Acc_intro fuel, x :: xs', y :: ys' =>
      fun (xsE : x :: xs' = xs) (ysE : y :: ys' = ys) =>
      if leT x y then
        x :: @merge_rec T leT xs' ys
          (fuel _ match xsE in _ = xs0, ysE in _ = ys0
                        return mergeord (xs', ys0) (xs0, ys0) with
                    erefl, erefl => or_introl erefl
                  end)
      else
        y :: @merge_rec T leT xs ys'
          (fuel _ match xsE in _ = xs0, ysE in _ = ys0
                        return mergeord (xs0, ys') (xs0, ys0) with
                    erefl, erefl => or_intror erefl
                  end)
  end erefl erefl.

Definition merge (T : Type) (leT : rel T) (xs ys : seq T) : seq T :=
  @merge_rec T leT xs ys (wf_mergeord xs ys).

Lemma mergeE (T : Type) (leT : rel T) : merge leT =2 path.merge leT.
Proof.
rewrite /merge => xs ys; move: xs ys (wf_mergeord xs ys).
by elim=> [|x xs IHxs]; elim=> [|y ys IHys] [acc] //=; rewrite IHxs IHys.
Qed.

Parametricity mergeord.
Parametricity wf_mergeord.
Parametricity merge.

End MergeAcc.

(* The [Revmerge] module implements a tail-recursive merge function using     *)
(* nested recursion. This implementation is suited for computation inside Coq.*)
Module Revmerge <: RevmergeSig.

Fixpoint merge_rec (T : Type) (leT : rel T) (xs ys accu : seq T) : seq T :=
  if xs is x :: xs' then
    (fix merge_rec' (ys accu : seq T) :=
       if ys is y :: ys' then
         if leT x y then
           merge_rec leT xs' ys (x :: accu) else merge_rec' ys' (y :: accu)
       else
         catrev xs accu) ys accu
  else catrev ys accu.

Definition revmerge (T : Type) (leT : rel T) (xs ys : seq T) : seq T :=
  merge_rec leT xs ys [::].

Lemma revmergeE (T : Type) (leT : rel T) (xs ys : seq T) :
  revmerge leT xs ys = rev (path.merge leT xs ys).
Proof.
rewrite /revmerge -[RHS]cats0.
elim: xs ys [::] => [|x xs IHxs]; elim=> [|y ys IHys] accu //=;
  try by rewrite catrevE rev_cons cat_rcons.
by case: ifP => _; rewrite rev_cons cat_rcons.
Qed.

Parametricity revmerge.

End Revmerge.

(* The [RevmergeAcc] module implements a tail-recursive merge function using  *)
(* well-founded recursion. This implementation is suited for code extraction. *)
Module RevmergeAcc <: RevmergeSig.

Import MergeAcc.

Fixpoint merge_rec (T : Type) (leT : rel T) (xs ys accu : seq T)
                   (fuel : Acc mergeord (xs, ys)) : seq T :=
  match fuel, xs, ys return xs = _ -> ys = _ -> _ with
    | _, [::], ys => fun _ _ => catrev ys accu
    | _, xs, [::] => fun _ _ => catrev xs accu
    | Acc_intro fuel, x :: xs', y :: ys' =>
      fun (xsE : x :: xs' = xs) (ysE : y :: ys' = ys) =>
      if leT x y then
        @merge_rec T leT xs' ys (x :: accu)
          (fuel _ match xsE in _ = xs0, ysE in _ = ys0
                        return mergeord (xs', ys0) (xs0, ys0) with
                    erefl, erefl => or_introl erefl
                  end)
      else
        @merge_rec T leT xs ys' (y :: accu)
          (fuel _ match xsE in _ = xs0, ysE in _ = ys0
                        return mergeord (xs0, ys') (xs0, ys0) with
                    erefl, erefl => or_intror erefl
                  end)
  end erefl erefl.

Definition revmerge (T : Type) (leT : rel T) (xs ys : seq T) : seq T :=
  @merge_rec T leT xs ys [::] (wf_mergeord xs ys).

Lemma revmergeE (T : Type) (leT : rel T) (xs ys : seq T) :
  revmerge leT xs ys = rev (path.merge leT xs ys).
Proof.
rewrite /revmerge -[RHS]cats0; move: xs ys [::] (wf_mergeord xs ys).
elim=> [|x xs IHxs]; elim=> [|y ys IHys] accu [acc] //=;
  try by rewrite catrevE rev_cons cat_rcons.
by case: ifP => _; rewrite rev_cons cat_rcons.
Qed.

Parametricity revmerge.

End RevmergeAcc.

(******************************************************************************)
(* Insertion sort                                                             *)
(******************************************************************************)

Module Insertion.
Section Insertion.

Variables (T : Type) (leT : rel T).

Definition sort := foldr (fun x => merge leT [:: x]) [::].

Import StableSort.

Lemma sortP : trace_sort leT sort.
Proof.
elim=> [|x _ [t -> /= ->]]; first by exists empty_trace.
by exists (branch_trace true (leaf_trace true [:: x] erefl) t).
Qed.

End Insertion.

Parametricity sort.

Definition sort_stable := StableSort.Pack sort sort_R sortP.

End Insertion.

Canonical Insertion.sort_stable.

(******************************************************************************)
(* The [CBN_] functor module takes a module [M] of type [MergeSig] and        *)
(* provides a family of mergesort functions [sort1], [sort2], [sort3], and    *)
(* [sortN]. These functions are bottom-up and structurally recursive and use  *)
(* [M.merge] internally for merging sorted lists.                             *)
(* The numbers [1], [2], and [3] in their names stand for the fact that they  *)
(* repeat to take a fixed-size prefix from the input, put it into the given   *)
(* order, and push it to a stack that manages the sorting process. Among      *)
(* those, [sort2] is exactly the same as [path.sort] of MathComp except that  *)
(* it is parameterized by the merge function. On the other hand, [sortN]      *)
(* takes the longest sorted prefix (in ascending or descending order) instead *)
(* of a fixed-size prefix, as in GHC's [Data.List.sort].                      *)
(* Since [M.merge] is expected to be a non-tail-recursive merge function,     *)
(* these sorting functions should allow us to compute the output              *)
(* incrementally in the call-by-need evaluation. In fact, computing the first *)
(* k smallest elements of a list of length n using one of these sort          *)
(* functions has O(n + k log k) time complexity, which is the known optimal   *)
(* time complexity of the partial and incremental sorting problems. However,  *)
(* the non-tail-recursive merge function linearly consumes the call stack and *)
(* triggers a stack overflow in the call-by-value evaluation.                 *)
(******************************************************************************)

Module CBN_ (M : MergeSig).

Section CBN.

Variable (T : Type) (leT : rel T).

Let condrev (r : bool) (s : seq T) : seq T := if r then rev s else s.

Fixpoint merge_sort_push (s : seq T) (stack : seq (seq T)) : seq (seq T) :=
  match stack with
  | [::] :: stack' | [::] as stack' => s :: stack'
  | s' :: stack' => [::] :: merge_sort_push (M.merge leT s' s) stack'
  end.

Fixpoint merge_sort_pop (s1 : seq T) (stack : seq (seq T)) : seq T :=
  if stack is s2 :: stack' then
    merge_sort_pop (M.merge leT s2 s1) stack' else s1.

Fixpoint sort1rec (stack : seq (seq T)) (s : seq T) : seq T :=
  if s is x :: s then sort1rec (merge_sort_push [:: x] stack) s else
  merge_sort_pop [::] stack.

Definition sort1 : seq T -> seq T := sort1rec [::].

Fixpoint sort2rec (stack : seq (seq T)) (s : seq T) : seq T :=
  if s is [:: x1, x2 & s'] then
    let s1 := if leT x1 x2 then [:: x1; x2] else [:: x2; x1] in
    sort2rec (merge_sort_push s1 stack) s'
  else merge_sort_pop s stack.

Definition sort2 : seq T -> seq T := sort2rec [::].

Fixpoint sort3rec (stack : seq (seq T)) (s : seq T) : seq T :=
  match s with
    | [:: x1, x2, x3 & s'] =>
      let s1 :=
          if leT x1 x2 then
            if leT x2 x3 then [:: x1; x2; x3]
            else if leT x1 x3 then [:: x1; x3; x2] else [:: x3; x1; x2]
          else
            if leT x1 x3 then [:: x2; x1; x3]
            else if leT x2 x3 then [:: x2; x3; x1] else [:: x3; x2; x1]
      in
      sort3rec (merge_sort_push s1 stack) s'
    | [:: x1; x2] =>
      merge_sort_pop (if leT x1 x2 then s else [:: x2; x1]) stack
    | _ => merge_sort_pop s stack
  end.

Definition sort3 : seq T -> seq T := sort3rec [::].

Fixpoint sortNrec (stack : seq (seq T)) (x : T) (s : seq T) : seq T :=
  if s is y :: s then
    if leT x y then incr stack y s [:: x] else decr stack y s [:: x]
  else
    merge_sort_pop [:: x] stack
with incr (stack : seq (seq T)) (x : T) (s accu : seq T) : seq T :=
  if s is y :: s then
    if leT x y then
      incr stack y s (x :: accu)
    else
      sortNrec (merge_sort_push (catrev accu [:: x]) stack) y s
  else
    merge_sort_pop (catrev accu [:: x]) stack
with decr (stack : seq (seq T)) (x : T) (s accu : seq T) : seq T :=
  if s is y :: s then
    if leT x y then
      sortNrec (merge_sort_push (x :: accu) stack) y s
    else
      decr stack y s (x :: accu)
  else
    merge_sort_pop (x :: accu) stack.

Definition sortN (s : seq T) : seq T :=
  if s is x :: s then sortNrec [::] x s else [::].

(* Proofs *)

Import StableSort.

Local Notation trace_sort := (trace_sort leT).
Let flatten_stack := foldr (fun x => cat^~ (@flatten_trace _ leT x)) nil.

Definition trace_sort_rec sort_rec := forall s stack, {t : trace leT |
   flatten_stack stack ++ s = flatten_trace t &
   sort_rec [seq sort_trace i | i <- stack] s = sort_trace t}.

Lemma trace_sortP sort : trace_sort_rec sort -> trace_sort (sort [::]).
Proof. by move/(_ _ [::]). Qed.

Lemma merge_sort_pushP (t : trace leT) (stack : seq (trace leT)) :
  {stack' : seq (trace leT) |
    flatten_stack (t :: stack) = flatten_stack stack' &
    merge_sort_push (sort_trace t) (map sort_trace stack) =
    map sort_trace stack'}.
Proof.
elim: stack t => [|t' stack IHstack] t /=; first by exists [:: t].
rewrite M.mergeE ifnilE -catA; case: trace_nilP => _ _.
  by exists (t :: stack); rewrite //= cats0.
have [/= {IHstack}stack -> ->] := IHstack (branch_trace true t' t).
by exists (empty_trace :: stack); rewrite //= cats0.
Qed.

Lemma merge_sort_popP (t : trace leT) (stack : seq (trace leT)) :
  {t' : trace leT |
    flatten_stack (t :: stack) = flatten_trace t' &
    merge_sort_pop (sort_trace t) (map sort_trace stack) = sort_trace t'}.
Proof.
elim: stack t => [|t' stack IHstack] t; first by exists t; rewrite //= cats0.
rewrite /= M.mergeE -catA.
by have [/= t'' -> ->] := IHstack (branch_trace true t' t); exists t''.
Qed.

Lemma sort1P : trace_sort sort1.
Proof.
apply/trace_sortP; elim=> [|x s IHs] stack; first exact: merge_sort_popP [tr] _.
case: (merge_sort_pushP [tr<= x] stack).
by rewrite (catA _ [:: _]) => {}stack /= -> ->; exact: IHs.
Qed.

Lemma sort2P : trace_sort sort2.
Proof.
apply/trace_sortP => s; have [n] := ubnP (size s); elim: n s => // n IHn.
move=> [|x [|y s]]/=; rewrite ?ltnS => size_s stack.
- exact: merge_sort_popP [tr<=] _.
- exact: merge_sort_popP [tr<= x] _.
case: (merge_sort_pushP [tr x; y] stack).
by rewrite (catA _ [:: _; _]) => /= {}stack -> ->; apply/IHn/ltnW.
Qed.

Lemma sort3P : trace_sort sort3.
Proof.
apply/trace_sortP => s; have [n] := ubnP (size s); elim: n s => // n IHn.
move=> [|x [|y [|z s]]]/=; rewrite ?ltnS => size_s stack.
- exact: merge_sort_popP [tr<=] _.
- exact: merge_sort_popP [tr<= x] _.
- exact: merge_sort_popP [tr x; y] _.
rewrite (catA _ [:: _; _; _]).
pose xyz : trace leT := branch_trace false [tr x; y] [tr<= z].
case: (merge_sort_pushP xyz stack) => /= stack' ->.
set push1 := merge_sort_push _ _; set push2 := merge_sort_push _ _.
have ->: push1 = push2 by congr merge_sort_push; do 3 case: ifP => //=.
by move=> ->; apply/IHn/ltnW/ltnW.
Qed.

Lemma sortNP : trace_sort sortN.
Proof.
case=> /= [|x s]; first by exists empty_trace.
suff /(_ [::]) : forall stack, {t : trace leT |
   flatten_stack stack ++ x :: s = flatten_trace t &
   sortNrec [seq sort_trace i | i <- stack] x s = sort_trace t} by [].
have [n] := ubnP (size s); elim: n x s => // n IHn x [|y s]/= sn stack.
  exact: merge_sort_popP [tr<= x] _.
set lexy := leT x y.
have: path (fun y x => leT x y == lexy) y [:: x] by rewrite /= eqxx.
have ->: [:: x, y & s] = rev [:: y; x] ++ s by [].
elim: s sn (lexy) (y) [:: x] => {lexy x y} => [|y s IHs' /=] /ltnW sn ord x acc.
  rewrite -/(sorted _ (_ :: _)) -rev_sorted cats0 => sorted_acc.
  case: (merge_sort_popP (leaf_trace ord _ sorted_acc) stack) => /= t ->.
  by rewrite revK; case: ord {sorted_acc} => ->; exists t.
case: ord (boolP (leT x y)) => [] [] lexy.
- move=> path_acc.
  have: path (fun y x => leT x y == true) y (x :: acc) by rewrite /= lexy eqxx.
  by move=> /(IHs' sn)[t]; rewrite -cat_rcons -rev_cons => -> ->; exists t.
- rewrite -/(sorted _ (_ :: _)) -rev_sorted => sorted_acc.
  case: (merge_sort_pushP (leaf_trace true _ sorted_acc) stack) => stack'.
  by rewrite /= catA => -> ->; apply/IHn.
- rewrite -/(sorted _ (_ :: _)) -rev_sorted => sorted_acc.
  case: (merge_sort_pushP (leaf_trace false _ sorted_acc) stack) => stack'.
  by rewrite /= catA revK => -> ->; apply/IHn.
- move=> path_acc.
  have: path (fun y x => leT x y == false) y (x :: acc).
    by rewrite /= eqbF_neg lexy.
  by move=> /(IHs' sn)[t]; rewrite -cat_rcons -rev_cons => -> ->; exists t.
Qed.

End CBN.

Realizer M.merge as merge_R arity 2 := M.merge_R.

Parametricity merge_sort_push.
Parametricity merge_sort_pop.
Parametricity sort1.
Parametricity sort2.
Parametricity sort3.
Parametricity sortN.

Definition sort1_stable := StableSort.Pack sort1 sort1_R sort1P.
Definition sort2_stable := StableSort.Pack sort2 sort2_R sort2P.
Definition sort3_stable := StableSort.Pack sort3 sort3_R sort3P.
Definition sortN_stable := StableSort.Pack sortN sortN_R sortNP.

End CBN_.

Module CBN := CBN_(Merge).
Module CBNAcc := CBN_(MergeAcc).

Canonical CBN.sort1_stable.
Canonical CBN.sort2_stable.
Canonical CBN.sort3_stable.
Canonical CBN.sortN_stable.
Canonical CBNAcc.sort1_stable.
Canonical CBNAcc.sort2_stable.
Canonical CBNAcc.sort3_stable.
Canonical CBNAcc.sortN_stable.

(******************************************************************************)
(* The [CBV_] functor module takes a module [M] of type [RevmergeSig] and     *)
(* provides a family of mergesort functions [sort1], [sort2], [sort3], and    *)
(* [sortN]. These functions are bottom-up and structurally recursive and use  *)
(* [M.revmerge] internally for merging sorted lists. Their naming convention  *)
(* is the same as in the above [CBN_] functor module.                         *)
(* As opposed to the [M.merge] function of a [M : MergeSig], the [M.revmerge] *)
(* function puts its result in the reverse order, and is expected to be a     *)
(* tail-recursive merge function, so that it does not consume the stack       *)
(* linearly in the call-by-value evaluation. Merging with the converse        *)
(* relation of the given order [leT] allows us to merge two lists sorted in   *)
(* the reverse order without taking their reversals (see, e.g., the last case *)
(* of [merge_sort_push]). Also, the push/pop trick of [path.sort] allows us   *)
(* to implement bottom-up mergesort functions with only O(log n) stack        *)
(* consumption. However, this algorithm does not allow us to compute the      *)
(* output incrementally in the optimal O(n + k log k) time regardless of the  *)
(* evaluation strategy.                                                       *)
(******************************************************************************)

Module CBV_ (M : RevmergeSig).
Section CBV.

Variables (T : Type) (leT : rel T).
Let geT x y := leT y x.

Let condrev (r : bool) (s : seq T) : seq T := if r then rev s else s.

Fixpoint merge_sort_push (xs : seq T) (stack : seq (seq T)) : seq (seq T) :=
  match stack with
    | [::] :: stack' | [::] as stack' => xs :: stack'
    | ys :: [::] :: stack | ys :: ([::] as stack) =>
      [::] :: M.revmerge leT ys xs :: stack
    | ys :: zs :: stack =>
      [::] :: [::] ::
           merge_sort_push (M.revmerge geT (M.revmerge leT ys xs) zs) stack
  end.

Fixpoint merge_sort_pop
         (mode : bool) (xs : seq T) (stack : seq (seq T)) : seq T :=
  match stack, mode with
    | [::], true => rev xs
    | [::], false => xs
    | [::] :: [::] :: stack, _ => merge_sort_pop mode xs stack
    | [::] :: stack, _ => merge_sort_pop (~~ mode) (rev xs) stack
    | ys :: stack, true => merge_sort_pop false (M.revmerge geT xs ys) stack
    | ys :: stack, false => merge_sort_pop true (M.revmerge leT ys xs) stack
  end.

Fixpoint sort1rec (stack : seq (seq T)) (s : seq T) : seq T :=
  if s is x :: s then sort1rec (merge_sort_push [:: x] stack) s else
  merge_sort_pop false [::] stack.

Definition sort1 : seq T -> seq T := sort1rec [::].

Fixpoint sort2rec (stack : seq (seq T)) (s : seq T) : seq T :=
  if s is [:: x1, x2 & s'] then
    let s1 := if leT x1 x2 then [:: x1; x2] else [:: x2; x1] in
    sort2rec (merge_sort_push s1 stack) s'
  else merge_sort_pop false s stack.

Definition sort2 : seq T -> seq T := sort2rec [::].

Fixpoint sort3rec (stack : seq (seq T)) (s : seq T) : seq T :=
  match s with
    | [:: x1, x2, x3 & s'] =>
      let s1 :=
          if leT x1 x2 then
            if leT x2 x3 then [:: x1; x2; x3]
            else if leT x1 x3 then [:: x1; x3; x2] else [:: x3; x1; x2]
          else
            if leT x1 x3 then [:: x2; x1; x3]
            else if leT x2 x3 then [:: x2; x3; x1] else [:: x3; x2; x1]
      in
      sort3rec (merge_sort_push s1 stack) s'
    | [:: x1; x2] =>
      merge_sort_pop false (if leT x1 x2 then s else [:: x2; x1]) stack
    | _ => merge_sort_pop false s stack
  end.

Definition sort3 : seq T -> seq T := sort3rec [::].

Fixpoint sortNrec (stack : seq (seq T)) (x : T) (s : seq T) : seq T :=
  if s is y :: s then
    if leT x y then incr stack y s [:: x] else decr stack y s [:: x]
  else
    merge_sort_pop false [:: x] stack
with incr (stack : seq (seq T)) (x : T) (s accu : seq T) : seq T :=
  if s is y :: s then
    if leT x y then
      incr stack y s (x :: accu)
    else
      sortNrec (merge_sort_push (catrev accu [:: x]) stack) y s
  else
    merge_sort_pop false (catrev accu [:: x]) stack
with decr (stack : seq (seq T)) (x : T) (s accu : seq T) : seq T :=
  if s is y :: s then
    if leT x y then
      sortNrec (merge_sort_push (x :: accu) stack) y s
    else
      decr stack y s (x :: accu)
  else
    merge_sort_pop false (x :: accu) stack.

Definition sortN (s : seq T) : seq T :=
  if s is x :: s then sortNrec [::] x s else [::].

(* Proofs *)

Import StableSort.

Local Notation trace_sort := (trace_sort leT).
Let flatten_stack := foldr (fun x => cat^~ (@flatten_trace _ leT x)) nil.

Let Fixpoint sort_stack (mode : bool) (stack : seq (trace leT)) : seq (seq T) :=
  if stack isn't t :: stack then [::] else
    condrev mode (sort_trace t) :: sort_stack (~~ mode) stack.

Definition trace_sort_rec sort_rec := forall s stack, {t : trace leT |
   flatten_stack stack ++ s = flatten_trace t &
   sort_rec (sort_stack false stack) s = sort_trace t}.

Lemma trace_sortP sort : trace_sort_rec sort -> trace_sort (sort [::]).
Proof. by move/(_ _ [::]). Qed.

Lemma merge_sort_pushP (t : trace leT) (stack : seq (trace leT)) :
  {stack' : seq (trace leT) |
    flatten_stack (t :: stack) = flatten_stack stack' &
    merge_sort_push (sort_trace t) (sort_stack false stack)
    = sort_stack false stack'}.
Proof.
move: t stack; fix IHstack 2; move=> t [|t' [|t'' stack]] /=.
- by exists [:: t].
- rewrite !M.revmergeE ifnilE trace_nilp; have [->|_] := nilP.
    by exists [:: t].
  by exists [:: empty_trace; branch_trace true t' t]; rewrite //= cats0.
- rewrite !M.revmergeE !ifnilE nilp_rev !trace_nilp; have [->|_] := nilP.
    by exists [:: t, t'' & stack]; rewrite ?cats0.
  rewrite -!catA; have [->|_] := nilP.
    exists [:: empty_trace, branch_trace true t' t & stack] => //.
    by rewrite /= ?cats0.
  have [/= {}stack -> ->] :=
    IHstack (branch_trace false t'' (branch_trace true t' t)) stack.
  by exists [:: empty_trace, empty_trace & stack]; rewrite /= ?cats0.
Qed.

Let nilp_condrev (r : bool) (s : seq T) : nilp (condrev r s) = nilp s.
Proof. by case: r; rewrite ?nilp_rev. Qed.

Lemma merge_sort_popP (mode : bool) (t : trace leT) (stack : seq (trace leT)) :
  {t' : trace leT |
    flatten_stack (t :: stack) = flatten_trace t' &
    merge_sort_pop mode (condrev mode (sort_trace t)) (sort_stack mode stack)
    = sort_trace t'}.
Proof.
move: mode t stack; fix IHstack 3; move=> mode t [|t' stack] /=.
  by exists t => //; case: mode; rewrite ?revK.
rewrite -catA !M.revmergeE ifnilE nilp_condrev.
case: trace_nilP => _ _; last first.
  by case: mode (IHstack (~~ mode) (branch_trace (~~ mode) t' t) stack).
case: stack => [|t'' stack] /=.
  by exists t => //; case: mode; rewrite ?revK.
rewrite !M.revmergeE !ifnilE !nilp_condrev !negbK revK.
case: trace_nilP => _ _; first by rewrite cats0; apply: IHstack.
rewrite -catA.
by case: mode (IHstack mode (branch_trace mode t'' t) stack); rewrite //= revK.
Qed.

Lemma sort1P : trace_sort sort1.
Proof.
apply/trace_sortP; elim=> [|x s IHs] stack; first exact: merge_sort_popP [tr] _.
case: (merge_sort_pushP [tr<= x] stack).
by rewrite (catA _ [:: _]) => {}stack /= -> ->; exact: IHs.
Qed.

Lemma sort2P : trace_sort sort2.
Proof.
apply/trace_sortP => s; have [n] := ubnP (size s); elim: n s => // n IHn.
move=> [|x [|y s]]/=; rewrite ?ltnS => size_s stack.
- exact: merge_sort_popP [tr<=] _.
- exact: merge_sort_popP [tr<= x] _.
case: (merge_sort_pushP [tr x; y] stack).
by rewrite (catA _ [:: _; _]) => /= {}stack -> ->; apply/IHn/ltnW.
Qed.

Lemma sort3P : trace_sort sort3.
Proof.
apply/trace_sortP => s; have [n] := ubnP (size s); elim: n s => // n IHn.
move=> [|x [|y [|z s]]]/=; rewrite ?ltnS => size_s stack.
- exact: merge_sort_popP [tr<=] _.
- exact: merge_sort_popP [tr<= x] _.
- exact: merge_sort_popP [tr x; y] _.
rewrite (catA _ [:: _; _; _]).
pose xyz : trace leT := branch_trace false [tr x; y] [tr<= z].
case: (merge_sort_pushP xyz stack) => /= stack' ->.
set push1 := merge_sort_push _ _; set push2 := merge_sort_push _ _.
have ->: push1 = push2 by congr merge_sort_push; do 3 case: ifP => //=.
by move=> ->; apply/IHn/ltnW/ltnW.
Qed.

Lemma sortNP : trace_sort sortN.
Proof.
case=> /= [|x s]; first by exists empty_trace.
suff /(_ [::]) : forall stack, {t : trace leT |
   flatten_stack stack ++ x :: s = flatten_trace t &
   sortNrec (sort_stack false stack) x s = sort_trace t} by [].
have [n] := ubnP (size s); elim: n x s => // n IHn x [|y s]/= sn stack.
  exact: merge_sort_popP [tr<= x] _.
set lexy := leT x y.
have: path (fun y x => leT x y == lexy) y [:: x] by rewrite /= eqxx.
have ->: [:: x, y & s] = rev [:: y; x] ++ s by [].
elim: s sn (lexy) (y) [:: x] => {lexy x y} => [|y s IHs' /=] /ltnW sn ord x acc.
  rewrite -/(sorted _ (_ :: _)) -rev_sorted cats0 => sorted_acc.
  case: (merge_sort_popP false (leaf_trace ord _ sorted_acc) stack) => /= t ->.
  by rewrite revK; case: ord {sorted_acc} => ->; exists t.
case: ord (boolP (leT x y)) => [] [] lexy.
- move=> path_acc.
  have: path (fun y x => leT x y == true) y (x :: acc) by rewrite /= lexy eqxx.
  by move=> /(IHs' sn)[t]; rewrite -cat_rcons -rev_cons => -> ->; exists t.
- rewrite -/(sorted _ (_ :: _)) -rev_sorted => sorted_acc.
  case: (merge_sort_pushP (leaf_trace true _ sorted_acc) stack) => stack'.
  by rewrite /= catA => -> ->; apply/IHn.
- rewrite -/(sorted _ (_ :: _)) -rev_sorted => sorted_acc.
  case: (merge_sort_pushP (leaf_trace false _ sorted_acc) stack) => stack'.
  by rewrite /= catA revK => -> ->; apply/IHn.
- move=> path_acc.
  have: path (fun y x => leT x y == false) y (x :: acc).
    by rewrite /= eqbF_neg lexy.
  by move=> /(IHs' sn)[t]; rewrite -cat_rcons -rev_cons => -> ->; exists t.
Qed.

End CBV.

Realizer M.revmerge as revmerge_R arity 2 := M.revmerge_R.

Parametricity merge_sort_push.
Parametricity merge_sort_pop.
Parametricity sort1.
Parametricity sort2.
Parametricity sort3.
Parametricity sortN.

Definition sort1_stable := StableSort.Pack sort1 sort1_R sort1P.
Definition sort2_stable := StableSort.Pack sort2 sort2_R sort2P.
Definition sort3_stable := StableSort.Pack sort3 sort3_R sort3P.
Definition sortN_stable := StableSort.Pack sortN sortN_R sortNP.

End CBV_.

Module CBV := CBV_(Revmerge).
Module CBVAcc := CBV_(RevmergeAcc).

Canonical CBV.sort1_stable.
Canonical CBV.sort2_stable.
Canonical CBV.sort3_stable.
Canonical CBV.sortN_stable.
Canonical CBVAcc.sort1_stable.
Canonical CBVAcc.sort2_stable.
Canonical CBVAcc.sort3_stable.
Canonical CBVAcc.sortN_stable.

(******************************************************************************)
(* Theory of stable sort functions                                            *)
(******************************************************************************)

Section StableSortTheory.

Let lexord (T : Type) (leT leT' : rel T) :=
  [rel x y | leT x y && (leT y x ==> leT' x y)].

Let lexord_total (T : Type) (leT leT' : rel T) :
  total leT -> total leT' -> total (lexord leT leT').
Proof.
move=> leT_total leT'_total x y /=.
by move: (leT_total x y) (leT'_total x y) => /orP[->|->] /orP[->|->];
  rewrite /= ?implybE ?orbT ?andbT //= (orbAC, orbA) (orNb, orbN).
Qed.

Let lexord_trans (T : Type) (leT leT' : rel T) :
  transitive leT -> transitive leT' -> transitive (lexord leT leT').
Proof.
move=> leT_tr leT'_tr y x z /= /andP[lexy leyx] /andP[leyz lezy].
rewrite (leT_tr _ _ _ lexy leyz); apply/implyP => lezx; move: leyx lezy.
by rewrite (leT_tr _ _ _ leyz lezx) (leT_tr _ _ _ lezx lexy); exact: leT'_tr.
Qed.

Let lexordA (T : Type) (leT leT' leT'' : rel T) :
  lexord leT (lexord leT' leT'') =2 lexord (lexord leT leT') leT''.
Proof. by move=> x y /=; case: (leT x y) (leT y x) => [] []. Qed.

Section StableSortTheory_Part1.

Variable (sort : stableSort).

Local Lemma param_sort : StableSort.sort_ty_R sort sort.
Proof. by case: sort => ? param ?; exact: param. Qed.

Lemma map_sort (T T' : Type) (f : T' -> T) (leT' : rel T') (leT : rel T) :
  {mono f : x y / leT' x y >-> leT x y} ->
  {morph map f : s1 / sort _ leT' s1 >-> sort _ leT s1}.
Proof.
move=> leT_mono xs; apply/esym/rel_map_map/param_sort/map_rel_map.
by move=> ? ? <- ? ? <-; apply/bool_R_refl/esym/leT_mono.
Qed.

Lemma sort_map (T T' : Type) (f : T' -> T) (leT : rel T) (s : seq T') :
  sort _ leT (map f s) = map f (sort _ (relpre f leT) s).
Proof. exact/esym/map_sort. Qed.

Section SortSeq.

Variable (T : Type) (P : {pred T}) (leT : rel T).

Variant sort_spec : seq T -> seq T -> Type :=
  SortSpec (t : StableSort.trace leT) :
    sort_spec (StableSort.flatten_trace t) (StableSort.sort_trace t).

Local Lemma sortP (s : seq T) : sort_spec s (sort _ leT s).
Proof.
by case: sort => ? ? sortP; have [/= t -> ->] := sortP _ leT s; constructor.
Qed.

Lemma all_sort (s : seq T) : all P (sort _ leT s) = all P s.
Proof. by case: sortP; exact: StableSort.all_trace. Qed.

Lemma size_sort (s : seq T) : size (sort _ leT s) = size s.
Proof. case: sortP; exact: StableSort.size_trace. Qed.

Lemma sort_nil : sort _ leT [::] = [::].
Proof. by case: (sort _) (size_sort [::]). Qed.

Lemma pairwise_sort (s : seq T) : pairwise leT s -> sort _ leT s = s.
Proof.
case: {s}sortP; elim=> [b l IHl r IHr|[] [|x [|y s]]] //=; last by case: leT.
rewrite pairwise_cat => /and3P[hlr /IHl -> /IHr ->].
rewrite !allrel_merge ?rev_cat ?revK //; first by case: b.
by rewrite /allrel all_rev [all _ _]allrelC /allrel all_rev.
Qed.

Lemma sorted_sort : transitive leT ->
  forall s : seq T, sorted leT s -> sort _ leT s = s.
Proof. by move=> leT_tr s; rewrite sorted_pairwise //; apply/pairwise_sort. Qed.

End SortSeq.

Lemma sorted_sort_in (T : Type) (P : {pred T}) (leT : rel T) :
  {in P & &, transitive leT} ->
  forall s : seq T, all P s -> sorted leT s -> sort _ leT s = s.
Proof.
move=> /in3_sig ? _ /all_sigP[s ->].
by rewrite sort_map sorted_map => /sorted_sort->.
Qed.

Section EqSortSeq.

Variables (T : eqType) (leT : rel T).

Lemma perm_sort (s : seq T) : perm_eql (sort _ leT s) s.
Proof. by case: sortP; exact: StableSort.perm_trace. Qed.

Lemma mem_sort (s : seq T) : sort _ leT s =i s.
Proof. exact/perm_mem/permPl/perm_sort. Qed.

Lemma sort_uniq (s : seq T) : uniq (sort _ leT s) = uniq s.
Proof. exact/perm_uniq/permPl/perm_sort. Qed.

End EqSortSeq.

Lemma sort_pairwise_stable (T : Type) (leT leT' : rel T) :
  total leT -> forall s : seq T, pairwise leT' s ->
  sorted (lexord leT leT') (sort _ leT s).
Proof.
move=> leT_total s; case: {s}sortP; elim=> [b l IHl r IHr|b s] /=.
  rewrite pairwise_cat => /and3P[hlr /IHl ? /IHr ?].
  rewrite fun_if ?(rev_sorted, merge_stable_sorted) ?if_same ?allrel_rev2//;
    do 2 rewrite /allrel ?all_rev StableSort.all_trace [all _ _]allrelC //.
  by rewrite allrelC.
move=> sorted_s1 /pairwise_sorted /(conj sorted_s1) /andP.
case: (b); rewrite -sorted_relI ?rev_sorted;
  apply: sub_sorted => x y /= /andP[/eqP xy xy']; rewrite ?xy ?xy' ?implybT //.
by case: (leT _ _) xy (leT_total x y) => //= _ ->.
Qed.

Lemma sort_pairwise_stable_in (T : Type) (P : {pred T}) (leT leT' : rel T) :
  {in P &, total leT} -> forall s : seq T, all P s -> pairwise leT' s ->
  sorted (lexord leT leT') (sort _ leT s).
Proof.
move=> /in2_sig leT_total _ /all_sigP[s ->].
by rewrite sort_map pairwise_map sorted_map; apply: sort_pairwise_stable.
Qed.

Lemma sort_stable (T : Type) (leT leT' : rel T) :
  total leT -> transitive leT' -> forall s : seq T, sorted leT' s ->
  sorted (lexord leT leT') (sort _ leT s).
Proof.
by move=> ? ? s; rewrite sorted_pairwise//; apply: sort_pairwise_stable.
Qed.

Lemma sort_stable_in (T : Type) (P : {pred T}) (leT leT' : rel T) :
  {in P &, total leT} -> {in P & &, transitive leT'} ->
  forall s : seq T, all P s -> sorted leT' s ->
  sorted (lexord leT leT') (sort _ leT s).
Proof.
move=> /in2_sig leT_total /in3_sig leT_tr _ /all_sigP[s ->].
by rewrite sort_map !sorted_map; apply: sort_stable.
Qed.

Lemma filter_sort (T : Type) (leT : rel T) :
  total leT -> transitive leT ->
  forall (p : pred T) (s : seq T),
    filter p (sort _ leT s) = sort _ leT (filter p s).
Proof.
move=> leT_total leT_tr p s; case Ds: s => [|x s1]; first by rewrite sort_nil.
pose lt := lexord (relpre (nth x s) leT) ltn.
have lt_tr: transitive lt by apply/lexord_trans/ltn_trans/relpre_trans.
rewrite -{s1}Ds -(mkseq_nth x s) !(filter_map, sort_map); congr map.
have lt_irr : irreflexive lt by move=> ?; rewrite /= ltnn implybF andbN.
apply/(@irr_sorted_eq _ lt); rewrite /lt /lexord //=; last 1 first.
- by move=> ?; rewrite !(mem_filter, mem_sort).
- exact/sorted_filter/sort_stable/iota_ltn_sorted/ltn_trans.
- exact/sort_stable/sorted_filter/iota_ltn_sorted/ltn_trans/ltn_trans.
Qed.

Lemma filter_sort_in (T : Type) (P : {pred T}) (leT : rel T) :
  {in P &, total leT} -> {in P & &, transitive leT} ->
  forall (p : pred T) (s : seq T),
    all P s -> filter p (sort _ leT s) = sort _ leT (filter p s).
Proof.
move=> /in2_sig leT_total /in3_sig leT_tr p _ /all_sigP[s ->].
by rewrite !(sort_map, filter_map) filter_sort.
Qed.

Lemma sort_sort (T : Type) (leT leT' : rel T) :
  total leT -> transitive leT -> total leT' -> transitive leT' ->
  forall s : seq T, sort _ leT (sort _ leT' s) = sort _ (lexord leT leT') s.
Proof.
move=> leT_total leT_tr leT'_total leT'_tr s.
case s_eq : {-}s => [|x s1]; first by rewrite s_eq !sort_nil.
pose lt' := lexord (relpre (nth x s) leT') ltn.
pose lt := lexord (relpre (nth x s) leT) lt'.
have lt'_tr: transitive lt' by apply/lexord_trans/ltn_trans/relpre_trans.
have lt_tr : transitive lt by apply/lexord_trans/lt'_tr/relpre_trans.
rewrite -(mkseq_nth x s) !(filter_map, sort_map); congr map.
apply/(@irr_sorted_eq _ lt); rewrite /lt /lexord //=.
- by move=> ?; rewrite /= ltnn !(implybF, andbN).
- exact/sort_stable/sort_stable/iota_ltn_sorted/ltn_trans.
- under eq_sorted do rewrite lexordA.
  exact/sort_stable/iota_ltn_sorted/ltn_trans/lexord_total.
- by move=> ?; rewrite !mem_sort.
Qed.

Lemma sort_sort_in (T : Type) (P : {pred T}) (leT leT' : rel T) :
  {in P &, total leT} -> {in P & &, transitive leT} ->
  {in P &, total leT'} -> {in P & &, transitive leT'} ->
  forall s : seq T,
    all P s -> sort _ leT (sort _ leT' s) = sort _ (lexord leT leT') s.
Proof.
move=> /in2_sig leT_total /in3_sig leT_tr /in2_sig leT'_total /in3_sig leT'_tr.
by move=> _ /all_sigP[s ->]; rewrite !sort_map sort_sort.
Qed.

Lemma sort_sorted (T : Type) (leT : rel T) :
  total leT -> forall s : seq T, sorted leT (sort _ leT s).
Proof.
move=> leT_total s; apply/sub_sorted/sort_stable => //= [? ? /andP[] //|].
by case: s => // x s; elim: s x => /=.
Qed.

Lemma sort_sorted_in (T : Type) (P : {pred T}) (leT : rel T) :
  {in P &, total leT} -> forall s : seq T, all P s -> sorted leT (sort _ leT s).
Proof.
by move=> /in2_sig ? _ /all_sigP[s ->]; rewrite sort_map sorted_map sort_sorted.
Qed.

Lemma perm_sortP (T : eqType) (leT : rel T) :
  total leT -> transitive leT -> antisymmetric leT ->
  forall s1 s2, reflect (sort _ leT s1 = sort _ leT s2) (perm_eq s1 s2).
Proof.
move=> leT_total leT_tr leT_asym s1 s2.
apply: (iffP idP) => eq12; last by rewrite -(perm_sort leT) eq12 perm_sort.
apply: (sorted_eq leT_tr leT_asym); rewrite ?sort_sorted //.
by rewrite perm_sort (permPl eq12) -(perm_sort leT).
Qed.

Lemma perm_sort_inP (T : eqType) (leT : rel T) (s1 s2 : seq T) :
  {in s1 &, total leT} -> {in s1 & &, transitive leT} ->
  {in s1 &, antisymmetric leT} ->
  reflect (sort _ leT s1 = sort _ leT s2) (perm_eq s1 s2).
Proof.
move=> /in2_sig leT_total /in3_sig leT_tr /in2_sig/(_ _ _ _)/val_inj leT_asym.
apply: (iffP idP) => s1s2; last by rewrite -(perm_sort leT) s1s2 perm_sort.
move: (s1s2); have /all_sigP[s1' ->] := allss s1.
have /all_sigP[{s1s2}s2 ->] : all (mem s1) s2 by rewrite -(perm_all _ s1s2).
by rewrite !sort_map => /(perm_map_inj val_inj) /(perm_sortP leT_total)->.
Qed.

End StableSortTheory_Part1.

Lemma eq_sort (sort1 sort2 : stableSort) (T : Type) (leT : rel T) :
  total leT -> transitive leT -> sort1 _ leT =1 sort2 _ leT.
Proof.
move=> leT_total leT_tr s; case Ds: s => [|x s1]; first by rewrite !sort_nil.
pose lt := lexord (relpre (nth x s) leT) ltn.
have lt_tr: transitive lt by apply/lexord_trans/ltn_trans/relpre_trans.
rewrite -{s1}Ds -(mkseq_nth x s) !(filter_map, sort_map); congr map.
apply/(@irr_sorted_eq _ lt); rewrite /lt /lexord //=.
- by move=> ?; rewrite /= ltnn implybF andbN.
- exact/sort_stable/iota_ltn_sorted/ltn_trans.
- exact/sort_stable/iota_ltn_sorted/ltn_trans.
- by move=> ?; rewrite !mem_sort.
Qed.

Lemma eq_in_sort
      (sort1 sort2 : stableSort) (T : Type) (P : {pred T}) (leT : rel T) :
  {in P &, total leT} -> {in P & &, transitive leT} ->
  forall s, all P s -> sort1 _ leT s = sort2 _ leT s.
Proof.
move=> /in2_sig ? /in3_sig ? _ /all_sigP[s ->].
by rewrite !sort_map; congr map; exact: eq_sort.
Qed.

Section StableSortTheory_Part2.

Variable (sort : stableSort).

Section Stability.

Variables (T : Type) (leT : rel T).
Variables (leT_total : total leT) (leT_tr : transitive leT).

Lemma eq_sort_insert : sort _ leT =1 Insertion.sort leT.
Proof. exact: eq_sort. Qed.

Lemma sort_cat (s1 s2 : seq T) :
  sort _ leT (s1 ++ s2) = path.merge leT (sort _ leT s1) (sort _ leT s2).
Proof. by rewrite !eq_sort_insert; elim: s1 => //= x s1 ->; rewrite mergeA. Qed.

Lemma mask_sort (s : seq T) (m : bitseq) :
  {m_s : bitseq | mask m_s (sort _ leT s) = sort _ leT (mask m s)}.
Proof.
case Ds: {-}s => [|x s1]; first by exists [::]; rewrite Ds mask0 sort_nil.
rewrite -(mkseq_nth x s) -map_mask !sort_map.
exists [seq i \in mask m (iota 0 (size s)) |
            i <- sort _ (xrelpre (nth x s) leT) (iota 0 (size s))].
rewrite -map_mask -filter_mask [in RHS]mask_filter ?iota_uniq ?filter_sort //.
by move=> ? ? ?; exact: leT_tr.
Qed.

Lemma sorted_mask_sort (s : seq T) (m : bitseq) :
  sorted leT (mask m s) -> {m_s : bitseq | mask m_s (sort _ leT s) = mask m s}.
Proof. by move/(sorted_sort sort leT_tr) <-; exact: mask_sort. Qed.

End Stability.

Section Stability_in.

Variables (T : Type) (P : {pred T}) (leT : rel T).
Hypothesis leT_total : {in P &, total leT}.
Hypothesis leT_tr : {in P & &, transitive leT}.

Let le_sT := relpre (val : sig P -> _) leT.
Let le_sT_total : total le_sT := in2_sig leT_total.
Let le_sT_tr : transitive le_sT := in3_sig leT_tr.

Lemma eq_in_sort_insert (s : seq T) :
  all P s -> sort _ leT s = Insertion.sort leT s.
Proof. exact: eq_in_sort. Qed.

Lemma sort_cat_in (s1 s2 : seq T) : all P s1 -> all P s2 ->
  sort _ leT (s1 ++ s2) = merge leT (sort _ leT s1) (sort _ leT s2).
Proof.
move=> /all_sigP [{}s1 ->] /all_sigP [{}s2 ->].
by rewrite -map_cat !sort_map merge_map; congr map; apply: sort_cat.
Qed.

Lemma mask_sort_in (s : seq T) (m : bitseq) :
  all P s -> {m_s : bitseq | mask m_s (sort _ leT s) = sort _ leT (mask m s)}.
Proof.
move=> /all_sigP [{}s ->]; case: (mask_sort (leT := le_sT) _ _ s m) => //.
by move=> m' m'E; exists m'; rewrite -map_mask !sort_map -map_mask m'E.
Qed.

Lemma sorted_mask_sort_in (s : seq T) (m : bitseq) :
  all P s -> sorted leT (mask m s) ->
  {m_s : bitseq | mask m_s (sort _ leT s) = mask m s}.
Proof.
move=> ? /(sorted_sort_in sort leT_tr _) <-; last exact: all_mask.
exact: mask_sort_in.
Qed.

End Stability_in.

Section Stability_subseq.

Variables (T : eqType) (leT : rel T).
Variables (leT_total : total leT) (leT_tr : transitive leT).

Lemma subseq_sort : {homo sort _ leT : t s / subseq t s}.
Proof.
move=> _ s /subseqP [m _ ->].
have [m' <-] := mask_sort leT_total leT_tr s m; exact: mask_subseq.
Qed.

Lemma sorted_subseq_sort (t s : seq T) :
  subseq t s -> sorted leT t -> subseq t (sort _ leT s).
Proof.
by move=> subseq_ts /(sorted_sort sort leT_tr) <-; exact: subseq_sort.
Qed.

Lemma mem2_sort (s : seq T) (x y : T) :
    leT x y -> mem2 s x y -> mem2 (sort _ leT s) x y.
Proof.
move=> lexy; rewrite !mem2E => /subseq_sort; rewrite !eq_sort_insert //.
by case: (_ == _); rewrite //= lexy.
Qed.

End Stability_subseq.

Section Stability_subseq_in.

Variables (T : eqType) (leT : rel T).

Lemma subseq_sort_in (t s : seq T) :
  {in s &, total leT} -> {in s & &, transitive leT} ->
  subseq t s -> subseq (sort _ leT t) (sort _ leT s).
Proof.
move=> leT_total leT_tr /subseqP [m _ ->].
have [m' <-] := mask_sort_in leT_total leT_tr m (allss _); exact: mask_subseq.
Qed.

Lemma sorted_subseq_sort_in (t s : seq T) :
  {in s &, total leT} -> {in s & &, transitive leT} ->
  subseq t s -> sorted leT t -> subseq t (sort _ leT s).
Proof.
move=> ? leT_tr ? /(sorted_sort_in sort leT_tr) <-; last exact/allP/mem_subseq.
exact: subseq_sort_in.
Qed.

Lemma mem2_sort_in (s : seq T) :
  {in s &, total leT} -> {in s & &, transitive leT} ->
  forall x y, leT x y -> mem2 s x y -> mem2 (sort _ leT s) x y.
Proof.
move=> leT_total leT_tr x y lexy; rewrite !mem2E.
move=> /[dup] /mem_subseq /allP ? /subseq_sort_in.
rewrite !(eq_in_sort_insert leT_total leT_tr) //.
by case: (_ == _); rewrite /= ?lexy; apply.
Qed.

End Stability_subseq_in.

End StableSortTheory_Part2.

End StableSortTheory.

Arguments map_sort                sort {T T' f leT' leT} _ _.
Arguments sort_map                sort {T T' f leT} s.
Arguments all_sort                sort {T} P leT s.
Arguments size_sort               sort {T} leT s.
Arguments sort_nil                sort {T} leT.
Arguments pairwise_sort           sort {T leT s} _.
Arguments sorted_sort             sort {T leT} leT_tr {s} _.
Arguments sorted_sort_in          sort {T P leT} leT_tr {s} _ _.
Arguments perm_sort               sort {T} leT s _.
Arguments mem_sort                sort {T} leT s _.
Arguments sort_uniq               sort {T} leT s.
Arguments sort_pairwise_stable    sort {T leT leT'} leT_total {s} _.
Arguments sort_pairwise_stable_in sort {T P leT leT'} leT_total {s} _ _.
Arguments sort_stable             sort {T leT leT'} leT_total leT'_tr {s} _.
Arguments sort_stable_in          sort {T P leT leT'} leT_total leT'_tr {s} _ _.
Arguments filter_sort             sort {T leT} leT_total leT_tr p s.
Arguments filter_sort_in          sort {T P leT} leT_total leT_tr p {s} _.
Arguments sort_sort               sort {T leT leT'}
                                  leT_total leT_tr leT'_total leT'_tr s.
Arguments sort_sort_in            sort {T P leT leT'}
                                  leT_total leT_tr leT'_total leT'_tr {s} _.
Arguments sort_sorted             sort {T leT} leT_total s.
Arguments sort_sorted_in          sort {T P leT} leT_total {s} _.
Arguments perm_sortP              sort {T leT} leT_total leT_tr leT_asym s1 s2.
Arguments perm_sort_inP           sort {T leT s1 s2} leT_total leT_tr leT_asym.
Arguments eq_sort                 sort1 sort2 {T leT} leT_total leT_tr _.
Arguments eq_in_sort              sort1 sort2 {T P leT} leT_total leT_tr {s} _.
Arguments eq_sort_insert          sort {T leT} leT_total leT_tr _.
Arguments sort_cat                sort {T leT} leT_total leT_tr s1 s2.
Arguments mask_sort               sort {T leT} leT_total leT_tr s m.
Arguments sorted_mask_sort        sort {T leT} leT_total leT_tr {s m} _.
Arguments eq_in_sort_insert       sort {T P leT} leT_total leT_tr {s} _.
Arguments sort_cat_in             sort {T P leT} leT_total leT_tr {s1 s2} _ _.
Arguments mask_sort_in            sort {T P leT} leT_total leT_tr {s} m _.
Arguments sorted_mask_sort_in     sort {T P leT} leT_total leT_tr {s m} _ _.
Arguments subseq_sort             sort {T leT} leT_total leT_tr {x y} _.
Arguments sorted_subseq_sort      sort {T leT} leT_total leT_tr {t s} _ _.
Arguments mem2_sort               sort {T leT} leT_total leT_tr {s x y} _ _.
Arguments subseq_sort_in          sort {T leT t s} leT_total leT_tr _.
Arguments sorted_subseq_sort_in   sort {T leT t s} leT_total leT_tr _ _.
Arguments mem2_sort_in            sort {T leT s} leT_total leT_tr x y _ _.


Require Import Coq.micromega.Lia.
Require Import Coq.Program.Basics.
Require Import Coq.Sorting.Sorted.
Require Import Coq.Lists.List.
Require Import Coq.Lists.SetoidList.
Import ListNotations.
Local Open Scope list_scope.

Lemma SortA_rev A R ls
  : @Sorted A (flip R) ls -> @Sorted A R (List.rev ls).
Proof.
  induction 1; cbn; [ constructor 1 | ].
  let H := match goal with H : HdRel _ _ _ |- _ => H end in
  destruct H; cbn in *; try solve [ repeat constructor ].
  let l := match goal with |- Sorted _ ((rev ?l ++ _) ++ _) => l end in
  induction (List.rev l) as [|x xs IH]; [ repeat constructor; assumption | ].
  cbn in *.
  invlist Sorted.
  constructor; eauto.
  set (ls := xs ++ _) in *.
  assert (List.length ls > 0)
    by (subst ls; rewrite app_length; cbn; lia).
  let H := match goal with H : HdRel _ _ ls |- HdRel _ _ (ls ++ _) => H end in
  destruct H; cbn in *; try solve [ repeat constructor; assumption ]; try lia.
Qed.

Lemma SortA_rev_iff A R ls
  : @Sorted A R (List.rev ls) <-> @Sorted A (flip R) ls.
Proof.
  rewrite <- (rev_involutive ls);
    split; intro; apply SortA_rev; rewrite ?rev_involutive in *;
    assumption.
Qed.


(** * Some useful lemmas

Among other things:
- associativity of horizontal composition of natural transformations [horcomp_assoc]
- functors from Set preserves epis, assuming the axiom of choice [preserves_to_HSET_isEpi]
- isomorphisms of categories transfer initiality
- if there is a universal arrow from the initial object, then the target category has
  an initial object [initial_universal_to_lift_initial]
- an adjunction whose unit is iso is a coreflection (i.e. the left adjoint is full and faithful)
    [isounit_coreflection]
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Epis.

Require Import UniMath.CategoryTheory.HorizontalComposition.

Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.catiso.

Require Import UniMath.CategoryTheory.Adjunctions.Core.

Local Notation "'SET'" := hset_category.
(* obsolete: Local Notation "G □ F" := (functor_composite F G) (at level 35).
already loaded: Local Notation "F ∙ G" := (functor_composite F G) (at level 35).*)
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Local  Notation "α ∙∙ β" := (horcomp β α) (at level 20).

Tactic Notation "cpre" uconstr(x) := apply (cancel_precomposition x).
Tactic Notation "cpost" uconstr(x) := apply (cancel_postcomposition).

Open Scope cat.

(** Even true of equivalences *)
Lemma catiso_initial {C D : precategory} (w : catiso C D) (ini : Initial C) : Initial D.
Proof.
  set (obweq := catiso_ob_weq w).
  use make_Initial.
  - exact (w ini).
  - use make_isInitial.
    intro b.
    assert (h := homotweqinvweq obweq b).
    rewrite <- h.
    eapply iscontrweqb.
    + apply invweq.
      use catiso_fully_faithful_weq.
    + apply (pr2 ini).
Defined.

Lemma initial_universal_to_lift_initial {D C : precategory}
      (S : D ⟶ C)
      (c : Initial C)
      {r : D} {f : C ⟦ c, S r ⟧}
      (unif : is_universal_arrow_to  S c r f) :
  isInitial _ r.
Proof.
  intro d.
  specialize (unif d (InitialArrow _ _)).
  use make_iscontr.
  - apply (iscontrpr1 unif).
  - intro g.
    cbn.
    apply path_to_ctr.
    apply InitialArrowUnique.
Qed.

(**
hom(X , Y) ~ hom(X , U F Y) ~ hom(F X , F Y)
*)
Lemma isounit_coreflection {C : category}{D : category } {F} (isF : is_left_adjoint (A := C) (B := D) F) :
  is_iso (C := [C , C])
         (unit_from_left_adjoint isF
          : [C,C] ⟦ functor_identity _, F ∙ right_adjoint isF ⟧) -> fully_faithful F.
Proof.
  intro isounit.
  assert (homweq := (adjunction_homsetiso_weq (pr2 isF))).
  assert (isounitpw := is_functor_iso_pointwise_if_iso _ _ _ _ _ _ isounit).
  intros S1 S2.
  eapply isweqhomot; revgoals.
  - unshelve apply weqproperty.
    eapply weqcomp.
    + eapply iso_comp_left_weq.
      use (_ ,, isounitpw S2 ).
    + apply invweq.
      use hom_weq.
      apply (adjunction_homsetiso_weq (pr2 isF)).
  - intro ff.
    cbn.
    unfold φ_adj_inv; cbn.
    rewrite functor_comp.
    rewrite <- assoc.
    etrans;[ apply cancel_precomposition, triangle_id_left_ad|].
    apply id_right.
Defined.

(** common generalization to [maponpaths] and [toforallpaths] *)

Lemma changef_path   {T1 T2 : UU} (f g : T1 → T2) (t1 t2 : T1) :
  f = g -> f t1 = f t2 -> g t1 = g t2.
Proof.
  induction 1; auto.
Qed.

Lemma changef_path_pw   {T1 T2 : UU} (f g : T1 → T2) (t1 t2 : T1) :
  (∏ x, f x = g x) -> f t1 = f t2 -> g t1 = g t2.
Proof.
  intro eq.
  induction (eq t1); induction (eq t2); auto.
Qed.

(** Associativity of horizontal composition of natural transformations *)
Lemma horcomp_assoc
  : ∏ {B C D E : category} {H H' : functor B C}
      {F F' : functor C D} {G G' : functor D E}
      (a : nat_trans H H') (b : nat_trans F F') (c : nat_trans G G') x,
    ((c ∙∙ b) ∙∙ a) x = (c ∙∙( b ∙∙ a)) x.
Proof.
  intros.
  cbn.
  do 2 (unfold horcomp_data; cbn).
  symmetry.
  rewrite functor_comp,assoc. apply idpath.
Qed.

(** Same as [nat_trans_comp_pointwise], but with B = A · A' *)
Definition nat_trans_comp_pointwise' :
  ∏ (C : precategory) (C' : category)  (F G H : ([C, C' , _ ])%Cat)
    (A : ([C, C' , _] ⟦ F, G ⟧)%Cat) (A' : ([C, C' , _] ⟦ G, H ⟧)%Cat) (a : C),
  ((A  : nat_trans _ _) a ·  (A' : nat_trans _ _) a)%Cat =  (A · A' : nat_trans _ _)%Cat a
  :=
  fun C C'  F G H A A' => @nat_trans_comp_pointwise C C' (homset_property C') F G H A A' _ (idpath _).

(** Composition in Set category is the usual composition of function *)
Lemma comp_cat_comp {A B C:hSet} (f : A -> B) (g:B -> C) x :
  g (f x) = compose (C:= SET) f g x.
Proof.
  reflexivity.
Qed.

(*
Lemma isEpi_pre_whisker (B C :precategory)(D : category)
      (G H : functor C D) (K : functor B C) (f : nat_trans G H)
  : (∏ x, isEpi (f x))
    ->
    isEpi (C:=functor_category B D )
          (x:= (G □ K)) (y:= (H □ K))
          (pre_whisker K f).
Proof.
  clear.
  intro isEpif.
  apply is_nat_trans_epi_from_pointwise_epis.
  intro a.
  apply isEpif.
Qed.
*)

(* This is true for finitary endofunctors
or assuming the axiom of choice if the target
category has effective epis
(because in this case, any epi is absolute)

 *)
(*
Lemma isEpi_post_whisker_pw (B :precategory)(C D : category)
      (G H : functor B C) (K : functor C D) (f : nat_trans G H)
  (KpreservesEpis : forall a b (g : (C ⟦ a, b⟧)%Cat), isEpi g -> isEpi ((#K g)%cat)) :
    (forall x, isEpi (C:=  _ ) (f x))
    -> ∏ b,
    isEpi
            (post_whisker f K b).
Proof.
  intros epif b.
  apply KpreservesEpis, epif.
Qed.
*)
(*
Lemma isEpi_post_whisker (B :precategory)(C D : category)
      (G H : functor B C) (K : functor C D) (f : nat_trans G H)
  (KpreservesEpis : forall a b (g : (C ⟦ a, b⟧)%Cat), isEpi g -> isEpi ((#K g)%cat)) :
    (forall x, isEpi (C:=  _ ) (f x))
    -> isEpi (C:=functor_category B D)
            (x:= (K □ G)) (y:= (K □ H))
            (post_whisker f K ).
Proof.
  intros epif.
  apply is_nat_trans_epi_from_pointwise_epis.
  apply isEpi_post_whisker_pw; assumption.
Qed.
*)

(*
Lemma isEpi_post_whisker_HSET (choice : AxiomOfChoice.AxiomOfChoice_surj)
      (B :precategory) (C:=hset_category) ( D : category)
      (G H : functor B C) (K : functor C D) (f : nat_trans G H) :
    (forall b, isEpi  (f b))
    ->
    isEpi (C:=functor_category B D)
            (x:= (K □ G)) (y:= (K □ H))
            (post_whisker f K).
Proof.
  apply isEpi_post_whisker.
  intros a b g epig.
  apply isSplitEpi_isEpi; [ apply homset_property|].
  apply preserves_isSplitEpi.
  apply SplitEpis_HSET; [|apply epig].
  apply choice.
Qed.
*)
(*
Le mettre dans UniMath
Lemma horcomp_pre_post :
  Π (C D:precategory) ( E : Precategory) (F F' : functor C D) (G G' : functor D E) (f:F ⟶ F') (g:G ⟶ G'),
  horcomp f g = compose (C:=functor_Precategory C E) (a:= (G □ F)) (b:= (G' □ F)) (c:= (G' □ F'))
                        (pre_whisker F g)
                        (post_whisker f G').
Proof.
  intros.
  apply nat_trans_eq.
  apply homset_property.
  intros;
    apply idpath.
Qed.
*)

(* inutile, c'est juste la composition de deux morphismes *)
(*
Lemma isEpi_horcomp_pw (B : precategory)(C D : category)
      (G H : functor B C) (G' H' : functor C D)
      (f : nat_trans G H) (f':nat_trans G' H')
  (H'epi : ∏ (a b : C) (g : (C ⟦ a, b ⟧)%Cat), isEpi g → isEpi ((# H')%Cat g))
  : (∏ x, isEpi  (f x))
    -> (∏ x, isEpi (f' x))
    -> ∏ x,  isEpi (horcomp f f' x).
Proof.
  intros epif epif'.
  intro x.
  apply isEpi_comp.
  - apply epif'.
  - apply H'epi, epif.
Qed.

Lemma isEpi_horcomp_pw_HSET (choice : AxiomOfChoice.AxiomOfChoice_surj)
      {B : precategory} (C := hset_category){D : category}
      (G H : functor B C) (G' H' : functor C D)
      (f : nat_trans G H) (f':nat_trans G' H')
  : (∏ x, isEpi  (f x))
    -> (∏ x, isEpi (f' x))
    -> ∏ x, isEpi (horcomp f f' x).
Proof.
  apply isEpi_horcomp_pw.
  intros a b g epig.
  apply isSplitEpi_isEpi; [ apply homset_property|].
  apply preserves_isSplitEpi.
  apply SplitEpis_HSET; [|apply epig].
  apply choice.
Qed.
*)
(*
Lemma isEpi_horcomp (B : precategory)(C D : category)
      (G H : functor B C) (G' H' : functor C D)
      (f : nat_trans G H) (f':nat_trans G' H')
  (H'epi : ∏ (a b : C) (g : (C ⟦ a, b ⟧)%Cat), isEpi g → isEpi ((# H')%Cat g))
  : (∏ x, isEpi  (f x))
    -> (∏ x, isEpi (f' x))
    -> isEpi (C:= functor_category B D)
             (x:= (G' □ G)) (y:= (H' □ H))
             (horcomp f f').
Proof.
  intros epif epif'.
  apply is_nat_trans_epi_from_pointwise_epis.
  apply isEpi_horcomp_pw; assumption.
Qed.
*)

(*
Lemma isEpi_horcomp_pw_HSET (choice : AxiomOfChoice.AxiomOfChoice_surj)
      {B : precategory} (C := hset_category){D : category}
      (G H : functor B C) (G' H' : functor C D)
      (f : nat_trans G H) (f':nat_trans G' H')
  : (∏ x, isEpi  (f x))
    -> (∏ x, isEpi (f' x))
    -> isEpi (C:= functor_category B D)
             (x:= (G' □ G)) (y:= (H' □ H))
             (horcomp f f').
Proof.
  apply isEpi_horcomp.
  intros a b g epig.
  apply isSplitEpi_isEpi; [ apply homset_property|].
  apply preserves_isSplitEpi.
  apply SplitEpis_HSET; [|apply epig].
  apply choice.
Qed.
*)

(*
(* copié de ssreflect. Pour l'instant inutile *)
Lemma master_key : unit.
  exact tt.
Qed.
Definition locked {A} := unit_rect _  (fun x : A => x) master_key.

Lemma lock A x : x = locked x :> A.
Proof.
  unfold locked.
  now destruct master_key.
Qed.

*)


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Local Open Scope R_scope.

Definition sin_term (a:R) (i:nat) : R :=
(-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1))).

Definition cos_term (a:R) (i:nat) : R :=
(-1) ^ i * (a ^ (2 * i) / INR (fact (2 * i))).

Definition sin_approx (a:R) (n:nat) : R := sum_f_R0 (sin_term a) n.

Definition cos_approx (a:R) (n:nat) : R := sum_f_R0 (cos_term a) n.

Theorem pre_sin_bound :
forall (a:R) (n:nat),
0 <= a ->
a <= 4 -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
Proof. hammer_hook "Rtrigo_alt" "Rtrigo_alt.pre_sin_bound".
intros; case (Req_dec a 0); intro Hyp_a.
rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx;
apply sum_eq_R0 || (symmetry ; apply sum_eq_R0);
intros; unfold sin_term; rewrite pow_add;
simpl; unfold Rdiv; rewrite Rmult_0_l;
ring.
unfold sin_approx; cut (0 < a).
intro Hyp_a_pos.
rewrite (decomp_sum (sin_term a) (2 * n + 1)).
rewrite (decomp_sum (sin_term a) (2 * (n + 1))).
replace (sin_term a 0) with a.
cut
(sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a - a /\
sin a - a <= sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1))) ->
a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * n + 1)) <= sin a /\
sin a <= a + sum_f_R0 (fun i:nat => sin_term a (S i)) (pred (2 * (n + 1)))).
intro; apply H1.
set (Un := fun n:nat => a ^ (2 * S n + 1) / INR (fact (2 * S n + 1))).
replace (pred (2 * n + 1)) with (2 * n)%nat.
replace (pred (2 * (n + 1))) with (S (2 * n)).
replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (2 * n)) with
(- sum_f_R0 (tg_alt Un) (2 * n)).
replace (sum_f_R0 (fun i:nat => sin_term a (S i)) (S (2 * n))) with
(- sum_f_R0 (tg_alt Un) (S (2 * n))).
cut
(sum_f_R0 (tg_alt Un) (S (2 * n)) <= a - sin a <=
sum_f_R0 (tg_alt Un) (2 * n) ->
- sum_f_R0 (tg_alt Un) (2 * n) <= sin a - a <=
- sum_f_R0 (tg_alt Un) (S (2 * n))).
intro; apply H2.
apply alternated_series_ineq.
unfold Un_decreasing, Un; intro;
cut ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))).
intro; rewrite H3.
replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)).
unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
left; apply pow_lt; assumption.
apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))).
rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red; intro;
assert (H5 := eq_sym H4); elim (fact_neq_0 _ H5).
rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1))));
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_r.
do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
simpl;
replace
(((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) *
((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with
(4 * INR n0 * INR n0 + 18 * INR n0 + 20); [ idtac | ring ].
apply Rle_trans with 20.
apply Rle_trans with 16.
replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ].
apply Rsqr_incr_1.
assumption.
assumption.
now apply IZR_le.
now apply IZR_le.
rewrite <- (Rplus_0_l 20) at 1;
apply Rplus_le_compat_r.
apply Rplus_le_le_0_compat.
apply Rmult_le_pos.
apply Rmult_le_pos.
now apply IZR_le.
apply pos_INR.
apply pos_INR.
apply Rmult_le_pos.
now apply IZR_le.
apply pos_INR.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
simpl; ring.
ring.
assert (H3 := cv_speed_pow_fact a); unfold Un; unfold Un_cv in H3;
unfold R_dist in H3; unfold Un_cv; unfold R_dist;
intros; elim (H3 eps H4); intros N H5.
exists N; intros; apply H5.
replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
unfold ge; apply le_trans with (2 * S n0)%nat.
apply le_trans with (2 * S N)%nat.
apply le_trans with (2 * N)%nat.
apply le_n_2n.
apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
apply le_n_Sn.
ring.
unfold sin.
destruct (exist_sin (Rsqr a)) as (x,p).
unfold sin_in, infinite_sum, R_dist in p;
unfold Un_cv, R_dist;
intros.
cut (0 < eps / Rabs a).
intro H4; destruct (p _ H4) as (N,H6).
exists N; intros.
replace (sum_f_R0 (tg_alt Un) n0) with
(a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
unfold Rminus; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
rewrite Ropp_plus_distr; rewrite Ropp_involutive;
repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc;
rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
pattern (/ Rabs a) at 1; rewrite <- (Rabs_Rinv a Hyp_a).
rewrite <- Rabs_mult, Rmult_plus_distr_l, <- 2!Rmult_assoc, <- Rinv_l_sym;
[ rewrite Rmult_1_l | assumption ];
rewrite (Rmult_comm (/ Rabs a)),
<- Rabs_Ropp, Ropp_plus_distr, Ropp_involutive, Rmult_1_l.
unfold Rminus, Rdiv in H6. apply H6; unfold ge;
apply le_trans with n0; [ exact H5 | apply le_n_Sn ].
rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
replace (sin_n 0) with 1.
simpl; rewrite Rmult_1_r; unfold Rminus;
rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum;
apply sum_eq.
intros; unfold sin_n, Un, tg_alt;
replace ((-1) ^ S i) with (- (-1) ^ i).
replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a).
unfold Rdiv; ring.
rewrite pow_add; rewrite pow_Rsqr; simpl; ring.
simpl; ring.
unfold sin_n; unfold Rdiv; simpl; rewrite Rinv_1;
rewrite Rmult_1_r; reflexivity.
apply lt_O_Sn.
unfold Rdiv; apply Rmult_lt_0_compat.
assumption.
apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
intros; elim H2; intros.
replace (sin a - a) with (- (a - sin a)); [ idtac | ring ].
split; apply Ropp_le_contravar; assumption.
replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with
(-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ].
apply sum_eq; intros; unfold sin_term, Un, tg_alt;
change ((-1) ^ S i) with (-1 * (-1) ^ i).
unfold Rdiv; ring.
replace (- sum_f_R0 (tg_alt Un) (2 * n)) with
(-1 * sum_f_R0 (tg_alt Un) (2 * n)); [ rewrite scal_sum | ring ].
apply sum_eq; intros.
unfold sin_term, Un, tg_alt;
change ((-1) ^ S i) with (-1 * (-1) ^ i).
unfold Rdiv; ring.
replace (2 * (n + 1))%nat with (S (S (2 * n))).
reflexivity.
ring.
replace (2 * n + 1)%nat with (S (2 * n)).
reflexivity.
ring.
intro; elim H1; intros.
split.
apply Rplus_le_reg_l with (- a).
rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
rewrite (Rplus_comm (- a)); apply H2.
apply Rplus_le_reg_l with (- a).
rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
rewrite (Rplus_comm (- a)); apply H3.
unfold sin_term; simpl; unfold Rdiv; rewrite Rinv_1;
ring.
replace (2 * (n + 1))%nat with (S (S (2 * n))).
apply lt_O_Sn.
ring.
replace (2 * n + 1)%nat with (S (2 * n)).
apply lt_O_Sn.
ring.
inversion H; [ assumption | elim Hyp_a; symmetry ; assumption ].
Qed.

Lemma pre_cos_bound :
forall (a:R) (n:nat),
- 2 <= a -> a <= 2 ->
cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)).
Proof. hammer_hook "Rtrigo_alt" "Rtrigo_alt.pre_cos_bound".
cut
((forall (a:R) (n:nat),
0 <= a ->
a <= 2 ->
cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) ->
forall (a:R) (n:nat),
- 2 <= a ->
a <= 2 ->
cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))).
intros H a n; apply H.
intros; unfold cos_approx.
rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)).
rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))).
replace (cos_term a0 0) with 1.
cut
(sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 - 1 /\
cos a0 - 1 <=
sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1))) ->
1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * n0 + 1)) <= cos a0 /\
cos a0 <=
1 + sum_f_R0 (fun i:nat => cos_term a0 (S i)) (pred (2 * (n0 + 1)))).
intro; apply H2.
set (Un := fun n:nat => a0 ^ (2 * S n) / INR (fact (2 * S n))).
replace (pred (2 * n0 + 1)) with (2 * n0)%nat.
replace (pred (2 * (n0 + 1))) with (S (2 * n0)).
replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (2 * n0)) with
(- sum_f_R0 (tg_alt Un) (2 * n0)).
replace (sum_f_R0 (fun i:nat => cos_term a0 (S i)) (S (2 * n0))) with
(- sum_f_R0 (tg_alt Un) (S (2 * n0))).
cut
(sum_f_R0 (tg_alt Un) (S (2 * n0)) <= 1 - cos a0 <=
sum_f_R0 (tg_alt Un) (2 * n0) ->
- sum_f_R0 (tg_alt Un) (2 * n0) <= cos a0 - 1 <=
- sum_f_R0 (tg_alt Un) (S (2 * n0))).
intro; apply H3.
apply alternated_series_ineq.
unfold Un_decreasing; intro; unfold Un.
cut ((2 * S (S n1))%nat = S (S (2 * S n1))).
intro; rewrite H4;
replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)).
unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
apply pow_le; assumption.
apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))).
rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red; intro;
assert (H6 := eq_sym H5); elim (fact_neq_0 _ H6).
rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1)))));
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR;
simpl;
replace
(((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1))
with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ].
apply Rle_trans with 12.
apply Rle_trans with 4.
change 4 with (Rsqr 2).
apply Rsqr_incr_1.
assumption.
assumption.
now apply IZR_le.
now apply IZR_le.
rewrite <- (Rplus_0_l 12) at 1;
apply Rplus_le_compat_r.
apply Rplus_le_le_0_compat.
apply Rmult_le_pos.
apply Rmult_le_pos.
now apply IZR_le.
apply pos_INR.
apply pos_INR.
apply Rmult_le_pos.
now apply IZR_le.
apply pos_INR.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
simpl; ring.
ring.
assert (H4 := cv_speed_pow_fact a0); unfold Un; unfold Un_cv in H4;
unfold R_dist in H4; unfold Un_cv; unfold R_dist;
intros; elim (H4 eps H5); intros N H6; exists N; intros.
apply H6; unfold ge; apply le_trans with (2 * S N)%nat.
apply le_trans with (2 * N)%nat.
apply le_n_2n.
apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
unfold cos. destruct (exist_cos (Rsqr a0)) as (x,p).
unfold cos_in, infinite_sum, R_dist in p;
unfold Un_cv, R_dist; intros.
destruct (p _ H4) as (N,H6).
exists N; intros.
replace (sum_f_R0 (tg_alt Un) n1) with
(1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
rewrite (Rplus_comm (-(1))); repeat rewrite Rplus_assoc;
rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
rewrite Ropp_plus_distr; rewrite Ropp_involutive;
unfold Rminus in H6; apply H6.
unfold ge; apply le_trans with n1.
exact H5.
apply le_n_Sn.
rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
replace (cos_n 0) with 1.
simpl; rewrite Rmult_1_r; unfold Rminus;
rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
rewrite Rplus_0_l;
replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
with
(-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
[ idtac | ring ]; rewrite scal_sum; apply sum_eq;
intros; unfold cos_n, Un, tg_alt.
replace ((-1) ^ S i) with (- (-1) ^ i).
replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
unfold Rdiv; ring.
rewrite pow_Rsqr; reflexivity.
simpl; ring.
unfold cos_n; unfold Rdiv; simpl; rewrite Rinv_1;
rewrite Rmult_1_r; reflexivity.
apply lt_O_Sn.
intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0));
[ idtac | ring ].
split; apply Ropp_le_contravar; assumption.
replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with
(-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ].
apply sum_eq; intros; unfold cos_term, Un, tg_alt;
change ((-1) ^ S i) with (-1 * (-1) ^ i).
unfold Rdiv; ring.
replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with
(-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ];
apply sum_eq; intros; unfold cos_term, Un, tg_alt;
change ((-1) ^ S i) with (-1 * (-1) ^ i).
unfold Rdiv; ring.
replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
reflexivity.
ring.
replace (2 * n0 + 1)%nat with (S (2 * n0)).
reflexivity.
ring.
intro; elim H2; intros; split.
apply Rplus_le_reg_l with (-(1)).
rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
rewrite (Rplus_comm (-1)); apply H3.
apply Rplus_le_reg_l with (-(1)).
rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
rewrite (Rplus_comm (-1)); apply H4.
unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1;
ring.
replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
apply lt_O_Sn.
ring.
replace (2 * n0 + 1)%nat with (S (2 * n0)).
apply lt_O_Sn.
ring.
intros; destruct (total_order_T 0 a) as [[Hlt|Heq]|Hgt].
apply H; [ left; assumption | assumption ].
apply H; [ right; assumption | assumption ].
cut (0 < - a).
intro; cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n).
intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H.
left; assumption.
rewrite <- (Ropp_involutive 2); apply Ropp_le_contravar; exact H0.
intros; unfold cos_approx; apply sum_eq; intros;
unfold cos_term; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
unfold Rdiv; reflexivity.
apply Ropp_0_gt_lt_contravar; assumption.
Qed.


Require Import PL.Imp PL.ImpExt PL.RTClosure.
Local Open Scope imp.

(* ################################################################# *)
(** The equivalence between the first-defined denotational semantics and small step semantics**)

(* ################################################################# *)
(** * From Denotations To Multi-step Relations *)
Theorem semantic_equiv_aexp1: forall st a n,
  aeval a st = n -> multi_astep st a (ANum n).
Proof.
  intros.
  revert n H; induction a; intros; simpl in H.
  + unfold constant_func in H.
    rewrite H.
    reflexivity.
  + rewrite <- H.
    etransitivity_n1; [reflexivity |].
    apply AS_Id.
  + etransitivity.
    { apply multi_congr_APlus1, IHa1. reflexivity. }
    etransitivity_n1.
    { apply multi_congr_APlus2; [apply AH_num |]. apply IHa2. reflexivity. }
    rewrite <- H.
    apply AS_Plus.
  + etransitivity.
    { apply multi_congr_AMinus1, IHa1. reflexivity. }
    etransitivity_n1.
    { apply multi_congr_AMinus2; [apply AH_num |]. apply IHa2. reflexivity. }
    rewrite <- H.
    apply AS_Minus.
  + etransitivity.
    { apply multi_congr_AMult1, IHa1. reflexivity. }
    etransitivity_n1.
    { apply multi_congr_AMult2; [apply AH_num |]. apply IHa2. reflexivity. }
    rewrite <- H.
    apply AS_Mult.
Qed.

Theorem semantic_equiv_bexp1: forall st b,
  (beval b st -> multi_bstep st b BTrue) /\
  (~ beval b st -> multi_bstep st b BFalse).
Proof.
  intros.
  induction b; simpl.
  + split.
    - intros.
      reflexivity.
    - unfold Sets.full.
      tauto.
  + split.
    - unfold Sets.empty.
      tauto.
    - intros.
      reflexivity.
  + assert (multi_bstep st (a1 == a2) (aeval a1 st == aeval a2 st)).
    {
      etransitivity.
      - apply multi_congr_BEq1, semantic_equiv_aexp1.
        reflexivity.
      - apply multi_congr_BEq2; [apply AH_num |].
        apply semantic_equiv_aexp1.
        reflexivity.
    }
    split; unfold Func.test_eq; intros;
    (etransitivity_n1; [exact H |]).
    - apply BS_Eq_True, H0.
    - apply BS_Eq_False, H0.
  + assert (multi_bstep st (a1 <= a2) (aeval a1 st <= aeval a2 st)).
    {
      etransitivity.
      - apply multi_congr_BLe1, semantic_equiv_aexp1.
        reflexivity.
      - apply multi_congr_BLe2; [apply AH_num |].
        apply semantic_equiv_aexp1.
        reflexivity.
    }
    split; unfold Func.test_le; intros;
    (etransitivity_n1; [exact H |]).
    - apply BS_Le_True, H0.
    - apply BS_Le_False.
      lia.
  + destruct IHb as [IH1 IH2].
    split; intros.
    - etransitivity_n1.
      * apply multi_congr_BNot, IH2.
        unfold Sets.complement in H; exact H.
      * apply BS_NotFalse.
    - etransitivity_n1.
      * apply multi_congr_BNot, IH1.
        unfold Sets.complement in H; tauto.
      * apply BS_NotTrue.
  + destruct IHb1 as [IHb11 IHb12].
    destruct IHb2 as [IHb21 IHb22].
    pose proof classic (beval b1 st).
    destruct H.
    - assert (multi_bstep st (b1 && b2) b2).
      {
        etransitivity_n1.
        * apply multi_congr_BAnd, IHb11, H.
        * apply BS_AndTrue.
      }
      split; unfold Sets.intersect; intros;
      (etransitivity; [exact H0 |]).
      * apply IHb21; tauto.
      * apply IHb22; tauto.
    - split; unfold Sets.intersect; intros; [ tauto |].
      etransitivity_n1.
      * apply multi_congr_BAnd, IHb12, H.
      * apply BS_AndFalse.
Qed.

Corollary semantic_equiv_bexp1_true: forall st b,
  beval b st -> multi_bstep st b BTrue.
Proof. intros. pose proof semantic_equiv_bexp1 st b. tauto. Qed.

Corollary semantic_equiv_bexp1_false: forall st b,
  (Sets.complement (beval b) st -> multi_bstep st b BFalse).
Proof. intros. pose proof semantic_equiv_bexp1 st b. tauto. Qed.

Lemma semantic_equiv_iter_loop1: forall st1 st2 n b c,
  (forall st1 st2, ceval c st1 st2 -> multi_cstep (c, st1) (Skip, st2)) ->
  iter_loop_body b (ceval c) n st1 st2 ->
  multi_cstep (While b Do c EndWhile, st1) (Skip, st2).
Proof.
  intros.
  revert st1 st2 H0; induction n; intros.
  + simpl in H0.
    unfold BinRel.test_rel in H0.
    destruct H0.
    subst st2.
    etransitivity_1n; [apply CS_While |].
    etransitivity; [apply multi_congr_CIf, semantic_equiv_bexp1_false, H1 |].
    etransitivity_1n; [apply CS_IfFalse |].
    reflexivity.
  + simpl in H0.
    unfold BinRel.concat at 1,
           BinRel.test_rel in H0.
    destruct H0 as [st [[? H0] ?]]; subst st.
    unfold BinRel.concat in H2.
    destruct H2 as [st1' [? ?]].
    etransitivity_1n; [apply CS_While |].
    etransitivity; [apply multi_congr_CIf, semantic_equiv_bexp1_true, H0 |].
    etransitivity_1n; [apply CS_IfTrue |].
    etransitivity; [apply multi_congr_CSeq, H, H1 |].
    etransitivity_1n; [apply CS_Seq |].
    apply IHn, H2.
Qed.

Theorem semantic_equiv_com1: forall st1 st2 c,
  ceval c st1 st2 -> multi_cstep (c, st1) (Skip, st2).
Proof.
  intros.
  revert st1 st2 H; induction c; intros.
  + rewrite ceval_CSkip in H.
    unfold BinRel.id in H.
    rewrite H.
    reflexivity.
  + rewrite ceval_CAss in H.
    destruct H.
    etransitivity_n1.
    - apply multi_congr_CAss, semantic_equiv_aexp1.
      reflexivity.
    - apply CS_Ass; tauto.
  + rewrite ceval_CSeq in H.
    unfold BinRel.concat in H.
    destruct H as [st' [? ?]].
    etransitivity; [apply multi_congr_CSeq, IHc1, H |].
    etransitivity_1n; [ apply CS_Seq |].
    apply IHc2, H0.
  + rewrite ceval_CIf in H.
    unfold if_sem in H.
    unfold BinRel.union,
           BinRel.concat,
           BinRel.test_rel in H.
    pose proof semantic_equiv_bexp1 st1 b.
    destruct H0.
    destruct H as [H | H]; destruct H as [st [[? ?] ?]]; subst st.
    - etransitivity; [apply multi_congr_CIf, H0, H2 |].
      etransitivity_1n; [apply CS_IfTrue |].
      apply IHc1, H3.
    - etransitivity; [apply multi_congr_CIf, H1, H2 |].
      etransitivity_1n; [apply CS_IfFalse |].
      apply IHc2, H3.
  + rewrite ceval_CWhile in H.
    unfold loop_sem in H.
    unfold BinRel.omega_union in H.
    destruct H as [n ?].
    apply semantic_equiv_iter_loop1 with n.
    - exact IHc.
    - exact H.
Qed.

(* ################################################################# *)
(** * From Multi-step Relations To Denotations *)

Lemma aeval_preserve: forall st a1 a2,
  astep st a1 a2 ->
  aeval a1 st  = aeval a2 st.
Proof.
  intros.
  induction H.
  + simpl.
    reflexivity.
  + simpl.
    unfold Func.add.
    lia.
  + simpl.
    unfold Func.add.
    lia.
  + simpl.
    unfold Func.add, constant_func.
    reflexivity.
  + simpl.
    unfold Func.sub.
    lia.
  + simpl.
    unfold Func.sub.
    lia.
  + simpl.
    unfold Func.sub, constant_func.
    reflexivity.
  + simpl.
    unfold Func.mul.
    nia.
  + simpl.
    unfold Func.mul.
    nia.
  + simpl.
    unfold Func.mul, constant_func.
    reflexivity.
Qed.

Theorem semantic_equiv_aexp2: forall st a n,
  multi_astep st a (ANum n) -> aeval a st = n.
Proof.
  intros.
  induction_1n H.
  + simpl.
    reflexivity.
  + pose proof aeval_preserve _ _ _ H.
    lia.
Qed.

Lemma beval_preserve: forall st b1 b2,
  bstep st b1 b2 ->
  (beval b1 st  <-> beval b2 st).
Proof.
  intros.
  induction H.
  + apply aeval_preserve in H.
    simpl.
    unfold Func.test_eq.
    lia.
  + apply aeval_preserve in H0.
    simpl.
    unfold Func.test_eq.
    lia.
  + simpl.
    unfold Func.test_eq, Sets.full.
    tauto.
  + simpl.
    unfold Func.test_eq, Sets.empty.
    tauto.
  + apply aeval_preserve in H.
    simpl.
    unfold Func.test_le.
    lia.
  + apply aeval_preserve in H0.
    simpl.
    unfold Func.test_le.
    lia.
  + simpl.
    unfold Func.test_le, Sets.full.
    tauto.
  + simpl.
    unfold Func.test_le, constant_func, Sets.empty.
    lia.
  + simpl.
    unfold Sets.complement.
    tauto.
  + simpl.
    unfold Sets.complement, Sets.full, Sets.empty.
    tauto.
  + simpl.
    unfold Sets.complement, Sets.full, Sets.empty.
    tauto.
  + simpl.
    unfold Sets.intersect.
    tauto.
  + simpl.
    unfold Sets.intersect, Sets.full.
    tauto.
  + simpl.
    unfold Sets.intersect, Sets.empty.
    tauto.
Qed.

Theorem semantic_equiv_bexp2: forall st b TF,
  multi_bstep st b TF ->
  (TF = BTrue -> beval b st) /\
  (TF = BFalse -> ~ beval b st).
Proof.
  intros.
  induction_1n H; simpl; intros.
  + split; intros; subst; simpl; unfold Sets.full, Sets.empty; tauto.
  + pose proof beval_preserve _ _ _ H.
    tauto.
Qed.

Lemma ceval_preserve: forall c1 c2 st1 st2,
  cstep (c1, st1) (c2, st2) ->
  forall st3, ceval c2 st2 st3 -> ceval c1 st1 st3.
Proof.
(** We could prove a stronger conclusion:

    forall st3, ceval c1 st1 st3 <-> ceval c2 st2 st3.

But this single direction version is enough to use. *)
  intros.
  revert st3 H0.
  induction_cstep H; simpl; intros.
  + apply aeval_preserve in H.
    rewrite ceval_CAss in H0.
    rewrite ceval_CAss.
    rewrite H.
    tauto.
  + rewrite ceval_CSkip in H1.
    rewrite ceval_CAss.
    unfold BinRel.id in H1.
    subst.
    tauto.
  + rewrite ceval_CSeq in H0.
    rewrite ceval_CSeq.
    unfold BinRel.concat in H0.
    unfold BinRel.concat.
    destruct H0 as [st2' [? ?]].
    exists st2'.
    specialize (IHcstep _ H0).
    tauto.
  + rewrite ceval_CSeq.
    unfold BinRel.concat, BinRel.id.
    exists st.
    split.
    - reflexivity.
    - exact H0.
  + rewrite ceval_CIf in H0.
    rewrite ceval_CIf.
    unfold if_sem in H0.
    unfold if_sem.
    unfold BinRel.union,
           BinRel.concat,
           BinRel.test_rel in H0.
    unfold BinRel.union,
           BinRel.concat,
           BinRel.test_rel.
    apply beval_preserve in H.
    simpl in H0.
    simpl.
    unfold Sets.complement in H0.
    unfold Sets.complement.
    destruct H0 as [[st2' ?] | [st2' ?]]; [left | right];
      exists st2'; tauto.
  + rewrite ceval_CIf.
    unfold if_sem.
    unfold BinRel.union,
           BinRel.concat,
           BinRel.test_rel.
    left; exists st. simpl.
    unfold Sets.full; tauto.
  + rewrite ceval_CIf.
    unfold if_sem.
    unfold BinRel.union,
           BinRel.concat,
           BinRel.test_rel.
    right; exists st; simpl.
    unfold Sets.complement, Sets.empty; tauto.
  + pose proof loop_unrolling b c.
    unfold com_equiv, BinRel.equiv in H.
    specialize (H st st3).
    tauto.
Qed.

Theorem semantic_equiv_com2: forall c st1 st2,
  multi_cstep (c, st1) (CSkip, st2) -> ceval c st1 st2.
Proof.
  intros.
  remember (CSkip) as c' eqn:H0.
  revert H0; induction_1n H; simpl; intros; subst.
  + simpl.
    unfold BinRel.id.
    reflexivity.
  + pose proof ceval_preserve _ _ _ _ H st2.
    tauto.
Qed.

(* ################################################################# *)
(** * Final Theorem *)

Theorem semantic_equiv: forall c st1 st2,
  ceval c st1 st2 <-> multi_cstep (c, st1) (CSkip, st2).
Proof.
  intros.
  split.
  + apply semantic_equiv_com1.
  + apply semantic_equiv_com2.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_29B.
Require Export GeoCoq.Elements.OriginalProofs.proposition_27B.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_33 :
   forall A B C D M,
   Par A B C D -> Cong A B C D -> BetS A M D -> BetS B M C ->
   Par A C B D /\ Cong A C B D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists a b c d m, (neq A B /\ neq C D /\ Col A B a /\ Col A B b /\ neq a b /\ Col C D c /\ Col C D d /\ neq c d /\ ~ Meet A B C D /\ BetS a m d /\ BetS c m b)) by (conclude_def Par );destruct Tf as [a[b[c[d[m]]]]];spliter.
assert (Col B M C) by (conclude_def Col ).
assert (Col B C M) by (forward_using lemma_collinearorder).
assert (~ Col B C A).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 assert (eq C C) by (conclude cn_equalityreflexive).
 assert (Col C D C) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (TS A B C D) by (conclude_def TS ).
assert (CongA A B C B C D) by (conclude proposition_29B).
assert (~ Col B C D).
 {
 intro.
 assert (Col C D B) by (forward_using lemma_collinearorder).
 assert (eq B B) by (conclude cn_equalityreflexive).
 assert (Col A B B) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (CongA B C D D C B) by (conclude lemma_ABCequalsCBA).
assert (CongA A B C D C B) by (conclude lemma_equalanglestransitive).
assert (Cong B C B C) by (conclude cn_congruencereflexive).
assert (nCol A B C) by (assert (nCol B C A) by auto;
 (forward_using lemma_NCorder)).
assert (Cong B A C D) by (forward_using lemma_congruenceflip).
assert (Cong B C C B) by (forward_using lemma_congruenceflip).
assert ((Cong A C D B /\ CongA B A C C D B /\ CongA B C A C B D)) by (conclude proposition_04).
assert (nCol A C B) by (forward_using lemma_NCorder).
assert (CongA A C B B C A) by (conclude lemma_ABCequalsCBA).
assert (CongA A C B C B D) by (conclude lemma_equalanglestransitive).
assert (Cong A C B D) by (forward_using lemma_congruenceflip).
assert (Col C B M) by (forward_using lemma_collinearorder).
assert (nCol C B A) by (forward_using lemma_NCorder).
assert (TS A C B D) by (conclude_def TS ).
assert (Par A C B D) by (conclude proposition_27B).
close.
Qed.

End Euclid.