fork download
copy 
  1. ; Expression evaluators - Is your expression transitive?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 9
  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.  
  55. (defun subset? (set1 set2)
  56.   (cond
  57.    ((null set1) t)
  58.    ((member_ (car set1) set2)
  59.     (subset? (cdr set1) set2))
  60.    (t NIL)))
  61.  
  62.  
  63. (defun union_ (set1 set2)
  64. ;  (print 'union_)
  65. ;  (print set1)
  66. ;  (print set2)
  67.   (cond
  68.    ((null set1) set2)
  69.    ((member_ (car set1) set2) ;member?
  70.     (union_ (cdr set1) set2)) ; union_
  71.    (t (cons (car set1)
  72.             (union_ (cdr set1) set2))))) ;union_
  73.  
  74. (union_ '(tomatoes and marcaroni casserole) '(marcaroni and cheese))
  75. ;(TOMATOES CASSEROLE MARCARONI AND CHEESE)
  76.  
  77.  
  78. (defun first_ (l)
  79.   (cond
  80.    ((null l) '())
  81.    (t (car l))))
  82.  
  83. (defun second_ (l)
  84.   (cond
  85.    ((null l) '())
  86.    (t (car (cdr l)))))
  87.  
  88. (defun third_ (l)
  89.   (cond
  90.    ((null l) '())
  91.    (t (car (cdr (cdr l))))))
  92.  
  93. (defun pair? (lat)
  94.   (cond
  95.    ((null lat) NIL)
  96.    ((atom lat) NIL)
  97.    ((and (and (not (eq (first_ lat) NIL))
  98.               (not (eq (second_ lat) NIL))))
  99.     (eq (third_ lat) NIL))
  100.    (t NIL)))
  101.  
  102. (defun rel? (rel)
  103.   (cond
  104.    ((null rel) t)
  105.    ((atom rel) NIL)
  106.    ((pair? (car rel))
  107.     (rel? (cdr rel)))
  108.    (t NIL)))   
  109.  
  110.  
  111. (defun rapply (rel x)
  112.   (cond
  113.    ((null rel) '())
  114.    ((null x) NIL)
  115.    ((and (rel? rel) (atom x))
  116.     (cond
  117.      ((eq (first_ (car rel)) x) 
  118.       (cons (second_ (car rel)) (rapply (cdr rel) x)))
  119.      (t (rapply (cdr rel) x))))
  120.    (t NIL)))
  121.  
  122. (defun lat? (l)
  123.   (cond
  124.    ((null l) t)
  125.    ((atom (car l)) (lat? (cdr l)))
  126.    (t nil)))
  127.  
  128. (defun build (a b)
  129.   (cons a (cons b '())))    
  130.  
  131. (defun rin (x set)
  132.   (cond
  133.    ((null x) NIL)
  134.    ((null set) '())
  135.    ((lat? set)
  136.     (cons (build x (car set))
  137.           (rin x (cdr set))))
  138.    (t NIL)))   
  139.  
  140. (defun rcomp (rel1 rel2)
  141.   (cond
  142.    ((null rel1) '())
  143.    (t (union_ ;'union_
  144.        (rin
  145.         (first_ (car rel1))
  146.         (rapply rel2 (second_ (car rel1))))
  147.        (rcomp (cdr rel1) rel2)))))   
  148.  
  149. (defun transitive? (rel)
  150.   (subset? (rcomp rel rel) rel))
  151.  
  152. (print (transitive? r1))
  153. ;T
  154.  
  155. (print (transitive? r3))
  156. ;T
  157.  
  158. (print (transitive? f1))
  159. ;T
  160.  
  161. ;non transitive relation
  162. (print (transitive? '((a b)(b d))))
  163. ;ie transforms to not nil and not something that is part of the parent relation
  164.  
Success #stdin #stdout 0.01s 10616KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
T 
T 
T 
NIL
https://ideone.com/xc8ps
language:
Common Lisp (clisp 2.49.92)
created:
14 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!