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

.

Browse Source 
original commit: 47a29e2d3e6382f738c8e3069d212d513cc1fe98
This commit is contained in:
Matthew Flatt 2000-03-20 16:57:59 +00:00
parent 5de0333c3d
commit b593a9112b
1 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/mred/wrap/mred.ss
View File

@ -4686,26 +4686,27 @@
(let ([l (with-handlers ([void (lambda (x) null)])
(directory-list dir))]
[dot? (send dot-check get-value)])
(letrec ([sort (lambda (l)
(if (or (null? l) (null? (cdr l)))
l
(let-values ([(l1 l2) (split l null null)])
(merge (sort l1) (sort l2)))))]
[split (lambda (l l1 l2)
(cond
[(null? l) (values l1 l2)]
[(null? (cdr l)) (values (cons (car l) l1) l2)]
[else (split (cddr l) (cons (car l) l1) (cons (cadr l) l2))]))]
(letrec ([split (lambda (n l)
(if (null? l)
'(() . ())
(if (< n 1)
(cons (list (car l)) (cdr l))
(let ([n (quotient n 2)])
(let* ([r1 (split n l)]
[r2 (split n (cdr r1))])
(cons (merge (car r1) (car r2)) (cdr r2)))))))]
[merge (lambda (l1 l2)
(cond
[(null? l1) l2]
[(null? l2) l1]
[(string<? (car l1) (car l2)) (cons (car l1) (merge (cdr l1) l2))]
[else (merge l2 l1)]))])
[(string<? (car l1) (car l2))
(cons (car l1) (merge (cdr l1) l2))]
[else (cons (car l2) (merge (cdr l2) l1))]))]
[sort (lambda (l) (car (split (length l) l)))])
(let-values ([(ds fs)
(let loop ([l l][ds null][fs null])
(cond
[(null? l) (values (cons ".." (sort (reverse! ds))) (sort (reverse! fs)))]
[(null? l) (values (cons ".." (sort ds)) (sort fs))]
[(and (not dot?) (char=? (string-ref (car l) 0) #\.)) (loop (cdr l) ds fs)]
[(file-exists? (build-path dir (car l))) (loop (cdr l) ds (cons (car l) fs))]
[else (loop (cdr l) (cons (car l) ds) fs)]))])