; Merge sort and stuff
; $Rev: 7 $
; cmp should be a strict partial order.
; merge[!] will pick from the first list when elements don't compare.
; sort is stable and always produces a new list.

(define (append-reverse rev tail)
  (if (null? rev)
      tail
      (append-reverse (cdr rev) (cons (car rev) tail))))

(define (append-reverse! rev tail)
  (if (null? rev)
      tail
      (let ((cr (cdr rev)))
        (set-cdr! rev tail)
        (append-reverse! cr rev))))

(define (reverse! lst)
  (append-reverse! lst '()))

(define (merge a b cmp)
  (define (merge-tail a b res)
    (cond ((null? a) (append-reverse! res b))
          ((null? b) (append-reverse! res a))
          ((cmp (car b) (car a)) (merge-tail a (cdr b)
                                             (cons (car b) res)))
          (else (merge-tail (cdr a) b
                            (cons (car a) res)))))
  (merge-tail a b '()))

(define (merge! a b cmp)
  (define (merge-tail! prev a b)
    (cond ((null? a) (set-cdr! prev b))
          ((null? b) (set-cdr! prev a))
          ((cmp (car b) (car a))
           (set-cdr! prev b)
           (merge-tail! b a (cdr b)))
          (else
           (set-cdr! prev a)
           (merge-tail! a (cdr a) b))))
  (let ((tem '(())))
    (merge-tail! tem a b)
    (cdr tem)))
  
(define (sort lst cmp)
  (define (sortn lst n)
    (if (= n 1)
        (list (car lst))
        (let ((m (bit-shift n -1)))
          (merge! (sortn lst m)
                  (sortn (list-tail lst m) (- n m))
                  cmp))))
  (if (null? lst)
      '()
      (sortn lst (length lst))))

(define (filter f lst)
  (do ((ls lst (cdr lst))
       (res '() (let ((el (car ls)))
                  (if (f el) (cons el res) res))))
      ((null? ls) (reverse! res))))

; Almost cons-free version
(define (filter! f lst)
  (define (filt! f prev lst)
    (cond ((null? lst)
           (set-cdr! prev '()))
          ((f (car lst))
           (set-cdr! prev lst)
           (filt! f lst (cdr lst)))
          (else (filt! f prev (cdr lst)))))
  (let ((tem '(())))
    (filt! f tem lst)
    (cdr tem)))

; sorted-lst should be sorted by a strict weak order.  eq should be
; an equivalence relation such that order-equivalent items are always eq
; (eq may have larger equivalence classes than the order but not smaller).
(define (dupes sorted-lst eq)
  (define (dup hd tl eat res)
    (cond ((null? tl) res)
          ((eq hd (car tl))
           (dup hd (cdr tl) #t (if eat res (cons hd res))))
          (else (dup (car tl) (cdr tl) #f res))))
  (if (null? sorted-lst)
      '()
      (reverse! (dup (car sorted-lst) (cdr sorted-lst) #f '()))))

; (lexcmp cmp1 ... cmpn) gives a lexicographic comparison function for
; lists.  It compares the first elements with cmp1, second elements
; with cmp2 etc.  Only the first n elements are compared.  It is an
; error for compared lists to be shorter than n.
(define (lexcmp . cmps)
  (define (lcmp cmps a b)
    (if (null? cmps)
        #f
        (let ((cmp (car cmps))
              (ca (car a))
              (cb (car b)))
          (cond ((cmp ca cb) #t)
                ((cmp cb ca) #f)
                (else (lcmp (cdr cmps) (cdr a) (cdr b)))))))
  (lambda (a b) (lcmp cmps a b)))