#:g1

seriesで宿題を解く

Posted 2012-11-23 14:57:59 GMT

http://nojiriko.asia/prolog/c160_880_1_1.html の問題をseriesで解いてみよう

(in-package :cl-user)

(ql:quickload :series)

(import '(series:collect-sum series:scan-range series:scan-fn series:collect-length series:until-if) )

;; [1] 次の数列の第20項までの和を計算するプログラムを繰り返し処理を用いて作成せよ。
;;      5,10,15,20,・・・・

(defun a1 ()
  ;; seriesは繰り返しに展開されます…
  (collect-sum (scan-range :from 5 :by 5 :length 20)))

(a1) ;=> 1050

;;  [2] 次の数列の和を計算するプログラムを繰り返し処理を用いて作成せよ。
;;      0.2, 0.4, 0.6, ・・・・・,10.0(ただし、10.0は何項目か分からない事とする。
;;      プログラム内では何回繰り返しするか記述しない条件にする事とする)

(defun a2 ()
  ;; --- FIXME 誤差が出るので整数のストリームを作成して後で割る
  (/ (collect-sum (scan-range :from 2 :by 2 :upto 100))
     10.0))

(a2) ;=> 255.0

;;  [3]初日に1円、2日目に2円、3日目に4円というように
;;    前日の2倍の金額を貯金していったとき、貯金の合計金額が
;;     100万円を超えるのは何日目になるかを算出するプログラムを作成せよ

(defun a3 ()
  (+ 1 (collect-length 
        (scan-fn 'integer
                 (lambda () 1) 
                 (lambda (x) (* 2 x))
                 (lambda (x) (< 1000000 x))))))

(a3) ;=> 21


HTML generated by 3bmd in LispWorks 7.0.0

Sagittarius 0.3.8 インストールメモ

Posted 2012-11-16 16:08:00 GMT

Sagittariusで、SRFI 105が標準サポートされたらしいので早速インストール。
OS: Ubuntu Linux 12.4 x86_64

$ wget http://sagittarius-scheme.googlecode.com/files/sagittarius-0.3.8.tar.gz
$ tar xvf sagittarius-0.3.8.tar.gz
$ cd sagittarius-0.3.8/
$ cmake .
$ make
$ make test
$ make doc
$ make install

ドキュメンテーション: Sagittarius Users' Reference

fib.scm:
#!read-macro=curly-infix

(display (let fib ((n 10) (a1 1) (a2 0)) (cond {{n = 1} a1} {zero?(n) a2} {else fib({n - 1} {a1 + a2} a1)})))

sash> (load "fib.scm")
;>> 55
;=> #t
…SRFI-105の芳醇な香り…

関数をラッピングするだけというマクロの書法

Posted 2012-11-10 09:05:00 GMT

最近kernelのようなfexprを持つLisp方言で遊んでみていますが、fexprでマクロのようなものを書くにしても、ぎりぎりまで普通の関数で書き、それをfexprでラップするのが簡単なようです。例えば、dolistを書くとすると、まず、exprでdolist相当の物を書き、

($define! xdolist 
  ($lambda (lst body-fn result-fn)
    (for-each body-fn lst)
    ($if (null? result-fn)
         ()
         (result-fn))))

(xdolist (list 1 2 3 4) ($lambda (e) (display e) (newline)) ($lambda () #f)) ;>> 1 ;>> 2 ;>> 3 ;>> 4 ;=> #f

それをfexprでラップします
($define! $dolist 
 ($vau ((var lst . result) . body) env 
  (eval (list xdolist 
              lst
              (list* $lambda (list var) body)
                     (list $lambda ()
                     (list* $let (list (list var #f)) result)))
        env)))

($dolist (e (list 1 2 3 4) e) (display e) (newline)) ;>> 1 ;>> 2 ;>> 3 ;>> 4 ;=> #f

これと同じような感じで、マクロを書くとすると、
(declaim (inline xdolist))
(defun xdolist (list fn result-fn)
  (block nil
    (mapc fn list)
    (and result-fn (funcall result-fn))))

(defmacro *dolist ((var list &optional result) &body body) `(xdolist ,list (lambda (,var) ,@body) (and ,result (lambda (&aux (,var nil)) (declare (ignorable ,var)) ,result))))

のような感じになるかと思います。 遅そうですが、補助関数をインライン化しておけばマクロと変わらないので、やりようによっては、tagbodyに展開される標準のdolistと同じようにできるようです。
(defun foo (u &aux (ans 0))
  (declare (optimize (speed 3) (safety 0) (debug 0))
           (fixnum ans))
  (*dolist (e u ans) (declare (ignore e)) (incf ans)))

; disassembly for FOO (assembled 43 bytes) XOR ECX, ECX ; no-arg-parsing entry point JMP L1 NOP NOP L0: ADD RCX, 2 MOV RDX, [RDX+1] L1: CMP RDX, 537919511 JNE L0 MOV RDX, RCX MOV RSP, RBP CLC POP RBP RET

(defun bar (u &aux (ans 0))
  (declare (optimize (speed 3) (safety 0) (debug 0))
           (fixnum ans))
  (dolist (e u ans) (declare (ignore e)) (incf ans)))

; disassembly for BAR (assembled 43 bytes) XOR ECX, ECX ; no-arg-parsing entry point JMP L1 NOP NOP L0: MOV RDX, [RDX+1] ADD RCX, 2 L1: CMP RDX, 537919511 JNE L0 MOV RDX, RCX MOV RSP, RBP CLC POP RBP RET

SBCL場合は、mapcがコンパイラの変形によりtagbodyに展開されるので、色々あって同じアセンブリコードにになりました。(というかそのためにインライン化を使って調整したんですが)
andを書くとすると
(defun xand (&rest clauses)
  (prog ((cs clauses))
     L  (when (endp (cdr cs))
          (return (funcall (car cs))))
        (funcall (car cs))
        (pop cs)
        (go L)))

(defmacro *and (&rest args) `(xand ,@(mapcar (lambda (a) `(lambda () ,a)) args)))

(*and t (values nil 8)) ;=> NIL ; 8

こんな感じになるかと思います。

メリットとデメリット

  • メリット:
    • Nikodemus Siivola氏お勧めのスタイルであるCALL-WITH-*と大体同じで、再コンパイルしなくても良かったり、デバッグしやすかったり、です
      参照: random-state.net / Why I Like CALL-WITH-* Style In Macros (June 6th 2007)
    • マクロをfuncallしたいという場合、中身を取り出してfuncallすれば良い
    • テストが書きやすい
    • 機能はすべて関数に持たせ、マクロは見た目の調整だけとすることで評価方法に依存するような妙なマクロができにくい

  • デメリット:
    • コンパイラが賢くない場合、遅いコードになる
    • 補助関数でインライン化が必須なら再コンパイルしなくて良いというメリットが一つ潰れるのではないか

まとめ

ここまで書いてきてなんですが、簡単にまとめれば、Nikodemus Siivola氏のCALL-WITH-*をマクロでラップするというのを敷衍したものですね。

Clozure CLのLAPで遊んでみよう (1)

Posted 2012-10-30 13:09:00 GMT

Lispの処理系では昔からアセンブリをS式の表現で書いたLAP(Lisp Assembly Program)というのがあったりします。
特に決まった書式もなく処理系によって使われ方もまちまちですが、CCLだとdisassembleの結果とLAPで関数を定義するccl::defx86lapfunction(x86)の書式が似ているので、色々便利かなと思って、ちょっと試してみました。
とりあえず1を返す関数で実験

(in-package :ccl)

(defun retone () 1)

(disassemble 'ccl::retone)
→
L0
         (leaq (@ (:^ L0) (% rip)) (% fn))       ;     [0]
         (testl (% nargs) (% nargs))             ;     [7]
         (jne L29)                               ;     [9]
         (pushq (% rbp))                         ;    [11]
         (movq (% rsp) (% rbp))                  ;    [12]
         (movl ($ 8) (% arg_z.l))                ;    [15]
         (leaveq)                                ;    [20]
         (retq)                                  ;    [21]
L29
         (uuo-error-wrong-number-of-args)        ;    [29]
出てきたLAPをdefx86lapfunctionのフォームにコピペして、それらしきもので置き換えてみる
(defx86lapfunction ret1 ()
  (check-nargs 0)
  (pushq (% rbp))     
  (movq (% rsp) (% rbp))
  (movl ($ '1) (% arg_z.l))
  (leave)                  
  (single-value-return))
適当解説:
         (leaq (@ (:^ L0) (% rip)) (% fn))       ;     [0]
はなんかのおまじない。
         (testl (% nargs) (% nargs))             ;     [7]
は0かどうかをテストしてるっぽいのに加え引数周りっぽいので(check-nargs 0)で置き換え
         (leaveq)                                ;    [20]
leaveqは無いとコンパイラに怒られるので、leaveに変更
         (retq)                                  ;    [21]
retqはどうもsingle-value-returnあたりっぽいので置き換え、というところです。
という感じで、disassemble
(disassemble 'ccl::ret1)
→
L0
         (leaq (@ (:^ L0) (% rip)) (% fn))       ;     [0]
         (testl (% nargs) (% nargs))             ;     [7]
         (jne L29)                               ;     [9]
         (pushq (% rbp))                         ;    [11]
         (movq (% rsp) (% rbp))                  ;    [12]
         (movl ($ 8) (% arg_z.l))                ;    [15]
         (leaveq)                                ;    [20]
         (retq)                                  ;    [21]
L29
         (uuo-error-wrong-number-of-args)        ;    [29]

同じものができました!
以上、特に落ちもなく

京都での感動

Posted 2012-10-28 13:42:00 GMT

Lispマシン展示も感動が色々ありましたが、個人的な感動のハイライトは、Lispマシンの父であるGreenblatt氏にSkype越しではありますが、挨拶できたことです。
rg


今回の参加者である古参ハッカーのMcCulloughが、Lispマシンの会場を中継していた際に、日本の参加者に「ちょっと話してみたら」とMacを見せたのですが、そこにちらっとGreenblatt氏が写っていたのを発見し、「Greenblatt!?、Greenblatt!?、Greenblatt!?」と英語にもならない質問で訊ねてみたところ、「そうそう」ということなので感動でした。
自分は、「ワーーー!!、ワーーー!!、Nice to meet you!!、ウオーーーーーー!!」と叫びつつ手を振ってだけに等しいので、挨拶と思われてない気もしますが。
皆で集合写真を撮った直後位の出来事だったのですが、周りの人達は自分の異様なハイテンションに皆半笑いだったように思います(McCulloughさんは半笑いでした)

そんなMcCulloughさんは、MIT CSAIL Tape Archivesという歴史的なMITのコンピュータの遺産を保存しよう、というプロジェクトに関わってられるようです。ILCのLTでもこのことについて宣伝があったようです。興味のある方は是非打診してみられては如何でしょうか。

Greenblatt氏の功績をもっと紹介して自分がハイテンションになっていた理由を皆に伝えたいと思う秋の京都でした。

ILC 2012 Good Old Lisp Machines 顛末記

Posted 2012-10-28 13:05:00 GMT

10/21から10/24日にかけて、International Lisp Conference 2012 京都が開催されました。
ILC 2012では私のようなレトコンピューティング好きには堪らないLispマシンの展示がありました。今回自分はLispマシンの展示をするスタッフ側に回ることになったのですが、Lispマシン展示の顛末について簡単に書き残しておこうと思います。

そもそもの始まり 2010年秋

そもそもの始まりは、2010/11/27のShibuya.lisp 第6回 の懇親会で ILC の日本開催について話が出た時に発表者でもあった小出さんが、「もし日本でILCが開催されるなら保存しているInterlisp-Dの実機を展示したい」という提案に始まります。 この提案を聞いていた竹岡さんが「それだったら、うちのSymbolicsも展示する」という話になり、さらに同じく発表者の大野さんがELIS関係者だったため「もし開催されるならELISも展示できるに違いない」ということになり、この時はそうなったら良いねという話で終わりました。

ILC 2012の京都開催が決まる 2011年秋

それから1年後、以前から日本での開催を打診されていたILCが京都で開催されることが決定。
数理システムのLispセミナーでILC京都についてちょっとした発表がありました。セミナーに小出さんも参加されていたので、よしじゃあ展示を提案するぞ、という流れに。
そしてILC開催の告知と論文の投稿募集的なところへ小出さんが投稿。受理されてILC京都の催しとなりました。

Lispマシン出展準備 2012年春

ILCの展示が受理されたので、各方面に出展の再確認、Symbolics所有の竹岡さんはOK。ELIS方面も、大野さんに確認し、そこからJAIST 日比野先生にOKを頂き3機種が展示できることに。いよいよ動き始めました。

ILCでLispマシン展示 2012年秋

そんなこんなで準備も色々あり、遂に展示本番。
小出さんは、東京からFuji Xerox 1121AIW(Dandelion)を車で運搬。竹岡さんは京都からSymbolics 3620を持ち込んで頂き、ELIS 8100と8200シリーズは、JAISTの博物館から運搬されてくることに。

Dandelion 2台は残念ながら両方共マウスが上手く動かず、Symbolics 3620は起動はしたものの、何かが焼け焦げる匂いがしたため、これは危険!ということで残念ながら静態展示へ。ELISは、静態展示指定とのことだったのでこれも静態展示。

Xerox Dandelion x2
Symbolics 3620
ELIS 8100 & 8200

会場の風景写真は、ILC 2012 Good Old Lisp Machines から見ることができます。

まとめ

やはり実機を持ち込むというのはなかなか大変でしたが、これがLispマシンか!という若者もそれなりにいたり、海外の方からはSymbolics/Xeroxは知ってるけど、ELISとはどういうものだという質問がそれなりにあったりしました。もっとLispマシンや、ELISが海外でも認知されると面白いことになるかなーという手応えはありました。
ちょっとした提案から始まったILCでのLispマシンの展示ですが、端で話を聞いていた自分もまさか実現するとは思いませんでした。
企画とInterlisp-Dの実機を展示された小出さん、ELIS展示を快諾して頂いた日比野先生、大野さん、Symbolicsを展示して頂いた竹岡さん、その他、皆様にご支援頂き実現できたものだと思いました。 貴重な体験を与えて頂けたことに感謝させて頂きたいです。

Sagittarius 0.3.7 インストールメモ

Posted 2012-10-19 08:11:00 GMT

Sagittariusで、SRFI 49が標準サポートされたらしいので早速インストール。
OS: Ubuntu Linux 11.10 x86_64

$ wget http://sagittarius-scheme.googlecode.com/files/sagittarius-0.3.7.tar.gz
$ tar xvf sagittarius-0.3.7.tar.gz
$ cd sagittarius-0.3.7/
$ cmake .
$ make
$ make test
$ make doc
$ make install

ドキュメンテーション: Sagittarius Users' Reference

fib.scm:
#!reader=srfi/:49

display let fib ((n 10) (a1 1) (a2 0)) cond group = 1 n a1 group zero? n a1 group else fib (- n 1) (+ a1 a2) a1

sash> (load "fib.scm")
;>> 55
;=> #t
…SRFI-49の芳醇な香り…

S式dylanの処理系Thomasを動かす

Posted 2012-10-14 15:06:00 GMT

特に何かあったという訳でもないのですが、急にS式dylanの実装のであるThomasが最近の処理系で動かないかなと思って試してみたくなりました。
処理系のソースは、

から取得できます。
Thomasが書かれたのは、かなり昔で1992年辺りと20年前。20年前といえばSchemeもR4RSです。
Gambit、Scheme->C、MIT Scheme等で動いていたようですが、GambitがR4RSモードをサポートしているので、Gambitで試してみることにしました。
kits/gambitにある取説の通りに
(load "load-compiler")
としてみますが、色々エラーとなります。
とりあえず、ちょっとでも動けば良いので、適当に修正します。
;; kits/gambit/hash.scm:
(define ##weak-pair? pair?)
(define ##weak-cons cons)
(define ##weak-car car)
(define ##weak-cdr cdr)
(define ##weak-set-cdr! set-cdr!)

(define ##gc-finalize ; setup GC finalization for populations and 1d tables (lambda () (gc-all-populations!) (gc-oned-tables!)))

;; kits/gambit/poplat.scm: (define ##weak-cons cons) (define ##weak-car car) (define ##weak-cdr cdr) (define ##weak-set-cdr! set-cdr!)

;; kits/gambit/gambit-specific.scm: (define (implementation-specific:catch-all-errors handler thunk) ;(##catch-all (lambda (s args) (handler (make-condition s args))) thunk) (thunk))

implementation-specific:catch-all-errors がエラーをハンドリングしないのでエラーがあったら終了ですw
とりあえず動く位には修正したので実行してみます。
scheme-r4rsだけでなくscheme-r5rs、scheme-ieee-1178-1990、scheme-srfi-0でも一応動いてみたりはするようです。
kits/gambit/src $ scheme-r5rs load-thomas.scm -e '(thomas-rep)'
Loading common
Loading support
Loading comp
Loading comp-util
Loading compiler
Loading comp-method
Loading comp-class
Loading comp-sf
Loading comp-exc
Loading runtime
Loading class
Loading generic
Loading class-structure
Loading runtime-top
Loading runtime-internal
Loading runtime-methods
Loading runtime-functions
Loading runtime-bitstrings
Loading runtime-collections
Loading runtime-collections-iterate
Loading runtime-collections-generic1
Loading runtime-collections-generic2
Loading runtime-collections-array
Loading runtime-collections-deque
Loading runtime-collections-list
Loading runtime-collections-range
Loading runtime-collections-string
Loading runtime-collections-table
Loading runtime-collections-vector
Loading runtime-exceptions
Loading rep

Apply thomas-rep to start a Thomas read-eval-print loop.

Entering Thomas read-eval-print-loop. Exit by typing "thomas:done"

? (define-method fib ((n <integer>)) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))

;Value: fib

? (fib 3) (fib 3)

;Value: 2

? (fib 10) (fib 10)

;Value: 55

? (fib 20) (fib 20)

;Value: 6765

;; condで定義(else:を書きたいだけ) ? (define-method fib ((n <number>)) (cond ((< n 2) n) (else: (+ (fib (- n 2)) (fib (- n 1))))))

;Value: fib

? (define-class <foo> (<object>) x (y init-value: 0 init-keyword: y:))

;Value: <foo>

? (define-class <bar> (<foo>) (z init-function: (method () 333)))

;Value: <bar>

? (bind ((foo (make <foo> y: 8))) ((setter x) foo 3) (list (x foo) (y foo)))

;Value: (3 8)

? (z (make <bar>))

;Value: 333

そこそこ動くとはいえ、クラスのスロットにアクセスしたりすると壊れたりする場合があるので、色々修理が必要なようです
そういえば、上例の一番最初のfib位だと、Gaucheでも修正無しでそのまま動きます。

関連エントリー:

577@【入門】Common Lisp その9【質問よろず】

Posted 2012-10-11 14:57:59 GMT

577 名前:デフォルトの名無しさん [sage]: 2012/10/12(金) 02:28:41.73
Cormenのintroduction to algorrithmsのinsertion-sortをcommon lispで そのまま書いてみようとしたのですがうまく動きません 擬似コードは↓のノート中程にあります http://www.catonmat.net/blog/wp-content/uploads/2008/08/mit-algorithms-lecture-01-01.jpg これをもとに

(defun insertion-sort (a)
  (let (key i j)
    (do ((j 1 (+ j 1)))
        ((= j (length a)) a)
      (setf key (nth j a))
      (let ((i 0)
            (j 0))
        (loop
          when (and (> i 0)
                    (> (nth i a) key))
            do
         (setf (nth (+ i 1) a) (nth i a))
         (setf i 0
               j 0))
        (setf (nth i a) key))
      )
    a))

と書いて

(insertion-sort '(5 2 4 6 1 3))

で何も値が返ってきませんでした どこが間違っているのでしょうか

バグ修正

  1. 変数スコープの取り方がおかしいので修正
  2. whenじゃなくてwhile
  3. iをデクリメントしてないので追記(無限ループの原因)

(defun insertion-sort (a)
  (do ((j 1 (1+ j))
       (len (length a)) )
      ((>= j len) a)
    (let ((key (nth j a))
          (i (- j 1)) )
      (loop :while (and (>= i 0)
                        (> (nth i a) key) )
            :do (setf (nth (+ i 1) a) (nth i a))
                (decf i) )
      (setf (nth (+ i 1) a) key) )))

(insertion-sort '(5 2 4 6 1 3))
;=>  (1 2 3 4 5 6)

改善

このような処理で使うデータ型としてリストは不適切なのでベクタに変更 参考: http://google-styleguide.googlecode.com/svn/trunk/lispguide.xml?showone=Lists_vs.Arrays#Lists_vs.Arrays

;;; DO一色
(defun insertion-sort (a)
  (do ((j 1 (1+ j))
       (len (length a)) )
      ((>= j len) a)
    (do ((key (aref a j))
         (i (1- j) (1- i)) )
        ((not (and (>= i 0)
                   (> (aref a i) key) ))
         (setf (aref a (1+ i)) key) )
      (setf (aref a (1+ i)) (aref a i)) )))

;;; LOOP一色 (defun insertion-sort (a) (loop :for j :from 1 :below (length a) :for key := (aref a j) :for i := (1- j) :do (loop :while (and (>= i 0) (> (aref a i) key)) :do (setf (aref a (1+ i)) (aref a i)) (decf i) ) (setf (aref a (1+ i)) key)) a)

(mapcar #'insertion-sort
        (list (vector)
              (vector 1)
              (vector 2 1)
              (vector 9 8 7 6 5 4 3 2 1)))
;=>  (#() #(1) #(1 2) #(1 2 3 4 5 6 7 8 9))


HTML generated by 3bmd in LispWorks 7.0.0

values-list vs multiple-value-call

Posted 2012-09-30 14:57:59 GMT

mapしたものをvalues-listで返すのと、リストは作らないで多値を返す方法では、どっちが良いのか調べてみたかった。 多値が5つ位だったら、直接返してもコンスが少ないので元が取れるかも 多くなると、コンスは少ないけどかなり遅くなる

(defun values-map (fn list)
  (declare (function fn)
           (optimize (debug 1) (speed 3)))
  (if (endp list)
      (values)
      (multiple-value-call #'values
                           (funcall fn (car list))
                           (values-map fn (cdr list)))))

(defun values-map2 (fn list) (declare (function fn) (optimize (debug 1) (speed 3))) (values-list (mapcar fn list)))

(defvar *5-data*
  (srfi-1:iota 5))

(loop :repeat 100000 :do (values-map #'identity *5-data*)) ;⇒ NIL #|------------------------------------------------------------| Evaluation took: 0.036 seconds of real time 0.036002 seconds of total run time (0.036002 user, 0.000000 system) 100.00% CPU 87,716,718 processor cycles 0 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#

(loop :repeat 100000 :do (values-map2 #'identity *5-data*)) ;⇒ NIL #|------------------------------------------------------------| Evaluation took: 0.017 seconds of real time 0.020001 seconds of total run time (0.020001 user, 0.000000 system) 117.65% CPU 39,264,201 processor cycles 9,601,024 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#

(defvar *100-data*
  (srfi-1:iota 100))

(loop :repeat 100000 :do (values-map #'identity *100-data*)) ;⇒ NIL #|------------------------------------------------------------| Evaluation took: 2.183 seconds of real time 2.168135 seconds of total run time (2.168135 user, 0.000000 system) 99.31% CPU 5,226,740,100 processor cycles 0 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#

(loop :repeat 100000 :do (values-map2 #'identity *100-data*)) ;⇒ NIL #|------------------------------------------------------------| Evaluation took: 0.163 seconds of real time 0.160010 seconds of total run time (0.152009 user, 0.008001 system) [ Run times consist of 0.012 seconds GC time, and 0.149 seconds non-GC time. ] 98.16% CPU 388,223,343 processor cycles 161,615,360 bytes consed

Intel(R) Core(TM)2 Duo CPU P8600 @ 2.40GHz |------------------------------------------------------------|#


HTML generated by 3bmd in LispWorks 7.0.0

Older entries (1501 remaining)