home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 549b.lha / Kamin / src.LZH / source / code.apl < prev    next >
Encoding:
Text File  |  1991-06-28  |  5.2 KB  |  196 lines
  1. ; From chapter 1
  2. (define +1 (x) (+ x 1))
  3. (define <= (x y) (or (< x y) (= x y)))
  4. ; Section 3.1,3
  5. (define fac (n) (*/ (indx n)))
  6. (fac 4)
  7. 24
  8. (define avg (v) (/ (+/ v) (shape v)))
  9. (avg '(2 4 6))
  10. 4
  11. (define neg (v) (- 0 v))
  12. (neg '(3 -5 -8))
  13. '(-3 5 8)
  14. (define min (v1 v2) (neg (max (neg v1) (neg v2))))
  15. (min 4 8)
  16. 4
  17. (min '(2 4 6 8) '(5 3 7 4))
  18. '(2 3 6 4)
  19. (define min/ (v) (neg (max/ (neg v))))
  20. (min/ '(5 3 7 4))
  21. 3
  22. (define mod (m n) (- m (* n (/ m n))))
  23. (mod '(2 5 8 11) '(1 2 3 4))
  24. '(0 1 2 3)
  25. (mod 10 '(2 5 8 11))
  26. '(0 0 2 10)
  27. (define even? (n) (= (mod n 2) 0))
  28. (even? '(1 2 3 4 5))
  29. '(0 1 0 1 0)
  30. (define even-sum (v) (+/ (compress (even? v) v)))
  31. (even-sum '(1 2 3 4 5))
  32. 6
  33. (define not= (x y) (if (= x y) 0 1))
  34. (not= 3 5)
  35. 1
  36. (not= '(1 3 5) '(1 4 8))
  37. 0
  38. (define not (x) (- 1 x))
  39. (define <> (x y) (not (= x y)))
  40. (<> '(1 3 5) '(1 4 8))
  41. '(0 1 1)
  42. (define reverse (a)
  43.         (begin
  44.          (set size ([] (shape a) 1))
  45.                  ([] a (+1 (- size (indx size))))))
  46. (set m (restruct '(4 4) '(1 1 0 0 0)))
  47.    '(1   1   0   0)
  48.    '(0   1   1   0)
  49.    '(0   0   1   1)
  50.    '(0   0   0   1)
  51. (reverse m)
  52.    '(0   0   0   1)
  53.    '(0   0   1   1)
  54.    '(0   1   1   0)
  55.    '(1   1   0   0)
  56. (define reverse (a)
  57.            ([] a (+1 (- (set size ([] (shape a) 1)) (indx size))))))
  58. (reverse m)
  59.    '(0   0   0   1)
  60.    '(0   0   1   1)
  61.    '(0   1   1   0)
  62.    '(1   1   0   0)
  63. (define signum (x) (+ (* (< x 0) -1)(> x 0)))
  64. (define abs (x) (* x (signum x)))
  65. (define find (x v) ([] (compress (= x v) (indx (shape v))) 1))
  66. (find 3 '(1 4 7 3 9 2))
  67. 4
  68. (define find-closest (x v)
  69.       (begin
  70.            (set absdiffs (abs (- v x)))
  71.            (find (min/ absdiffs) absdiffs)))
  72. (find-closest 10 '(8 11 4 13 7))
  73. 2
  74. (define sqr (x) (* x x))
  75. (define variance (v) (/ (+/ (sqr (- v (avg v)))) (shape v)))
  76. (variance '(5 10 15 20))
  77. 31
  78. (define binom (n)
  79.      (begin (set l '(1))
  80.               (print l)
  81.               (while (< (shape l) n)
  82.                     (begin
  83.                           (set l (+ (cat 0 l)(cat l 0)))
  84.                           (print l)))))
  85. (define prime (n)
  86.         (and/ (<> 0 (mod n (+1 (indx (- n 2)))))))
  87. (define dropend (v) ([] v (indx (- (shape v) 1))))
  88. (define +\ (v)
  89.          (if (= (shape v) 0) v
  90.                (cat (+\ (dropend v)) (+/ v))))
  91. (+\ '(1 3 5 7))
  92. '(1   4   9   16)
  93. (define assign (v i x)
  94.       (cat ([] v (indx (- i 1)))
  95.            (cat x ([] v (+ i (indx (- (shape v) i)))))))
  96. (assign '(1 2 3 4 5) 3 6)
  97. '(1 2 6 4 5)
  98. (define drop1 (v) ([] v (+1 (indx (- (shape v) 1)))))
  99. (define vecassign (v i x)
  100.       (if (= (shape i) 0) v
  101.              (vecassign (assign v ([] i 1)([] x 1))
  102.                        (drop1 i) (drop1 x))))
  103. (vecassign '(10 20 30 40 50) '(3 5 1) '(7 9 11))
  104. '(11 20 7 40 9)
  105. (define fillzeros (v)
  106.        (vecassign (restruct (+/ (+ v 1)) 0)
  107.                     (+\ (+ v 1))
  108.                     (restruct (shape v) 1)))
  109. (fillzeros '(2 0 3 1))
  110. '(0 0 1 1 0 0 0 1 0 1)
  111. (define mod-outer-prod (v1 v2)
  112.          (mod (trans (restruct (cat (shape v2)(shape v1)) v1))
  113.              (restruct (cat (shape v1) (shape v2)) v2)))
  114. (mod-outer-prod (indx 4) (indx 7))
  115. '(0 1 1 1 1 1 1)
  116. '(0 0 2 2 2 2 2)
  117. '(0 1 0 3 3 3 3)
  118. '(0 0 1 0 4 4 4)
  119. (define primes<= (n)
  120.     (compress (= 2 (+/ (= 0 (mod-outer-prod (set s (indx n)) s))))
  121.               s))
  122. (primes<= 7)
  123. '(2 3 5 7)
  124. ; Section 3.3??
  125. (define dup-cols (v n)
  126.     (trans (restruct (cat n (shape v)) v)))
  127. (define dup-rows (v n)
  128.     ([] (restruct (cat 1 (shape v)) v) (restruct n 1)))
  129. (define freqvec (scores lo hi)
  130.      (begin
  131.           (set width (+ (- hi lo) 1))
  132.           (+/ (trans (= 
  133.                 (dup-cols scores width)
  134.                 (dup-rows (+ (indx width) (- lo 1)) (shape scores))))))))
  135. (define cumfreqvec (freqs) (+\ freqs))
  136. (define range (scores) (cat (min/ scores) (max/ scores)))
  137. (define mode (freqs lo) (+ (find (max/ freqs) freqs) (- lo 1)))
  138. (define median (cumfreqs lo)
  139.            (+ (- lo 1) (find-closest (max/ cumfreqs) (* 2 cumfreqs))))
  140. (define addelt (e i v)
  141.     (cat ([] v (indx (- i 1)))
  142.          (cat e ([] v (+ (indx (- (+1 (shape v)) i)) (- i 1))))))
  143. (define addrow (v i m)
  144.     ([] (restruct (+ '(1 0) (shape m)) (cat v m))
  145.           (addelt 1 i (+1 (indx ([] (shape m) 1))))))
  146. (define addcol (v i m)
  147.     (trans (addrow v i (trans m))))
  148. (define histo (freqs lo hi)
  149.     (begin
  150.          (set width (+1 (- hi lo)))
  151.          (set length (max/ freqs))
  152.          (set hist
  153.              (<=   (restruct (cat width length) (indx length))
  154.                  (dup-cols freqs length)))
  155.          (addcol (- (indx width) (- 1 lo)) 1 hist)))
  156. (define graph (freqs lo)
  157.    (begin
  158.        (set length (max/ freqs))
  159.        (set lines (restruct (cat (+ length 1) length)
  160.                                   (cat (restruct length 0) 1)))
  161.        (set thegraph (reverse (trans ([] lines (+ freqs 1)))))
  162.        (addrow (- (indx (shape freqs)) (- 1 lo)) (+ length 1) thegraph)))
  163. (set SCORES '(-2 1 -1 0 0 2 1 1))
  164. (set FREQS (freqvec SCORES -2 2))
  165. '(1 1 2 3 1)
  166. (set CUMFREQS (cumfreqvec FREQS))
  167. '(1 2 4 7 8)
  168. (range SCORES)
  169. '(-2 2)
  170. (mode FREQS -2)
  171. 1 
  172. (median CUMFREQS -2)
  173. 0 
  174. (histo FREQS -2 2)
  175. '(-2 1 0 0)
  176. '(-1 1 0 0)
  177. '(0 1 1 0)
  178. '(1 1 1 1)
  179. '(2 1 0 0)
  180. (graph FREQS -2)
  181. '(0 0 0 1 0)
  182. '(0 0 1 0 0)
  183. '(1 1 0 0 1)
  184. '(-2 -1 0 1 2)
  185. (graph CUMFREQS -2)
  186. '(0 0 0 0 1)
  187. '(0 0 0 1 0)
  188. '(0 0 0 0 0)
  189. '(0 0 0 0 0)
  190. '(0 0 1 0 0)
  191. '(0 0 0 0 0)
  192. '(0 1 0 0 0)
  193. '(1 0 0 0 0)
  194. '(-2 -1 0 1 2)
  195. quit
  196.