HOME
Common Lisp
code
書き込む
|
HOME |
Common Lisp |
code |
書き込む |
自信の無いところもあります。 間違いなどが見つかりましたら 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)))))
;;反復
(defun ndots-rep (n)
(do ((i 0 (+ i 1))) ((= i n))
(format t ".")))
;;再帰
(defun ndots-rec (n)
(if (plusp n)
(progn
(format t ".")
(ndots-rec (- n 1)))))
;;反復
(defun a-rep (ls)
(do ((ls1 ls (cdr ls1))
(n 0 (+ n (if (eq (car ls1) 'a) 1 0))))
((not ls1) n)))
;;再帰
(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)))
(menber '(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)))))
;;別解
(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)))))
;; 別解
(defun list (&rest items)
items)
(defun length (ls)
(if ls
(+ 1 (length (car ls)))
0))
(defun menber (obj ls)
(if ls
(if (eql obj (cdr ls))
ls
(menbar 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 ")")))))
;;別解
(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))))))
ノート：
(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))
実行例:>(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)))))
;; bst を format t で降順に表示する
(defun show-bst(bst0)
(when bst0
(show-bst (node-r bst0))
(format t "~A " (node-elt bst0))
(show-bst (node-l bst0))))
;; 別解、降順のリストを返す。
(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)))
;; 反復
(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))))
;; 再帰
(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)) ;変更部分
(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) ;変更部分
(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))) ;変更部分
(aref vec start)) ;変更部分
(let ((mid (+ start (round (/ range 2)))))
(let ((obj2 (funcall key (aref vec mid)))) ;変更部分
(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)))))))) ;;変更部分
(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))) ;変更部分
(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)) ;変更部分、 "old" はベクトル
(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 ;変更部分
(eq c0 'all) ;変更部分
(and (eq c0 'word) (or (alpha-char-p c) (digit-char-p c))) ;変更部分
(and (eq c0 'number) (digit-char-p c)) ;変更部分
(char= c0 c)) ;変更部分
(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)))
ノート：
"FOO" 3 byte
'FOO 名前 3 byte
パッケージ 4 byte
変数 4 byte
関数 4 byte
属性リスト 4 byte
----------------------
計 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 '|:|)))
;; Henley かどうか？ 引数はファイル名
(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)))))
ノート：> (henley "original.txt" "henley1000.txt" 1000) ;original.txt をもとにして 1000 語からなる文章を作る。 NIL > (henley "original.txt" "henley100.txt" 100) ;original.txt をもとにして 100 語からなる文章を作る。 NIL > (henleyp "original.txt") ;original.txt を Henley が書いたか？ * = 5.4500003 sentences 1-11:****************** 11-21:******************* 21-32:******** 32-42:*** 42-54:* NIL ;No と判断 > (henleyp "henley100.txt") ;henley100.txt を Henley が書いたか？ * = 1.0 sentences 5-12:** 12-19:* 19-27: 27-34: 34-43:* ;やたら長い文が１つある。 T ;Yes と判断 > (henleyp "henley1000.txt") more than 60 words in one sentence. T ;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)))
ノート：> (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)))))
ノート：>(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)))))))))
ノート：p = a + k1(b - a) (0 &le k1 &le 1.0) q = c + k2(d - c) (0 &le k2 &le 1.0)線分 AB と CD が交わるためには p = q となることが必要。
(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))))))
ノート：
(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)))))
ノート：(defmacro nth-expr (n &body body) ; いまいち、実行時の処理がまったく減らない。 `(nth ,n (list ,@body))) (defun nth-expr (n &rest av) ; ”いまいち”の定義は関数で書いたのと変わらない。 (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))
())))
;; 別解
(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))ノート：
>(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) ;a b c を保持、 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 ;a b c はもとの値に戻る。 NIL
(defmacro push- (obj lst)
`(setf ,lst (cons ,obj ,lst)))
;; 本当の 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))))
;; 間違った 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))))
実行結果：> (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))(disassemble 'call-my-add)
1 (CALL1 0) ; MY-ADDまた、呼び出していない場合、my-add の名前は表示されない。 ちなみに、my-add のような小さい関数は default で inline されてしまうので、 inline されないようにするには、
(declaim (notinline my-add))と宣言する必要がある。
(defun foo-tail (x)
(labels ((rec (x sum)
(if (zerop x)
sum
(rec (1- x) (1+ sum)))))
(rec x 0)))
2倍ほど改善される。ちなみに、もともとの定義ではすぐに 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 |
書き込む |