;;  sort.ss: sorting utilities
;;  Copyright (C) 2006 David Herman
;;
;;  This library is free software; you can redistribute it and/or modify it
;;  under the terms of the GNU Lesser General Public License as published by
;;  the Free Software Foundation; either version 2.1 of the License, or (at
;;  your option) any later version.
;;
;;  This library is distributed in the hope that it will be useful, but WITHOUT
;;  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;  License for more details.
;;
;;  You should have received a copy of the GNU Lesser General Public License
;;  along with this library; if not, write to the Free Software Foundation,
;;  Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;
;; The `string-natural-compare' procedure is based on the C `strnatcmp' by Martin Pool.
;; Copyright (C) 2000 by Martin Pool <[email protected]>

(module sort mzscheme
  (require (lib "match.ss")
           (lib "etc.ss"))

  (define (string-ref* str i)
    (if (< i (string-length str))
        (string-ref str i)
        #\nul))

  (define (skip-whitespace str i)
    (if (char-whitespace? (string-ref* str i))
        (skip-whitespace str (add1 i))
        i))

  (define (char-non-numeric? ch)
    (not (char-numeric? ch)))

  (define string-natural-compare
    (opt-lambda (a b [case-insensitive? #f])
      (let loop ([ai 0] [bi 0])
        (let ([ai (skip-whitespace a ai)]
              [bi (skip-whitespace b bi)])
          (match (list (string-ref* a ai) (string-ref* b bi))
            [(#\nul #\nul) '=]
            [(#\nul _) '<]
            [(_ #\nul) '>]
            [(#\0 #\0)
             (let compare-left ([ai ai] [bi bi])
               (match (list (string-ref* a ai) (string-ref* b bi))
                 [((? char-non-numeric?) (? char-non-numeric?))
                  (loop ai bi)]
                 [((? char-non-numeric?) _) '<]
                 [(_ (? char-non-numeric?)) '>]
                 [(ca cb)
                  (cond
                    [(char<? ca cb) '<]
                    [(char>? ca cb) '>]
                    [else (compare-left (add1 ai) (add1 bi))])]))]
            [((? char-numeric?) (? char-numeric?))
             (let compare-right ([ai ai] [bi bi] [bias #f])
               (match (list (string-ref* a ai) (string-ref* b bi))
                 [((? char-non-numeric?) (? char-non-numeric?))
                  (or bias (loop ai bi))]
                 [((? char-non-numeric?) _) '<]
                 [(_ (? char-non-numeric?)) '>]
                 [(ca cb)
                  (compare-right
                   (add1 ai)
                   (add1 bi)
                   (or bias (and (char<? ca cb) '<) (and (char>? ca cb) '>)))]))]
            [(ca cb)
             (cond
               [(and case-insensitive? (char-ci<? ca cb)) '<]
               [(and case-insensitive? (char-ci>? ca cb)) '>]
               [(and (not case-insensitive?) (char<? ca cb)) '<]
               [(and (not case-insensitive?) (char>? ca cb)) '>]
               [else (loop (add1 ai) (add1 bi))])])))))

  (define (string-natural<? s1 s2)
    (eq? (string-natural-compare s1 s2 #f) '<))

  (define (string-natural<=? s1 s2)
    (case (string-natural-compare s1 s2 #f)
      [(< =) #t]
      [else #f]))

  (define (string-natural>? s1 s2)
    (eq? (string-natural-compare s1 s2 #f) '>))

  (define (string-natural>=? s1 s2)
    (case (string-natural-compare s1 s2 #f)
      [(> =) #t]
      [else #f]))

  (define (string-natural-ci<? s1 s2)
    (eq? (string-natural-compare s1 s2 #t) '<))

  (define (string-natural-ci<=? s1 s2)
    (case (string-natural-compare s1 s2 #t)
      [(< =) #t]
      [else #f]))

  (define (string-natural-ci>? s1 s2)
    (eq? (string-natural-compare s1 s2 #t) '>))

  (define (string-natural-ci>=? s1 s2)
    (case (string-natural-compare s1 s2 #t)
      [(> =) #t]
      [else #f]))

  (define (make-path-comparator string-comparator)
    (lambda (x1 x2)
      (string-comparator (if (path? x1) (path->string x1) x1)
                         (if (path? x2) (path->string x2) x2))))

  (define path-natural<? (make-path-comparator string-natural<?))
  (define path-natural<=? (make-path-comparator string-natural<=?))
  (define path-natural>? (make-path-comparator string-natural>?))
  (define path-natural>=? (make-path-comparator string-natural>=?))
  (define path-natural-ci<? (make-path-comparator string-natural-ci<?))
  (define path-natural-ci<=? (make-path-comparator string-natural-ci<=?))
  (define path-natural-ci>? (make-path-comparator string-natural-ci>?))
  (define path-natural-ci>=? (make-path-comparator string-natural-ci>=?))

  (provide (all-defined-except string-ref* skip-whitespace char-non-numeric? string-natural-compare make-path-comparator)))