fork download
copy 
  1. ; Expression evaluators - Compose function f and g?
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 8
  5. ; Exercise 5
  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 fapply (f x)
  57.   (cond
  58.    ((null f) NIL)
  59.    ((null x) NIL)
  60.    ((and (rel? f) (atom x))
  61.     (cond
  62.      ((eq (first (car f)) x) (second (car f)))
  63.      (t (fapply (cdr f) x))))
  64.    (t NIL)))
  65.  
  66. (defun fcomp-pair (rel1 pair)
  67.   (cond
  68.    ((null rel1) '())
  69.    ((null pair) NIL)
  70.    ((and (rel? rel1) (pair? pair))
  71.     (cond 
  72.      ((not (null (fapply rel1 (second pair))))
  73.       (build (first pair) (fapply rel1 (second pair))))
  74.      (t NIL)))
  75.    (t NIL)))
  76.  
  77. (fcomp-pair '((a b)(c d)) '(a c))
  78. ;(a d)
  79.  
  80. (fcomp-pair '((a b)(c d)) '(a b))
  81. ;NIL
  82.  
  83. (defun fcomp (rel1 rel2)
  84.   (cond
  85.    ((null rel1) '())
  86.    ((null rel2) NIL)
  87.    ((and (rel? rel1) (rel? rel2))
  88.     (cond
  89.      ((not (null (fapply rel1 (second (car rel2)) )))
  90.       (cons (fcomp-pair rel1 (car rel2))
  91.             (fcomp rel1 (cdr rel2))))
  92.      (t (fcomp rel1 (cdr rel2)))))
  93.    (t NIL)))
  94.  
  95. (print (second (car '((b c)(d e)))))
  96. ;C
  97.  
  98. (print (fapply  '((a b)(c d)) 'c))
  99. ;D
  100.  
  101. (print (fapply '((a b)(c d)) (second (car '((b c)(d e))))))
  102. ;D
  103.  
  104. (print (fcomp '((y z)) '((x y))))
  105. ; ((X Z))
  106.  
  107. (print (fcomp '((b c)(d e)) '((a b)(c d))))
  108. ;((A C) (C E))
  109.  
  110. (print (fcomp f1 f4))
  111. ;NIL
  112.  
  113. (print (fcomp f1 f3))
  114. ;NIL
  115.  
  116. (print (fcomp f4 f1))
  117. ;((A $) (D $))
  118.  
  119. (print (fcomp f4 f3))
  120. ;((B $))
  121.  
Success #stdin #stdout 0.01s 10840KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/vEwoI
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!