fork download 
  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 build (a b)
  67.   (cons a (cons b '())))   
  68.  
  69. (defun fcomp-pair (rel1 pair)
  70.   (cond
  71.    ((null rel1) '())
  72.    ((null pair) NIL)
  73.    ((and (rel? rel1) (pair? pair))
  74.     (cond 
  75.      ((not (null (fapply rel1 (second_ pair))))
  76.       (build (first_ pair) (fapply rel1 (second_ pair))))
  77.      (t NIL)))
  78.    (t NIL)))
  79.  
  80. (fcomp-pair '((a b)(c d)) '(a c))
  81. ;(a d)
  82.  
  83. (fcomp-pair '((a b)(c d)) '(a b))
  84. ;NIL
  85.  
  86. (defun fcomp (rel1 rel2)
  87.   (cond
  88.    ((null rel1) '())
  89.    ((null rel2) NIL)
  90.    ((and (rel? rel1) (rel? rel2))
  91.     (cond
  92.      ((not (null (fapply rel1 (second (car rel2)) )))
  93.       (cons (fcomp-pair rel1 (car rel2))
  94.             (fcomp rel1 (cdr rel2))))
  95.      (t (fcomp rel1 (cdr rel2)))))
  96.    (t NIL)))
  97.  
  98. (print (second (car '((b c)(d e)))))
  99. ;C
  100.  
  101. (print (fapply  '((a b)(c d)) 'c))
  102. ;D
  103.  
  104. (print (fapply '((a b)(c d)) (second (car '((b c)(d e))))))
  105. ;D
  106.  
  107. (print (fcomp '((y z)) '((x y))))
  108. ; ((X Z))
  109.  
  110. (print (fcomp '((b c)(d e)) '((a b)(c d))))
  111. ;((A C) (C E))
  112.  
  113. (print (fcomp f1 f4))
  114. ;NIL
  115.  
  116. (print (fcomp f1 f3))
  117. ;NIL
  118.  
  119. (print (fcomp f4 f1))
  120. ;((A $) (D $))
  121.  
  122. (print (fcomp f4 f3))
  123. ;((B $))
  124.  
Success #stdin #stdout 0.01s 10616KB
comments (?)
stdin 
Standard input is empty
stdout 
C 
D 
D 
((X Z)) 
((A C) (C E)) 
NIL 
NIL 
((A $) (D $)) 
((B $))
https://ideone.com/eCSso
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!