fork download
copy 
  1. ; Expression evaluators - Is this reflexive?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 2
  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 build (a b)
  25.   (cons a (cons b '())))
  26.  
  27. (defun idrel (s)
  28.   (cond
  29.    ((null s) '())
  30.    (t (cons (build (car s) (car s))
  31.             (idrel (cdr s))))))
  32.  
  33. (defun domset (rel)
  34.   (cond
  35.    ((null rel) '())
  36.    (t (makeset (flatten rel '())))))
  37.  
  38. (defun member? (a lat)
  39.   (cond
  40.    ((null lat) NIL)
  41.    (t (or
  42.        (eq (car lat) a)
  43.        (member? a (cdr lat))))))
  44.  
  45. (defun makeset (lat)
  46.   (cond 
  47.    ((null lat) '())
  48.    ((member? (car lat) (cdr lat))
  49.     (makeset (cdr lat)))
  50.    (t (cons (car lat)
  51.             (makeset (cdr lat))))))
  52.  
  53. (defun notatom (lat)
  54.   (not (atom lat)))
  55.  
  56. (defun flatten (lat acc)
  57.   (cond
  58.    ((null lat) acc)
  59.    ((notatom (car lat))
  60.     (flatten (car lat) (flatten (cdr lat) acc)))
  61.    (t (flatten (cdr lat) (cons (car lat) acc)))))
  62.  
  63. (idrel (domset r1))
  64. ;((A A) (B B))
  65.  
  66. (idrel (domset r2))
  67. ;((C C))
  68.  
  69. (idrel (domset r3))
  70. ;((A A) (C C) (B B))
  71.  
  72. (member? 'a '(a b c))
  73. ;T
  74.  
  75. (defun first_ (l)
  76.   (cond
  77.    ((null l) '())
  78.    (t (car l))))
  79.  
  80. (defun second_ (l)
  81.   (cond
  82.    ((null l) '())
  83.    (t (car (cdr l)))))
  84.  
  85. (defun third_ (l)
  86.   (cond
  87.    ((null l) '())
  88.    (t (car (cdr (cdr l))))))
  89.  
  90. (first_ '(a b))
  91. ;A
  92.  
  93. (second_ '(c d))
  94. ;D
  95.  
  96. (third_ '(a b c))
  97. ;C
  98.  
  99. (defun pair? (lat)
  100.   (cond
  101.    ((null lat) NIL)
  102.    ((atom lat) NIL)
  103.    ((and (and (not (eq (first_ lat) NIL))
  104.               (not (eq (second_ lat) NIL))))
  105.     (eq (third_ lat) NIL))
  106.    (t NIL)))
  107.  
  108. (pair? '(a b))
  109. ;T
  110.  
  111. (pair? 'a)
  112. ;NIL false
  113.  
  114. (pair? '(a b c))
  115. ;NIL false
  116.  
  117. (defun rel? (rel)
  118.   (cond
  119.    ((null rel) t)
  120.    ((atom rel) NIL)
  121.    ((pair? (car rel))
  122.     (rel? (cdr rel)))
  123.    (t NIL)))
  124.  
  125. (rel? '((a b)))
  126. ;T
  127.  
  128. (rel? '((a a)(a b)))
  129. ;T 
  130.  
  131. (rel? '(a b))
  132. ;NIL false
  133.  
  134. (rel? '((a b c)))
  135. ;NIL false
  136.  
  137. (rel? '((a b) c))
  138. ;NIL
  139.  
  140. (defun eq-pair (pair-a pair-b)
  141.   (cond
  142.    ((null pair-a) NIL)
  143.    ((null pair-b) NIL)
  144.    ((atom pair-a) NIL)
  145.    ((atom pair-b) NIL)
  146.    ((not (pair? pair-a)) NIL)
  147.    ((not (pair? pair-b)) NIL)
  148.    ((and (eq (first_ pair-a) 
  149.              (first_ pair-b))
  150.          (eq (second_ pair-a)
  151.              (second_ pair-b))))
  152.    (t NIL)))
  153.  
  154. (eq-pair '(a b) '(a b))
  155. ;T
  156.  
  157. (eq-pair '(a a) '(b b))
  158. ;NIL false
  159.  
  160. (eq-pair '(a b c) '(a b c))
  161. ;NIL false
  162.  
  163. (eq-pair '(a a) 'a)
  164. ;false
  165.  
  166. (defun member-pair? (pair rel)
  167.   (cond
  168.    ((null pair) t)
  169.    ((null rel) NIL)
  170.    ((not(pair? pair)) NIL)
  171.    ((not(rel? rel)) NIL)
  172.    ((eq-pair (car rel) pair) t)   
  173.    (t (member-pair? pair (cdr rel)))))
  174.  
  175. (member-pair? '(a b) '(a b c))
  176. ;NIL false
  177.  
  178. (member-pair? '(a d) '(a b c))
  179. ;NIL false
  180.  
  181. (member-pair? '(a a) '((a a)(a b)))
  182. ;T
  183.  
  184. (member-pair? '(a a) '((a b)(a a)))
  185.  
  186. (defun member-rel? (rel1 rel2)
  187.   (cond
  188.    ((null rel1) t)
  189.    ((null rel2) NIL)
  190.    ((not (rel? rel1)) NIL)
  191.    ((not (rel? rel2)) NIL)
  192.    ((member-pair? (car rel1) rel2)    
  193.     (member-rel? (cdr rel1) rel2))
  194.    (t NIL)))
  195.  
  196. (member-rel? '((a a)) '((a b)(a a)))
  197. ;T
  198.  
  199. (member-rel? '((a a)) '((a b)(a c)))
  200. ;NIL false
  201.  
  202. (member-rel? '((a)) '((a b)(a a)))
  203. ;NIL false
  204.  
  205. (member-rel? '((a)) '((a b)(a)))
  206. ;NIL false
  207.  
  208. (member-rel? '(a a) '((a b)(a a)))
  209. ;NIL false
  210.  
  211. (member-rel? '((a a)) '(a b))
  212. ;NIL false
  213.  
  214. (defun reflexive? (lat)
  215.   (cond
  216.    ((null lat) NIL)
  217.    (t (member-rel? (idrel (domset lat)) lat))))
  218.  
  219. (domset r1)
  220. ; (A B)
  221.  
  222. (idrel (domset r1))
  223. ; ((A A) (B B))
  224.  
  225. (member-rel? (idrel (domset r1)) r1)
  226. ;T 
  227.  
  228. (print (reflexive? r1))
  229. ;T
  230.  
  231. (print (reflexive? r2))
  232. ;T
  233.  
  234. (print (reflexive? r3))
  235. ;NIL false
  236.  
Success #stdin #stdout 0.01s 10624KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
T 
T 
NIL
https://ideone.com/eyGGv
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!