(let* ((x 6)
(y (* x x)))
(+ x y))
; => 42
((lambda (x)
((lambda (y)
(+ x y))
(* x x)))
6)
; => 42
(setf y '(1 2 3))
(list* 0 y)
; => (0 1 2 3)
(cons 0 y)
; => (0 1 2 3)
(list* y 4)
; => ((1 2 3) . 4)
(cons y 4)
; => ((1 2 3) . 4)
(list* y 4 5)
; => ((1 2 3) 4 . 5)
(cons y 4 5)
; => Evaluation aborted on #<SB-INT:SIMPLE-PROGRAM-ERROR "invalid number of arguments: ~S" {100427BF53}>
(defun dprint (x)
(cond
((atom x) (princ x))
(t
(princ "(")
(dprint (first x))
(pr-rest (rest x))
(princ ")"))))
(defun pr-rest (x)
(princ " . ")
(dprint x))
(dprint '(a b))
; => (A . (B . NIL))
(dprint '(a b c d))
; => (A . (B . (C . (D . NIL))))
演習3.3のdprint関数を用い、pr-rest関数を再定義する。
(defun pr-rest (x)
;; (null x) の返り値として nil を明示的に指定する
(cond ((null x) nil)
((atom x)
(princ " . ")
(princ x))
(t (princ " ")
(dprint (first x))
(pr-rest (rest x)))))
(dprint '(a b))
; => (A B)
(dprint '(a . b))
; => (A . B)
(dprint '(a b c d))
; => (A B C D)
(dprint '(a b c . d))
; => (A B C . D)
(defstruct node
name
(yes nil)
(no nil))
(defvar *db*
(make-node :name 'animal
:yes (make-node
:name 'mammal)
:no (make-node
:name 'vegetable
:no (make-node :name 'mineral))))
(setf *counter* 1)
(setf *limit* 20)
(defun questions (&optional (node *db*) (counter *counter*))
(cond
((< *limit* counter)
(format t "I have questioned ~A times, but I can't give the correct answer." *limit*)
(setf (node-no node) (give-up)
counter 1)
(t
(incf counter)
(format t "~&Is it a ~A? " (node-name node))
(case (read)
((y yes) (ask-next-question-or-get-answer node-yes node counter))
((n no) (ask-next-question-or-get-answer node-no node counter))
(it 'aha!)
(otherwise (format t "Reply with YES, NO, or IT if I have guessed it.")
(questions node counter))))))
(defmacro ask-next-question-or-get-answer (node-yes/no node count)
`(if (not (null (,node-yes/no ,node)))
(questions (,node-yes/no ,node) ,count)
(setf (,node-yes/no ,node) (give-up))))
(defun give-up ()
(format t "~&I give up - what is it? ")
(make-node :name (read)))
(setf a 'global-a)
(defvar *b* 'global-b)
(defun fn () *b*)
(let ((a 'local-a)
(*b* 'local-b))
(list a *b* (fn) (symbol-value 'a) (symbol-value '*b*)))
; => (LOCAL-A LOCAL-B LOCAL-B GLOBAL-A LOCAL-B)
(defun find-all (item sequence &rest keyword-args
&key (test #'eql) test-not &allow-other-keys)
"this function can be used with even KCL (Kyoto Common Lisp)."
(if test-not
(apply #'remove item sequence
:test-not (complement test-not)
;; (append keyword-args (list :test-not (complement test-not)))
`(,@keyword-args :test-not ,(complement test-not)))
(apply #'remove item sequence
:test (complement test)
;; (append keyword-args (list :test (complement test)))
`(,@keyword-args :test ,(complement test)))))
(setf nums '(1 2 3 2 1))
(find-all 1 nums :test #'= :key #'abs)
(defun remove-key-value (key list &optional (acc '()))
(if (member key list)
(let ((first (first list)))
(if (and (keywordp first) (eql key first))
(append (reverse acc) (remove-key-value key (cddr list)))
(remove-key-value key (cdr list) (cons first acc))))
list))
(defun find-all (item sequence &rest keyword-args
&key (test #'eql) test-not &allow-other-keys)
"this function can be used with even KCL (Kyoto Common Lisp)."
(let* ((my-test (cadr (member :test keyword-args)))
(my-test-not (cadr (member :test-not keyword-args)))
(test (if my-test my-test test))
(test-not (if my-test-not my-test-not test-not)))
(if test-not
(apply #'remove item sequence
:test-not (complement test-not) (remove-key-value :test-not keyword-args))
(apply #'remove item sequence
:test (complement test) (remove-key-value :test keyword-args)))))
(remove-key-value :test '(:foo 1 :test 2))
(remove-key-value :test '(:test 2 :piyo 3))
(remove-key-value :test '(:foo 1 :test 2 :piyo 3))
(remove-key-value :test '(:foo 1 :test 2 :piyo 3 :test 4 :bar 5))
(remove-key-value :testa '(:foo 1 :test 2 :piyo 3 :test 4 :bar 5))
(setf nums '(1 2 3 2 1))
(find-all 1 nums :test #'= :key #'abs)
(defun unique-plist (plist)
(labels
((rec (list acc)
(cond
((null list) acc)
((member (car list) acc :test #'equal)
(rec (cddr list) acc))
(t
(rec (cddr list)
(append acc (list (car list) (cadr list))))))))
(rec plist nil)))
(unique-plist '(:hoge foo :bar piyo :hoge bbb :bar aaa))
; => (:HOGE FOO :BAR PIYO)
(defun find-all-for-kcl (item sequence &rest keyword-args
&key (test #'eql) test-not &allow-other-keys)
(if test-not
(apply #'remove item sequence
(unique-plist (append (list :test-not (complement test-not)) keyword-args)))
(apply #'remove item sequence
(unique-plist (append (list :test (complement test)) keyword-args)))))
(defun length-r (list)
;; y の値は利用しない
(reduce (lambda (x y) (+ x 1))
list
;; :initial-balue ではなくて :initial-value
:initial-value 0))
(defun length-r (list)
(reduce #'+ list
;; 以下のように :key を指定すれば
;; (mapcar #'(lambda (x) 1) list) と同じことを行う
:key (lambda (x) 1)))
(describe 'lcm) (describe 'nreconc)
「3.1 Lisp スタイルガイド」にてacons関数が説明されている。
(defparameter a-list (acons 'foo 'bar nil)) a-list ; => ((FOO . BAR)) (acons 'piyo 'hoge a-list) ; => ((PIYO . HOGE) (FOO . BAR)) a-list ; => ((FOO . BAR))
(defparameter words '(this is a test))
(format t "~a" words)
; => (THIS IS A TEST)
(format t "~{~a~}" words)
; => THISISATEST
(format t "~{~a~^ ~}." words)
; => THIS IS A TEST.
(format t "~@(~{~a~^ ~}.~)" words)
; => This is a test.