From a106cbecbe8dcf5dc5a36cd28c7572f50ff9592b Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 20 May 2010 13:25:59 -0400 Subject: [PATCH 1/3] bug in read-words/line fixed, please propagate --- collects/2htdp/batch-io.rkt | 5 +- collects/racket/list.rkt | 358 ------------------ .../2htdp/scribblings/batch-io.scrbl | 1 + collects/teachpack/2htdp/scribblings/data.txt | 1 + 4 files changed, 4 insertions(+), 361 deletions(-) delete mode 100644 collects/racket/list.rkt diff --git a/collects/2htdp/batch-io.rkt b/collects/2htdp/batch-io.rkt index bc68ec9903..90a8c5f3a3 100644 --- a/collects/2htdp/batch-io.rkt +++ b/collects/2htdp/batch-io.rkt @@ -77,7 +77,7 @@ (define lines (read-chunks f read-line (lambda (x) x))) (foldl (lambda (f r) (define fst (filter (compose not (curry string=? "")) (split f))) - (if (empty? fst) r (combine fst r))) + (combine fst r)) '() lines)) (def-reader (read-csv-file f) @@ -93,10 +93,9 @@ (define-syntax (simulate-file stx) (syntax-case stx () [(simulate-file) - (raise-syntax-error #f "expects a reader function as first argument" stx)] + (raise-syntax-error #f "expects at least one sub-expression" stx)] [(simulate-file reader str ...) #'(simulate-file/proc (f2h reader) str ...)])) - (define (simulate-file/proc reader . los) (define _1 (check-proc "simulate-file" reader 1 "reader" "one argument")) (define _2 diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt deleted file mode 100644 index 64ee2bae0c..0000000000 --- a/collects/racket/list.rkt +++ /dev/null @@ -1,358 +0,0 @@ -#lang scheme/base - -(provide first second third fourth fifth sixth seventh eighth ninth tenth - - last-pair last rest - - cons? - empty - empty? - - make-list - - drop - take - split-at - drop-right - take-right - split-at-right - - append* - flatten - add-between - remove-duplicates - filter-map - count - partition - - argmin - argmax - - ;; 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 (make-list n x) - (unless (exact-nonnegative-integer? n) - (raise-type-error 'make-list "non-negative exact integer" n)) - (let loop ([n n] [r '()]) - (if (zero? n) r (loop (sub1 n) (cons x r))))) - -;; internal use below -(define (drop* list n) ; no error checking, returns #f if index is too large - (if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n))))) -(define (too-large who list n) - (raise-mismatch-error - who - (format "index ~e too large for list~a: " - n (if (list? list) "" " (not a proper list)")) - list)) - -(define (take list0 n0) - (unless (exact-nonnegative-integer? n0) - (raise-type-error 'take "non-negative exact integer" n0)) - (let loop ([list list0] [n n0]) - (cond [(zero? n) '()] - [(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))] - [else (too-large 'take list0 n0)]))) - -(define (drop list n) - ;; could be defined as `list-tail', but this is better for errors anyway - (unless (exact-nonnegative-integer? n) - (raise-type-error 'drop "non-negative exact integer" n)) - (or (drop* list n) (too-large 'drop list n))) - -(define (split-at list0 n0) - (unless (exact-nonnegative-integer? n0) - (raise-type-error 'split-at "non-negative exact integer" n0)) - (let loop ([list list0] [n n0] [pfx '()]) - (cond [(zero? n) (values (reverse pfx) list)] - [(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))] - [else (too-large 'take list0 n0)]))) - -;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick - -(define (take-right list n) - (unless (exact-nonnegative-integer? n) - (raise-type-error 'take-right "non-negative exact integer" n)) - (let loop ([list list] - [lead (or (drop* list n) (too-large 'take-right list n))]) - ;; could throw an error for non-lists, but be more like `take' - (if (pair? lead) - (loop (cdr list) (cdr lead)) - list))) - -(define (drop-right list n) - (unless (exact-nonnegative-integer? n) - (raise-type-error 'drop-right "non-negative exact integer" n)) - (let loop ([list list] - [lead (or (drop* list n) (too-large 'drop-right list n))]) - ;; could throw an error for non-lists, but be more like `drop' - (if (pair? lead) - (cons (car list) (loop (cdr list) (cdr lead))) - '()))) - -(define (split-at-right list n) - (unless (exact-nonnegative-integer? n) - (raise-type-error 'split-at-right "non-negative exact integer" n)) - (let loop ([list list] - [lead (or (drop* list n) (too-large 'split-at-right list n))] - [pfx '()]) - ;; could throw an error for non-lists, but be more like `split-at' - (if (pair? lead) - (loop (cdr list) (cdr lead) (cons (car list) pfx)) - (values (reverse pfx) list)))) - -(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?] #:key [key #f]) - ;; `no-key' is used to optimize the case for long lists, it could be done for - ;; shorter ones too, but that adds a ton of code to the result (about 2k). - (define-syntax-rule (no-key x) x) - (unless (list? l) (raise-type-error 'remove-duplicates "list" l)) - (let* ([len (length l)] - [h (cond [(<= len 1) #t] - [(<= len 40) #f] - [(eq? =? eq?) (make-hasheq)] - [(eq? =? equal?) (make-hash)] - [else #f])]) - (case h - [(#t) l] - [(#f) - ;; plain n^2 list traversal (optimized for common cases) for short lists - ;; and for equalities other than `eq?' or `equal?' The length threshold - ;; above (40) was determined by trying it out with lists of length n - ;; holding (random n) numbers. - (let ([key (or key (lambda (x) x))]) - (let-syntax ([loop (syntax-rules () - [(_ search) - (let loop ([l l] [seen null]) - (if (null? l) - l - (let* ([x (car l)] [k (key x)] [l (cdr l)]) - (if (search k seen) - (loop l seen) - (cons x (loop l (cons k 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)))])))] - [else - ;; Use a hash for long lists with simple hash tables. - (let-syntax ([loop - (syntax-rules () - [(_ getkey) - (let loop ([l l]) - (if (null? l) - l - (let* ([x (car l)] [k (getkey x)] [l (cdr l)]) - (if (hash-ref h k #f) - (loop l) - (begin (hash-set! h k #t) - (cons x (loop l)))))))])]) - (if key (loop key) (loop no-key)))]))) - -(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)))))))) - -;; very similar to `filter-map', one more such function will justify some macro -(define (count f l . ls) - (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls)))) - (raise-type-error - 'count (format "procedure (arity ~a)" (add1 (length ls))) f)) - (unless (and (list? l) (andmap list? ls)) - (raise-type-error - 'count "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] [c 0]) - (if (null? l) - c - (loop (cdr l) (map cdr ls) - (if (apply f (car l) (map car ls)) (add1 c) c)))) - (error 'count "all lists must have same size"))) - (let loop ([l l] [c 0]) - (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c)))))) - -;; 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 packaging -(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)))))) - - -;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X -(define (mk-min cmp name f xs) - (unless (and (procedure? f) - (procedure-arity-includes? f 1)) - (raise-type-error name "procedure (arity 1)" f)) - (unless (and (list? xs) - (pair? xs)) - (raise-type-error name "non-empty list" xs)) - (let ([init-min-var (f (car xs))]) - (unless (real? init-min-var) - (raise-type-error name "procedure that returns real numbers" f)) - (let loop ([min (car xs)] - [min-var init-min-var] - [xs (cdr xs)]) - (cond - [(null? xs) min] - [else - (let ([new-min (f (car xs))]) - (unless (real? new-min) - (raise-type-error name "procedure that returns real numbers" f)) - (cond - [(cmp new-min min-var) - (loop (car xs) new-min (cdr xs))] - [else - (loop min min-var (cdr xs))]))])))) - -(define (argmin f xs) (mk-min < 'argmin f xs)) -(define (argmax f xs) (mk-min > 'argmax f xs)) diff --git a/collects/teachpack/2htdp/scribblings/batch-io.scrbl b/collects/teachpack/2htdp/scribblings/batch-io.scrbl index 8530ce1833..9563d0ab17 100644 --- a/collects/teachpack/2htdp/scribblings/batch-io.scrbl +++ b/collects/teachpack/2htdp/scribblings/batch-io.scrbl @@ -93,6 +93,7 @@ a part of the separator that surrounds the word @scheme["good"]. ] The results is similar to the one that @scheme[read-words] produces, except that the organization of the file into lines is preserved. +In particular, the empty third line is represented as an empty list of words. } @item{@reading[read-csv-file (listof (listof any/c))]{a list of lists of comma-separated values} diff --git a/collects/teachpack/2htdp/scribblings/data.txt b/collects/teachpack/2htdp/scribblings/data.txt index dda98f1b07..f9f384494e 100644 --- a/collects/teachpack/2htdp/scribblings/data.txt +++ b/collects/teachpack/2htdp/scribblings/data.txt @@ -1,3 +1,4 @@ hello world good bye + i am done From 70089070c7e8281b7a99e53322f0b184e83d525f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 May 2010 12:01:48 -0600 Subject: [PATCH 2/3] clarify that 'exec-file is not necessarily an absolute path --- collects/scribblings/reference/filesystem.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index ce08fc185a..a8cf6efa27 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -111,7 +111,7 @@ by @racket[kind], which must be one of the following: @item{@indexed-racket['exec-file] --- the path of the Racket executable as provided by the operating system for the current - invocation. + invocation. For some operating systems, the path can be relative. @margin-note{For GRacket, the executable path is the name of a GRacket executable.}} From 458b9364bdd326f81b02f14f660bb66c23a3a3be Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 May 2010 12:02:26 -0600 Subject: [PATCH 3/3] restore racket/list --- collects/racket/list.rkt | 358 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 358 insertions(+) create mode 100644 collects/racket/list.rkt diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt new file mode 100644 index 0000000000..64ee2bae0c --- /dev/null +++ b/collects/racket/list.rkt @@ -0,0 +1,358 @@ +#lang scheme/base + +(provide first second third fourth fifth sixth seventh eighth ninth tenth + + last-pair last rest + + cons? + empty + empty? + + make-list + + drop + take + split-at + drop-right + take-right + split-at-right + + append* + flatten + add-between + remove-duplicates + filter-map + count + partition + + argmin + argmax + + ;; 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 (make-list n x) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'make-list "non-negative exact integer" n)) + (let loop ([n n] [r '()]) + (if (zero? n) r (loop (sub1 n) (cons x r))))) + +;; internal use below +(define (drop* list n) ; no error checking, returns #f if index is too large + (if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n))))) +(define (too-large who list n) + (raise-mismatch-error + who + (format "index ~e too large for list~a: " + n (if (list? list) "" " (not a proper list)")) + list)) + +(define (take list0 n0) + (unless (exact-nonnegative-integer? n0) + (raise-type-error 'take "non-negative exact integer" n0)) + (let loop ([list list0] [n n0]) + (cond [(zero? n) '()] + [(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))] + [else (too-large 'take list0 n0)]))) + +(define (drop list n) + ;; could be defined as `list-tail', but this is better for errors anyway + (unless (exact-nonnegative-integer? n) + (raise-type-error 'drop "non-negative exact integer" n)) + (or (drop* list n) (too-large 'drop list n))) + +(define (split-at list0 n0) + (unless (exact-nonnegative-integer? n0) + (raise-type-error 'split-at "non-negative exact integer" n0)) + (let loop ([list list0] [n n0] [pfx '()]) + (cond [(zero? n) (values (reverse pfx) list)] + [(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))] + [else (too-large 'take list0 n0)]))) + +;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick + +(define (take-right list n) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'take-right "non-negative exact integer" n)) + (let loop ([list list] + [lead (or (drop* list n) (too-large 'take-right list n))]) + ;; could throw an error for non-lists, but be more like `take' + (if (pair? lead) + (loop (cdr list) (cdr lead)) + list))) + +(define (drop-right list n) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'drop-right "non-negative exact integer" n)) + (let loop ([list list] + [lead (or (drop* list n) (too-large 'drop-right list n))]) + ;; could throw an error for non-lists, but be more like `drop' + (if (pair? lead) + (cons (car list) (loop (cdr list) (cdr lead))) + '()))) + +(define (split-at-right list n) + (unless (exact-nonnegative-integer? n) + (raise-type-error 'split-at-right "non-negative exact integer" n)) + (let loop ([list list] + [lead (or (drop* list n) (too-large 'split-at-right list n))] + [pfx '()]) + ;; could throw an error for non-lists, but be more like `split-at' + (if (pair? lead) + (loop (cdr list) (cdr lead) (cons (car list) pfx)) + (values (reverse pfx) list)))) + +(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?] #:key [key #f]) + ;; `no-key' is used to optimize the case for long lists, it could be done for + ;; shorter ones too, but that adds a ton of code to the result (about 2k). + (define-syntax-rule (no-key x) x) + (unless (list? l) (raise-type-error 'remove-duplicates "list" l)) + (let* ([len (length l)] + [h (cond [(<= len 1) #t] + [(<= len 40) #f] + [(eq? =? eq?) (make-hasheq)] + [(eq? =? equal?) (make-hash)] + [else #f])]) + (case h + [(#t) l] + [(#f) + ;; plain n^2 list traversal (optimized for common cases) for short lists + ;; and for equalities other than `eq?' or `equal?' The length threshold + ;; above (40) was determined by trying it out with lists of length n + ;; holding (random n) numbers. + (let ([key (or key (lambda (x) x))]) + (let-syntax ([loop (syntax-rules () + [(_ search) + (let loop ([l l] [seen null]) + (if (null? l) + l + (let* ([x (car l)] [k (key x)] [l (cdr l)]) + (if (search k seen) + (loop l seen) + (cons x (loop l (cons k 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)))])))] + [else + ;; Use a hash for long lists with simple hash tables. + (let-syntax ([loop + (syntax-rules () + [(_ getkey) + (let loop ([l l]) + (if (null? l) + l + (let* ([x (car l)] [k (getkey x)] [l (cdr l)]) + (if (hash-ref h k #f) + (loop l) + (begin (hash-set! h k #t) + (cons x (loop l)))))))])]) + (if key (loop key) (loop no-key)))]))) + +(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)))))))) + +;; very similar to `filter-map', one more such function will justify some macro +(define (count f l . ls) + (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls)))) + (raise-type-error + 'count (format "procedure (arity ~a)" (add1 (length ls))) f)) + (unless (and (list? l) (andmap list? ls)) + (raise-type-error + 'count "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] [c 0]) + (if (null? l) + c + (loop (cdr l) (map cdr ls) + (if (apply f (car l) (map car ls)) (add1 c) c)))) + (error 'count "all lists must have same size"))) + (let loop ([l l] [c 0]) + (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c)))))) + +;; 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 packaging +(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)))))) + + +;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X +(define (mk-min cmp name f xs) + (unless (and (procedure? f) + (procedure-arity-includes? f 1)) + (raise-type-error name "procedure (arity 1)" f)) + (unless (and (list? xs) + (pair? xs)) + (raise-type-error name "non-empty list" xs)) + (let ([init-min-var (f (car xs))]) + (unless (real? init-min-var) + (raise-type-error name "procedure that returns real numbers" f)) + (let loop ([min (car xs)] + [min-var init-min-var] + [xs (cdr xs)]) + (cond + [(null? xs) min] + [else + (let ([new-min (f (car xs))]) + (unless (real? new-min) + (raise-type-error name "procedure that returns real numbers" f)) + (cond + [(cmp new-min min-var) + (loop (car xs) new-min (cdr xs))] + [else + (loop min min-var (cdr xs))]))])))) + +(define (argmin f xs) (mk-min < 'argmin f xs)) +(define (argmax f xs) (mk-min > 'argmax f xs))