Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2009-06-28

40年前のlisp 1.5のプログラムをCLで

| 04:46 | 40年前のlisp 1.5のプログラムをCLで - わだばLisperになる を含むブックマーク はてなブックマーク - 40年前のlisp 1.5のプログラムをCLで - わだばLisperになる

CiNiiを漁っていたところ40年前(1969年)の和田英一先生の『プログラムのページ』という記事をみつけました。

こちらの記事はLISP 1.5で書いてあり、M式での定義も載っていたりするのですが、LISP 1.5のプログラムはCLに簡単に直訳できるのでCLに訳してみました。

ちなみに記事の中の「プログラムフィーチャー」というのはPROGのことです。

(defun *abs (x)
  (cond ((< x 0) (- x))
        (T x)))

(defun poly (x coef)
  (cond ((null coef) 0)
        (T (+ (car coef)
              (* x (poly x (cdr coef)))))))

(defun deriv (coef)
  (prog (u v w)
        (setq u 1.0)
        (setq w (cdr coef))
      A (cond ((null w) (return v)))
        (setq v (append v (list (* u (car w)))))
        (setq w (cdr w))
        (setq u (1+ u))
        (go A)))

(defun newton (initi coef eps)
  (prog (delta max)
        (print '(value of function argument))
        (setq max 20)
      A (cond ((zerop max) (return 'NG)))
        (setq delta (- (/ (car (print (list (poly initi coef)
                                            initi)))
                          (poly initi (deriv coef)))))
        (setq initi (+ initi delta))
        (cond ((< (*abs delta) eps) (return initi)))
        (setq max (1- max))
        (go A)))

これでも良いのですが、折角なのでLISP 1.5のプログラムに見えるようにユーティリティを準備してみます。

;; LISP 1.5っぽくdefineを定義
(defun define (defs)
  (mapc (lambda (def)
          (destructuring-bind (name body) def
            (setf (symbol-function name) (coerce body 'function))))
        defs))

;; LISP 1.5っぽくエイリアスを定義
(setf (symbol-function 'minus) #'-
      (symbol-function 'plus) #'+
      (symbol-function 'times) #'*
      (symbol-function 'quotient) #'/
      (symbol-function 'add1) #'1+
      (symbol-function 'sub1) #'1-
      (symbol-function 'lessp) #'< )
;; LISP 1.5風に書き直してみる
(define (quote (
  (*abs (lambda (x)
          (cond ((minusp x) (minus x))
                (T x))))
  (poly (lambda (x coef)
          (cond ((null coef) 0)
                (T (plus (car coef)
                         (times x (poly x (cdr coef))))))))
  (deriv (lambda (coef)
           (prog (u v w)
                 (setq u 1.0)
                 (setq w (cdr coef))
               A (cond ((null w) (return v)))
                 (setq v (append v (list (times u (car w)))))
                 (setq w (cdr w))
                 (setq u (add1 u))
                 (go A))))
  (newton (lambda (initi coef eps)
            (prog (delta max)
                  (print (quote (value of function argument)))
                  (setq max 20)
                A (cond ((zerop max) (return (quote NG))))
                  (setq delta (minus (quotient (car (print (list (poly initi coef)
                                                           initi)))
                                               (poly initi (deriv coef)))))
                  (setq initi (plus initi delta))
                  (cond ((lessp (*abs delta) eps) (return initi)))
                  (setq max (sub1 max))
                  (go A)))))))

実行してみる

(newton -.4999999 '(.3000000e+01 -.26000000e+02 0 .1260000e+03) .1000000e-04)

(VALUE OF FUNCTION ARGUMENT) 
(0.2500062 -0.4999999) 
(-0.0025248528 -0.50364965) 
(-2.3841858e-7 -0.50361353)
;=> -0.50361353
(newton .4000000 '(.3000000e+01 -.26000000e+02 0 .1260000e+03) .1000000e-04)

(VALUE OF FUNCTION ARGUMENT) 
(0.66400075 0.4) 
(0.055171967 0.38074243) 
(5.283356e-4 0.37882653) 
(-4.7683716e-7 0.3788078)
;=> 0.37880784
(newton .1000000 '(.3000000e+01 -.26000000e+02 0 .1260000e+03) .1000000e-04)

(VALUE OF FUNCTION ARGUMENT) 
(0.526 0.1) 
(0.022853851 0.123672366) 
(5.9843063e-5 0.12480271)
;=> 0.12480568
(newton 0 '(.4000000e+01 0 .10000000e+01) .10000000e-07)

(VALUE OF FUNCTION ARGUMENT) 
(4.0 0) 
(#<SINGLE-FLOAT quiet NaN> #.SB-EXT:SINGLE-FLOAT-NEGATIVE-INFINITY) 
(#<SINGLE-FLOAT quiet NaN> #<SINGLE-FLOAT quiet NaN>) 
...
(#<SINGLE-FLOAT quiet NaN> #<SINGLE-FLOAT quiet NaN>)
;=>NG

40年前のプログラムがたったこれだけの手間で普通に動くとかLISPって移植性ばつ牛ン!!!