fork(1) download
copy 
  1. ; Expression evals - Can you compose these relations?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 8
  6. ; Common Lisp
  7. ; http://t...content-available-to-author-only...r.com/thelittlelisper
  8. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper-chapter-8-friends-and.html
  9. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
  10. ; ------------------------------
  11. (setf r1 '((a b)(a a)(b b)))
  12. (setf r2 '((c c)))
  13. (setf r3 '((a c)(b c)))
  14. (setf r4 '((a b)(b a)))
  15. (setf f1 '((a 1)(b 2)(c 2)(d 1)))
  16. (setf f2 '())
  17. (setf f3 '((a 2)(b 1)))
  18. (setf f4 '((1 $)(3 *)))
  19. (setf d1 '(a b)) 
  20. (setf d2 '(c d))
  21. (setf x 'a)
  22. ; ------------------------------
  23.  
  24. (defun member* (a l)
  25.   (cond
  26.    ((null l) NIL)
  27.    ((atom (car l))
  28.     (or
  29.      (eq (car l) a)
  30.      (member* a (cdr l))))
  31.    (t (or 
  32.        (member* a (car l))
  33.        (member* a (cdr l))))))
  34.  
  35. (defun eqlist? (l1 l2)
  36.   (cond
  37.    ((and (null l1) (null l2)) t)
  38.    ((or (null l1) (null l2)) NIL)
  39.    (t (and
  40.        (eq (car l1) (car l2))
  41.        (eqlist? (cdr l1) (cdr l2))))))
  42.  
  43. (defun member_ (lista listb)
  44.   (cond
  45.    ((null lista) t)
  46.    ((null listb) NIL)
  47.    ((atom listb)
  48.     (eq lista listb))
  49.    ((atom lista)
  50.     (member* lista listb))
  51.    ((eqlist? lista listb) t)
  52.    (t (or (member_ lista (car listb))
  53.        (member_ lista (cdr listb))))))
  54.    ;(t NIL)))
  55.  
  56. (defun union_ (set1 set2)
  57. ;  (print 'union_)
  58. ;  (print set1)
  59. ;  (print set2)
  60.   (cond
  61.    ((null set1) set2)
  62.    ((member_ (car set1) set2) ;member?
  63.     (union_ (cdr set1) set2)) ; union_
  64.    (t (cons (car set1)
  65.             (union_ (cdr set1) set2))))) ;union_
  66.  
  67. (union_ '(tomatoes and marcaroni casserole) '(marcaroni and cheese))
  68. ;(TOMATOES CASSEROLE MARCARONI AND CHEESE)
  69.  
  70.  
  71. (defun first_ (l)
  72.   (cond
  73.    ((null l) '())
  74.    (t (car l))))
  75.  
  76. (defun second_ (l)
  77.   (cond
  78.    ((null l) '())
  79.    (t (car (cdr l)))))
  80.  
  81. (defun third_ (l)
  82.   (cond
  83.    ((null l) '())
  84.    (t (car (cdr (cdr l))))))
  85.  
  86. (defun pair? (lat)
  87.   (cond
  88.    ((null lat) NIL)
  89.    ((atom lat) NIL)
  90.    ((and (and (not (eq (first_ lat) NIL))
  91.               (not (eq (second_ lat) NIL))))
  92.     (eq (third_ lat) NIL))
  93.    (t NIL)))
  94.  
  95. (defun rel? (rel)
  96.   (cond
  97.    ((null rel) t)
  98.    ((atom rel) NIL)
  99.    ((pair? (car rel))
  100.     (rel? (cdr rel)))
  101.    (t NIL)))   
  102.  
  103.  
  104. (defun rapply (rel x)
  105.   (cond
  106.    ((null rel) '())
  107.    ((null x) NIL)
  108.    ((and (rel? rel) (atom x))
  109.     (cond
  110.      ((eq (first_ (car rel)) x) 
  111.       (cons (second_ (car rel)) (rapply (cdr rel) x)))
  112.      (t (rapply (cdr rel) x))))
  113.    (t NIL)))
  114.  
  115. (defun lat? (l)
  116.   (cond
  117.    ((null l) t)
  118.    ((atom (car l)) (lat? (cdr l)))
  119.    (t nil)))
  120.  
  121. (defun build (a b)
  122.   (cons a (cons b '())))    
  123.  
  124. (defun rin (x set)
  125.   (cond
  126.    ((null x) NIL)
  127.    ((null set) '())
  128.    ((lat? set)
  129.     (cons (build x (car set))
  130.           (rin x (cdr set))))
  131.    (t NIL)))   
  132.  
  133. (defun rcomp (rel1 rel2)
  134. ;  (print 'rcomp)
  135. ;  (print rel1)
  136. ;  (print  rel2)
  137.   (cond
  138.    ((null rel1) '())
  139.    (t (union_ ;'union_
  140.        (rin
  141.         (first_ (car rel1))
  142.         (rapply rel2 (second_ (car rel1))))
  143.        (rcomp (cdr rel1) rel2)))))
  144.  
  145. (print (rcomp '((a b)(b d)) '((a b)(b d))))
  146. ;((a d))
  147. (print (rcomp '((a b)(b d)) '((a b)(b d))))
  148. ;((a d))
  149.  
  150. (print (rcomp r1 r3))
  151. ;((A C) (A C) (B C))
  152.  
  153. (print (rcomp r1 f1))
  154. ;((A 2) (A 1) (B 2))
  155.  
  156. (print (rcomp r1 r1))
  157. ;((A B) (A A) (B B))
  158.  
Success #stdin #stdout 0.01s 10624KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
((A D)) 
((A D)) 
((A C) (B C)) 
((A 2) (A 1) (B 2)) 
((A B) (A A) (B B))
https://ideone.com/nOLNu
language:
Common Lisp (clisp 2.49.92)
created:
13 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!