src/sicp/ex4_4.rkt

   1 #lang racket
   2
   3 (define (tagged-list? exp tag)
   4   (if (pair? exp)
   5       (eq? (car exp) tag)
   6       #f))
   7
   8 (define (make-if predicate consequent alternative)
   9   (list 'if predicate consequent alternative))
  10
  11 ;; and
  12 (define (and? expr) (tagged-list? expr 'and))
  13 (define (eval-and expr env) (eval-and-predicates (cdr expr) env))
  14
  15 (define (eval-and-predicates expr env)
  16   (cond ((null? expr) #t)
  17         ((eval (car expr) env) (eval-and-predicates (cdr expr) env))
  18         (else #f)))
  19
  20 ;; or
  21 (define (or? expr) (tagged-list? expr 'or))
  22 (define (eval-or expr env) (eval-or-predicates (cdr expr) env))
  23
  24 (define (eval-or-predicates expr env)
  25   (cond ((null? expr) #f)
  26         ((eval (car expr) env) #t)
  27         (else (eval-or-predicates (cdr expr) env))))
  28
  29 ;; derived expressions
  30 (define (and->if expr)
  31   (expand-and-predicates (cdr expr)))
  32
  33 (define (expand-and-predicates expr)
  34   (cond ((null? expr) '#t)
  35         (else (make-if (car expr)
  36                        (expand-and-predicates (cdr expr))
  37                        '#f))))
  38
  39 (define (or->if expr)
  40   (expand-or-predicates expr))
  41
  42 (define (expand-or-predicates expr)
  43   (cond ((null? expr) '#f)
  44         (else (make-if (car expr)
  45                        '#t
  46                        (expand-or-predicates (cdr expr))))))