diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index d6c4aac2b4..6fdd3c5100 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -1,7 +1,7 @@ (module intermediate-funs scheme/base (require "teachprims.ss" mzlib/etc - mzlib/list + scheme/list syntax/docprovide (for-syntax scheme/base)) @@ -33,6 +33,12 @@ (ormap ((X -> boolean) (listof X) -> boolean) "(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))") + (argmin ((X -> real) (listof X) -> X) + "to find the (first) element of the list that minimizes the output of the function") + + (argmax ((X -> real) (listof X) -> X) + "to find the (first) element of the list that minimizes the output of the function") + (memf ((X -> boolean) (listof X) -> (union false (listof X))) "to determine whether the first argument produces true for some value in the second argument") (apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index 550faf8f3b..430b7bafd1 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -22,6 +22,9 @@ filter-map partition + argmin + argmax + ;; convenience append-map filter-not) @@ -278,3 +281,33 @@ (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/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index acdd768839..bda29a70ea 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -672,6 +672,28 @@ returns @scheme[#f]. (filter-not even? '(1 2 3 4 5 6)) ]} +@defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ + +This returns the first element in the list @scheme[lst] that minimizes +the result of @scheme[proc]. + +@mz-examples[#:eval list-eval +(argmin car '((3 pears) (1 banana) (2 apples))) +(argmin car '((1 banana) (1 orange))) +] +} + +@defproc[(argmax [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ + +This returns the first element in the list @scheme[lst] that maximizes +the result of @scheme[proc]. + +@mz-examples[#:eval list-eval +(argmax car '((3 pears) (1 banana) (2 apples))) +(argmax car '((3 pears) (3 oranges))) +] +} + @close-eval[list-eval] @; ---------------------------------------- diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 6938d9a641..ad9152bc63 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -270,6 +270,61 @@ (test '(1 2 3) am list '(1 2 3)) (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3))) +;; ---------- argmin & argmax ---------- + +(let () + + (define ((check-regs . regexps) exn) + (and (exn:fail? exn) + (andmap (λ (reg) (regexp-match reg (exn-message exn))) + regexps))) + + (test 'argmin object-name argmin) + (test 1 argmin (lambda (x) 0) (list 1)) + (test 1 argmin (lambda (x) x) (list 1 2 3)) + (test 1 argmin (lambda (x) 1) (list 1 2 3)) + + (test 3 + 'argmin-makes-right-number-of-calls + (let ([c 0]) + (argmin (lambda (x) (set! c (+ c 1)) 0) + (list 1 2 3)) + c)) + + (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples))) + + (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure")) + (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list")) + (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + + (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) + (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list")) + + (test 'argmax object-name argmax) + (test 1 argmax (lambda (x) 0) (list 1)) + (test 3 argmax (lambda (x) x) (list 1 2 3)) + (test 1 argmax (lambda (x) 1) (list 1 2 3)) + + (test 3 + 'argmax-makes-right-number-of-calls + (let ([c 0]) + (argmax (lambda (x) (set! c (+ c 1)) 0) + (list 1 2 3)) + c)) + + (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples))) + + (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure")) + (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list")) + (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + + (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) + (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list"))) + + + ;; ---------- check no collisions with srfi/1 ---------- (test (void) eval '(module foo scheme/base (require scheme/base srfi/1/list))