home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 549b.lha / Kamin / src.LZH / source / code.ssl < prev    next >
Encoding:
Text File  |  1991-06-28  |  11.7 KB  |  371 lines
  1. ; From previous chapters (esp. Scheme and Lisp)
  2. (set +1 (lambda (x) (+ x 1)))
  3. (set mapcar (lambda (f l)
  4.      (if (null? l) '()
  5.       (cons (f (car l)) (mapcar f (cdr l)))))))
  6. (set sqr (lambda (x) (* x x)))
  7. (set cadr (lambda (x) (car (cdr x))))
  8. (set cddr (lambda (x) (cdr (cdr x))))
  9. (set cadddr (lambda (x) (car (cdr (cdr (cdr x))))))
  10. (set abs (lambda (x) (if (< x 0) (- 0 x) x)))
  11. (set mod (lambda (m n) (- m (* n (/ m n)))))
  12. (set divides (lambda (m n) (= (mod n m) 0)))
  13. (set length (lambda (l) (if (null? l) 0 (+1 (length (cdr l))))))
  14. (set append (lambda (x y)
  15.    (if (null? x) y
  16.       (cons (car x) (append (cdr x) y)))))
  17. (set list1 (lambda (x) (cons x '())))
  18. (set list2 (lambda (x y) (cons x (cons y '()))))
  19. (set not (lambda (x) (if x '() 'T)))
  20. (set or (lambda (x y) (if x x y)))
  21. (set and (lambda (x y) (if x y x)))
  22. (set cadr (lambda (x) (car (cdr x))))
  23. (set caddr (lambda (x) (car (cdr (cdr x)))))
  24. (set curry (lambda (f) (lambda (x) (lambda (y) (f x y)))))
  25. (set id (lambda (x) x))
  26. (set compose (lambda (f g) (lambda (x) (g (f x)))))
  27. (set member? (lambda (x l)
  28.    (if (null? l) '()
  29.      (if (= x (car l)) 'T
  30.         (member? x (cdr l))))))
  31. (set union (lambda (s1 s2)
  32.      (if (null? s1) s2
  33.          (if (member? (car s1) s2)
  34.                 (union (cdr s1) s2)
  35.              (cons (car s1) (union (cdr s1) s2))))))
  36. (set empty-queue '())
  37. (set front (lambda (q) (car q)))
  38. (set rm-front (lambda (q) (cdr q)))
  39. (set enqueue (lambda (t q)
  40.    (if (null? q) (list1 t) (cons (car q) (enqueue t (cdr q))))))
  41. (set empty? (lambda (q) (null? q)))
  42. ; Section 5.0
  43. (set pred (lambda (x) (> x 5)))
  44. (set fun-srch-for (lambda (n)
  45.      (find-val pred (interval 1 n) (+1 n))))
  46. (set find-val (lambda (pred lis failure-value)
  47.      (if (null? lis) failure-value
  48.          (if (pred (car lis)) (car lis)
  49.              (find-val pred (cdr lis) failure-value)))))
  50. (set interval (lambda (i j)
  51.    (if (> i j) '() (cons i (interval (+1 i) j)))))
  52. (fun-srch-for 10)
  53. 6
  54. (set fun-srch-for-sqr (lambda (n)
  55.      (find-val pred (mapcar sqr (interval 1 n)) (sqr (+1 n)))))
  56. (fun-srch-for-sqr 10)
  57. 9
  58. ; Section 5.1
  59. (set fun-srch-while (lambda () (find-val pred (ints-from 1) '())))
  60. (set ints-from (lambda (i) (cons i (ints-from (+1 i)))))
  61. (fun-srch-while)
  62. 6
  63. ; Section 5.2.3
  64. (set x (mapcar +1 '(2 3)))
  65. '(... ...)
  66. (car x)
  67. 3
  68. (cadr x)
  69. 4
  70. x
  71. '(3 4 ...)
  72. (cddr x)
  73. '()
  74. x
  75. '(3 4)
  76. (set ints-from (lambda (i)
  77.         (cons i (ints-from (+1 i)))))
  78. (set ints (ints-from 0))
  79. '(... ...)
  80. (car ints)
  81. 0
  82. (cadr ints)
  83. 1
  84. ints
  85. '(0 1 ...)
  86. (set force (lambda (x)
  87.    (if (list? x)  ; apply list? to every component
  88.      (if (force (car x)) (force (cdr x)) '())
  89.      'T)))
  90. (set x (mapcar +1 '(2 3)))
  91. '(... ...)
  92. (force x)
  93. 'T
  94. x
  95. '(3 4)
  96. (set first-n (lambda (n l)
  97.    (if (null? l) '()
  98.      (if (= n 0) '()
  99.        (cons (car l) (first-n (- n 1) (cdr l)))))))
  100. (set ints5 (first-n 5 ints))
  101. '(... ...)
  102. (force ints5)
  103. 'T
  104. ints5
  105. '(0 1 2 3 4)
  106. (set next (lambda (n xi) (/ (+ xi (/ n xi)) 2)))
  107. (set xlist (lambda (xi n) (cons xi (xlist (next n xi) n))))
  108. (set mk-xlist (lambda (n) (xlist 1 n)))
  109. (set abs-conv (lambda (epsilon)
  110.    (lambda (l) (< (abs (- (cadr l) (car l))) epsilon))))
  111. (set abs-sqrt (lambda (n)
  112.    (find-list (abs-conv 3) cadr (mk-xlist n))))
  113. (set find-list (lambda (pred extract l)
  114.    (if (null? l) '() (if (pred l) (extract l)
  115.      (find-list pred extract (cdr l))))))
  116. (abs-sqrt 100)
  117. 10
  118. (set next (lambda (n xi) (/ (+ xi (/ n (* xi xi))) 2)))
  119. (set abs-cbrt (lambda (n)
  120.      (find-list (abs-conv 2) cadr (mk-xlist n))))
  121. (abs-cbrt 100)
  122. 5
  123. (set remove-multiples (lambda (n l)
  124.    (if (null? l) '()
  125.      (if (divides n (car l))
  126.         (remove-multiples n (cdr l))
  127.         (cons (car l) (remove-multiples n (cdr l)))))))
  128. (set sieve (lambda (l) (if (null? l) '()
  129.         (cons (car l)
  130.               (sieve (remove-multiples (car l) (cdr l)))))))
  131. (set primes<= (lambda (n) (sieve (interval 2 n))))
  132. (set primes (sieve (ints-from 2)))
  133. (set first-n-primes (lambda (n) (first-n n primes)))
  134. (set p (first-n-primes 5))
  135. (force p)
  136. p
  137. ;
  138. (set next-int +1)
  139. (set repeat-until (lambda (init next pred)
  140.    (if (pred init) init
  141.      (repeat-until (next init) next pred))))
  142. (set new-fun-srch-while (lambda ()
  143.    (repeat-until 1 next-int pred)))
  144. (set pred (lambda (x) (> x 5)))
  145. (new-fun-srch-while)
  146. 6
  147. ;
  148. (set find-atom (lambda (s) (find-val pred (flatten s) '())))
  149. (set flatten (lambda (x)
  150.      (if (null? x) '()
  151.           (if (atom? x) (list1 x)
  152.               (append (flatten (car x)) (flatten (cdr x)))))))
  153. (set samefringe (lambda (x y) (equal (flatten x) (flatten y))))
  154. (set find-perm (lambda (l)
  155.     (find-val pred (permutations l) '())))
  156. (set append* (lambda (l)
  157.     (if (null? l) '() (append (car l) (append* (cdr l))))))
  158. (set filter (lambda (pred l)
  159.     (if (null? l) '()
  160.      (if (pred (car l)) (cons (car l) (filter pred (cdr l)))
  161.        (filter pred (cdr l))))))
  162. (set remove (lambda (item l)
  163.      (filter (lambda (x) (not (= x item))) l)))
  164. (set permutations (lambda (l)
  165.   (if (= (length l) 1) (list1 l)
  166.      (append* (mapcar (lambda (x) (mapcar (lambda (z) (cons x z))
  167.                                   (permutations (remove x l)))) l)))))
  168. (set p (permutations '(a b c)))
  169. (force p)
  170. '(Permutations of a b c)
  171. p
  172. (set pred (lambda (perm) (= (car perm) 2)))
  173. (set p (find-perm '(1 2 3 4)))
  174. (force p)
  175. p
  176. '(2 1 3 4)
  177. ;
  178. (set ints (cons 0 (mapcar +1 ints)))
  179. (set powersof2 (cons 1 (mapcar double powersof2)))
  180. (set mapcar2 (lambda (f l1 l2)
  181.         (cons (f (car l1) (car l2))
  182.                 (mapcar2 f (cdr l1) (cdr l2)))))
  183. (set posints (cdr ints))
  184. (set X (cons x0 (mapcar2 f X posints)))
  185. (set facs (cons 1 (mapcar2 * facs posints)))
  186. (cadddr facs)
  187. 6
  188. ; Section 5.4
  189. (set evalBoolexp (lambda (e a)
  190.      (if (symbol? e) (isTrue? e a)
  191.        (if (= (car e) 'not)
  192.                (not (evalBoolexp (cadr e) a))
  193.           (if (= (car e) 'or)
  194.                 (or (evalBoolexp (cadr e) a)
  195.                       (evalBoolexp (caddr e) a))
  196.               (and (evalBoolexp (cadr e) a)
  197.                       (evalBoolexp (caddr e) a)))))))
  198. (set mapaddx (lambda (x l) ; add x to each list in l, then append to l
  199.      (append l (mapcar (lambda (y) (cons x y)) l))))
  200. (set gensubsets (lambda (l) ; create a list containing all sub-sets of l
  201.      (if (null? (cdr l)) (list2 l '())
  202.          (mapaddx (car l) (gensubsets (cdr l))))))
  203. (set variables (lambda (e) ; All variables occurring in e
  204.      (if (symbol? e) (cons e '())
  205.           (if (= (car e) 'not) (variables (cadr e))
  206.                (union (variables (cadr e)) (variables (caddr e)))))))
  207. (set assignments (lambda (e) (gensubsets (variables e))))
  208. (set isTrue? member?)
  209. (set findTruth (lambda (e alist)
  210.      ; Find if any assignment on alist satisfies e
  211.      (if (null? alist) '() ; No assignments left to try
  212.           (if (evalBoolexp e (car alist)) 'T
  213.                (findTruth e (cdr alist))))))
  214. (set SAT (lambda (e)
  215.      (if (findTruth e (assignments e))
  216.           'Satisfiable
  217.           'Unsatisfiable)))
  218. (SAT '(not (or p (and (or (not p) q) (or (not p) (not q))))))
  219. ; Section 5.5
  220. (set add-points (lambda (p q)
  221.     (list2 (+ (car p) (car q)) (+ (cadr p) (cadr q)))))
  222. (set gen-paths (lambda (p points)
  223.     (cons p
  224.      (mapcar (lambda (r) (gen-paths r points))
  225.                    (mapcar (lambda (q) (add-points q p)) points)))))
  226. (set P '((2 2)(0 1)(3 0)))
  227. '((2 2)(0 1)(3 0))
  228. (set PATHS (gen-paths '(0 0) P))
  229. (set == (lambda (p q) (and (= (car p) (car q)) (= (cadr p) (cadr q)))))
  230. (set << (lambda (p q) (or (< (car p) (car q)) (< (cadr p) (cadr q)))))
  231. (set dfs (lambda (t pred term)
  232.      (if (pred (car t)) 'T  ; success
  233.           (if (term (car t)) '()  ; failure on this branch
  234.                (dfs* (cdr t) pred term)))))
  235. (set dfs* (lambda (l pred term)
  236.      (if (null? l) '() ; failure
  237.           (if (dfs (car l) pred term) 'T
  238.                (dfs* (cdr l) pred term)))))
  239. (set reaches-dfs (lambda (p0 paths)
  240.      (dfs paths
  241.             (lambda (q) (== p0 q))
  242.             (lambda (q) (<< p0 q)))))
  243. ;
  244. (set enqueue* (lambda (q items)
  245.      (if (null? items) q (enqueue* (enqueue (car items) q) (cdr items)))))
  246. ;
  247. (set bfs (lambda (t pred term)
  248.      (bfs-queue (enqueue t empty-queue) pred term)))
  249. (set bfs-queue (lambda (q pred term)
  250.      (if (empty? q) '()
  251.        (if (pred (car (front q))) 'T
  252.         (if (term (car (front q))) (bfs-queue (rm-front q) pred term)
  253.          (bfs-queue (enqueue* (rm-front q) (cdr (front q)))
  254.                     pred term))))))
  255. (set reaches-bfs (lambda (p0 paths)
  256.      (bfs paths
  257.             (lambda (q) (== p0 q))
  258.             (lambda (q) (<< p0 q)))))
  259. (reaches-dfs '(4 6) PATHS)
  260. 'T
  261. (reaches-bfs '(4 3) PATHS)
  262. '()
  263. ; Section 5.7
  264. ;; The following is SCHEME code!!
  265. ;(set find-val (lambda (pred str failure-value)
  266. ;   (if (empty-stream? str) failure-value
  267. ;     (if (pred (head str)) (head str)
  268. ;       (find-val pred (tail str) failure-value)))))
  269. ;(set if2 (lambda (pred x y) (if (pred x) x y)))
  270. ;(set find-val (lambda (pred str failure-value)
  271. ;   (if (empty-stream? str) failure-value
  272. ;     (if2 pred (head str)
  273. ;       (find-val pred (tail str) failure-value)))))
  274. ;(set ones (cons 1 (lambda () ones)))
  275. ;(1 <closure>)
  276. ;(car ((cdr ones)))
  277. ;1
  278. ;(set flatten (lambda (l)
  279. ;     (if (null? l) '()
  280. ;         (if (atom? l) (list2 l (lambda () '()))
  281. ;             (append-str (flatten (car l))
  282. ;                         (lambda () (flatten (cdr l))))))))
  283. ;(set append-str (lambda (s1 s2)
  284. ;     (if (null? s1) (s2)
  285. ;          (list2 (car s1) (lambda () (append-str ((cadr s1)) s2))))))
  286. ;(set find-str (lambda (pred s)
  287. ;     (if (null? s) '()
  288. ;          (if (pred (car s)) (car s)
  289. ;               (find-str pred ((cadr s)))))))
  290. ;(set find-atom (lambda (pred l)
  291. ;      (find-str pred (flatten l))))
  292. ; Back to SASL
  293. ; Section 5.8
  294. (set TRUE (lambda (t f) t))
  295. (set FALSE (lambda (t f) f))
  296. (set IF (lambda (c t f) (c t f)))
  297. (IF TRUE 'a 'b)
  298. 'a
  299. (set EQ (lambda (x y) (if (= x y) TRUE FALSE)))
  300. (set fac (lambda (x) (IF (EQ x 0) 1 (* x (fac (- x 1))))))
  301. (fac 4)
  302. 24
  303. (set AND (lambda (x y) (IF x y x)))
  304. (set CONS (lambda (a d) (lambda (f) (f a d FALSE))))
  305. (set NIL (lambda (f) (f NIL NIL TRUE)))
  306. (set CAR (lambda (l) (l (lambda (car cdr null?) car))))
  307. (set CDR (lambda (l) (l (lambda (car cdr null?) cdr))))
  308. (set NULL? (lambda (l) (l (lambda (car cdr null?) null?))))
  309. (set CADR (lambda (x) (CAR (CDR x))))
  310. (CADR (CONS 'abc (CONS 3 NIL)))
  311. 3
  312. (set l1 (CONS 4 (CONS 5 (CONS 6 NIL))))
  313. (set +/ (lambda (l)
  314.        (IF (NULL? l) 0 (+ (CAR l) (+/ (CDR l))))))
  315. (+/ l1)
  316. 15
  317. (set ZERO (lambda (f) (lambda (x) x)))
  318. (set ONE (lambda (f) (lambda (x) (f x))))
  319. (set TWO (lambda (f) (lambda (x) (f (f x)))))
  320. (set print-int (lambda (n) ((n +1) 0)))
  321. (print-int TWO)
  322. 2
  323. (set +ONE (lambda (n) (lambda (g) (compose g (n g)))))
  324. (set PLUS (lambda (m n) (lambda (g) (compose (m g) (n g)))))
  325. (set THREE (PLUS ONE TWO))
  326. (print-int THREE)
  327. 3
  328. (set MULT (lambda (m n) (compose m n)))
  329. (set SIX (MULT THREE TWO))
  330. (print-int SIX)
  331. 6
  332. (set LIST2 (lambda (x y) (CONS x (CONS y NIL))))
  333. (set STEP (lambda (m-a) (LIST2 (CADR m-a) (+ONE (CADR m-a))))),
  334. (set -ONE (lambda (n) (CAR ((n STEP) (LIST2 ZERO ZERO)))))
  335. (set SUB (lambda (m n) ((n -ONE) m)))
  336. (set FOUR (SUB SIX TWO))
  337. (print-int FOUR)
  338. 4
  339. (set GT (lambda (m n) (NOT (=ZERO? (SUB m n)))))
  340. (set GE (lambda (m n) (=ZERO? (SUB n m))))
  341. (set EQUAL (lambda (m n)
  342.    (AND (=ZERO? (SUB m n)) (=ZERO? (SUB n m)))))
  343. (set uncurry (lambda (f) (lambda (x y) ((f x) y))))
  344. (set F (curry FALSE))
  345. (set =ZERO? (lambda (n)
  346.      (uncurry (lambda (y) ((n F) (lambda (x) y))))))
  347. (IF (=ZERO? ZERO) 'yes 'no)
  348. 'yes
  349. (IF (=ZERO? FOUR) 'yes 'no)
  350. 'no
  351. (set fac (lambda (n)
  352.      (IF (EQUAL n ZERO) ONE (MULT n (fac (SUB n ONE))))))
  353. (print-int (fac FOUR))
  354. 24
  355. (set FAC-STEP (lambda (x-y)
  356.      (LIST2 (-ONE (CAR x-y)) (MULT (CAR x-y) (CADR x-y)))))
  357. (set FAC (lambda (n) (CADR ((n FAC-STEP) (LIST2 n ONE)))))
  358. (print-int (FAC FOUR))
  359. 24
  360. (set W (lambda (F) (lambda (f) (F (f f)))))
  361. (set Y (lambda (F) ((W F) (W F))))
  362. (set ONES (Y (lambda (ones) (CONS ONE ones))))
  363. (print-int (CAR (CDR (CDR ONES))))
  364. 1
  365. (set FAC (Y (lambda (fac)
  366.      (lambda (n)
  367.           (IF (EQUAL n ZERO) ONE (MULT n (fac (SUB n ONE))))))))
  368. (print-int (FAC FOUR))
  369. 24
  370. quit
  371.