227 lines
7.7 KiB
Scheme
227 lines
7.7 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide first second third fourth fifth sixth seventh eighth ninth tenth
|
|
|
|
last-pair last rest
|
|
|
|
cons?
|
|
empty
|
|
empty?
|
|
|
|
drop
|
|
take
|
|
|
|
append*
|
|
flatten
|
|
add-between
|
|
remove-duplicates
|
|
filter-map
|
|
partition
|
|
|
|
;; convenience
|
|
append-map
|
|
filter-not)
|
|
|
|
(define (first x)
|
|
(if (and (pair? x) (list? x))
|
|
(car x)
|
|
(raise-type-error 'first "non-empty list" x)))
|
|
|
|
(define-syntax define-lgetter
|
|
(syntax-rules ()
|
|
[(_ name npos)
|
|
(define (name l0)
|
|
(if (list? l0)
|
|
(let loop ([l l0] [pos npos])
|
|
(if (pair? l)
|
|
(if (eq? pos 1) (car l) (loop (cdr l) (sub1 pos)))
|
|
(raise-type-error
|
|
'name (format "list with ~a or more items" npos) l0)))
|
|
(raise-type-error 'name "list" l0)))]))
|
|
(define-lgetter second 2)
|
|
(define-lgetter third 3)
|
|
(define-lgetter fourth 4)
|
|
(define-lgetter fifth 5)
|
|
(define-lgetter sixth 6)
|
|
(define-lgetter seventh 7)
|
|
(define-lgetter eighth 8)
|
|
(define-lgetter ninth 9)
|
|
(define-lgetter tenth 10)
|
|
|
|
(define (last-pair l)
|
|
(if (pair? l)
|
|
(let loop ([l l] [x (cdr l)])
|
|
(if (pair? x)
|
|
(loop x (cdr x))
|
|
l))
|
|
(raise-type-error 'last-pair "pair" l)))
|
|
|
|
(define (last l)
|
|
(if (and (pair? l) (list? l))
|
|
(let loop ([l l] [x (cdr l)])
|
|
(if (pair? x)
|
|
(loop x (cdr x))
|
|
(car l)))
|
|
(raise-type-error 'last "non-empty list" l)))
|
|
|
|
(define (rest l)
|
|
(if (and (pair? l) (list? l))
|
|
(cdr l)
|
|
(raise-type-error 'rest "non-empty list" l)))
|
|
|
|
(define cons? (lambda (l) (pair? l)))
|
|
(define empty? (lambda (l) (null? l)))
|
|
(define empty '())
|
|
|
|
(define drop list-tail)
|
|
(define (take list0 n0)
|
|
(unless (and (integer? n0) (exact? n0))
|
|
(raise-type-error 'take "non-negative integer" n0))
|
|
(let loop ([list list0] [n n0])
|
|
(cond [(zero? n) '()]
|
|
[(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))]
|
|
[else (raise-mismatch-error
|
|
'take
|
|
(format "index ~e too large for list~a: ~e"
|
|
n0
|
|
(if (list? list) "" " (not a proper list)")
|
|
list0)
|
|
n0)])))
|
|
|
|
(define append*
|
|
(case-lambda [(ls) (apply append ls)] ; optimize common case
|
|
[(l . lss) (apply append (apply list* l lss))]))
|
|
|
|
(define (flatten orig-sexp)
|
|
(let loop ([sexp orig-sexp] [acc null])
|
|
(cond [(null? sexp) acc]
|
|
[(pair? sexp) (loop (car sexp) (loop (cdr sexp) acc))]
|
|
[else (cons sexp acc)])))
|
|
|
|
;; General note: many non-tail recursive, which are just as fast in mzscheme
|
|
|
|
(define (add-between l x)
|
|
(cond [(not (list? l)) (raise-type-error 'add-between "list" l)]
|
|
[(null? l) null]
|
|
[(null? (cdr l)) l]
|
|
[else (cons (car l)
|
|
(let loop ([l (cdr l)])
|
|
(if (null? l)
|
|
null
|
|
(list* x (car l) (loop (cdr l))))))]))
|
|
|
|
;; This is nice for symmetry, but confusing to use, and we can get it using
|
|
;; something like (append* (add-between l ls)), or even `flatten' for an
|
|
;; arbitrary nesting.
|
|
;; (define (lists-join ls l)
|
|
;; (cond [(null? ls) ls]
|
|
;; [(null? l) ls] ; empty separator
|
|
;; [else (append (car ls)
|
|
;; (let loop ([ls (cdr ls)])
|
|
;; (if (null? ls)
|
|
;; ls
|
|
;; (append l (car ls) (loop (cdr ls))))))]))
|
|
|
|
(define (remove-duplicates l [=? equal?])
|
|
(unless (list? l) (raise-type-error 'remove-duplicates "list" l))
|
|
(let ([h (cond [(< (length l) 40) #f]
|
|
[(eq? =? eq?) (make-hasheq)]
|
|
[(eq? =? equal?) (make-hash)]
|
|
[else #f])])
|
|
(if h
|
|
;; Using a hash table when the list is long enough and a using `equal?'
|
|
;; or `eq?'. The length threshold (40) was determined by trying it out
|
|
;; with lists of length n holding (random n) numbers.
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
l
|
|
(let ([x (car l)] [l (cdr l)])
|
|
(if (hash-ref h x #f)
|
|
(loop l)
|
|
(begin (hash-set! h x #t) (cons x (loop l)))))))
|
|
;; plain n^2 list traversal (optimized for common cases)
|
|
(let-syntax ([loop (syntax-rules ()
|
|
[(_ search)
|
|
(let loop ([l l] [seen null])
|
|
(if (null? l)
|
|
l
|
|
(let ([x (car l)] [l (cdr l)])
|
|
(if (search x seen)
|
|
(loop l seen)
|
|
(cons x (loop l (cons x seen)))))))])])
|
|
(cond [(eq? =? equal?) (loop member)]
|
|
[(eq? =? eq?) (loop memq)]
|
|
[(eq? =? eqv?) (loop memv)]
|
|
[else (loop (lambda (x seen)
|
|
(ormap (lambda (y) (=? x y)) seen)))])))))
|
|
|
|
(define (filter-map f l . ls)
|
|
(unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
|
|
(raise-type-error
|
|
'filter-map (format "procedure (arity ~a)" (add1 (length ls))) f))
|
|
(unless (and (list? l) (andmap list? ls))
|
|
(raise-type-error
|
|
'filter-map "proper list"
|
|
(ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
|
|
(if (pair? ls)
|
|
(let ([len (length l)])
|
|
(if (andmap (lambda (l) (= len (length l))) ls)
|
|
(let loop ([l l] [ls ls])
|
|
(if (null? l)
|
|
null
|
|
(let ([x (apply f (car l) (map car ls))])
|
|
(if x
|
|
(cons x (loop (cdr l) (map cdr ls)))
|
|
(loop (cdr l) (map cdr ls))))))
|
|
(error 'filter-map "all lists must have same size")))
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
null
|
|
(let ([x (f (car l))])
|
|
(if x (cons x (loop (cdr l))) (loop (cdr l))))))))
|
|
|
|
;; Originally from srfi-1 -- shares common tail with the input when possible
|
|
;; (define (partition f l)
|
|
;; (unless (and (procedure? f) (procedure-arity-includes? f 1))
|
|
;; (raise-type-error 'partition "procedure (arity 1)" f))
|
|
;; (unless (list? l) (raise-type-error 'partition "proper list" l))
|
|
;; (let loop ([l l])
|
|
;; (if (null? l)
|
|
;; (values null null)
|
|
;; (let* ([x (car l)] [x? (f x)])
|
|
;; (let-values ([(in out) (loop (cdr l))])
|
|
;; (if x?
|
|
;; (values (if (pair? out) (cons x in) l) out)
|
|
;; (values in (if (pair? in) (cons x out) l))))))))
|
|
|
|
;; But that one is slower than this, probably due to value packages
|
|
(define (partition pred l)
|
|
(unless (and (procedure? pred) (procedure-arity-includes? pred 1))
|
|
(raise-type-error 'partition "procedure (arity 1)" pred))
|
|
(unless (list? l) (raise-type-error 'partition "proper list" l))
|
|
(let loop ([l l] [i '()] [o '()])
|
|
(if (null? l)
|
|
(values (reverse i) (reverse o))
|
|
(let ([x (car l)] [l (cdr l)])
|
|
(if (pred x) (loop l (cons x i) o) (loop l i (cons x o)))))))
|
|
|
|
(define append-map
|
|
(case-lambda [(f l) (apply append (map f l))]
|
|
[(f l1 l2) (apply append (map f l1 l2))]
|
|
[(f l . ls) (apply append (apply map f l ls))]))
|
|
|
|
;; this is an exact copy of `filter' in scheme/private/list, with the
|
|
;; `if' branches swapped.
|
|
(define (filter-not f list)
|
|
(unless (and (procedure? f)
|
|
(procedure-arity-includes? f 1))
|
|
(raise-type-error 'filter-not "procedure (arity 1)" f))
|
|
(unless (list? list)
|
|
(raise-type-error 'filter-not "proper list" list))
|
|
;; accumulating the result and reversing it is currently slightly
|
|
;; faster than a plain loop
|
|
(let loop ([l list] [result null])
|
|
(if (null? l)
|
|
(reverse result)
|
|
(loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
|