⟦0b06e7c42⟧

TextFile

;;; Basic generic operations

(define (add x y) (operate-2 'add x y))
(define (sub x y) (operate-2 'sub x y))
(define (mul x y) (operate-2 'mul x y))
(define (div x y) (operate-2 'div x y))
(define (=zero? x) (operate '=zero? x))
(define (negate x) (operate 'negate x))

;; Sample use of generic multiplication
(define (square x) (mul x x))

;; Data-directed implementation of generic operators
(define (operate op obj)
  (let ((proc (get (type obj) op)))
    (if (not (null? proc))   ;operator is defined on type
        (proc (contents obj))
        (error "Operator undefined on this type -- OPERATE"
               (list op obj)))))

(define (operate-2 op arg1 arg2)
  (let ((t1 (type arg1)))
    (if (eq? t1 (type arg2))
        (let ((proc (get t1 op)))
          (if (not (null? proc)) 
              (proc (contents arg1) (contents arg2))
              (error "Op/type undefined -- OPERATE-2" (list op t1))))
        (error "Operands not of same type -- OPERATE-2"
               (list op arg1 arg2)))))

;;; Table-constructor
(define (make-table)
  (let ((local-table (cons '*table* nil)))

    (define (lookup key-1 key-2)
      (let ((subtable (assq key-1 (cdr local-table))))
        (if (null? subtable)
            nil
            (let ((pair (assq key-2 (cdr subtable))))
              (if (null? pair)
                  nil
                  (cdr pair))))))

    (define (insert! key-1 key-2 value)
      (let ((subtable (assq key-1 (cdr local-table))))
        (if (null? subtable)
            (set-cdr! local-table
                      (cons (cons key-1
                                  (cons (cons key-2 value) nil))
                            (cdr local-table)))
            (let ((pair (assq key-2 (cdr subtable))))
              (if (null? pair)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))
                  (set-cdr! pair value))))))

    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))

    dispatch))

;;; Defining the operation table
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

;;; Installing ordinary numbers in the system

(define (+number x y) (make-number (+ x y)))
(define (-number x y) (make-number (- x y)))
(define (*number x y) (make-number (* x y)))
(define (/number x y) (make-number (/ x y)))
(define (negate-number x) (- x))
(define (=zero-number? x) (= x 0))

(define (make-number x) (attach-type 'number x))

(put 'number 'add +number)
(put 'number 'sub -number)
(put 'number 'mul *number)
(put 'number 'div /number)
(put 'number 'negate negate-number)
(put 'number '=zero? =zero-number?) 

;;; The underlying type mechanism

(define (attach-type type contents)
  (if (and (eq? type 'number) (number? contents))
      contents
      (cons type contents)))

(define (type datum)
  (cond ((number? datum) 'number)
        ((not (atom? datum)) (car datum))
        (else (error "Bad typed datum -- TYPE" datum))))

(define (contents datum)
  (cond ((number? datum) datum)
        ((not (atom? datum)) (cdr datum))
        (else (error "Bad typed datum -- CONTENTS" datum))))

;;; Installing polynomials in the generic arithmetic system

(define (+poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (make-polynomial (variable p1)
                       (+terms (term-list p1)
                               (term-list p2)))
      (error "Polys not in same var -- +POLY" (list p1 p2))))

(define (*poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (make-polynomial (variable p1)
                       (*terms (term-list p1)
                               (term-list p2)))
      (error "Polys not in same var -- *POLY" (list p1 p2))))

(define (=zero-poly? p)
  (empty-termlist? (term-list p)))

(put 'polynomial 'add +poly)
(put 'polynomial 'mul *poly)
(put 'polynomial '=zero? =zero-poly?)

;;; Operations on term lists

(define (+terms l1 l2)
  (cond ((empty-termlist? l1) l2)
        ((empty-termlist? l2) l1)
        (else
         (let ((t1 (first-term l1)) (t2 (first-term l2)))
           (cond ((> (order t1) (order t2))
                  (adjoin-term (order t1)
                               (coeff t1)
                               (+terms (rest-terms l1) l2)))
                 ((> (order t2) (order t1))
                  (adjoin-term (order t2)
                               (coeff t2)
                               (+terms l1 (rest-terms l2))))
                 (else
                  (adjoin-term (order t1)
                               (add (coeff t1) (coeff t2))
                               (+terms (rest-terms l1)
                                       (rest-terms l2)))))))))

(define (*terms l1 l2)
  (if (empty-termlist? l1)
      (the-empty-termlist)
      (+terms (*-term-by-all-terms (first-term l1) l2)
              (*terms (rest-terms l1) l2))))

(define (*-term-by-all-terms t1 l)
  (if (empty-termlist? l)
      (the-empty-termlist)
      (let ((t2 (first-term l)))
        (adjoin-term (+ (order t1) (order t2))
                     (mul (coeff t1) (coeff t2))
                     (*-term-by-all-terms t1 (rest-terms l))))))


(define (adjoin-term order coeff l)
  (cond ((=zero? coeff) l)                ;slight simplification
        (else
         (cons (make-term order coeff) l))))

;;; Representations of polynomials and term lists

(define (first-term l) (car l))
(define (rest-terms l) (cdr l))
(define (empty-termlist? l) (null? l))
(define (the-empty-termlist) '())

(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))

(define (make-polynomial variable term-list)
  (attach-type 'polynomial (cons variable term-list)))

(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (same-variable? v1 v2) (eq? v1 v2))

;;; Installing rational numbers in the generic arithmtic system
(define (+rat x y)
  (make-rat (add (mul (numer x) (denom y))
                 (mul (denom x) (numer y)))
            (mul (denom x) (denom y))))

(define (-rat x y)
  (make-rat (sub (mul (numer x) (denom y))
                 (mul (denom x) (numer y)))
            (mul (denom x) (denom y))))

(define (*rat x y)
  (make-rat (mul (numer x) (numer y))
            (mul (denom x) (denom y))))

(define (/rat x y)
  (make-rat (mul (numer x) (denom y))
            (mul (denom x) (numer y))))

(define (negate-rat x)
  (make-rat (negate (numer x))
            (denom x)))

(define (=zero?-rat x)
  (=zero? (numer x)))

(put 'rational 'add +rat)
(put 'rational 'sub -rat)
(put 'rational 'mul *rat)
(put 'rational 'div /rat)
(put 'rational 'negate negate-rat)
(put 'rational '=zero? =zero?-rat)


(define (make-rat n d)
  (let ((g (gcd n d)))
    (attach-type 'rational
                 (cons (quotient n g) (quotient d g)))))

(define (numer q) (car q))
(define (denom q) (cdr q))
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦0b06e7c42⟧ TextFile

Derivation

TextFile
