fork download 
  1. ; ycombinator - Apply this fn to this pair in the list
  2. ; ------------------------------
  3. ; The Little Lisper 3rd Edition
  4. ; Chapter 9
  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-9-lamdba-ultimate.html
  9. ; http://t...content-available-to-author-only...t.com/2010/06/little-lisper.html
  10. ; ------------------------------
  11.  
  12. (defun first_ (l)
  13.   (cond
  14.    ((null l) '())
  15.    (t (car l))))
  16.  
  17. (defun second_ (l)
  18.   (cond
  19.    ((null l) '())
  20.    (t (car (cdr l)))))
  21.  
  22. (defun third_ (l)
  23.   (cond
  24.    ((null l) '())
  25.    (t (car (cdr (cdr l))))))
  26.  
  27. (defun pair? (lat)
  28.   (cond
  29.    ((null lat) NIL)
  30.    ((atom lat) NIL)
  31.    ((and (and (not (eq (first_ lat) NIL))
  32.               (not (eq (second_ lat) NIL))))
  33.     (eq (third_ lat) NIL))
  34.    (t NIL)))
  35.  
  36. (defun eq-pair-first (pair-a-first pair-b)
  37.   (cond
  38.    ((null pair-a-first) NIL)
  39.    ((null pair-b) NIL)
  40.    ((not(atom pair-a-first)) NIL)
  41.    ((atom pair-b) NIL)
  42.    ((not (pair? pair-b)) NIL)
  43.    ((eq pair-a-first 
  44.              (first_ pair-b)))
  45.    (t NIL)))
  46.  
  47. (print (eq-pair-first 'a '(a b)))
  48. ;T
  49.  
  50. (print (eq-pair-first 'a '(b a)))
  51. ;NIL false
  52.  
  53.  
  54. (defun rel? (rel)
  55.   (cond
  56.    ((null rel) t)
  57.    ((atom rel) NIL)
  58.    ((pair? (car rel))
  59.     (rel? (cdr rel)))
  60.    (t NIL)))
  61.  
  62. (print (rel? '((a b)(a c)(a a))))
  63. ;T
  64.  
  65. (defun exists? (first rel)   
  66.   (cond
  67.    ((null first) t)
  68.    ((null rel) NIL)
  69.    ((not(rel? rel)) NIL)
  70.    ((eq-pair-first first (car rel)) t)   
  71.    (t (exists? first (cdr rel)))))
  72.  
  73. (print (exists? 'a '((a b)(a c)(a a))))
  74. ;T
  75.  
  76. (print (exists? 'd '((a b)(a c)(a a))))
  77. ;NIL false
  78.  
  79. (defun find-match (a l)
  80.   (cond
  81.    ((null a) '())
  82.    ((null l) NIL)
  83.    ((not(rel? l)) NIL)
  84.    ((eq-pair-first a (car l) ) (car l))   
  85.    (t (find-match a (cdr l)))))
  86.  
  87. (print (find-match 'a '((a b)(a c)(a a))))
  88. ;(A B)
  89.  
  90. (defun assq-sf (a l sk fk)
  91.   (cond
  92.    ((exists? a l)
  93.     (funcall sk (find-match a l)))
  94.    (t (funcall fk a))))
  95.  
  96. (defun build (a b)
  97.   (cons a (cons b '())))
  98.  
  99. (defun add1 (n) 
  100.   (+ 1 n))
  101.  
  102. (setf a 'apple)
  103. (setf b1 '())
  104. (setf b2 '((apple 1)(plum 2)))
  105. (setf b3 '((peach 3)))
  106. (setf sk (lambda (p)(build (first p) (add1 (second p)))))
  107. (setf fk (lambda  (name) (cons name (quote (not-in-list)))))
  108.  
  109. (print (assq-sf a b1 sk fk))
  110. ;(APPLE NOT-IN-LIST)
  111.  
  112. (print (assq-sf a b2 sk fk))
  113. ;(APPLE 2)
  114.  
  115. (print (assq-sf a b3 sk fk))
  116. ;(APPLE NOT-IN-LIST)
  117.  
Success #stdin #stdout 0.01s 10608KB
comments (?)
stdin 
Standard input is empty
stdout 
T 
NIL 
T 
T 
NIL 
(A B) 
(APPLE NOT-IN-LIST) 
(APPLE 2) 
(APPLE NOT-IN-LIST)
https://ideone.com/lUDEK
language:
Common Lisp (clisp 2.49.92)
created:
14 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!