home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 549b.lha / Kamin / src.LZH / source / code.clu < prev    next >
Encoding:
Text File  |  1991-06-28  |  9.3 KB  |  306 lines
  1. ; From Chapter 1
  2. (define sqr (x) (* x x))
  3. (define abs (x) (if (< x 0) (- 0 x) x))
  4. (define +1 (x) (+ x 1))
  5. (define and (x y) (if x y x))
  6. (define or (x y) (if x x y))
  7. (define not (x) (if x 0 1))
  8. (define <> (x y) (not (= x y)))
  9. (define >= (x y) (or (> x y) (= x y)))
  10. (define <= (x y) (or (< x y) (= x y)))
  11. (define mod (m n) (- m (* n (/ m n))))
  12. (define min (x y) (if (< x y) x y))
  13. (define max (x y) (if (> x y) x y))
  14. ; Section 6.1
  15. (cluster Point
  16.     ; Export: new, abscissa, ordinate, reflect, rotate, compare, quadrant
  17.     (rep x-coord y-coord)
  18.     (define new (x y) (Point x y))
  19.     (define abscissa (p) (x-coord p))
  20.     (define ordinate (p) (y-coord p))
  21.     (define reflect (p)
  22.          (begin
  23.                (set-x-coord p (- 0 (x-coord p)))
  24.                (set-y-coord p (- 0 (y-coord p)))))
  25.     (define rotate (p)
  26.          (begin
  27.                (set temp (x-coord p))
  28.                (set-x-coord p (y-coord p))
  29.                (set-y-coord p (- 0 temp))))
  30.     (define compare (p1 p2)
  31.          (< (sqrdist p1) (sqrdist p2)))
  32.     (define quadrant (p)
  33.          (if (>= (x-coord p) 0)
  34.               (if (>= (y-coord p) 0) 1 2)
  35.               (if (< (y-coord p) 0) 3 4)))
  36.     ; sqrdist is not exported
  37.     (define sqrdist (p)
  38.          (+ (sqr (x-coord p)) (sqr (y-coord p))))
  39. )
  40. (set p1 (Point$new 3 4))
  41. (Point$rotate p1)
  42. (Point$abscissa p1)
  43. 4
  44. (Point$ordinate p1)
  45. -3
  46. (Point$reflect p1)
  47. (Point$abscissa p1)
  48. -4
  49. (Point$ordinate p1)
  50. 3
  51. (set p2 (Point$new 1 5))
  52. (Point$compare p1 p2)
  53. 1
  54. (define enclosed-area (p1 p2)
  55.       (abs (* (- (Point$abscissa p1) (Point$abscissa p2))
  56.         (- (Point$ordinate p1) (Point$ordinate p2)))))
  57. (enclosed-area p1 p2)
  58. 10
  59. (cluster Point
  60.     ; Export: new, abscissa, ordinate, reflect, rotate, compare, quadrant
  61.     (rep x-mag y-mag quad)
  62.     (define new (x y) (Point (abs x) (abs y) (compute-quad x y)))
  63.     (define abscissa (p)
  64.          (if (> (quad p) 2) (- 0 (x-mag p)) (x-mag p)))
  65.     (define ordinate (p)
  66.          (if (or (= (quad p) 2) (= (quad p) 3))
  67.               (- 0 (y-mag p))
  68.               (y-mag p)))
  69.     (define reflect (p)
  70.          (set-quad p (+1 (mod (+1 (quad p)) 4))))
  71.     (define rotate (p)
  72.          (begin
  73.                (set temp (x-mag p))
  74.                (set-x-mag p (y-mag p))
  75.                (set-y-mag p temp)
  76.                (set-quad p (+1 (mod (quad p) 4)))))
  77.     (define compare (p1 p2)
  78.          (< (sqrdist p1) (sqrdist p2)))
  79.     (define quadrant (p) (quad p))
  80.     ; compute-quad, sqrdist are not exported
  81.     (define compute-quad (x y)
  82.          (if (>= x 0)
  83.               (if (>= y 0) 1 2)
  84.               (if (< y 0) 3 4)))
  85.     (define sqrdist (p)
  86.          (+ (sqr (x-mag p)) (sqr (y-mag p))))
  87. )
  88. (set p1 (Point$new 3 4))
  89. (Point$rotate p1)
  90. (Point$abscissa p1)
  91. 4
  92. (Point$ordinate p1)
  93. -3
  94. (Point$reflect p1)
  95. (Point$abscissa p1)
  96. -4
  97. (Point$ordinate p1)
  98. 3
  99. (set p2 (Point$new 1 5))
  100. (Point$compare p1 p2)
  101. 1
  102. (define enclosed-area (p1 p2)
  103.       (abs (* (- (Point$abscissa p1) (Point$abscissa p2))
  104.         (- (Point$ordinate p1) (Point$ordinate p2)))))
  105. (enclosed-area p1 p2)
  106. 10
  107. ; Section 6.2.3
  108. (cluster List
  109.     ; Exports: nil, null?, cons, car, cdr, rplaca, rplacd
  110.     (rep type a d)
  111.     (define nil () (List 0 0 0))
  112.     (define null? (l) (= (type l) 0))
  113.     (define cons (item l) (List 1 item l))
  114.     (define car (l) (a l))
  115.     (define cdr (l) (d l))
  116.     (define rplaca (l a) (set-a l a))
  117.     (define rplacd (l d) (set-d l d))
  118. )
  119. (set x (List$cons 1 (List$cons 2 (List$nil)))) ; x is 1,2
  120. (set y x) ; y is 1,2
  121. (List$car x)
  122. 1
  123. (List$car y)
  124. 1
  125. (List$car (List$cdr x))
  126. 2
  127. (List$rplaca y 3) ; y is 3,2, and so is x
  128. (List$car x)
  129. 3
  130. (List$car y)
  131. 3
  132. (define length (l)
  133.     (if (List$null? l) 0 (+1 (length (List$cdr l)))))
  134. (length x)
  135. 2
  136. (length y)
  137. 2
  138. ;
  139. (define nth (n l)
  140.       (if (= n 0) (List$car l) (nth (- n 1) (List$cdr l))))
  141. (define changenth (n x l)
  142.       (if (= n 0) (List$rplaca l x) (changenth (- n 1) x (List$cdr l)))))
  143. ;
  144. (cluster Array
  145.       ; Exports: new, index, assign
  146.       ; Indexing is from base, array has length size,
  147.       ; and elements are in list elts.
  148.       (rep base size elts)
  149.       (define new (b s) (Array b s (zerolist s)))
  150.       (define index (A i)
  151.             (if (out-of-bounds A i) 0 (nth (- i (base A)) (elts A))))
  152.       (define assign (A i x)
  153.             (if (out-of-bounds A i) A (changenth (- i (base A)) x (elts A))))
  154.       ; zerolist, out-of-bounds not exported
  155.       (define zerolist (n)
  156.             (if (= n 0) (List$nil) (List$cons 0 (zerolist (- n 1)))))
  157.       (define out-of-bounds (A i)
  158.             (or (< i (base A)) (> i (- (+ (base A) (size A)) 1))))
  159. )
  160. (set A (Array$new 1 10))
  161. (set i 0)
  162. (while (< i 10) (begin (set i (+ i 1)) (Array$assign A i (* i i))))
  163. (set i 0)
  164. (while (< i 10) (begin (set i (+ i 1)) (print (Array$index A i))))
  165. ;
  166. (cluster Pair
  167.     ; Exports: fst, snd, mkPair
  168.     (rep f s)
  169.     (define fst (p) (f p))
  170.     (define snd (p) (s p))
  171.     (define mkPair (x y) (Pair x y))
  172. )
  173. ;
  174. (define assoc (i l)
  175.        (if (List$null? l) l
  176.             (if (= (Pair$fst (List$car l)) i)
  177.                  l
  178.                  (assoc i (List$cdr l)))))
  179. ;
  180. (cluster SpArray
  181.     ; Exports: new, index, assign
  182.     (rep base size elts)
  183.     (define new (b s) (SpArray b s (List$nil)))
  184.     (define index (A i)
  185.            (begin
  186.                (set found (assoc i (elts A)))
  187.                (if (List$null? found) 0 (Pair$snd (List$car found)))))
  188.     (define assign (A i x)
  189.          (if (out-of-bounds A i) A
  190.              (begin
  191.                  (set found (assoc i (elts A)))
  192.                  (if (List$null? found)
  193.                      (set-elts A (List$cons (Pair$mkPair i x) (elts A)))
  194.                      (List$rplaca found (Pair$mkPair i x)))
  195.                  A)))
  196.     ; out-of-bounds not exported
  197.     (define out-of-bounds (A i)
  198.           (or (< i (base A)) (> i (- (+ (base A) (size A)) 1))))
  199. )
  200. (set A (SpArray$new 1 10))
  201. (set i 0)
  202. (while (< i 10) (begin (set i (+ i 1)) (SpArray$assign A i (* i i))))
  203. (set i 0)
  204. (while (< i 10) (begin (set i (+ i 1)) (print (SpArray$index A i))))
  205. ; Section 6.4
  206. (cluster Poly
  207.     ; Export: create, degree, coeff, zero?, add, minus, sub, mul, prnt
  208.     (rep coeffs lo hi)
  209.     (define create (c n)
  210.         (begin
  211.              (set A (Array$new 0 20))
  212.              (Array$assign A n c)
  213.              (Poly A n n)))
  214.     (define degree (p) (hi p))
  215.     (define coeff (p n)
  216.         (if (or (< n (lo p)) (> n (hi p))) 0 (Array$index (coeffs p) n)))
  217.     (define zero? (p) (= 0 (coeff p (lo p))))
  218.     (define add (p q)
  219.         (begin
  220.              (set result (create 0 0))
  221.              (set-lo result (min (lo p) (lo q)))
  222.              (set-hi result (max (hi p) (hi q)))
  223.              (set i (lo result))
  224.              (while (<= i (hi result))
  225.                  (begin
  226.                       (set-coeff result i (+ (coeff p i) (coeff q i)))
  227.                       (set i (+1 i))))
  228.              (remove-zeros result)
  229.              result))
  230.     (define minus (p)
  231.         (begin
  232.              (set result (create 0 0))
  233.              (set-lo result (lo p))
  234.              (set-hi result (hi p))
  235.              (set i (lo p))
  236.              (while (<= i (hi p))
  237.                  (begin
  238.                       (set-coeff result i (- 0 (coeff p i)))
  239.                       (set i (+1 i))))
  240.                result))
  241.     (define sub (p q)
  242.         (add p (minus q)))
  243.     (define mul (p q)
  244.         (begin
  245.              (set result (create 0 0))
  246.              (if (> (+ (hi p) (hi q)) 19) result ; error!
  247.                  (if (or (zero? p) (zero? q)) result
  248.                     (begin
  249.                          (set-lo result (+ (lo p) (lo q)))
  250.                          (set-hi result (+ (hi p) (hi q)))
  251.                          (set p-hi (hi p))
  252.                          (set q-hi (hi q))
  253.                          (set q-lo (lo q))
  254.                          (set i (lo p))
  255.                          (while (<= i p-hi)
  256.                               (begin
  257.                                    (set j q-lo)
  258.                                    (while (<= j q-hi)
  259.                                              (begin
  260.                                     (set-coeff result (+ i j)
  261.                                           (+ (coeff result (+ i j))
  262.                                          (* (coeff p i) (coeff q j))))
  263.                                       (set j (+1 j))))
  264.                                  (set i (+1 i))))
  265.                          result)))))
  266.     (define prnt (p)
  267.      (if (zero? p) (begin (print 0) (print 0))
  268.        (begin
  269.          (set expon (hi p))
  270.          (while (>= expon (lo p))
  271.            (if (= (coeff p expon) 0)
  272.              (set expon (- expon 1))
  273.              (begin (print (coeff p expon)) (print expon)
  274.                     (set expon (- expon 1))))))))
  275.   ; set-coeff, remove-zeros not exported
  276.     (define set-coeff (p n c)
  277.           (Array$assign (coeffs p) n c))
  278.     (define remove-zeros (p) ; (lo p) is too low, and/or (hi p) too high
  279.         (begin
  280.              (while (and (= 0 (coeff p (lo p))) (<= (lo p) (hi p)))
  281.                   (set-lo p (+1 (lo p))))
  282.              (if (> (lo p) (hi p)) ; p a zero polynomial
  283.                   (begin (set-lo p 0) (set-hi p 0))
  284.                   (while (= 0 (coeff p (hi p)))
  285.                           (set-hi p (- (hi p) 1))))))
  286. )
  287. (define diff (p)
  288.     (begin
  289.         (set n 1)
  290.         (set pdx (Poly$create 0 0))
  291.         (while (<= n (Poly$degree p))
  292.             (begin
  293.                 (set pdx (Poly$add pdx
  294.                        (Poly$create (* n (Poly$coeff p n)) (- n 1))))
  295.                 (set n (+1 n))))
  296.         pdx))
  297. (set p (Poly$create 5 2))
  298. (set q (Poly$create 3 1))
  299. (set r (Poly$add p q))
  300. (Poly$prnt (diff r))
  301. 10
  302. 1
  303. 3
  304. 0
  305. quit
  306.