;;;         Mergesort.lsp
;;;  free for non-commercial use only
;;;   1999 (C.) Vladimir Nesterovsky
;;;      vnestr@netvision.net.il
;;; http://www.netvision.net.il/php/vnestr

;;; sort a list by standard mergesort method
;;; using a user-specified comparison function
;;; which should return true if and only if its
;;; first argument is strictly less than the
;;; second (in some appropriate sense).

;;; also, define a wrapper function that'll allow
;;; for sorting by user-supplied "value function",
;;; which is a function of one argument returning
;;; some "value" recognizable by the built-in '<
;;; operator. Sorting in this way can be much much
;;; faster then the usual way of calling the
;;; comparison function for each compare, because
;;; this potentially slow and heavy value-function
;;; gets called only ONCE for each element, and later
;;; all the compares are done with very fast and
;;; efficient built-in '< calls

;;; keeping original order of equal elements
;;; in the list (what's called "stable sort")

;;; uses recursion, so potentially unsafe

;;; more code is inlined to speed up the end cases
;;; handling, like 2-, 3- or 4-elements lists,
;;; also reducing the amount of recursion,
;;; which amounts to some 45% speed gain

(defun mergesort (lst less-then?)
 ;; is it the fastest autolisp version?
 (setq less-then? (make-usubr less-then?))
 (_mrgsrt lst))

(defun make-usubr (f)
 (cond
  ((and (not (atom f))
        (not (equal 'LAMBDA (car f))))
     (eval (cons 'LAMBDA f)))
  ((eval f))))


(defun _mrgsrt (ls / len a b c d l1)
 (cond
  ((< (setq len (length ls)) 2)
    ;; one-element or empty list
    ls)
  ((= len 2)
    ;; 26% speed gain for 10-elems list, 18% for 250
    ;; when this special case inlined
    (if (less-then? (cadr ls) (car ls))
      (reverse ls)
      ls))
  ((= len 3)
    ;; more 10% speed gain
    (if (less-then? (cadr ls) (car ls))
      (cond
        ((less-then? (caddr ls) (cadr ls))
          (reverse ls))
        ((less-then? (caddr ls) (car ls))
          (list (cadr ls) (caddr ls) (car ls)))
        ((list (cadr ls) (car ls) (caddr ls))))
      (cond
        ((less-then? (caddr ls) (car ls))
          (list (caddr ls) (car ls) (cadr ls)))
        ((less-then? (caddr ls) (cadr ls))
          (list (car ls) (caddr ls) (cadr ls)))
        ( ls ))))
  ((= len 4)
    ;; another 15% speed gain for 4*2^n initial lengths
    ;; (no impact on 3*2^n cases)
    (if (less-then? (cadr ls) (car ls))
      (setq a (cadr ls) b (car ls))
      (setq b (cadr ls) a (car ls)))
    (if (less-then? (last ls) (caddr ls))
      (setq c (last ls) d (caddr ls))
      (setq d (last ls) c (caddr ls)))
    (cond
      ((less-then? d a)
        (list c d a b))
      ((less-then? d b)
        (if (less-then? c a)
          (list c a d b)
          (list a c d b)))
      ((cond
          ((less-then? c a)
            (list c a b d))
          ((less-then? c b)
            (list a c b d))
          ((list a b c d))))))
  ( t
    ;; general case
    (repeat (/ len 2)
      (setq l1 (cons (car ls) l1)
            ls (cdr ls)))
    (_mrgsrt-merge
      (_mrgsrt (reverse l1))
      (_mrgsrt ls)))))


;;; merge two sorted lists in a stable manner
;;; less-then? usubr assumed to be defined globally
;;; may be used independently when needed
(defun _mrgsrt-merge (l1 l2 / rslt)
    (while (and l1 l2)     ;merge the sorted halves back
      (while (and l1 l2
               (not (less-then? (car l2) (car l1))))
        (setq rslt (cons (car l1) rslt)
               l1  (cdr l1)))
      (while (and l1 l2
               (less-then? (car l2) (car l1)))
        (setq rslt (cons (car l2) rslt)
               l2  (cdr l2))) )
    (foreach e l1 (Setq rslt (cons e rslt)))
    (foreach e l2 (Setq rslt (cons e rslt)))
    (reverse rslt))


;;; sort by Value function
;;;  (it's generally much faster then sorting
;;;   by compare-function because potentially
;;;   slow value-function will be called only
;;;   once for each element here)
;;; Value function is such that excepts one
;;;  argument and returns an atomic value
;;;  for which calling '< is meaningful
;;;  (numbers usually, but may be strings too).
(defun Vmergesort (lst valfun)
 (setq valfun (make-usubr valfun))
 (mapcar 'cdr
  (mergesort
   (mapcar '(lambda (e)      ;calculate results
              (cons (valfun e) e)) ; in advance
            lst)             ;store them and
   car-less?)))              ;sort by comparing CARs

(defun car-less? (a b)
 (< (car a) (car b)))

;;; one possible efficiency improvement can be
;;; to implement a special version of vmergesort
;;; hand-coded to sort its argument list elements
;;; by their CARs and also automatically strip them
;;; away with CDRs while merging half-lists back

(princ "\n   Usage: (MERGESORT list compare-function) ")
(princ "\n   Or better: (VMERGESORT list value-function)")
(princ)