はじめに
平成29年8月3日出版開始の拙著「まったく初めての人のためのISLisp」に掲載されたISLispコードを再掲載します。電子書籍では画面が小さいために読みづらい場合があること、コピペのしやすさ、のためにここにコードを再掲載します。
再会
(defun tarai(x y z)
(if (<= x y)
y
(tarai (tarai (- x 1) y z)
(tarai (- y 1) z x)
(tarai (- z 1) x y))))
関数定義
(defun f->c (x)
(* (quotient 5 9) (- x 32)))
(defun c->f (x)
(+ (* (quotient 9 5) x) 32))
再帰定義
(defun fact (n)
(if (= n 0)
1
(* n (fact (- n 1)) )))
(defun fib (n)
(cond ((= n 0) 0)
((= n 1) 1)
(t (+ (fib (- n 1)) (fib (- n 2))) )))
(defun caaaar (x)
(car (car (car (car x)))))
(defun cddddr (x)
(cdr (cdr (cdr (cdr x)))))
(defun my-list (:rest x)
x)
(defun my-equal (x y)
(cond ((symbolp x) (eq x y))
((atom x) (eql x y))
((my-equal (car x) (car y))
(my-equal (cdr x) (cdr y)))))
my-listの補足説明
その前のlistの説明ではこれもconsと空リストを使っていますと言っておきながら上記のmy-listは使っていません。ここは説明不足でした。
引数が例えば2個に限定されていればmy-listは次のように定義できます。
(defun my-list (x y)
(cons x (cons y ()))
引数が3個なら次のようになります。
(defun my-list (x y z)
(cons x (cons y (cons z ()))))
このようにconsと空リストを使って定義できます。ところが不定個の引数となるとこのような定義ができません。ISLisp（Common Lispも）では :rest を引数の前につけるとその引数に全部の要素をリストにまとめたものが取り込まれることとなっています。これを利用したものです。
局所定義とスコープ
(defun fx1 (x) (expt (- x 1) 2))
(defun fy1 (y) (expt (- y 1) 2))
(defun fz1 (z) (expt (- z 1) 2))
(defun f (x y z)
(sqrt (+ (fx1 x) (fy1 y) (fz1 z))))
(defun f (x y z)
(let ((x1 (expt (- x 1) 2))
(y1 (expt (- y 1) 2))
(z1 (expt (- z 1) 2)))
(sqrt (+ x1 y1 z1))))
(defun f (x d)
(* (g d) x))
(defun g (d)
(cond ((= d 2) 80)
((= d 9) 80)
((= d 29) 80)
(t 100)))
(defun f (x d)
(flet ((g (d)
(cond ((= d 2) 80)
((= d 9) 80)
((= d 29) 80)
(t 100))))
(* (g d) x)))
(defun f (x d)
(labels ((g (d)
(cond ((= d 2) 80)
((= d 9) 80)
((= d 29) 80)
(t 100))))
(* (g d) x)))
(defun fact (n)
(flet ((fact1 (m)
(if (= m 0)
1
(* m (fact1 (- m 1))))))
(fact1 n)))
(defun f (x d)
(flet ((g ()
(cond ((= d 2) 80)
((= d 9) 80)
((= d 29) 80)
(t 100))))
(* (g) x)))
スコープとクロージャ
(defglobal bar 1)
(defun foo (x)
(flet ((boo (y)
x))
(setq bar boo)))
高階関数
(defun f (ls)
(if (null ls)
nil
(cons (* (car ls) 2) (f (cdr ls)))))
(defun f (ls)
(if (null ls)
nil
(cons (* (car ls) 3) (f (cdr ls)))))
(defun f (n ls)
(if (null ls)
nil
(cons (* (car ls) n) (f n (cdr ls)))))
(defun f (g ls)
(if (null ls)
nil
(cons (funcall g (car ls)) (f g (cdr ls)))))
(defun g (op const)
(lambda (x) (funcall op x const)))
制御構造１
(defun fact (n)
(for ((i 1 (+ i 1))
(s 1 (* s i)))
((> i n) s)))
(defun fact (n)
(let ((i 1)
(s 1))
(while (<= i n)
(setq s (* s i))
(setq i (+ i 1)))
s))
(defun product (x)
(for ((ls x (cdr ls))
(s 1 (* s (car ls))))
((null ls) s)))
(defun product (x)
(block exit
(for ((ls x (cdr ls))
(s 1 (* s (car ls))))
((null ls) s)
(if (= (car ls) 0)
(return-from exit 0)))))
(defun fact (n)
(let ((i 1)
(s 1))
(block exit
(tagbody
loop
(if (> i n)
(return-from exit s))
(setq s (* s i))
(setq i (+ i 1))
(go loop)))))
制御構造２
(defun foo ()
(print "foo")
(catch 'tag
(boo)))
(defun boo ()
(print "boo")
(throw 'tag 1))
(defun foo ()
(print "foo")
(catch 'tag
(unwind-protect
(boo)
(print "kataduke"))))
(defun boo ()
(print "boo")
(throw 'tag 1))
同図像性
(defmacro inc (x)
`(setq ,x (+ ,x 1)))
二次方程式の解
(defun d (a b c)
(- (* b b) (* 4 a c)))
(defun solve (a b c)
(let ((d1 (d a b c)))
(cond ((< d1 0) nil)
((= d1 0)(quotient (- b)(* 2 a)))
((> d1 0)
(list (quotient (+ (- b)(sqrt d1)) (* 2 a))
(quotient (- (- b)(sqrt d1)) (* 2 a)))))))
(defun search (form start end)
(for ((n start (+ n 0.01)))
((> n end) t)
(if (nearp (funcall form n) 0)
(print n))))
(defun f (x)
(+ (* 2 x x) (* 3 x) -5))
(defun nearp (x y)
(and (< x (+ y 0.000001))
(> x (- y 0.000001))))
DNA暗号
(defun copy (x)
(cond ((null x) nil)
((eq (car x) 'A)
(cons 'U (copy (cdr x))))
((eq (car x) 'T)
(cons 'A (copy (cdr x))))
((eq (car x) 'G)
(cons 'C (copy (cdr x))))
((eq (car x) 'C)
(cons 'G (copy (cdr x))))))
(defun decode (x)
(decode1 x nil))
(defun decode1 (x switch)
(cond ((null x) nil)
(t (let* ((x1 (elt x 0))
(x2 (elt x 1))
(x3 (elt x 2))
(y (list x1 x2 x3)))
(cond ((and (equal y '(a u g))(null switch))
(cons 'begin (decode1 (cdr (cdr (cdr x))) t)))
((and (equal y '(a u g))(eq switch t))
(cons 'met (decode1 (cdr (cdr (cdr x))) switch)))
((equal y '(u u u))
(cons 'phe (decode1 (cdr (cdr (cdr x))) switch)))
((equal y '(u u c))
(cons 'ala (decode1 (cdr (cdr (cdr x))) switch))))))))
3文字とアミノ酸の対応表 （参考「DNAの構造とはたらき」ペレ出版）
3文字 アミノ酸 略号 3文字 アミノ酸 略号
U U U フェニル phe U A U チロシン tyr
U U C アラニン ala U A C チロシン thr
U U A ロイシン leu U A A ここまで end
U U G ロイシン leu U A G ここまで end
C U U ロイシン leu C A U ヒスチジン his
C U C ロイシン leu C A C ヒスチジン his
C U A ロイシン leu C A A グルタミン gln
C U G ロイシン leu C A G グルタミン gln
A U U イソロイシン ile A A U アスパラギン asn
A U C イソロイシン ile A A C アスパラギン asn
A U A イソロイシン ile A A A リジン lys
A U G メチオニン met A A G リジン lys
「ここから」 begin G A U アスパラギン酸 asp
G U U バリン val G A C アスパラギン酸 asp
G U C バリン val G A A グルタミン酸 glu
G U A バリン val G A G グルタミン酸 glu
G U G バリン val U G U システイン cys
U C U セリン ser U G C システイン cys
U C C セリン ser U G A ここまで end
U C A セリン ser U G G トリプトファン trp
U C G セリン ser C G U アルギニン arg
C C U プロリン pro C G C アルギニン arg
C C C プロリン pro C G A アルギニン arg
C C A プロリン pro C G G アルギニン arg
C C G プロリン pro A G U セリン ser
A C U スレオニン thr A G C セリン ser
A C C スレオニン thr A G A アルギニン arg
A C A スレオニン thr A G G アルギニン arg
A C G スレオニン thr G G U グリシン gly
G C U アラニン ala G G C グリシン gly
G C C アラニン ala G G A グリシン gly
G C A アラニン ala G G G グリシン gly
G C G アラニン ala
行列積
(defun mat* (x y)
(let ((m (create-array '(2 2))))
(for ((i 0 (+ i 1)))
((>= i 2) m)
(for ((j 0 (+ j 1)))
((>= j 2))
(for ((k 0 (+ k 1))
(val 0))
((>= k 2) (set-aref val m i j))
(setq val (+ val (* (aref x i k)
(aref y k j)))))))))
(defun mat* (x y)
(let* ((d1 (array-dimensions x))
(d2 (array-dimensions y))
(d1r (elt d1 0))
(d1c (elt d1 1))
(d2r (elt d2 0))
(d2c (elt d2 1))
(m (create-array (list d1r d2c))))
(if (not (= d1c d2r))
(error "size mismatch matrix" (list d1c d2r)))
(for ((i 0 (+ i 1)))
((>= i d1r) m)
(for ((j 0 (+ j 1)))
((>= j d2c))
(for ((k 0 (+ k 1))
(val 0))
((>= k d1c) (set-aref val m i j))
(setq val (+ val (* (aref x i k)
(aref y k j)))))))))
補足説明
forの局所変数のvalですが、初期値が与えられるだけで、アップデートの部分がありません。こういう使い方もいいことになっています。