(*---------------------------------------------------------------------------
            A not totally naive version of Quicksort 
 ---------------------------------------------------------------------------*)

app load ["bossLib", "Q", "sortingTheory", "partitionTheory", "pairTools"];

open combinTheory relationTheory pairTheory listTheory 
     sortingTheory permTheory partitionTheory bossLib pairTools;

infix 8 by;

(*---------------------------------------------------------------------------
     Misc. lemmas ... should perhaps already be part of the system.
 ---------------------------------------------------------------------------*)

val MEM_FILTER = Q.prove
(`!P L x. MEM x (FILTER P L) = P x /\ MEM x L`,
Induct_on `L`  
 THEN RW_TAC list_ss [MEM,FILTER] 
 THEN PROVE_TAC [MEM]);

val MEM_APPEND_DISJ = Q.prove
(`!x l1 l2. MEM x (APPEND l1 l2) = MEM x l1 \/ MEM x l2`,
Induct_on `l1` THEN RW_TAC list_ss [APPEND,MEM] THEN PROVE_TAC[]);


(*---------------------------------------------------------------------------*
 * The property of a relation being total.                                   *
 *---------------------------------------------------------------------------*)

val total_def = Define `total R = !x y. R x y \/ R y x`;


(*---------------------------------------------------------------------------*
 *      Quicksort                                                            *
 *---------------------------------------------------------------------------*)

val fqsort_def = 
 Hol_defn "fqsort"
    `(fqsort ord [] = []) /\
     (fqsort ord (h::t) = 
           let (l1,l2) = partition (\y. ord y h) t
           in
           APPEND (fqsort ord l1) 
               (h::fqsort ord l2))`;


(*---------------------------------------------------------------------------
 * Termination of fqsort 
 *---------------------------------------------------------------------------*)

val (fqsort_eqns,fqsort_ind) = Defn.tprove
 (fqsort_def,
  WF_REL_TAC fqsort_def `measure (LENGTH o SND)`
     THEN RW_TAC list_ss [o_DEF,partition_def]
     THEN IMP_RES_THEN MP_TAC part_length_lem
     THEN RW_TAC list_ss []);


(*---------------------------------------------------------------------------*
 *           Properties of fqsort                                            *
 *---------------------------------------------------------------------------*)

val fqsort_MEM_stable = Q.store_thm
("fqsort_MEM",
 `!R L x. MEM x (fqsort R L) = MEM x L`,
recInduct fqsort_ind
 THEN RW_TAC std_ss [fqsort_eqns,partition_def]
 THEN LET_EQ_TAC [LET2_RATOR,LET2_RAND]
 THEN RW_TAC list_ss [MEM_APPEND_DISJ,MEM]
 THEN RES_THEN (TRY o SUBST1_TAC o SPEC_ALL)
 THEN Q.PAT_ASSUM `x = y` (MP_TAC o MATCH_MP part_MEM)
 THEN RW_TAC list_ss [] THEN PROVE_TAC [MEM_APPEND_DISJ]);


(*---------------------------------------------------------------------------*
 * The result list is a permutation of the input list.  Uses a lemma that    *
 * says that appending the two partitions of the original list is a          *
 * permutation of the original list.                                         *
 *---------------------------------------------------------------------------*)

val part_PERM = Q.prove
(`!P L a1 a2 l1 l2. 
   ((a1,a2) = part P L l1 l2) 
      ==> 
   PERM (APPEND L (APPEND l1 l2)) (APPEND a1 a2)`,
Induct_on `L` 
  THEN RW_TAC list_ss [part_def, PERM_refl]
  THEN RES_TAC THEN MATCH_MP_TAC PERM_trans1 THENL
  [Q.EXISTS_TAC `APPEND L (APPEND (h::l1) l2)`,
   Q.EXISTS_TAC `APPEND L (APPEND l1 (h::l2))`]
  THEN PROVE_TAC [APPEND,APPEND_ASSOC,CONS_PERM,PERM_refl]);


val fqsort_PERM = Q.store_thm
("fqsort_PERM",
`!R L. PERM L (fqsort R L)`,
recInduct fqsort_ind
  THEN RW_TAC list_ss [fqsort_eqns,PERM_refl,partition_def]
  THEN LET_EQ_TAC [LET2_RATOR,LET2_RAND]
  THEN MATCH_MP_TAC CONS_PERM
  THEN MATCH_MP_TAC PERM_trans1
  THEN Q.EXISTS_TAC`APPEND l1 l2`
  THEN RW_TAC std_ss [] THENL
  [Q.PAT_ASSUM `x = y` (MP_TAC o MATCH_MP part_PERM) THEN RW_TAC list_ss [],
   `PERM l1 (fqsort ord l1)` by RES_TAC THEN 
   `PERM l2 (fqsort ord l2)` by RES_TAC THEN PROVE_TAC [PERM_cong]]);


(*---------------------------------------------------------------------------
 * The result list is sorted.
 *---------------------------------------------------------------------------*)

val fqsort_sorts = 
Q.store_thm
("fqsort_sorts",
`!R L. transitive R /\ total R ==> SORTED R (fqsort R L)`,
 recInduct fqsort_ind 
  THEN RW_TAC list_ss [fqsort_eqns,SORTED_def,partition_def]
  THEN LET_EQ_TAC [LET2_RATOR,LET2_RAND]
  THEN MATCH_MP_TAC SORTED_APPEND
  THEN IMP_RES_THEN (fn th => ASM_REWRITE_TAC [th]) SORTED_eq
  THEN RW_TAC list_ss [MEM_FILTER,MEM,fqsort_MEM_stable] 
  THEN ((RES_TAC THEN NO_TAC) ORELSE ALL_TAC)
  THEN Q.PAT_ASSUM `x = y` (MP_TAC o MATCH_MP 
        (REWRITE_RULE[PROVE []`x/\y/\z ==> w = x ==> y/\z ==> w`]
            parts_have_prop))
  THEN RW_TAC std_ss [MEM]
  THEN PROVE_TAC [transitive_def,total_def]);


(*---------------------------------------------------------------------------
 * Bring everything together.
 *---------------------------------------------------------------------------*)

val fqsort_correct = Q.store_thm
("fqsort_correct", 
`!R. transitive R /\ total R ==> performs_sorting fqsort R`,
PROVE_TAC
  [performs_sorting_def, fqsort_PERM, fqsort_sorts]);
