added argmin and argmax to scheme/list and to the teaching languages

svn: r12960

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)

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))

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]
 
 @; ----------------------------------------

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))