100 lines
3.6 KiB
Racket
100 lines
3.6 KiB
Racket
#lang scheme
|
|
|
|
;; ---------------------------------------------------------------------------------------------------
|
|
;; define higher-order primitives that consume boolean-valued functions
|
|
|
|
(require "teachprims.rkt" "teach.rkt")
|
|
|
|
(provide intermediate-andmap intermediate-ormap intermediate-filter
|
|
intermediate-quicksort intermediate-sort)
|
|
|
|
|
|
;; --- checking auxiliaries ---
|
|
(define (arity-check t r f a)
|
|
(unless (and (procedure? f) (procedure-arity-includes? f a))
|
|
(if (= a 1)
|
|
(hocheck t "~a argument must be a function that accepts one argument, given ~e" r f)
|
|
(hocheck t "~a argument must be a function that accepts ~a arguments, given ~e" r a f))))
|
|
|
|
(define-syntax-rule
|
|
(boolean-test-wrapper tag (f z ...))
|
|
(let ()
|
|
(define msg (format "the function given to ~a" tag))
|
|
(define *name (object-name f))
|
|
(define name (if *name (format "~a (~a)" *name msg) msg))
|
|
(define (g z ...)
|
|
(define f@x (f z ...))
|
|
(if (boolean? f@x)
|
|
f@x
|
|
(error tag "expected a boolean from ~a, but received ~e" name f@x)))
|
|
g))
|
|
|
|
(define (list-check? name msg l)
|
|
(unless (beginner-list? l)
|
|
(hocheck name "expected a list for the ~a argument, given ~e" msg l)))
|
|
|
|
;; --- refined function definitions ---
|
|
|
|
(define-syntax-rule
|
|
(define-boolean name)
|
|
(define-teach intermediate name
|
|
(lambda (f l)
|
|
(arity-check 'name "first" f 1)
|
|
(list-check? 'name "second" l)
|
|
(unless (beginner-list? l)
|
|
(hocheck 'name "expected a list for the second argument, given ~e" l))
|
|
(define g (boolean-test-wrapper 'name (f x)))
|
|
(name g l))))
|
|
|
|
(define-boolean andmap)
|
|
(define-boolean ormap)
|
|
(define-boolean filter)
|
|
|
|
(define-syntax-rule
|
|
(define-sort name)
|
|
(define-teach intermediate name
|
|
(lambda (l cmp?)
|
|
(list-check? 'name "first" l)
|
|
(arity-check 'name "second" cmp? 2)
|
|
(define dmp? (boolean-test-wrapper 'name (cmp? x y)))
|
|
(sort l dmp?))))
|
|
|
|
(define-sort sort)
|
|
(define-sort quicksort)
|
|
|
|
#| TESTS
|
|
|
|
(define (tester tag name)
|
|
(lambda (x)
|
|
(unless (regexp-match name (exn-message x))
|
|
(displayln '****broken-test****)
|
|
(displayln `(,tag ,(exn-message x))))))
|
|
|
|
(define-syntax-rule
|
|
(exn-tester label name function inputs ...)
|
|
(with-handlers ((exn:fail? (tester label name)))
|
|
(function inputs ...)
|
|
(error 'exn-tester "***case ~a (~a) failed***" label name)))
|
|
|
|
(exn-tester 1 "ormap" intermediate-ormap cons '(1 2 3))
|
|
(exn-tester 2 "andmap" intermediate-andmap cons '(1 2 3))
|
|
(exn-tester 3 "ormap" intermediate-ormap add1 1)
|
|
(exn-tester 4 "andmap" intermediate-andmap add1 1)
|
|
(exn-tester 5 "ormap" intermediate-ormap (lambda (x) x) '(1 2 3))
|
|
(exn-tester 6 "andmap" intermediate-andmap (lambda (x) x) '(1 2 3))
|
|
(exn-tester 7 "andmap" intermediate-andmap add1 '(1 2 3))
|
|
(exn-tester 8 "filter" intermediate-filter (lambda (x) x) '(1 2 3))
|
|
(exn-tester 9 "filter" intermediate-filter add1 '(1 2 3))
|
|
(exn-tester 10 "sort" intermediate-sort '(1 2 3) (lambda (x y) (if (< x y) y #false)))
|
|
(exn-tester 11 "quick" intermediate-quicksort '(1 2 3) (lambda (x y) (if (< x y) y #false)))
|
|
|
|
(unless (equal? (intermediate-ormap odd? '(1 2 3)) #t) (error 'x "1"))
|
|
(unless (equal? (intermediate-andmap odd? '(1 2 3)) #f) (error 'x "2"))
|
|
(unless (equal? (intermediate-andmap odd? '(1 3 5)) #t) (error 'x "3"))
|
|
(unless (equal? (intermediate-ormap even? '(1 3 5)) #f) (error 'x "4"))
|
|
(unless (equal? (intermediate-filter odd? '(1 2 3)) '(1 3)) (error 'x "5"))
|
|
(unless (equal? (intermediate-filter odd? '()) '()) (error 'x "6"))
|
|
(unless (equal? (intermediate-sort '(1 0 2) <) '(0 1 2)) (error 'x "7"))
|
|
(unless (equal? (intermediate-quicksort '(1 0 2) <) '(0 1 2)) (error 'x "8"))
|
|
|#
|