Insertion sort

Module Insertion.
Section InsertionSort.

Variable T : eqType.
Variable leT : rel T.
Implicit Types x y z : T.
Implicit Types s t u : seq T.

Insert an element e into a sorted list s

Fixpoint insert e s : seq T :=
  if s is x :: s' then
    if leT e x then
      e :: s
    else
      x :: (insert e s')
  else [:: e].

Sort input list s

Fixpoint sort s : seq T :=
  if s is x :: s' then
    insert x (sort s')
  else
    [::].

Now we'd like to prove sort functionally correct. "Functionally" means here "as a relation between the input and output". Notice that we don't treat the question of time/space complexity. I'll use "correct" as a synonym for "functionally" correct in the following discussion.

If you'd like to see how specify complexity, you might want to check "A Machine-checked Proof of the Average-case Complexity of Quicksort in Coq" paper by van der Weegen and McKinna (2008).

What does mean for a sorting algorithm to be correct?

It could have been a requirement that the output of the algorithm is _sorted_.

Let's give this notation a precise meaning. We call the corresponding predicate sorted' because we will later refine the definition into something more general that helps us a lot with inductive proofs.

This fails because x2 :: s' is not a structural subterm of s.

Fail Fixpoint sorted' s : bool :=
  if s is x1 :: x2 :: s' then
    leT x1 x2 && (sorted' (x2 :: s'))
  else true.
The command has indeed failed with message:
Recursive definition of sorted' is ill-formed.
In environment
T : eqType
leT : rel T
sorted' : seq T -> bool
s : seq T
x1 : T
l : seq T
x2 : T
s' : seq T
Recursive call to sorted' has principal argument equal
to "x2 :: s'" instead of
one of the following variables: "l"
"s'".
Recursive definition is:
"fun s =>
 match s with
 | [::] => true
 | [:: x1] => true
 | [:: x1, x2 & s'] => leT x1 x2 && sorted' (x2 :: s')
 end".

We just need to add as annotation:

Fixpoint sorted' s : bool :=
  if s is x1 :: ((x2 :: s') as tail) then
    leT x1 x2 && (sorted' tail)
  else true.

The obvious definition we came up with is not very easy to work with. We would see it later when trying to prove that insert function preserves sortedness.

So instead we are going to use Mathcomp's sorted predicate, which is based on the notion of path.

Print sorted.
sorted = 
fun (T : Type) (e : rel T) (s : seq T) =>
match s with
| [::] => true
| x :: s' => path e x s'
end
     : forall T : Type, rel T -> seq T -> bool

Arguments sorted [T]%type_scope _ _%seq_scope

Print path.
path = 
fun (T : Type) (e : rel T) =>
fix path (x : T) (p : seq T) {struct p} : bool :=
  match p with
  | [::] => true
  | y :: p' => e x y && path y p'
  end
     : forall T : Type, rel T -> T -> seq T -> bool

Arguments path {T}%type_scope _ _ _%seq_scope

path (<=) x p means x <= x1 <= x2 <= ... <= xn, where p = [:: x1; x2; ... xn] and <= is a binary relation.

With the modified definition the helper lemma

is much easier to prove (exercise):

Lemma sorted_cons x s :
  sorted leT (x :: s) -> sorted leT s.
T:eqType
leT:rel T
x:T
s:seq T
sorted leT (x :: s) -> sorted leT s
Proof.
T:eqType
leT:rel T
x:T
s:seq T
sorted leT (x :: s) -> sorted leT s
Admitted.

It's easy to see that requiring just sortedness of the output list is a rather weak specification -- a function always returning an empty list would also be correct:

Definition fake_sort s : seq T := [::].

Lemma sorted_fake_sort s : sorted leT (fake_sort s).
T:eqType
leT:rel T
s:seq T
sorted leT (fake_sort s)
Proof.
T:eqType
leT:rel T
s:seq T
sorted leT (fake_sort s) by []. Qed.

What we actually care about is to keep the elements together with their repective number of occurences, i.e. forall x : T, count (pred1 x) s = count (pred1 x) (sort s), where pred1 x means fun y => x == y. This expresses the notion of _permutation_ of two lists.

There is one more concern w.r.t. the spec we came up with so far -- it's non-computable as it requires us to compute count-expressions over a possibly infinite type T, because we quantify the whole statement over T. Intuitively, we know that for any two lists we can compute if one is a permutation of the other when we have decidable equality over the type of elements.

Mathcomp introduces a computable of notion of equivalence up to permutation: perm_eq defined as follows:

Print perm_eq.
perm_eq = 
fun (T : eqType) (s1 s2 : seq T) =>
all [pred x | count_mem x s1 == count_mem x s2]
  (s1 ++ s2)
     : forall T : eqType, seq T -> seq T -> bool

Arguments perm_eq {T} (_ _)%seq_scope

perm_eq is equivalent to

all [pred x | (count_mem x) s1 == (count_mem x) s2] s1
&&
all
    [pred x | (count_mem x) s1 == (count_mem x) s2] s2

    .. coq::

       Print count_mem.

Moreover, any two lists s1 and s2 that are a permutation of each other, give us the following property which is universal for _any_ predicate p: forall p : pred T, count p s1 = count p s2 expressed as a [reflect]-predicate:

About permP.
permP :
forall {T : eqType} {s1 s2 : seq T},
reflect (count^~ s1 =1 count^~ s2) (perm_eq s1 s2)

permP is not universe polymorphic
Arguments permP {T} {s1 s2}%seq_scope
permP is opaque
Expands to: Constant mathcomp.ssreflect.seq.permP

Upshot: Our final notion of correctness of sorting algorithms can be expressed semi-formally as follows sorted (sort s) /\ perm_eq s (sort s).

Let's try proving these properties for the insertion sort algorithm we implemented

(** * The output is sorted *)


Lemma sort_sorted s :
  sorted leT (sort s).
T:eqType
leT:rel T
s:seq T
sorted leT (sort s)
Proof.
T:eqType
leT:rel T
s:seq T
sorted leT (sort s)
elim: s=> [//| x s IHs /=].
T:eqType
leT:rel T
x:T
s:seq T
IHs:sorted leT (sort s)
sorted leT (insert x (sort s))
Abort.

We need the fact that insert preserves sortedness. Let's prove it as a standalone lemma.

Lemma insert_sorted e s :
  sorted leT s ->
  sorted leT (insert e s).
T:eqType
leT:rel T
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
Proof.
T:eqType
leT:rel T
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
elim: s=> [//| x1 s IHs].
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
sorted leT (x1 :: s) ->
sorted leT (insert e (x1 :: s))
move=> /=.
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path leT x1 s ->
sorted leT
  (if leT e x1
   then [:: e, x1 & s]
   else x1 :: insert e s)
move=> path_x1_s.
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
sorted leT
  (if leT e x1
   then [:: e, x1 & s]
   else x1 :: insert e s)
case: ifP=> [e_le_x1 | e_gt_x1].
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_le_x1:leT e x1
sorted leT [:: e, x1 & s]
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s)
-
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_le_x1:leT e x1
sorted leT [:: e, x1 & s]
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s) by rewrite /= e_le_x1 path_x1_s.
T:eqType
leT:rel T
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s)
(* Notice that we lack one essential fact about
   `leT` -- totality *)
Abort.

Hypothesis leT_total : total leT.
Print total.
total = 
fun (T : Type) (R : rel T) =>
forall x y : T, R x y || R y x
     : forall T : Type, rel T -> Prop

Arguments total [T]%type_scope _

Lemma insert_sorted e s :
  sorted leT s ->
  sorted leT (insert e s).
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
Proof.
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
elim: s=> [//| x1 s IHs].
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
sorted leT (x1 :: s) ->
sorted leT (insert e (x1 :: s))
move=> /= path_x1_s.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
sorted leT
  (if leT e x1
   then [:: e, x1 & s]
   else x1 :: insert e s)
case: ifP=> [e_le_x1 | e_gt_x1].
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_le_x1:leT e x1
sorted leT [:: e, x1 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s)
-
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_le_x1:leT e x1
sorted leT [:: e, x1 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s) by rewrite /= e_le_x1 path_x1_s.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
sorted leT (x1 :: insert e s)
have:= leT_total e x1.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
leT e x1 || leT x1 e -> sorted leT (x1 :: insert e s)
rewrite {}e_gt_x1.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
false || leT x1 e -> sorted leT (x1 :: insert e s)
move=> /= x1_le_e.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:sorted leT s -> sorted leT (insert e s)
path_x1_s:path leT x1 s
x1_le_e:leT x1 e
path leT x1 (insert e s)
move: path_x1_s=> {}/path_sorted/IHs.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
x1_le_e:leT x1 e
sorted leT (insert e s) -> path leT x1 (insert e s)
case: s=> [|x2 s]; first by rewrite /= x1_le_e.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
sorted leT (insert e (x2 :: s)) ->
path leT x1 (insert e (x2 :: s))
move=> /=.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
sorted leT
  (if leT e x2
   then [:: e, x2 & s]
   else x2 :: insert e s) ->
path leT x1
  (if leT e x2
   then [:: e, x2 & s]
   else x2 :: insert e s)
case: ifP.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 ->
sorted leT [:: e, x2 & s] ->
path leT x1 [:: e, x2 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 = false ->
sorted leT (x2 :: insert e s) ->
path leT x1 (x2 :: insert e s)
-
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 ->
sorted leT [:: e, x2 & s] ->
path leT x1 [:: e, x2 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 = false ->
sorted leT (x2 :: insert e s) ->
path leT x1 (x2 :: insert e s) move=> /=.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 ->
leT e x2 && path leT x2 s ->
[&& leT x1 e, leT e x2 & path leT x2 s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 = false ->
sorted leT (x2 :: insert e s) ->
path leT x1 (x2 :: insert e s)
  move=>-> /= ->.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT x1 e && true
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 = false ->
sorted leT (x2 :: insert e s) ->
path leT x1 (x2 :: insert e s)
  by rewrite x1_le_e.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
x1_le_e:leT x1 e
x2:T
s:seq T
leT e x2 = false ->
sorted leT (x2 :: insert e s) ->
path leT x1 (x2 :: insert e s)

We are moving in circles here, let' steps back and generalize the problem.

Abort.

Lemma insert_path z e s :
  leT z e ->
  path leT z s ->
  path leT z (insert e s).
T:eqType
leT:rel T
leT_total:total leT
z, e:T
s:seq T
leT z e -> path leT z s -> path leT z (insert e s)
Proof.
T:eqType
leT:rel T
leT_total:total leT
z, e:T
s:seq T
leT z e -> path leT z s -> path leT z (insert e s)
move: z.
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
forall z,
leT z e -> path leT z s -> path leT z (insert e s)
elim: s=> [/=| x1 s IHs] z.
T:eqType
leT:rel T
leT_total:total leT
e, z:T
leT z e -> true -> leT z e && true
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
leT z e ->
path leT z (x1 :: s) ->
path leT z (insert e (x1 :: s))
-
T:eqType
leT:rel T
leT_total:total leT
e, z:T
leT z e -> true -> leT z e && true
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
leT z e ->
path leT z (x1 :: s) ->
path leT z (insert e (x1 :: s)) by move=>->.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
leT z e ->
path leT z (x1 :: s) ->
path leT z (insert e (x1 :: s))
move=> z_le_e.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
path leT z (x1 :: s) ->
path leT z (insert e (x1 :: s))
move=> /=.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
leT z x1 && path leT x1 s ->
path leT z
  (if leT e x1
   then [:: e, x1 & s]
   else x1 :: insert e s)
case/andP=> z_le_x1 path_x1_s.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
path leT z
  (if leT e x1
   then [:: e, x1 & s]
   else x1 :: insert e s)
case: ifP.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
leT e x1 -> path leT z [:: e, x1 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
leT e x1 = false -> path leT z (x1 :: insert e s)
-
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
leT e x1 -> path leT z [:: e, x1 & s]
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
leT e x1 = false -> path leT z (x1 :: insert e s) by rewrite /= z_le_e path_x1_s => ->.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
leT e x1 = false -> path leT z (x1 :: insert e s)
move=> /= e_gt_x1.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
leT z x1 && path leT x1 (insert e s)
rewrite z_le_x1.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
true && path leT x1 (insert e s)
have:= leT_total e x1.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
e_gt_x1:leT e x1 = false
leT e x1 || leT x1 e ->
true && path leT x1 (insert e s)
rewrite {}e_gt_x1 /= => x1_le_e.
T:eqType
leT:rel T
leT_total:total leT
e, x1:T
s:seq T
IHs:forall z,
leT z e ->
path leT z s -> path leT z (insert e s)
z:T
z_le_e:leT z e
z_le_x1:leT z x1
path_x1_s:path leT x1 s
x1_le_e:leT x1 e
path leT x1 (insert e s)
exact: IHs.
Qed.

Optional exercise: refactor the proof above into an idiomatic one.

Lemma insert_sorted e s :
  sorted leT s ->
  sorted leT (insert e s).
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
Proof.
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
sorted leT s -> sorted leT (insert e s)
rewrite /sorted.
T:eqType
leT:rel T
leT_total:total leT
e:T
s:seq T
match s with
| [::] => true
| x :: s' => path leT x s'
end ->
match insert e s with
| [::] => true
| x :: s' => path leT x s'
end
case: s=> // x s.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
path leT x s ->
match insert e (x :: s) with
| [::] => true
| x :: s' => path leT x s'
end
move=> /=.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
path leT x s ->
match
  (if leT e x then [:: e, x & s] else x :: insert e s)
with
| [::] => true
| x :: s' => path leT x s'
end
case: ifP; first by move=> /= ->->.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
leT e x = false ->
path leT x s -> path leT x (insert e s)
move=> e_gt_x.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
e_gt_x:leT e x = false
path leT x s -> path leT x (insert e s)
apply: insert_path.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
e_gt_x:leT e x = false
leT x e
have:= leT_total e x.
T:eqType
leT:rel T
leT_total:total leT
e, x:T
s:seq T
e_gt_x:leT e x = false
leT e x || leT x e -> leT x e
by rewrite e_gt_x /= => ->.
Qed.

Exercise

Lemma sort_sorted s :
  sorted leT (sort s).
T:eqType
leT:rel T
leT_total:total leT
s:seq T
sorted leT (sort s)
Proof.
T:eqType
leT:rel T
leT_total:total leT
s:seq T
sorted leT (sort s)
Admitted.

End InsertionSort.

Arguments sort {T} _ _.
Arguments insert {T} _ _ _.




Section SortIsPermutation.

Variable T : eqType.
Variables leT : rel T.

(** a helper lemma (exercise) *)
Lemma count_insert p e s :
  count p (insert leT e s) = p e + count p s.
T:eqType
leT:rel T
p:pred T
e:T
s:seq T
count p (insert leT e s) = p e + count p s
Proof.
T:eqType
leT:rel T
p:pred T
e:T
s:seq T
count p (insert leT e s) = p e + count p s
by elim: s => //= x s; case: ifP=> _ //= ->; rewrite addnCA.
Qed.

About perm_eql.
Notation perm_eql s1 s2 := (perm_eq s1 =1 perm_eq s2)
Expands to: Notation mathcomp.ssreflect.seq.perm_eql


Lemma perm_sort s : perm_eql (sort leT s) s.
T:eqType
leT:rel T
s:seq T
perm_eql (sort leT s) s
Proof.
T:eqType
leT:rel T
s:seq T
perm_eql (sort leT s) s
Search _ (perm_eq ?s1 =1 perm_eq ?s2).
perm_rev:
  forall [T : eqType] (s : seq T), perm_eql (rev s) s
perm_rotr:
  forall [T : eqType] (n : nat) (s : seq T),
  perm_eql (rotr n s) s
perm_rot:
  forall [T : eqType] (n : nat) (s : seq T),
  perm_eql (rot n s) s
permPl:
  forall {T : eqType} {s1 s2 : seq T},
  reflect (perm_eql s1 s2) (perm_eq s1 s2)
permEl:
  forall [T : eqType] [s1 s2 : seq T],
  perm_eql s1 s2 -> perm_eq s1 s2
perm_sort:
  forall [T : eqType] (leT : rel T) (s : seq T),
  perm_eql (path.sort leT s) s
perm_catC:
  forall [T : eqType] (s1 s2 : seq T),
  perm_eql (s1 ++ s2) (s2 ++ s1)
perm_rcons:
  forall [T : eqType] (x : T) (s : seq T),
  perm_eql (rcons s x) (x :: s)
perm_merge:
  forall [T : eqType] (leT : rel T) (s1 s2 : seq T),
  perm_eql (merge leT s1 s2) (s1 ++ s2)
perm_catl:
  forall [T : eqType] (s : seq T) [t1 t2 : seq T],
  perm_eq t1 t2 -> perm_eql (s ++ t1) (s ++ t2)
perm_catr:
  forall [T : eqType] [s1 s2 : seq T] (t : seq T),
  perm_eq s1 s2 -> perm_eql (s1 ++ t) (s2 ++ t)
perm_catAC:
  forall [T : eqType] (s1 s2 s3 : seq T),
  perm_eql ((s1 ++ s2) ++ s3) ((s1 ++ s3) ++ s2)
perm_catCA:
  forall [T : eqType] (s1 s2 s3 : seq T),
  perm_eql (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3)
perm_filterC:
  forall [T : eqType] (a : pred T) (s : seq T),
  perm_eql
    ([seq x <- s | a x] ++ [seq x <- s | predC a x]) s
perm_catACA:
  forall [T : eqType] (s1 s2 s3 s4 : seq T),
  perm_eql ((s1 ++ s2) ++ s3 ++ s4)
    ((s1 ++ s3) ++ s2 ++ s4)
allpairs_rconsr:
  forall [S : Type] [T : S -> Type] [R : eqType]
    (f : forall x : S, T x -> R) (s : seq S)
    (y0 : forall x : S, T x)
    (t : forall x : S, seq (T x)),
  perm_eql
    [seq f x y | x <- s, y <- rcons (t x) (y0 x)]
    ([seq f x y | x <- s, y <- t x] ++
     [seq f x (y0 x) | x <- s])
perm_allpairs_consr:
  forall [S : Type] [T : S -> Type] [R : eqType]
    (f : forall x : S, T x -> R) (s : seq S)
    (y0 : forall x : S, T x)
    (t : forall x : S, seq (T x)),
  perm_eql [seq f x y | x <- s, y <- y0 x :: t x]
    ([seq f x (y0 x) | x <- s] ++
     [seq f x y | x <- s, y <- t x])
perm_allpairs_catr:
  forall [S : Type] [T : S -> Type] [R : eqType]
    (f : forall x : S, T x -> R) (s : seq S)
    (t1 t2 : forall x : S, seq (T x)),
  perm_eql [seq f x y | x <- s, y <- t1 x ++ t2 x]
    ([seq f x y | x <- s, y <- t1 x] ++
     [seq f x y | x <- s, y <- t2 x])
T:eqType
leT:rel T
s:seq T
perm_eql (sort leT s) s
apply/permPl/permP.
T:eqType
leT:rel T
s:seq T
count^~ (sort leT s) =1 count^~ s
(** exercise *)
elim: s=> //= x s IHs p.
T:eqType
leT:rel T
x:T
s:seq T
IHs:count^~ (sort leT s) =1 count^~ s
p:pred T
count p (insert leT x (sort leT s)) = p x + count p s
by rewrite count_insert IHs.
Qed.

This is why we state perm_sort lemma using perm_eql -- it can be used as an equation like so

Lemma mem_sort s : sort leT s =i s.
T:eqType
leT:rel T
s:seq T
sort leT s =i s
Proof.
T:eqType
leT:rel T
s:seq T
sort leT s =i s by apply: perm_mem; rewrite perm_sort. Qed.

Lemma sort_uniq s : uniq (sort leT s) = uniq s.
T:eqType
leT:rel T
s:seq T
uniq (sort leT s) = uniq s
Proof.
T:eqType
leT:rel T
s:seq T
uniq (sort leT s) = uniq s by apply: perm_uniq; rewrite perm_sort. Qed.

End SortIsPermutation.



Section SortProperties.

Variable T : eqType.
Variables leT : rel T.

Lemma sorted_sort s :
  sorted leT s -> sort leT s = s.
T:eqType
leT:rel T
s:seq T
sorted leT s -> sort leT s = s
Proof.
T:eqType
leT:rel T
s:seq T
sorted leT s -> sort leT s = s
elim: s=> // x1 s IHs S.
T:eqType
leT:rel T
x1:T
s:seq T
IHs:sorted leT s -> sort leT s = s
S:sorted leT (x1 :: s)
sort leT (x1 :: s) = x1 :: s
move: (S) => {}/sorted_cons/IHs /= ->.
T:eqType
leT:rel T
x1:T
s:seq T
S:sorted leT (x1 :: s)
insert leT x1 s = x1 :: s
move: S=> /=.
T:eqType
leT:rel T
x1:T
s:seq T
path leT x1 s -> insert leT x1 s = x1 :: s
case: s=> //= x2 s.
T:eqType
leT:rel T
x1, x2:T
s:seq T
leT x1 x2 && path leT x2 s ->
(if leT x1 x2
 then [:: x1, x2 & s]
 else x2 :: insert leT x1 s) = [:: x1, x2 & s]
by case/andP=> ->.
Qed.

End SortProperties.

End Insertion.

Merge sort

Module Merge.

Section MergeSortDef.

Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

Fixpoint split s : seq T * seq T :=
  match s with
  | [::] => (s, s)
  | [:: x] => (s, [::])
  | [:: x, y & s] =>
      let '(t1, t2) := split s in
      (x :: t1, y :: t2)
  end.

Arguments split : simpl nomatch.

Lemma split_lt1 s2 s1 s :
  1 < size s ->
  split s = (s1, s2) ->
  (size s1 < size s).
disp:()%type
T:orderType disp
s2, s1, s:seq T
1 < size s -> split s = (s1, s2) -> size s1 < size s
Proof.
disp:()%type
T:orderType disp
s2, s1, s:seq T
1 < size s -> split s = (s1, s2) -> size s1 < size s
Admitted.

Lemma split_lt2 s1 s2 s :
  1 < size s ->
  split s = (s1, s2) ->
  (size s2 < size s).
disp:()%type
T:orderType disp
s1, s2, s:seq T
1 < size s -> split s = (s1, s2) -> size s2 < size s
Proof.
disp:()%type
T:orderType disp
s1, s2, s:seq T
1 < size s -> split s = (s1, s2) -> size s2 < size s
Admitted.

Fail Fixpoint merge s t : seq T :=
  match s, t with
  | [::], _ => t
  | _, [::] => s
  | x :: s', y :: t' =>
      if (x <= y)%O then x :: merge s' t else y :: merge s t'
  end.
The command has indeed failed with message:
Cannot guess decreasing argument of fix.

Fixpoint merge s t : seq T :=
  let fix merge_s t :=
    match s, t with
    | [::], _ => t
    | _, [::] => s
    | x :: s', y :: t' =>
      if (x <= y)%O
      then x :: merge s' t
      else y :: merge_s  t'
    end
  in merge_s t.


Fail Fixpoint sort s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in merge (sort s1) (sort s2)
  end.
The command has indeed failed with message:
Recursive definition of sort is ill-formed.
In environment
disp : ()
T : orderType disp
sort : seq T -> seq T
s : seq T
s0 : T
l : seq T
s1 : T
l0 : seq T
s2 : seq T
s3 : seq T
Recursive call to sort has principal argument equal to
"s2" instead of one of the following variables: "l"
"l0".
Recursive definition is:
"fun s =>
 match s with
 | [:: _, _ & _] =>
     let
     '(s2, s3) := split s in merge (sort s2) (sort s3)
 | _ => s
 end".

Fail Fixpoint sort s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in merge (sort s1) (sort s2)
  end.
The command has indeed failed with message:
Recursive definition of sort is ill-formed.
In environment
disp : ()
T : orderType disp
sort : seq T -> seq T
s : seq T
s0 : T
l : seq T
s1 : T
l0 : seq T
s2 : seq T
s3 : seq T
Recursive call to sort has principal argument equal to
"s2" instead of one of the following variables: "l"
"l0".
Recursive definition is:
"fun s =>
 match s with
 | [:: _, _ & _] =>
     let
     '(s2, s3) := split s in merge (sort s2) (sort s3)
 | _ => s
 end".

Print Typing Flags.
check_guarded: true
check_positive: true
check_universes: true
cumulative sprop: false
definitional uip: false

Unset Guard Checking.

Print Typing Flags.
check_guarded: false
check_positive: true
check_universes: true
cumulative sprop: false
definitional uip: false

Fixpoint sort_unguarded s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in
         merge (sort_unguarded s1) (sort_unguarded s2)
  end.
Print Assumptions sort_unguarded.
Section Variables:
disp
: ()
T
: orderType disp
Axioms:
sort_unguarded is assumed to be guarded.
Set Guard Checking.

Fixpoint sort s {measure (size s)} : seq T  :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in
         merge (sort s1) (sort s2)
  end.
Next Obligation.
disp:()%type
T:orderType disp
s:seq T
sort:forall s0, (size s0 < size s)%coq_nat -> seq T
H0:[::] <> s
H:forall wildcard' : T, [:: wildcard'] <> s
s1, s2:seq T
Heq_anonymous:(s1, s2) = split s
(size s1 < size s)%coq_nat
apply/ltP; rewrite (@split_lt1 s2) //.
disp:()%type
T:orderType disp
s:seq T
sort:forall s0, (size s0 < size s)%coq_nat -> seq T
H0:[::] <> s
H:forall wildcard' : T, [:: wildcard'] <> s
s1, s2:seq T
Heq_anonymous:(s1, s2) = split s
1 < size s
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation.
disp:()%type
T:orderType disp
s:seq T
sort:forall s0, (size s0 < size s)%coq_nat -> seq T
H0:[::] <> s
H:forall wildcard' : T, [:: wildcard'] <> s
s1, s2:seq T
Heq_anonymous:(s1, s2) = split s
(size s2 < size s)%coq_nat
apply/ltP; rewrite (@split_lt2 s1) //.
disp:()%type
T:orderType disp
s:seq T
sort:forall s0, (size s0 < size s)%coq_nat -> seq T
H0:[::] <> s
H:forall wildcard' : T, [:: wildcard'] <> s
s1, s2:seq T
Heq_anonymous:(s1, s2) = split s
1 < size s
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation.
disp:()%type
T:orderType disp
s:seq T
sort:forall s0, (size s0 < size s)%coq_nat -> seq T
H:T
H0:seq T
H1:T
H2:seq T
(forall wildcard' : T,
 [:: wildcard'] <> [:: H, H1 & H2]) /\
[::] <> [:: H, H1 & H2] by []. Qed.


End MergeSortDef.

Section MergeSortTest.

Compute merge [:: 1; 3; 5] [:: 2; 4; 6].
= [:: 1; 2; 3; 4; 5; 6]
: seq Order.NatOrder.orderType

Compute sort_unguarded [:: 6; 4; 2; 1; 3; 5].
= [:: 1; 2; 3; 4; 5; 6]
: seq Order.NatOrder.orderType

Compute sort [:: 6; 4; 2; 1; 3; 5].
= [:: 1; 2; 3; 4; 5; 6]
: seq Order.NatOrder.orderType

End MergeSortTest.


Section MergeSortCorrect.

Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

Lemma sort_sorted s :
  sorted (<=%O) (sort s).
disp:()%type
T:orderType disp
s:seq T
sorted <=%O (sort s)
Proof.
disp:()%type
T:orderType disp
s:seq T
sorted <=%O (sort s)
Admitted.

End MergeSortCorrect.
End Merge.

Accessibility predicate on natural numbers

Section AccFrom.

Variable (p : pred nat).

The acc_from predicate lets us count up: we are not allowed to use acc_from to drive computation (extract information from proofs of propositions to make computationally relevant terms), but you can define a recursive function from a type like this to a type in Type and the termination checker is totally (pun intended) happy with it. We'll see this sort of example at the end.

Inductive acc_from i : Prop :=
| AccNow of p i
| AccLater of acc_from i.+1.

End AccFrom.

Check out the corresponding induction principle.

About acc_from_ind.
acc_from_ind :
forall [p : pred nat] [P : nat -> Prop],
(forall i : nat, p i -> P i) ->
(forall i : nat, acc_from p i.+1 -> P i.+1 -> P i) ->
forall i : nat, acc_from p i -> P i

acc_from_ind is not universe polymorphic
Arguments acc_from_ind [p] [P]%function_scope (_
  _)%function_scope [i]%nat_scope _
acc_from_ind is transparent
Expands to: Constant SerTop.acc_from_ind

Simple examples

Section SimpleExamples.

Let's do a couple of proofs to get the gist of acc_from

1. The property of "being equal to 42" is accessible from 0:

Goal acc_from (fun n => n == 42) 0.
acc_from (eq_op^~ 42) 0
Proof.
acc_from (eq_op^~ 42) 0
do 42 apply: AccLater.
acc_from (eq_op^~ 42) 42
by apply: AccNow.
Qed.

2. But it's inaccessible from 43:

Goal acc_from (fun n => n == 42) 43 -> False.
acc_from (eq_op^~ 42) 43 -> False
Proof.
acc_from (eq_op^~ 42) 43 -> False

If you start proving the current goal directly, you will quickly get stuck because your goal is too specialised. Clearly, you need induction over the accessibility predicate, but elim messes up your base case (look at the type of acc_from_ind).

elim.
forall i : nat, i == 42 -> False
forall i : nat,
acc_from (eq_op^~ 42) i.+1 -> False -> False
Show Proof.
(fun __top_assumption_ : acc_from (eq_op^~ 42) 43 =>
 (fun
    (_evar_0_ : forall i : nat,
                (eq_op^~ 42) i -> (fun=> False) i)
    (_evar_0_0 : forall i : nat,
                 acc_from (eq_op^~ 42) i.+1 ->
                 (fun=> False) i.+1 -> (fun=> False) i)
  => acc_from_ind _evar_0_ _evar_0_0 __top_assumption_)
   ?Goal ?Goal0)
forall i : nat, i == 42 -> False
forall i : nat,
acc_from (eq_op^~ 42) i.+1 -> False -> False
(* the first subgoal is unprovable *)
Abort.

We could try and create a more useful induction principle for our case but we might as well just use a low-level tactic fix which translates directly to Gallina's fixed-point combinator.

Goal acc_from (fun n => n == 42) 43 -> False.
acc_from (eq_op^~ 42) 43 -> False
Proof.
acc_from (eq_op^~ 42) 43 -> False
fix inacc 1.
inacc:acc_from (eq_op^~ 42) 43 -> False
acc_from (eq_op^~ 42) 43 -> False
Show Proof.
(fix inacc (H : acc_from (eq_op^~ 42) 43) : False :=
   ?Goal H)
inacc:acc_from (eq_op^~ 42) 43 -> False
acc_from (eq_op^~ 42) 43 -> False

To recursively call inacc on a structurally smaller argument we need to case analyse the top of the goal stack:

case.
inacc:acc_from (eq_op^~ 42) 43 -> False
43 == 42 -> False
inacc:acc_from (eq_op^~ 42) 43 -> False
acc_from (eq_op^~ 42) 44 -> False

The base case is easy now:

-
inacc:acc_from (eq_op^~ 42) 43 -> False
43 == 42 -> False
inacc:acc_from (eq_op^~ 42) 43 -> False
acc_from (eq_op^~ 42) 44 -> False by [].
inacc:acc_from (eq_op^~ 42) 43 -> False
acc_from (eq_op^~ 42) 44 -> False

But here we are stuck.

Abort.

So we generalize the goal to make the proof go through.

Lemma inacc_from43 :
  forall x, 42 < x -> acc_from (fun n => n == 42) x -> False.
forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
Proof.
forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
fix inacc 3.
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
Show Proof.
(fix inacc
   (x : nat) (H : 42 < x)
   (H0 : acc_from (eq_op^~ 42) x) {struct H0} :
     False :=
   ?Goal x H H0)
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
move=> x x_gt42.
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
acc_from (eq_op^~ 42) x -> False
case=> [/eqP E|].
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
E:x = 42
False
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
acc_from (eq_op^~ 42) x.+1 -> False
-
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
E:x = 42
False
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
acc_from (eq_op^~ 42) x.+1 -> False by rewrite E in x_gt42.
inacc:forall x : nat,
42 < x -> acc_from (eq_op^~ 42) x -> False
x:nat
x_gt42:42 < x
acc_from (eq_op^~ 42) x.+1 -> False
apply: inacc.
x:nat
x_gt42:42 < x
42 < x.+1
by apply: (ltn_trans x_gt42).
Qed.

End SimpleExamples.