suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Moved (and improved) sort! etc from Swindle to mzlib/list.ss

Browse Source 
* Expose sort!, merge! and merge, since they're also useful

* Made `mergesort' be an alias for `sort'.

* Removed it all from Swindle

* Removed `sort' from compat.ss

* Needed to adjust a few other files, no problems but
  graphics/value-turtles provides its own version of `merge'

svn: r2542
This commit is contained in:
Eli Barzilay 2006-03-30 09:39:30 +00:00
parent 26294f0232
commit 6744633338
6 changed files with 152 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/graphics/value-turtles.ss
View File

@ -2,7 +2,7 @@
(require (lib "math.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(all-except (lib "list.ss") merge)
(lib "struct.ss"))
(provide turtles move draw turn turn/radians merge clean)
@ -347,4 +347,4 @@
(define (clean tv) (send tv clean-op))
(set! saved-turtle-snip% turtle-snip%)
(set! saved-turtles turtles))
(set! saved-turtles turtles))

10
collects/mzlib/compat.ss
View File

@ -1,21 +1,19 @@
(module compat mzscheme
(require "list.ss")
(provide real-time
1+ 1-
>=? <=? >? <? =?
flush-output-port
sort
gentemp
atom?
putprop getprop
new-cafe
define-structure)
(define 1+ add1)
(define 1- sub1)
(define =? =)
(define <? <)
(define >? >)
@ -26,10 +24,6 @@
(define gentemp gensym)
(define sort ; Chez argument order
(lambda (less-than? l)
(mergesort l less-than?)))
(define flush-output-port flush-output)
(define real-time current-milliseconds)

2
collects/mzlib/integer-set.ss
View File

@ -1,5 +1,5 @@
(module integer-set mzscheme
(require (lib "list.ss")
(require (all-except (lib "list.ss") merge)
(lib "contract.ss"))
#;(define-syntax test-block

204
collects/mzlib/list.ss
View File

@ -3,42 +3,150 @@
(require "spidey.ss")
(provide set-first!
first
second
third
fourth
fifth
sixth
seventh
eighth
first
second
third
fourth
fifth
sixth
seventh
eighth
set-rest!
rest
set-rest!
rest
cons?
empty
empty?
cons?
empty
empty?
foldl
foldr
foldl
foldr
last-pair
last-pair
remv
remq
remove
remv*
remq*
remove*
remv
remq
remove
remv*
remq*
remove*
assf
memf
assf
memf
filter
quicksort
mergesort)
filter
quicksort
mergesort
sort
sort!
merge
merge!)
;; used by sort-internal, but can be useful by itself
(define (merge! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)))))
(cond [(null? a) b]
[(null? b) a]
[(less? (car b) (car a))
(if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b)))
b]
[else ; (car a) <= (car b)
(if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b))
a]))
;; a non-destructive version for symmetry with merge!
(define (merge a b less?)
(cond [(null? a) b]
[(null? b) a]
[else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)])
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(list* y x a)
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(list* x y b)
(cons x (loop (car a) (cdr a) y b)))))]))
;; This is a destructive stable merge-sort, adapted from slib and improved by
;; Eli Barzilay
;; The original source said:
;; It uses a version of merge-sort invented, to the best of my knowledge,
;; by David H. D. Warren, and first used in the DEC-10 Prolog system.
;; R. A. O'Keefe adapted it to work destructively in Scheme.
;; but it's a plain destructive merge sort.
(define (sort-internal lst less? copy? who)
(define (step n)
(cond [(> n 3) (let* (; let* not really needed with mzscheme's l->r eval
[j (quotient n 2)] [a (step j)] [b (step (- n j))])
(merge! a b less?))]
;; the following two cases are just explicit treatment of sublists
;; of length 2 and 3, could remove both (and use the above case for
;; n>1) and it would still work, except a little slower
[(= n 3) (let ([p lst] [p1 (cdr lst)] [p2 (cddr lst)])
(let ([x (car p)] [y (car p1)] [z (car p2)])
(set! lst (cdr p2))
(cond [(less? y x) ; y x
(cond [(less? z y) ; z y x
(set-car! p z)
(set-car! p1 y)
(set-car! p2 x)]
[(less? z x) ; y z x
(set-car! p y)
(set-car! p1 z)
(set-car! p2 x)]
[else ; y x z
(set-car! p y)
(set-car! p1 x)])]
[(less? z x) ; z x y
(set-car! p z)
(set-car! p1 x)
(set-car! p2 y)]
[(less? z y) ; x z y
(set-car! p1 z)
(set-car! p2 y)])
(set-cdr! p2 '())
p))]
[(= n 2) (let ([x (car lst)] [y (cadr lst)] [p lst])
(set! lst (cddr lst))
(when (less? y x) (set-car! p y) (set-car! (cdr p) x))
(set-cdr! (cdr p) '())
p)]
[(= n 1) (let ([p lst])
(set! lst (cdr lst))
(set-cdr! p '())
p)]
[else '()]))
(unless (list? lst)
(raise-type-error who "proper list" lst))
(unless (procedure-arity-includes? less? 2)
(raise-type-error who "procedure of arity 2" less?))
(let ([n (length lst)])
(cond [(<= n 1) lst]
;; check if the list is already sorted
;; (which can be a common case, eg, directory lists).
[(let loop ([last (car lst)] [next (cdr lst)])
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next)))))
lst]
[else (when copy? (set! lst (append lst '())))
(step n)])))
(define (sort! lst less?)
(sort-internal lst less? #f 'sort!))
(define (sort lst less?)
(sort-internal lst less? #t 'sort))
;; deprecated!
(define quicksort
(polymorphic
(lambda (l less-than)
@ -68,34 +176,8 @@
(loop pivot max))))))))
(vector->list v)))))
(define mergesort
(polymorphic
(lambda (alox less-than)
(letrec ([split (lambda (alox r)
(cond
[(null? alox) r]
[(null? (cdr alox)) (cons alox r)]
[else (split (cdr alox) (cons (list (car alox)) r))]))]
[merge (lambda (l1 l2 r)
(cond
[(null? l1) (append! (reverse! r) l2)]
[(null? l2) (append! (reverse! r) l1)]
[(less-than (car l1) (car l2))
(merge (cdr l1) l2 (cons (car l1) r))]
[else (merge (cdr l2) l1 (cons (car l2) r))]))]
[map2 (lambda (l)
(cond
[(null? l) '()]
[(null? (cdr l)) l]
[else (cons (merge (car l) (cadr l) null)
(map2 (cddr l)))]))]
[until (lambda (l)
(if (null? (cdr l))
(car l)
(until (map2 l))))])
(if (null? alox)
null
(until (split alox null)))))))
;; deprecated!
(define mergesort sort)
(define remove
(polymorphic
@ -109,17 +191,17 @@
[else (cons (car list)
(loop (cdr list)))]))])])
rm)))
(define remq
(polymorphic
(lambda (item list)
(remove item list eq?))))
(define remv
(polymorphic
(lambda (item list)
(remove item list eqv?))))
(define remove*
(polymorphic
(case-lambda
@ -133,7 +215,7 @@
[(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)]
[else (loop (cdr l-rest))])))])]
[(l r) (remove* l r equal?)])))
(define remq*
(polymorphic
(lambda (l r)

11
collects/profj/types.ss
View File

@ -8,7 +8,7 @@
(lib "class.ss")
"ast.ss")
(provide (all-defined-except sort number-assign-conversions remove-dups meth-member?
(provide (all-defined-except number-assign-conversions remove-dups meth-member?
generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
@ -616,10 +616,6 @@
(method-record-atypes (car methods)))
(meth-member? meth (cdr methods)))))
;sort: (list number) -> (list number)
(define (sort l)
(quicksort l (lambda (i1 i2) (< (car i1) (car i2)))))
;number-assign-conversion: (list type) (list type) type-records -> int
(define (number-assign-conversions site-args method-args type-recs)
(cond
@ -641,11 +637,12 @@
(assignable (filter (lambda (mr)
(andmap a-convert? (m-atypes mr) arg-types))
methods))
(assignable-count (sort
(assignable-count (sort
(map (lambda (mr)
(list (number-assign-conversions arg-types (m-atypes mr) type-recs)
mr))
assignable))))
assignable)
(lambda (i1 i2) (< (car i1) (car i2))))))
(cond
((null? methods) (arg-count-fail))
((= 1 (length methods-same)) (car methods-same))

124
collects/swindle/misc.ss
View File

@ -1882,128 +1882,4 @@
[(_ str clause ...)
#`(let ([s str]) (cond #,@(do-clauses #'(clause ...))))]))
;; ----------------------------------------------------------------------------
;; Taken from slib (faster than then quicksort and mergesort in list.ss).
;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;>>... Sorting
;;> The following section defines functions for sorting. They are taken
;;> directly from slib since they are more convenient and faster than the
;;> functions in mzlib/list. See the source for more details.
;;>> (sorted? sequence less?)
;;> True when `sequence' is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;> such that its elements are sorted according to `less?':
;;> (not (less? (list-ref list i) (list-ref list (- i 1)))).
(define* (sorted? seq less?)
(cond [(null? seq) #t]
[(vector? seq)
(let ([n (vector-length seq)])
(if (<= n 1)
#t
(do ([i 1 (+ i 1)])
[(or (= i n)
(less? (vector-ref seq i) (vector-ref seq (- i 1))))
(= i n)])))]
[else
(let loop ([last (car seq)] [next (cdr seq)])
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next)))))]))
;;>> (merge a b less?)
;;> Takes two lists `a' and `b' such that both (sorted? a less?) and
;;> (sorted? b less?) are true, and returns a new list in which the
;;> elements of `a' and `b' have been stably interleaved so that (sorted?
;;> (merge a b less?) less?) is true. Note: this does not accept vectors.
(define* (merge a b less?)
(cond [(null? a) b]
[(null? b) a]
[else (let loop ([x (car a)] [a (cdr a)] [y (car b)] [b (cdr b)])
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b)))))]))
;;>> (merge! a b less?)
;;> Takes two sorted lists `a' and `b' and smashes their cdr fields to
;;> form a single sorted list including the elements of both. Note: this
;;> does not accept vectors.
(define* (merge! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)))))
(cond [(null? a) b]
[(null? b) a]
[(less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b]
[else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a]))
;;>> (sort! sequence less?)
;;> Sorts the list or vector `sequence' destructively.
;; It uses a version of merge-sort invented, to the best of my knowledge, by
;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;; R. A. O'Keefe adapted it to work destructively in Scheme.
(define* (sort! seq less?)
(define (step n)
(cond [(> n 2) (let* ([j (quotient n 2)]
[a (step j)]
[k (- n j)]
[b (step k)])
(merge! a b less?))]
[(= n 2) (let ([x (car seq)]
[y (cadr seq)]
[p seq])
(set! seq (cddr seq))
(when (less? y x)
(set-car! p y) (set-car! (cdr p) x))
(set-cdr! (cdr p) '())
p)]
[(= n 1) (let ([p seq])
(set! seq (cdr seq))
(set-cdr! p '())
p)]
[else '()]))
(if (vector? seq)
(let ([n (vector-length seq)] [vec seq])
(set! seq (vector->list seq))
(do ([p (step n) (cdr p)] [i 0 (+ i 1)])
[(null? p) vec]
(vector-set! vec i (car p))))
;; otherwise, assume it is a list
(step (length seq))))
;;>> (sort sequence less?)
;;> Sorts a vector or list non-destructively. It does this by sorting a
;;> copy of the sequence.
;; My understanding is that the Standard says that the result of append is
;; always "newly allocated" except for sharing structure with "the last
;; argument", so (append x '()) ought to be a standard way of copying a list x.
(define* (sort seq less?)
(if (vector? seq)
(list->vector (sort! (vector->list seq) less?))
(sort! (append seq '()) less?)))
)