;;; File:
;;;   mergesort.scm
;;; Author:
;;;   Samuel A. Rebelsky
;;; Summary:
;;;   Procedures for sorting stuff using the legendary merge sort procedure.
;;; Version:
;;;   1.5 of November 2006
;;; Contents:
;;;   Primary Procedures:
;;;     (merge-sort stuff may-precede?)
;;;       Sort the list, stuff, using may-precede? to compare elements..
;;;     (new-merge-sort stuff may-precede?)
;;;       Sort the list, stuff, using may-precede? to compare elements.
;;;     (merge sorted1 sorted2 may-precede?)
;;;       Merge two sorted lists.
;;;     (split lst)
;;;       Split lst into two lists (a list of two lists).
;;;     (random-list max len)
;;;       Create a list of len elements, each of which is between 0 and
;;;       max, inclusive.
;;; History
;;;   At end.

; +--------------------+----------------------------------------------
; | Primary Procedures |
; +--------------------+

;;; Procedure:
;;;   merge-sort
;;;   new-merge-sort
;;; Parameters:
;;;   stuff, a list to sort
;;;   may-precede?, a binary predicate that compares keys.
;;; Purpose:
;;;   Sort stuff.
;;; Produces:
;;;   sorted-stuff, a sorted list
;;; Preconditions:
;;;   may-precede? can be applied to any two elements of stuff.
;;;   may-precede? represents a transitive operation.
;;;   stuff is not empty.
;;; Postconditions:
;;;   sorted-stuff is sorted.  That is, the key of any
;;;     element may precede the key of any subsequent element.
;;;     In Scheme, we'd say that
;;;       (may-precede? (list-ref sorted i) (list-ref sorted (+ i 1)))
;;;   sorted-stuff is a permutation of stuff.
;;;   Does not affect stuff.
;;;   sorted-stuff may share cons cells with stuff.
;;; Practica:
;;;   To sort values, a list of numbers, in increasing order.
;;;     (merge-sort values <=)
;;;   To sort values, a list of numbers, in decreasing order.
;;;     (merge-sort values >=)
;;;   To sort people, a list of (last-name first-name phone-number)
;;;     triplets, by phone number
;;;     (merge-sort people 
;;;                 (lambda (person1 person2) 
;;;                   (string<=? (caddr person1) (caddr person2))))
(define merge-sort
  (lambda (stuff may-precede?)
    ; If there are only zero or one elements in the list,
    ; the list is already sorted.
    (if (or (null? stuff) (null? (cdr stuff)))
        stuff
        ; Otherwise, 
        ;   split the list in half,
        ;   sort each half,
        ;   and then merge the sorted halves.
        (let* ((halves (split stuff))
               (some (car halves))
               (rest (cadr halves)))
          (merge (merge-sort some may-precede?)
                 (merge-sort rest may-precede?)
                 may-precede?)))))

(define new-merge-sort
  (lambda (stuff may-precede?)
    (letrec (
             ; Repeatedly merge pairs
             (repeat-merge
               (lambda (list-of-lists)
                 ; (display list-of-lists) (newline)
                 ; If there's only one list in the list of lists
                 (if (null? (cdr list-of-lists))
                     ; Use that list
                     (car list-of-lists)
                     ; Otherwise, merge neighboring pairs and start again.
                     (repeat-merge (merge-pairs list-of-lists)))))
             ; Merge neighboring pairs in a list of lists
             (merge-pairs
               (lambda (list-of-lists)
                 (cond
                   ; Base case: Empty list.
                   ((null? list-of-lists) null)
                   ; Base case: Single-element list (nothing to merge)
                   ((null? (cdr list-of-lists)) list-of-lists)
                   ; Recursive case: Merge first two and continue
                   (else (cons (merge (car list-of-lists) (cadr list-of-lists)
                                      may-precede?)
                               (merge-pairs (cddr list-of-lists))))))))
      (repeat-merge (map list stuff)))))

;;; Procedure:
;;;   merge
;;; Parameters:
;;;   sorted1, a sorted list.
;;;   sorted2, a sorted list.
;;;   may-precede?, a binary predicate that compares keys
;;; Purpose:
;;;   Merge the two lists.
;;; Produces:
;;;   sorted, a sorted list.
;;; Preconditions:
;;;   may-precede? can be applied to any two values in sorted1 or sorted2
;;;   may-precede? represents a transitive operation.
;;;   sorted1 and sorted2 are sorted by may-precede?.  A list is sorted
;;;     by may-precede? if 
;;;       (may-precede? (list-ref lst i) (list-ref lst (+ 1 i)))
;;;     for all reasonable i.
;;; Postconditions:
;;;   The result list is sorted by may-precede? (see above for def'n).
;;;   sorted is a permutation of (append sorted1 sorted2).
;;;   Does not affect sorted1 or sorted2.
;;;   sorted may share cons cells with sorted1 or sorted2.
(define merge
  (lambda (sorted1 sorted2 may-precede?)
    (cond
      ; If the first list is empty, return the second
      ((null? sorted1) sorted2)
      ; If the second list is empty, return the first
      ((null? sorted2) sorted1)
      ; If the first element of the first list is smaller,
      ; make it the first element of the result and recurse.
      ((may-precede? (car sorted1) (car sorted2))
       (cons (car sorted1) 
             (merge (cdr sorted1) sorted2 may-precede?)))
      ; Otherwise, do something similar using the first element
      ; of the second list
      (else
       (cons (car sorted2) 
             (merge sorted1 (cdr sorted2) may-precede?))))))

;;; Procedure:
;;;   split
;;; Parameters:
;;;   lst, a list
;;; Purpose:
;;;   Split a list into two nearly-equal halves.
;;; Produces:
;;;   (firsthalf secondhalf), a list of two lists.
;;; Preconditions:
;;;   lst is a list.
;;; Postconditions:
;;;   (append firsthalf secondhalf) is a permutation of lst.  That is,
;;;     each element of lst appears in either firsthalf or secondhalf
;;;     and every element of firsthalf or secondhalf appears in lst.
;;;   Does not modify lst.
;;;   Either firsthalf or secondhalf may share cons cells with lst.
(define split
  (lambda (lst)
    ;;; helper
    ;;;   Remove the first count elements of a list.  Return the
    ;;;   pair consisting of the removed elements (in order) and
    ;;;   the remaining elements.
    (let helper ((remaining lst) ; Elements remaining to be used
                 (revacc null)   ; Accumulated initial elements
                 (count          ; How many elements left to use
                  (quotient (length lst) 2)))
      ; If no elements remain to be used,
      (if (= count 0)
          ; The first half is in revacc and the second half
          ; consists of any remaining elements.
          (list (reverse revacc) remaining)
          ; Otherwise, use up one more element.
          (helper (cdr remaining)
                  (cons (car remaining) revacc)
                  (- count 1))))))

; +--------------------+----------------------------------------------
; | Utility Procedures |
; +--------------------+

;;; Procedure:
;;;   random-list
;;; Parameters:
;;;   max, the largest value to be produced
;;;   len, an integer
;;; Purpose:
;;;   Produces a list of "random" values.
;;; Preconditions:
;;;   max > 0
;;;   len >= 0
;;; Postconditions:
;;;   The result list has length length.
;;;   Every value in the result list is between 0 and max, inclusive.
;;;   The result list is hard to predict.
(define random-list
  (lambda (max len)
    (if (= len 0) null
        (cons (random (+ max 1)) (random-list max (- len 1))))))

; +---------+---------------------------------------------------------
; | History |
; +---------+

;;;   Wednesday, 22 November 2000 [v 1.0]
;;;     Created.
;;;   Tuesday, 24 April 2001 [v 1.1]
;;;     Renamed the comparison procedure to may-precede?.
;;;     Updated documentation.
;;;     Added a few more internal comments.
;;;     Changed the return type of split to "two values".
;;;   Tuesday, 26 November 2002 [v 1.2]
;;;     Removed get-key from the parameters of merge-sort and merge.
;;;     Added new-merge-sort
;;;     Updated documentation.
;;;     Changed the return type of split back to "list of lists"
;;;   Monday, 28 April 2003 [v 1.3]
;;;     Updated documentation.
;;;   Monday, 24 November 2003 [v 1.4]
;;;     Changed name from mergesort.ss to mergesort.scm.
;;;     Updated documentation.
;;;   Saturday, 11 November 2006 [v 1.5]
;;;     Cleaned up documentation.