46 lines
1.9 KiB
Scheme
46 lines
1.9 KiB
Scheme
|
(define-library (srfi 95)
|
|||
|
|
(import (scheme base)
|
|||
|
|
(scheme load))
|
|||
|
|
;; this hack works only if the current directory is the root of picrin.
|
|||
|
|
(load "piclib/srfi/1.scm")
|
|||
|
|
(import (srfi 1))
|
|||
|
|
(define (list-sorted? ls less?)
|
|||
|
|
(let loop ((cur ls))
|
|||
|
|
(if (<= (length cur) 1) #t
|
|||
|
|
(if (less? (second cur) (first cur)) #f
|
|||
|
|
(loop (cdr cur))))))
|
|||
|
|
(define (identity x) x)
|
|||
|
|
(define (quotient a b) (exact (floor (/ a b))))
|
|||
|
|
(define (merge ls1 ls2 less? . opt-key)
|
|||
|
|
(let ((key (if (null? opt-key) identity (car opt-key))))
|
|||
|
|
(let rec ((arg1 ls1) (arg2 ls2))
|
|||
|
|
(cond ((null? arg1) arg2)
|
|||
|
|
((null? arg2) arg1)
|
|||
|
|
((less? (key (car arg1)) (key (car arg2))) (cons (car arg1) (rec (cdr arg1) arg2)))
|
|||
|
|
(else (cons (car arg2) (rec arg1 (cdr arg2))))))))
|
|||
|
|
(define (merge-sub! ls1 ls2 less? key)
|
|||
|
|
(let rec ((arg1 ls1) (arg2 ls2))
|
|||
|
|
(cond ((null? arg1) arg2)
|
|||
|
|
((null? arg2) arg1)
|
|||
|
|
((not (less? (key (car arg2)) (key (car arg1)))) (set-cdr! arg1 (rec (cdr arg1) arg2)) arg1)
|
|||
|
|
(else (set-cdr! arg2 (rec arg1 (cdr arg2))) arg2))))
|
|||
|
|
(define (merge! ls1 ls2 less? . opt-key)
|
|||
|
|
(let ((key (if (null? opt-key) identity (car opt-key)))
|
|||
|
|
(c1 (car ls1)) (c2 (car ls2)))
|
|||
|
|
(if (less? (key c2) (key c1)) (begin (set-car! ls1 c2) (set-car! ls2 c1)))
|
|||
|
|
(merge-sub! ls1 ls2 less? key)))
|
|||
|
|
(define (merge-sort ls less?)
|
|||
|
|
(if (<= (length ls) 1) ls
|
|||
|
|
(let* ((n (length ls)) (p (quotient n 2)) (as (take ls p)) (bs (drop ls p))
|
|||
|
|
(sa (merge-sort as less?)) (sb (merge-sort bs less?)))
|
|||
|
|
(merge sa sb less?))))
|
|||
|
|
|
|||
|
|
(define (merge-sort! ls less?)
|
|||
|
|
(if (<= (length ls) 1) ls
|
|||
|
|
(let* ((n (length ls)) (p (quotient n 2)) (bs (drop ls p)) (as (take! ls p))
|
|||
|
|
(sa (merge-sort! as less?)) (sb (merge-sort! bs less?)))
|
|||
|
|
(merge! sa sb less?))))
|
|||
|
|
(export list-sorted? merge merge! merge-sort merge-sort!)
|
|||
|
|
)
|
|||
|
|
|