fork download
copy 
  1. ; Expression evals - Is your expression partial order?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 10
  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 first_ (l)
  25.   (cond
  26.    ((null l) '())
  27.    (t (car l))))
  28.  
  29. (defun second_ (l)
  30.   (cond
  31.    ((null l) '())
  32.    (t (car (cdr l)))))
  33.  
  34. (defun third_ (l)
  35.   (cond
  36.    ((null l) '())
  37.    (t (car (cdr (cdr l))))))
  38.  
  39. (defun pair? (lat)
  40.   (cond
  41.    ((null lat) NIL)
  42.    ((atom lat) NIL)
  43.    ((and (and (not (eq (first_ lat) NIL))
  44.               (not (eq (second_ lat) NIL))))
  45.     (eq (third_ lat) NIL))
  46.    (t NIL)))
  47.  
  48. (defun rel? (rel)
  49.   (cond
  50.    ((null rel) t)
  51.    ((atom rel) NIL)
  52.    ((pair? (car rel))
  53.     (rel? (cdr rel)))
  54.    (t NIL)))
  55.  
  56. (defun eq-pair (pair-a pair-b)
  57.   (cond
  58.    ((null pair-a) NIL)
  59.    ((null pair-b) NIL)
  60.    ((atom pair-a) NIL)
  61.    ((atom pair-b) NIL)
  62.    ((not (pair? pair-a)) NIL)
  63.    ((not (pair? pair-b)) NIL)
  64.    ((and (eq (first_ pair-a) 
  65.              (first_ pair-b))
  66.          (eq (second_ pair-a)
  67.              (second_ pair-b))))
  68.    (t NIL)))
  69.  
  70. (defun member-pair? (pair rel)
  71.   (cond
  72.    ((null pair) t)
  73.    ((null rel) NIL)
  74.    ((not(pair? pair)) NIL)
  75.    ((not(rel? rel)) NIL)
  76.    ((eq-pair (car rel) pair) t)   
  77.    (t (member-pair? pair (cdr rel)))))
  78.  
  79. (defun member-rel? (rel1 rel2)
  80.   (cond
  81.    ((null rel1) t)
  82.    ((null rel2) NIL)
  83.    ((not (rel? rel1)) NIL)
  84.    ((not (rel? rel2)) NIL)
  85.    ((member-pair? (car rel1) rel2)    
  86.     (member-rel? (cdr rel1) rel2))
  87.    (t NIL)))
  88.  
  89. (defun build (a b)
  90.   (cons a (cons b '())))
  91.  
  92. (defun idrel (s)
  93.   (cond
  94.    ((null s) '())
  95.    (t (cons (build (car s) (car s))
  96.             (idrel (cdr s))))))
  97.  
  98. (defun makeset (lat)
  99.   (cond 
  100.    ((null lat) '())
  101.    ;((member? (car lat) (cdr lat))
  102.    ((member_ (car lat) (cdr lat))
  103.     (makeset (cdr lat)))
  104.    (t (cons (car lat)
  105.             (makeset (cdr lat))))))
  106.  
  107. (defun notatom (lat)
  108.   (not (atom lat)))
  109.  
  110. (defun flatten (lat acc)
  111.   (cond
  112.    ((null lat) acc)
  113.    ((notatom (car lat))
  114.     (flatten (car lat) (flatten (cdr lat) acc)))
  115.    (t (flatten (cdr lat) (cons (car lat) acc)))))                        
  116.  
  117. (defun domset (rel)
  118.   (cond
  119.    ((null rel) '())
  120.    (t (makeset (flatten rel '())))))            
  121.  
  122. (defun reflexive? (lat)
  123.   (cond
  124.    ((null lat) NIL)
  125.    (t (member-rel? (idrel (domset lat)) lat))))
  126.  
  127. (defun reflexive? (lat)
  128.   (cond
  129.    ((null lat) NIL)
  130.    (t (member-rel? (idrel (domset lat)) lat))))
  131.  
  132.  
  133. (defun member* (a l)
  134.   (cond
  135.    ((null l) NIL)
  136.    ((atom (car l))
  137.     (or
  138.      (eq (car l) a)
  139.      (member* a (cdr l))))
  140.    (t (or 
  141.        (member* a (car l))
  142.        (member* a (cdr l))))))
  143.  
  144. (defun eqlist? (l1 l2)
  145.   (cond
  146.    ((and (null l1) (null l2)) t)
  147.    ((or (null l1) (null l2)) NIL)
  148.    (t (and
  149.        (eq (car l1) (car l2))
  150.        (eqlist? (cdr l1) (cdr l2))))))
  151.  
  152. (defun member_ (lista listb)
  153.   (cond
  154.    ((null lista) t)
  155.    ((null listb) NIL)
  156.    ((atom listb)
  157.     (eq lista listb))
  158.    ((atom lista)
  159.     (member* lista listb))
  160.    ((eqlist? lista listb) t)
  161.    (t (or (member_ lista (car listb))
  162.        (member_ lista (cdr listb))))))
  163.  
  164. (defun subset? (set1 set2)
  165.   (cond
  166.    ((null set1) t)
  167.    ((member_ (car set1) set2)
  168.     (subset? (cdr set1) set2))
  169.    (t NIL)))
  170.  
  171.  
  172. (defun union_ (set1 set2)
  173.   (cond
  174.    ((null set1) set2)
  175.    ((member_ (car set1) set2) 
  176.     (union_ (cdr set1) set2)) 
  177.    (t (cons (car set1)
  178.             (union_ (cdr set1) set2))))) 
  179.  
  180. (defun rapply (rel x)
  181.   (cond
  182.    ((null rel) '())
  183.    ((null x) NIL)
  184.    ((and (rel? rel) (atom x))
  185.     (cond
  186.      ((eq (first_ (car rel)) x) 
  187.       (cons (second_ (car rel)) (rapply (cdr rel) x)))
  188.      (t (rapply (cdr rel) x))))
  189.    (t NIL)))
  190.  
  191. (defun lat? (l)
  192.   (cond
  193.    ((null l) t)
  194.    ((atom (car l)) (lat? (cdr l)))
  195.    (t nil)))
  196.  
  197. (defun rin (x set)
  198.   (cond
  199.    ((null x) NIL)
  200.    ((null set) '())
  201.    ((lat? set)
  202.     (cons (build x (car set))
  203.           (rin x (cdr set))))
  204.    (t NIL)))   
  205.  
  206. (defun rcomp (rel1 rel2)
  207.   (cond
  208.    ((null rel1) '())
  209.    (t (union_ ;'union_
  210.        (rin
  211.         (first_ (car rel1))
  212.         (rapply rel2 (second_ (car rel1))))
  213.        (rcomp (cdr rel1) rel2)))))   
  214.  
  215. (defun transitive? (rel)
  216.   (subset? (rcomp rel rel) rel))      
  217.  
  218. (defun quasi-order? (rel)
  219.   (and (reflexive? rel) (transitive? rel)))
  220.  
  221. (print (quasi-order? r1))
  222. ;T
  223.  
  224. (print (quasi-order? r3))
  225. ;NIL false
  226.  
  227. (defun intersect (set1 set2)
  228.   (cond
  229.    ((null set1) '())
  230.    ((not (member_ (car set1) set2))
  231.     (intersect (cdr set1) set2))
  232.    (t (cons (car set1)
  233.             (intersect (cdr set1) set2)))))
  234.  
  235. (defun revrel (rel)
  236.   (cond
  237.    ((null rel) '())
  238.     (t (cons 
  239.        (build
  240.         (second_ (car rel));_
  241.         (first_ (car rel)));_
  242.        (revrel (cdr rel))))))            
  243.  
  244. (defun antisymetric? (rel)
  245.   (subset? (intersect (revrel rel) rel) (idrel (domset rel))))
  246.  
  247. (defun partial-order? (rel)
  248.   (and (quasi-order? rel) (antisymetric? rel)))
  249.  
  250. (print (partial-order? r1))
  251. ;T
  252.  
  253. (print (partial-order? r3))
  254. ;NIL false
  255.  
  256. (defun eqset? (set1 set2)
  257.   (and
  258.    (subset? set1 set2)
  259.    (subset? set2 set1)))
  260.  
  261.  
  262. (defun symmetric? (rel)
  263.   (eqset? rel (revrel rel)))
  264.  
  265. (defun equivalence? (rel)
  266.   (and (quasi-order? rel) (symmetric? rel)))
  267.  
  268. (print (equivalence? r1))
  269. ;NIL false
  270.  
  271. (print (equivalence? r2))
  272. ;T
  273.  
Success #stdin #stdout 0.01s 10648KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
T 
NIL 
T 
NIL 
NIL 
T
https://ideone.com/KNRM6
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!