fork download
copy 
  1. ; Expression evaluators - Is this symmetric?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 3
  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. (member* 'chips '((potato) (chips ((with) fish) (chips))))
  36. ;T
  37.  
  38. (member* 'fries '((potato) (chips ((with) fish) (chips))))
  39. ;NIL false
  40.  
  41. (defun lat? (l)
  42.   (cond
  43.    ((null l) t)
  44.    ((atom (car l)) (lat? (cdr l)))
  45.    (t nil)))
  46. (lat? '(bacon (and eggs)))
  47. ;NIL
  48.  
  49. (lat? '(bacon and eggs))
  50. ;T
  51.  
  52. (defun eqlat? (lat1 lat2)
  53.   (cond
  54.    ((and
  55.     (null lat1)
  56.      (null lat2)) t)
  57.    ((null lat1) NIL)
  58.    ((null lat2) NIL)
  59.    ((not (lat? lat1)) NIL)
  60.    ((not (lat? lat2)) NIL)
  61.    ((eq (car lat1) (car lat2))
  62.         (eqlat? (cdr lat1) (cdr lat2)))
  63.    (t NIL)))
  64.  
  65. (eqlat? '(a b) '(a b))
  66. ;T
  67.  
  68. (eqlat? '(a b) '(a a))
  69. ;NIL false
  70.  
  71. (eqlat? '(a b) '(a b c))
  72. ;NIL false
  73.  
  74. (eqlat? '(a b) '(a (b)))
  75. ;NIL false
  76.  
  77. (defun non-atom? (a)
  78.   (not (atom a)))
  79.  
  80. (non-atom? 'a)
  81. ;NIL false
  82.  
  83. (non-atom? '(a))
  84. ;T
  85.  
  86. (defun eqlist? (l1 l2)
  87.   (cond
  88.    ((and (null l1) (null l2)) t)
  89.    ((or (null l1) (null l2)) NIL)
  90.    (t (and
  91.        (eq (car l1) (car l2))
  92.        (eqlist? (cdr l1) (cdr l2))))))
  93.  
  94. (eqlist? '((a b)(c d)) '((a b)(c d)))
  95. ;T
  96.  
  97. (eqlist? '((a b)(c d)) '((a b)(c e)))
  98. ;NIL false
  99.  
  100. (defun equal? (s1 s2)
  101.   (cond
  102.    ((and (atom s1) (atom s2))
  103.         (eq s1 s2))
  104.    ((and
  105.      (non-atom? s1)
  106.      (non-atom? s2))
  107.     (eqlist? s1 s2))
  108.     (t NIL)))
  109.  
  110. (equal? 'a 'a)
  111. ;T
  112.  
  113. (equal? '(a) '(a))
  114. ;T  
  115.  
  116. (defun member_ (lista listb)
  117.   (cond
  118.    ((null lista) t)
  119.    ((null listb) NIL)
  120.    ((atom listb)
  121.     (eq lista listb))
  122.    ((atom lista)
  123.     (member* lista listb))
  124.    ((eqlist? lista listb) t)
  125.    (t (or (member_ lista (car listb))
  126.        (member_ lista (cdr listb))))))
  127.    ;(t NIL)))
  128.  
  129. (member_ '((with) fish) '((potato) (chips ((with) fish) (chips))))
  130. ;T
  131.  
  132. (member_ '(chips) '((potato) (chips ((with) fish) (chips))))
  133. ;T
  134.  
  135. (member_ '((a a)) '((a b)(a a)))
  136. ;T
  137.  
  138. (member_ '((a c)) '((a b)(a a)))
  139. ;NIL false
  140.  
  141. (member_ '(a a) '((a b)(a a)))
  142. ;T
  143.  
  144. (defun subset? (set1 set2)
  145.   (cond
  146.    ((null set1) t)
  147.    ((member_ (car set1) set2)
  148.     (subset? (cdr set1) set2))
  149.    (t NIL)))
  150.  
  151. (subset? '(b) '(c b))
  152. ;T
  153.  
  154. (subset? '((a b)) '((a a)(a b)))
  155. ;T
  156.  
  157. (subset? '((a a)(a b)) '((a a)(a b)(a c)(a d)))
  158. ;T
  159.  
  160. (defun eqset? (set1 set2)
  161.   (and
  162.    (subset? set1 set2)
  163.    (subset? set2 set1)))
  164.  
  165. (eqset? '((a b)) '((a b)))
  166. ;T
  167.  
  168. (defun build (a b)
  169.   (cons a (cons b '())))
  170.  
  171. (defun revrel (rel)
  172.   (cond
  173.    ((null rel) '())
  174.     (t (cons 
  175.        (build
  176.         (second (car rel))
  177.         (first (car rel)))
  178.        (revrel (cdr rel))))))
  179.  
  180. (revrel '((a b)(c d)))
  181. ;((B A) (D C))
  182.  
  183. (revrel r1)
  184. ;((B A) (A A) (B B))
  185.  
  186. (defun symmetric? (rel)
  187.   (eqset? rel (revrel rel)))
  188.  
  189. (symmetric? r1)
  190. ;NIL false
  191.  
  192. (symmetric? r2)
  193. ;T
  194.  
  195. (symmetric? f2)
  196. ;T
  197.  
  198. (defun intersect (set1 set2)
  199.   (cond
  200.    ((null set1) '())
  201.    ((not (member_ (car set1) set2))
  202.     (intersect (cdr set1) set2))
  203.    (t (cons (car set1)
  204.             (intersect (cdr set1) set2)))))
  205.  
  206. (intersect '((a a)(a b)(b b)) '((a a)(b b)))
  207. ;((A A) (B B))
  208.  
  209. (intersect '(a b) '(a b c))
  210. ;(A B)
  211.  
  212. (defun idrel (s)
  213.   (cond
  214.    ((null s) '())
  215.    (t (cons (build (car s) (car s))
  216.             (idrel (cdr s))))))
  217.  
  218. (defun member? (a lat)
  219.   (cond
  220.    ((null lat) NIL)
  221.    (t (or
  222.        (eq (car lat) a)
  223.        (member? a (cdr lat))))))            
  224.  
  225. (defun makeset (lat)
  226.   (cond 
  227.    ((null lat) '())
  228.    ((member? (car lat) (cdr lat))
  229.     (makeset (cdr lat)))
  230.    (t (cons (car lat)
  231.             (makeset (cdr lat))))))
  232.  
  233. (defun notatom (lat)
  234.   (not (atom lat)))   
  235.  
  236. (defun flatten (lat acc)
  237.   (cond
  238.    ((null lat) acc)
  239.    ((notatom (car lat))
  240.     (flatten (car lat) (flatten (cdr lat) acc)))
  241.    (t (flatten (cdr lat) (cons (car lat) acc)))))
  242.  
  243. (defun domset (rel)
  244.   (cond
  245.    ((null rel) '())
  246.    (t (makeset (flatten rel '())))))            
  247.  
  248. (defun antisymetric? (rel)
  249.   (subset? (intersect (revrel rel) rel) (idrel (domset rel))))
  250.  
  251. (revrel r1)
  252. ;((B A) (A A) (B B))
  253.  
  254. (intersect (revrel r1) r1)
  255. ;((A A) (B B))
  256.  
  257. (antisymetric? r1)
  258. ;T
  259.  
  260. (antisymetric? r2)
  261. ;T
  262.  
  263. (antisymetric? r4)
  264. ;NIL false
  265.  
  266. (defun asymmetric? (rel)
  267.   (null (intersect rel (revrel rel))))
  268.  
  269. (print (asymmetric? r1))
  270. ;NIL false
  271.  
  272. (print (asymmetric? r2))
  273. ;NIL false
  274.  
  275. (print (asymmetric? r3))
  276. ;T
  277.  
  278. (print (asymmetric? r4))
  279. ;NIL false
  280.  
  281. (print (asymmetric? f1))
  282. ;T
  283.  
  284. (print (asymmetric? f2))
  285. ;T
  286.  
  287. (print (asymmetric? f3))
  288. ;T
  289.  
  290. (print (asymmetric? f4))
  291. ;T
  292.  
  293. ; assymetric - contains no matching pairs in the relation
  294. ; For all a and b in X, if a is related to b, then b is not related to a.
  295.  
  296.  
Success #stdin #stdout 0.01s 10640KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
NIL 
NIL 
T 
NIL 
T 
T 
T 
T
https://ideone.com/UjDsC
language:
Common Lisp (clisp 2.49.92)
created:
15 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!