conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

cleanup

This commit is contained in:
Yuichi Nishiwaki 2014-03-15 20:43:22 +09:00
parent e35820da54
commit 5b0bce9ce3
1 changed files with 68 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
piclib/srfi/95.scm
View File

@ -1,45 +1,84 @@
(define-library (srfi 95)
(import (scheme base)
(scheme load))
(scheme load))
;; this hack works only if the current directory is the root of picrin.
(load "piclib/srfi/1.scm")
(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))))
(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))))))))
(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))))
(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)) (d1 (cdr ls1)) (d2 (cdr ls2)))
(if (less? (key c2) (key c1)) (begin (set-car! ls1 c2) (set-car! ls2 c1) (set-cdr! ls1 d2) (set-cdr! ls2 d1)))
(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?))))
 
(c1 (car ls1))
(c2 (car ls2))
(d1 (cdr ls1))
(d2 (cdr ls2)))
(when (less? (key c2) (key c1))
(set-car! ls1 c2)
(set-car! ls2 c1)
(set-cdr! ls1 d2)
(set-cdr! ls2 d1))
(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!)
)
(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!))