HOME | Common Lisp | code |
I wrote answers for them to encourage you to solve the questions in the book. If any problem, please contact me (takafumi@shido.info).
(defun our-fourth (ls) (car (cdr (cdr (cdr ls)))))
(defun our-max (a b) (if (> a b) a b))
(defun nest-p (ls) (if ls (or (listp (car ls)) (nest-p (cdr ls)))))
;; repetition (defun ndots-rep (n) (do ((i 0 (+ i 1))) ((= i n)) (format t "."))) ;; recursion (defun ndots-rec (n) (if (plusp n) (progn (format t ".") (ndots-rec (- n 1)))))
;; repetition (defun a-rep (ls) (do ((ls1 ls (cdr ls1)) (n 0 (+ n (if (eq (car ls1) 'a) 1 0)))) ((not ls1) n))) ;; recursion (defun a-rec (ls) (if ls (+ (if (eq (car ls) 'a) 1 0) (a-rec (cdr ls))) 0))
(defun summit (lst) (apply #'+ (remove nil lst)))
(defun summit (lst) (if lst (+ (or (car lst) 0) (summit (cdr lst))) 0))
(defun new-union (a b) (let ((ra (reverse a))) (dolist (x b) (if (not (member x ra)) (push x ra))) (reverse ra)))
(defun occurrences (ls) (let ((acc nil)) (dolist (obj ls) (let ((p (assoc obj acc))) (if p (incf (cdr p)) (push (cons obj 1) acc)))) (sort acc #'> :key #'cdr)))
(member '(a) '((a) (b)) :test #'equal)
(defun pos+ (ls) (pos+rec ls 0)) (defun pos+rec (ls i) (if ls (cons (+ i (car ls)) (pos+rec (cdr ls) (+ i 1))))) ;;Alternative (defun pos+ (ls &optional (i 0)) ; we need an optional parameter (if ls (cons (+ i (car ls)) (pos+ (cdr ls) (+ i 1)))))
(defun pos+ (ls) (do ((ls1 ls (cdr ls1)) (i 0 (+ i 1)) (acc nil (cons (+ i (car ls1)) acc))) ((not ls1) (reverse acc))))
(defun pos+ (ls) (let ((i -1)) (mapcar #'(lambda (x) (+ x (incf i))) ls)))
(defun cons (x y) (let ((ls '(nil . nil))) (setf (cdr ls) x (car ls) y) ls))
(defun list (&rest items) (list-0 items)) (defun list-0 (ls) (if ls (cons (car ls) (list-0 (cdr ls))))) ;; Alternative (defun list (&rest items) items)
(defun length (ls) (if ls (+ 1 (length (car ls))) 0))
(defun member (obj ls) (if ls (if (eql obj (cdr ls)) ls (member obj (car ls)))))
(defun n-elts (elt n) (if (> n 1) (cons n elt) ;instead of (list n elt) elt))
(defun showdots (ls) (showdots-rec ls 0)) (defun showdots-rec (ls i) (if ls (progn (if (atom (car ls)) (format t "(~A . " (car ls)) (progn (format t "(") (showdots-rec (car ls) 0) (format t " . "))) (showdots-rec (cdr ls) (+ 1 i))) (progn (format t "NIL") (dotimes (j i) (format t ")"))))) ;; Alternative (defun showdots (ls) (format t "~A" (showdots-rec ls))) (defun showdots-rec (ls) (if ls (if (atom ls) ls (format nil "(~A . ~A)" (showdots-rec (car ls)) (showdots-rec (cdr ls))))))note:
(defparameter *net* '((a b c) (b a c) (c a b d) (d c))) (defun new-paths (path node net) (let (acc) (dolist (x (cdr (assoc node net))) (or (member x path) (push (cons x path) acc))) acc)) (defun bfs-l (end queue net sol) (if queue (let ((path (car queue))) (let ((node (car path))) (bfs-l end (append (cdr queue)(new-paths path node net)) net (if (eql node end) path sol)))) (reverse sol))) (defun longest-path (start end net) (bfs-l end (list (list start)) net nil))result of execution:
>(longest-path 'a 'd *net*) (a b c d)
(defun quarter-turn (a) (let ((d2 (array-dimensions a))) (let ((d (car d2)) (b (make-array d2))) (let ((c (/ (- d 1) 2))) (do ((i 0 (+ i 1))) ((= i d)) (do ((j 0 (+ j 1))) ((= j d)) (setf (aref b (+ (* -1 (- j c)) c) i ) (aref a i j))))) b)))
(defun copy-list (li) (reduce #'cons li :from-end t :initial-value nil))
(defun reverse (li) (reduce #'(lambda (x y) (cons y x)) li :initial-value nil))
(defstruct tst item left middle right)
(defun copy-tst (tst0) (if tst0 (make-tst :item (tst-item tst0) :left (copy-tst (tst-left tst0)) :middle (copy-tst (tst-middle tst0)) :right (copy-tst (tst-right tst0)))))
(defun find-tst (obj tst0) (if tst0 (or (eql obj (tst-item tst0)) (find-tst obj (tst-left tst0)) (find-tst obj (tst-middle tst0)) (find-tst obj (tst-right tst0)))))
;; show bst in descending order using format t. (defun show-bst(bst0) (when bst0 (show-bst (node-r bst0)) (format t "~A " (node-elt bst0)) (show-bst (node-l bst0)))) ;; Alternative, return a list of descending order (defun bst->list (bst0) (labels ((rec (bst1 acc) (if bst1 (rec (node-r bst1) (cons (node-elt bst1) (rec (node-l bst1) acc))) acc))) (rec bst0 nil)))
(defun alist->hash (al &key (test #'eql)) (let ((h (make-hash-table :test test))) (dolist (p al) (setf (gethash (car p) h) (cdr p))) h))
(defun hash->alist (h) (let ((acc nil)) (maphash #'(lambda (k v) (push (cons k v) acc)) h) acc))
((lambda (x) (cons x x)) (car y))
((lambda (w) ((lambda (y) (cons w y)) (+ w z))) (car x))
(defun mystery (x y) (cond ((null y) nil) ((eql (car y) x) 0) (t (let ((z (mystery x (cdr y)))) (and z (+ z 1))))))
(defun sq (x) (if (and (< 0 x 6) (integerp x)) x (* x x)))
(defun month-num (m y) (+ (case m (1 0) (2 31) (3 59) (4 90) (5 120) (6 151) (7 181) (8 212) (9 243) (10 273) (11 304) (12 334) (13 365)) (if (and (> m 2) (leap? y)) 1 0)))
(defun presedes (x v) (let (acc (v1 (concatenate 'vector v))) (dotimes (i (length v)) (if (and (eql x (svref v i)) (< 0 i)) (push (svref v (- i 1)) acc))) (remove-duplicates acc)))
;; repetition (defun intersperse (obj ls) (do ((ls1 (reverse (cdr ls)) (cdr ls1)) (ls2 nil (cons obj (cons (car ls1) ls2)))) ((not ls1) (cons (car ls) ls2)))) ;; recursion (defun intersperse (obj ls) (cons (car ls) (intersperse-rec obj (reverse (cdr ls)) nil))) (defun intersperse-rec (obj ls acc) (if ls (intersperse-rec obj (cdr ls) (cons obj (cons (car ls) acc))) acc))
(defun suc (ls) (let ((o (car ls))) (dolist (x (cdr ls) t) (if (= 1 (abs (- o x))) (setf o x) (return-from suc nil)))))
(defun suc (ls) (do ((ls1 (cdr ls) (cdr ls1)) (o (car ls) (car ls1))) ((not ls1) t) (if (/= 1 (abs (- o (car ls1)))) (return nil))))
(defun suc (ls) (block nil (let ((o (car ls))) (if (mapc #'(lambda (x) (if (= 1 (abs (- o x))) (setf o x) (return nil))) (cdr ls)) t))))
(defun extreme (v) (extreme-rec v 1 (length v) (svref v 0) (svref v 0))) (defun extreme-rec (v i n mn mx) (if (= i n) (values mn mx) (let ((x (svref v i))) (extreme-rec v (+ i 1) n (if (< x mn) x mn) (if (< mx x) x mx)))))
;;; use catch and throw (defun shortest-path (start end net) (if (eql start end) (list start) (catch 'found (bfs end (list (list start)) net)))) (defun bfs (end queue net) (if (null queue) nil (let* ((path (car queue)) (node (car path))) (bfs end (append (cdr queue) (new-paths path node net end)) net)))) (defun new-paths (path node net end) (mapcar #'(lambda (n) (let ((path1 (cons n path))) (if (eql n end) (throw 'found (reverse path1)) path1))) (cdr (assoc node net))))
(defun tokens-6-1 (str &key (test #'constituent) (start 0)) ;modified (let ((p1 (position-if test str :start start))) (if p1 (let ((p2 (position-if-not test str :start p1))) (cons (subseq str p1 p2) (if p2 (tokens-6-1 str :test test :start p2)))))))
(defun bin-search-6-2 (obj vec &key (key #'identity) (test #'eql) (start 0) end) ;modified (let ((len (or end (length vec)))) (and (not (zerop len)) (finder-6-2 obj vec start (- len 1) key test)))) (defun finder (obj vec start end key test) (let ((range (- end start))) (if (zerop range) (if (funcall test obj (funcall key (aref vec start))) ;modified (aref vec start)) ;modified (let ((mid (+ start (round (/ range 2))))) (let ((obj2 (funcall key (aref vec mid)))) ;modified (if (< obj obj2) (finder obj vec start (- mid 1) key test) (if (> obj obj2) (finder obj vec (+ mid 1) end key test) (aref vec mid)))))))) ;;modified
(defun n-av (&rest av) (length av))
(defun most2 (f ls) (cond ((not ls) (values nil nil)) ((not (cdr ls)) (values (car ls) nil)) (t (let* ((n1 (first ls)) (n2 (second ls)) (v1 (funcall f n1)) (v2 (funcall f n2))) (when (< v1 v2) (rotatef n1 n2) (rotatef v1 v2)) (dolist (o (nthcdr 2 ls)) (let ((vo (funcall f o))) (cond ((< v1 vo) (setf v2 v1 v1 vo n2 n1 n1 o)) ((< v2 vo) (setf v2 vo n2 o)) (t nil)))) (values n1 n2)))))
(defun remove-if-6-5 (f ls) (filter #'(lambda (x) (and (not (funcall f x)) x)) ls))
(let (mx) (defun max-so-far (n) (if (or (not mx) (< mx n)) (setf mx n) mx)))
(let (prev) (defun greater-p (n) (prog1 (and prev (< prev n)) (setf prev n))))
(let ((store (make-array 101))) (defun frugel (n) (or (svref store n) (setf (svref store n) (expensive n)))))
(defun apply8 (&rest av) (let ((*print-base* 8)) (apply #'apply av)))
(defun lines->list (file) (with-open-file (str file :direction :input) (do ((line (read-line str nil nil) (read-line str nil nil)) (acc nil (cons line acc))) ((not line) (nreverse acc)))))
(defun s->list (file) (with-open-file (str file :direction :input) (do ((s (read str nil nil) (read str nil nil)) (acc nil (cons s acc))) ((not s) (nreverse acc)))))
(defun remove-comments (fin fout &optional (cchar #\%)) (with-open-file (s-in fin :direction :input) (with-open-file (s-out fout :direction :output) (do ((line (read-line s-in nil nil) (read-line s-in nil nil))) ((not line)) (let ((cp (position cchar line))) (format s-out "~A~%" (if cp (subseq line 0 cp) line)))))))
(defun show-matrix (ar) (let ((size (array-dimensions ar))) (dotimes (i (first size)) (dotimes (j (second size)) (format t " ~10,2F" (aref ar i j))) (terpri))))
(defun stream-subst (old new in out) (let* ((pos 0) (len (length old)) (buf (new-buf len)) (from-buf nil)) (do ((c (read-char in nil :eof) (or (setf from-buf (buf-next buf)) (read-char in nil :eof)))) ((eql c :eof)) (cond ((or (char= #\+ (char old pos)) (char= c (char old pos))) ;modified (incf pos) (cond ((= pos len) ; 3 (princ new out) (setf pos 0) (buf-clear buf)) ((not from-buf) ; 2 (buf-insert c buf)))) ((zerop pos) ; 1 (princ c out) (when from-buf (buf-pop buf) (buf-reset buf))) (t ; 4 (unless from-buf (buf-insert c buf)) (princ (buf-pop buf) out) (buf-reset buf) (setf pos 0)))) (buf-flush buf out)))
;;; three wild cards; %w, %d, and %a are used. ;;; %a, all character ;;; %w, a-zA-Z and 0-9 ;;; %d, 0-9 ;;; %%, % itself (defun parse-pattern (pat) (labels ((rec (i n ctrl acc) (if (< i n) (let* ((c (char pat i)) (ctrl-next (and (not ctrl) (char= c #\%)))) (rec (1+ i) n ctrl-next (if ctrl-next acc (cons (if ctrl (case c (#\a 'all) (#\w 'word) (#\d 'digit) (#\% #\%)) c) acc)))) (concatenate 'vector (nreverse acc))))) (rec 0 (length pat) nil nil))) (defun stream-subst (pat new in out) (let* ((pos 0) (old (parse-pattern pat)) ;modified, "old" is a vector (len (length old)) (buf (new-buf len)) (from-buf nil)) (do ((c (read-char in nil :eof) (or (setf from-buf (buf-next buf)) (read-char in nil :eof)))) ((eql c :eof)) (let ((c0 (svref old pos))) (cond ((or ;modified (eq c0 'all) ;modified (and (eq c0 'word) (or (alpha-char-p c) (digit-char-p c))) ;modified (and (eq c0 'number) (digit-char-p c)) ;modified (char= c0 c)) ;modified (incf pos) (cond ((= pos len) ; 3 (princ new out) (setf pos 0) (buf-clear buf)) ((not from-buf) ; 2 (buf-insert c buf)))) ((zerop pos) ; 1 (princ c out) (when from-buf (buf-pop buf) (buf-reset buf))) (t ; 4 (unless from-buf (buf-insert c buf)) (princ (buf-pop buf) out) (buf-reset buf) (setf pos 0))))) (buf-flush buf out)))note:
"FOO" 3 byte 'FOO name 3 byte package 4 byte variable 4 byte function 4 byte attribute list 4 byte ---------------------- total 19 byte
(defpackage "LING" (:use "COMMON-LISP") (:export "BUF" "BREF" "NEW-BUF" "BUF-INSERT" "BUF-POP" "BUF-NEXT" "BUF-RESET" "BUF-CLEAR" "BUF-FLUSH")) (in-package ling)
(defpackage "FILE" (:use "COMMON-LISP" "LING")) (in-package file)
(defun terminal (sy) (or (eq sy '|.|) (eq sy '|!|) (eq sy '|?|) (eq sy '|:|))) ;; Is it written by Henley? The parameter is a file name. (defun henleyp (fi) (let ((buffer (make-string maxword)) (pos 0) (nwls nil) (nw 0)) (with-open-file (s fi :direction :input) (do ((c (read-char s nil :eof) (read-char s nil :eof))) ((eql c :eof)) (if (or (alpha-char-p c) (char= c #\')) (progn (setf (aref buffer pos) c) (incf pos)) (progn (unless (zerop pos) (incf nw) (setf pos 0)) (let ((p (punc c))) (when p (if (terminal p) (progn (push nw nwls) (setf nw 0)) (incf nw)))))))) (anal-cwlist nwls))) (defun hispos (x r mn n) (let ((p (truncate (- x mn) r))) (if (= p n) (- p 1) p))) (defun nstar (n) (make-string n :initial-element #\*)) (defun anal-cwlist (cwls) (let ((mx (apply #'max cwls)) (mn (apply #'min cwls)) (a (make-array 5 :initial-element 0))) (if (< 60 mx) (progn (format t "more than 60 words in one sentence.~%") t) (let ((r (/ (- mx mn) 5))) (dolist (x cwls) (incf (aref a (hispos x r mn 5)))) (let* ((j mn) (hmax (max (aref a 0) (aref a 1) (aref a 2) (aref a 3) (aref a 4))) (n* (/ hmax 20.0))) (format t "* = ~A sentences~%" (if (< n* 1.0) 1.0 n*) ) (dotimes (i 5) (format t "~2D-~2D:~A~%" (truncate j) (+ (truncate (incf j r)) (if (= i 4) 1 0)) (nstar (if (< n* 1.0) (aref a i) (truncate (/ (aref a i) n*))))))) (if (< (aref a 3) (aref a 4)) t nil)))))note:
> (henley "original.txt" "henley1000.txt" 1000) ;making a sentence with 1000 words from original.txt NIL > (henley "original.txt" "henley100.txt" 100) ;making a sentence with 100 words from original.txt NIL > (henleyp "original.txt") ;Does Henley write original.txt? * = 5.4500003 sentences 1-11:****************** 11-21:******************* 21-32:******** 32-42:*** 42-54:* NIL ;The function says No > (henleyp "henley100.txt") ;Does Henley write henley100.txt? * = 1.0 sentences 5-12:** 12-19:* 19-27: 27-34: 34-43:* ; There is a long sentence. T ; The program says Yes > (henleyp "henley1000.txt") more than 60 words in one sentence. T ;The program says Yes
(defvar *imin* 4) ;shortest sentence contains 9 words (defparameter *f-h* (make-hash-table :test #'eq)) ; a h-table for forward words (defparameter *b-h* (make-hash-table :test #'eq)) ; a h-table for backward words (defconstant mw 100) ;;; reading a sample text (defun read-text6 (f) (let ((p 0) (b (make-string mw))) (with-open-file (s f :direction :input) (do ((c (read-char s nil nil) (read-char s nil nil))) ((not c)) (if (or (alpha-char-p c) (char= c #\')) (setf (char b p) c p (1+ p)) (progn (when (plusp p) (see6 (intern (string-downcase (substring b 0 p)))) (setf p 0)) (let ((p (punc c))) (if p (see6 p))))))))) ;;; registration on hash teables (let ((prev '|.|)) (defun see6 (wsym) (pushnew wsym (gethash prev *f-h*)) (pushnew prev (gethash wsym *b-h*)) (setf prev wsym))) ; making a sentence (defun make-sen (w) (labels ((-show (&rest lss) (let ((i 0)) (dolist (ls lss) (dolist (x ls) (format t "~A " x) (if (zerop (mod (incf i) 8)) (terpri))))) (throw 'done nil)) (rec (b f i n) (if (< i n) (let ((b-next (gethash (car b) *b-h*)) (f-next (gethash (car f) *f-h*))) (if (and (< *imin* i) (member-if #'terminal b-next) (member-if #'terminal f-next)) (-show b (cdr (reverse f))) (dolist (b1 (remove-if #'terminal b-next)) (dolist (f1 (remove-if #'terminal f-next)) (rec (cons b1 b) (cons f1 f) (1+ i) n)))))))) (catch 'done (let ((ls (list (intern (string-downcase (symbol-name w)))))) (do ((n 10 (1+ n))) ((= n 30)) (rec ls ls 0 n)))))) (let (txt0) (defun funny-sen (txt word) (unless (equal txt0 txt) (clrhash *f-h*) (clrhash *b-h*) (read-text6 txt) (setf txt0 txt)) (make-sen word)))note:
> (funny-sen "original.txt" 'friend) programmers care about my friend robert and rest parameters NIL
(defun not-descending (ls) (not (apply #'>= ls)))
(defun coins(a) (labels ((rec (am coins ncoins) (if coins (multiple-value-bind (n r) (floor am (car coins)) (rec r (cdr coins) (cons n ncoins))) (nreverse (cons am ncoins))))) (rec a '(25 10 5) nil)))
(defun best10-10years () (labels ((rec (i n) (if (= i 10) n (rec (1+ i) (+ n (random 2)))))) (dotimes (i 10) (format t "~A " (rec 0 0)))))note:
>(best10-10years) 2 4 3 3 6 7 6 5 9 4 NIL >(best10-10years) 4 5 8 4 4 5 4 2 4 8 NIL >(best10-10years) 3 5 5 5 8 5 2 7 8 4 NIL >(best10-10years) 4 5 7 5 4 4 8 3 7 5 NIL
(defun isec (x1 y1 x2 y2 x3 y3 x4 y4) (let ((dx1 (- x2 x1)) (dy1 (- y2 y1)) (dx2 (- x4 x3)) (dy2 (- y4 y3)) (dx3 (- x3 x1)) (dy3 (- y3 y1))) (let ((d (- (* dx1 dy2) (* dx2 dy1)))) (unless (= d 0) (let ((k1 (/ (- (* dx3 dy2) (* dx2 dy3)) d)) (k2 (/ (- (* dx3 dy1) (* dx1 dy3)) d))) (if (and (<= 0 k1 1) (<= 0 k2 1)) (cons (+ x1 (* dx1 k1)) (+ y1 (* dy1 k1)))))))))note:
p = a + k1(b - a) (0 &le k1 &le 1.0) q = c + k2(d - c) (0 &le k2 &le 1.0)p = q is required to that segments AB and CD join each other.
(defun bisec (f min max epsilon) (let ((m (* 0.5 (+ min max)))) (if (< (- max min) epsilon) m (let ((fmin (funcall f min)) (fmax (funcall f max)) (fm (funcall f m))) (cond ((< 0 (* fmin fmax)) (error "wrong range")) ((= 0 fm) m) ((< 0 (* fmin fm)) (bisec f m max epsilon)) ((< 0 (* fmax fm)) (bisec f min m epsilon)) (t nil))))))note:
(defun horner (x &rest parms) (labels ((rec (parms acc) (if parms (rec (cdr parms) (+ (* acc x) (car parms))) acc))) (rec parms 0)))
> (log (1+ most-positive-fixnum) 2) 24
> most-positive-long-float 8.8080652584198167656L646456992 > most-positive-double-float 1.7976931348623157d308 > most-positive-single-float 3.4028235E38 > most-positive-short-float 1.7014s38
(defmacro cif (pred then else) `(cond (,pred ,then) (t ,else)))
(defmacro nth-expr (n &body body) (if (integerp n) (nth n body) `(case ,n ,@(let ((i -1)) (mapcar #'(lambda(x) `(,(incf i) ,x)) body)))))note:
(defmacro nth-expr (n &body body) ; bad answer `(nth ,n (list ,@body))) (defun nth-expr (n &rest av) ; "bad answer2 can be written as a function" (nth n av))
(defmacro ntimes (n &body body) (with-gensyms (gn grec) `(let ((,gn ,n)) (labels ((,grec (i) (when (< i ,gn) ,@body (,grec (1+ i))))) (,grec 0)))))
(defmacro n-of (n expr) (with-gensyms (gn gi gacc) `(do ((,gn ,n) (,gi 0 (1+ ,gi)) (,gacc nil (cons ,expr ,gacc))) ((= ,gi ,gn) (nreverse ,gacc)) ()))) ;; altertive (defmacro n-of (n expr) (let((grec (gensym))) `(labels ((,grec (i j acc) (if (= i j) (nreverse acc) (,grec (1+ i) j (cons ,expr acc))))) (,grec 0 ,n nil))))
(defmacro retain (parms &body body) `((lambda ,parms ,@body) ,@parms))note:
>(let ((a 0) (b 1) (c 2) (d 3)) > (format t "values before retain: a=~A, b=~A, c=~A, d=~A~%" a b c d) > (retain (a b c) ;retain a b c. not d. > (setf a (* a 10) > b (* b 10) > c (* c 10) > d (* d 10)) > (format t "values in retain: a=~A, b=~A, c=~A, d=~A~%" a b c d)) > (format t "values after retain: a=~A, b=~A, c=~A, d=~A~%" a b c d)) values before retain: a=0, b=1, c=2, d=3 values in retain: a=0, b=10, c=20, d=30 values after retain: a=0, b=1, c=2, d=30 ;values a b c becomes original NIL
(defmacro push- (obj lst) `(setf ,lst (cons ,obj ,lst))) ;; check the real push (defun test-push () (let ((a (make-array 3)) (i 0)) (setf (aref a 0) (list 0) (aref a 1) (list 1) (aref a 2) (list 2)) (push 4 (aref a (incf i))) (format t "~A ~A ~A~%" (aref a 0) (aref a 1) (aref a 2)))) ;; check the wrong push (defun test-push- () (let ((a (make-array 3)) (i 0)) (setf (aref a 0) (list 0) (aref a 1) (list 1) (aref a 2) (list 2)) (push- 4 (aref a (incf i))) (format t "~A ~A ~A~%" (aref a 0) (aref a 1) (aref a 2))))result:
> (test-push) (0) (4 1) (2) NIL > (test-push-) (0) (4 2) (2) NIL
(defclass rectangle () ((height :accessor rectangle-height :initarg :height :initform 0) (width :accessor rectangle-width :initarg :width :initform 0))) (defclass circle () ((radius :accessor circle-radius :initarg :radius :initform 0))) (defmethod area ((x rectangle)) (* (rectangle-width x) (rectangle-height x))) (defmethod area ((x circle)) (let ((*WARN-ON-FLOATING-POINT-CONTAGION* nil)) (* pi (expt (circle-radius x) 2))))
(defclass point () ((x :accessor x :initarg :x :initform 0) (y :accessor y :initarg :y :initform 0) (z :accessor z :initarg :z :initform 0))) (defclass surface () ((color :accessor surface-color :initarg :color))) (defclass sphere (surface) ((radius :accessor sphere-radius :initarg :radius :initform 0) (center :accessor sphere-center :initarg :center :initform (make-instance 'point :x 0 :y 0 :z 0)))) (defun defsphere (x y z r c) (let ((s (make-instance 'sphere :radius r :center (make-instance 'point :x x :y y :z z) :color c))) (push s *world*) s)) (defmethod intersect ((s sphere) (pt point) xr yr zr) (let* ((c (sphere-center s)) (n (minroot (+ (sq xr) (sq yr) (sq zr)) (* 2 (+ (* (- (x pt) (x c)) xr) (* (- (y pt) (y c)) yr) (* (- (z pt) (z c)) zr))) (+ (sq (- (x pt) (x c))) (sq (- (y pt) (y c))) (sq (- (z pt) (z c))) (- (sq (sphere-radius s))))))) (if n (make-instance 'point :x (+ (x pt) (* n xr)) :y (+ (y pt) (* n yr)) :z (+ (z pt) (* n zr)))))) (defmethod normal ((s sphere) (pt point)) (let ((c (sphere-center s))) (unit-vector (- (x c) (x pt)) (- (y c) (y pt)) (- (z c) (z pt)))))
(defun most-spec-app-meth (gfun av) (let ((classlist (mapcar #'precedence av))) (dolist (meth (method gfun)) (if (do ((i 0 (1+ i)) (spec (specialization meth) (cdr spec))) ((not spec) t) (or (member (car spec) (nth i classlist) :test #'equal) (return))) (return-from most-spec-app-meth meth)))))
(defvar *area-counter* 0) (defmethod area :before (obj) (declare (ignore obj)) (incf *area-counter*))
(let ((ele '(a))) (list ele ele ele))
(list (list 'a) (list 'a) (list 'a))
(let ((ele '(a))) (list (copy-list ele) ele ele))
(defun copy-queue (q0) (let ((q1 (make-queue))) (setf (car q1) (copy-list (car q0)) (cdr q1) (last (car q1))) q1))
(defun pushqueue (obj q) (setf (car q) (cons (obj) (car q))))
(defun move-front (obj q) (let ((ls (car q))) (setf (car q) (if (member obj ls) (cons obj (remove obj ls)) ls) (cdr q) (last (car q)))) (car q))
(defun in-circule (obj ls) (labels ((rec (ls1) (if ls1 (cond ((eql obj (car ls1)) t) ((eq ls (cdr ls1)) nil) (t (rec (cdr ls1))))))) (rec ls)))
(defun cdr-circular-p (ls) (labels ((rec (ls1) (if ls1 (or (eq (cdr ls1) ls) (rec (cdr ls1)))))) (rec ls)))
(defun car-circular-p (ls) (eq ls (car ls)))
(declaim (inline my-add)) (defun my-add (n) (+ n 1)) (defun call-my-add (n) (my-add n))and call
1 (CALL1 0) ; MY-ADDOtherwise, my-add is not appeared in the info. In the case of clist, small functions like my-add are inlined by default. To prohibit it, you have to declare like:
(declaim (notinline my-add))
(defun foo-tail (x) (labels ((rec (x sum) (if (zerop x) sum (rec (1- x) (1+ sum))))) (rec x 0)))It get twice faster. In addition, original deffinition causes a stack overflow.
(defmacro with-type (type expr) (or (leave-it expr) `(the ,type ,(if (atom expr) expr (expand-call type (binarize expr)))))) (eval-when (:compile-toplevel :load-toplevel) (defun leave-it (expr) (if (atom expr) (if (symbolp expr) (if (char= #\? (char (symbol-name expr) 0)) expr) expr))) (defun expand-call (type expr) `(,(car expr) ,@(mapcar #'(lambda (a) `(with-type ,type ,a)) (cdr expr)))) (defun binarize (expr) (if (and (nthcdr 3 expr) (member (car expr) '(+ - * /))) (destructuring-bind (op a1 a2 . rest) expr (binarize `(,op (,op ,a1 ,a2) ,@rest))) expr)))
(defconstant qsize 100) (defvar *net* '((a b c) (b c) (c d))) (let ((qs 0) (qe 1) (qv (make-array qsize))) (defun shortest-path (start end net) (setf (svref qv 0) (list start)) (bfs end net)) (defun bfs (end net) (if (= qs qe) nil (let ((path (svref qv (mod qs qsize)))) (let ((node (car path))) (if (eql node end) (reverse path) (progn (incf qs) (new-paths path node net) (bfs end net))))))) (defun new-paths (path node net) (dolist (n (cdr (assoc node net))) (setf (svref qv (mod qe qsize)) (cons n path)) (incf qe))))
HOME | Common Lisp | code |