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 |

2011-05-31

CLでSRFI-8

| 19:44 | CLでSRFI-8 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-8 - わだばLisperになる

今回は、SRFI-8 ですが、多値の束縛のための構文です。

素のR5RSだと多値関係は、call-with-valuesで

(call-with-values
  (lambda ()
    (partition (precedes pivot) others))
  (lambda (fore aft)
    (append (qsort fore) (cons pivot (qsort aft)))))

のように書くようですが、もっと簡単に書きたいということで、

(receive (fore aft) (partition (precedes pivot) others)
  (append (qsort fore) (cons pivot (qsort aft))))

に書けるようにするもののようです。

CLで定義する場合は、MULTIPLE-VALUE-BINDと同じなので、

(setf (macro-function 'receive)
      (macro-function 'multiple-value-bind))

のように定義するのが一番簡単です。

receiveという名前は短くて便利そうなのでエイリアスを作成している人はちらほらいるのかなと思ってgoogleコード検索してみましたが、意外なことにみつけられませんでした。

mvbindとかmbindはあるようですが…。

2011-05-30

CLでSRFI-62

| 16:12 | CLでSRFI-62 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-62 - わだばLisperになる

今回は、SRFI-62 S式1つ分のコメントです。

具体的にどんなものかというと

(list #; 1 2 3)
;=> (2 3)

のようなもので#;の後ろ1つだけをコメントとして扱うというものです。

CLのリーダーマクロ的には、式を1つ読んで無視すれば良いので簡単に作れます。

#;のように2文字で構成されるディスパッチ文字マクロでは、十進の引数が取れるのですが、もったいないのでSRFI-62の勝手な拡張として引数を使ってみることにしてみました。

#;は#1;の省略形で#;2は、次の2つの式を無視することになります。オーバーラップするとエラー

'(#2; a b #2;c d e)")
;=> (E)

割と便利な気もするんですが、デフォルトのSLIME上だと、;の方が勝ってしまうため、#;を意図通りに動作させるには若干の改造が必要かなと思います。

2011-05-29

'T と () は劣悪なパッケージ環境でも平気

| 17:09 | 'T と () は劣悪なパッケージ環境でも平気 - わだばLisperになる を含むブックマーク はてなブックマーク - 'T と () は劣悪なパッケージ環境でも平気 - わだばLisperになる

以前にも書いたMacLISPのコードに散見される誰かのスタイルですが、どうでも良いメリットを発見したのでメモしておきます。

そのメリットとは、'Tも () リードマクロが関係するために劣悪なパッケージ環境にも強いということです!

(make-package :foo :use nil)

(in-package :foo)

(cl:when '()
  "foo!")
;=> COMMON-LISP:NIL

(cl:when 'nil
  "foo!")
;=> "foo!"

(cl:when t
  "foo!")
;>>> error

(cl:when 't
  "foo!")
;=> "foo!"

(cl:when (quote ())
  "foo!")
;>>> error

(cl:when (quote nil)
  "foo!")
;>>> error

(cl:when (quote t)
  "foo!")
;>>> error

CLでSRFI-16

| 16:12 | CLでSRFI-16 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-16 - わだばLisperになる

今回は、SRFI-16 case-lambdaです。

拡張されていないSchemeにはCLでのラムダリスト的なものはなく、手短に書きたい時などのために簡便な方法が色々と考えられているようです。

case-lambdaは引数のパターンをcaseで判断してボディを実行するというもの。

(setf (symbol-function (intern (reverse (string 'arg-length))))
      (case-lambda ((x) 1)
                   ((x y) 2)
                   (args :many)))
;=> #<FUNCTION (LAMBDA (&REST #:G1)) {10174EF339}>

(htgnel-gra 1)
;=> 1

(htgnel-gra 1 2)
;=> 2

(htgnel-gra 1 2 3)
;=> :MANY

(htgnel-gra 1 2 3 4)
;=> :MANY

あまり見掛けない気もするので、検索してみたらcase-lambda自体の定義が殆どでした。

あまり使い勝手が良さそうでもないので、人気がないのかもしれません。

2011-05-27

CLでSRFI-61

| 21:32 | CLでSRFI-61 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-61 - わだばLisperになる

SRFI-87で、=> が出てきたので、今回は、その流れで、SRFI-61です。

Schemeのcondでは、=>が使えるのは前回も書きましたが、それにガード節を加えたものがSRFI-61です。

このガード節を上手く使うことによって色々できます。

(shadowing-import 'srfi-61:cond)

(let ((alist '((a . 1) (b . 2) (c . 3))))
  (cond ((assoc 'a alist) #'values :=> #'cdr)
        (:else nil)))
;=> 1

(let ((alist '((a . 1) (b . 2) (c . 3))))
  (cond ((assoc 'z alist) #'values :=> #'cdr)
        (:else nil)))
;=> NIL

今回もキーワードは、キーワードシンボルで書くことにしてみました。

シンボルの衝突を考えなくて良いのでキーワードにしておくとやっぱり楽かなと思います。

2011-05-26

CLでSRFI-87

| 21:13 | CLでSRFI-87 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-87 - わだばLisperになる

簡単そうなところからSRFIを移植していますが、今回は、SRFI-87です。

Schemeのcondでは、=>が使えて、述語が真ならば=>で指定した関数をその結果に適用できたりします。

SRFI-87は、それをcaseにも導入してみよう、というところです。

(shadowing-import 'srfi-87:case)

(case 1
  ((1 2 3 4) :=> #'values)
  ((5 6 7) (print '(5 6 7)))
  (:else :=> #'list))
;=> 1

(case 5
  ((1 2 3 4) :=> #'values)
  ((5 6 7) (print '(5 6 7)))
  (:else :=> #'list))
;->
;   (5 6 7)
;=> (5 6 7)

(case 8
  ((1 2 3 4) :=> #'values)
  ((5 6 7) (print '(5 6 7)))
  (:else :=> #'list))
;=> (8)

移植について

今回もdefine-syntaxにはmbeを利用しています。

元のSchemeのものを知っている方は、おや、と思うところがあると思いますが、シンボルのインポートがらみで、=>とelseが他のパッケージとぶつかったりすると混ぜて使うのが面倒になりそうなので、キーワードにしてしまいました。

2011-05-25

CLでSRFI-98

| 21:19 | CLでSRFI-98 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-98 - わだばLisperになる

なんとなくぼんやりとSRFIを移植していますが、今回は、moshのhigepon氏でおなじみのSRFI-98です。

CLではget-environment-variableはGETENVという名前で大抵の処理系にあり、get-environment-valiablesは、ENVIRONMENTのような名前で存在することが多いようです。

使い方は、

(use-package :srfi-98)

(get-environment-variable "SHELL")
;=> "/usr/bin/zsh"

(get-environment-variables)
;=> (("STY" . "1896.pts-0.setq") ("TERM" . "vt100")
;   ......

のようなところ。

CLのGETENVの場合、SETFメソッドも付いてくることが多いのでついでに拡張してみました

(setf (get-environment-variable "FOO") "1234")

(get-environment-variable "FOO") 
;=> "1234"

2011-05-24

PRINT-OBJECTでfortune

| 22:04 | PRINT-OBJECTでfortune - わだばLisperになる を含むブックマーク はてなブックマーク - PRINT-OBJECTでfortune - わだばLisperになる

closure-htmlなどでは、オブジェクトの印字で、#.(foo ... #|comment|#)のようなものが返ってくるのですが、どういう仕掛けでリードマクロがはいったものを返してくるんだろうと不思議に思っていました。

Twitterでつぶやいていたら、print-objectでやってるんじゃないか、とのアドバイスをもらい、早速試してみたのですが、なるほど印字表現を工夫するだけで同様のことができます。

良く良く考えてみれば、#<... >もリーダーマクロです。

ということで、記念にどうでも良い機能を盛り込んだものを作成。インスタンスが評価されるたびにfortuneが実行されます。

もちろんオブジェクトの実体は印字表現とは別個のものなので変数にも普通に格納できます。

(ql:quickload :kmrcl)

(defclass foo () ())

(defmethod print-object ((obj foo) stream)
  (format stream
          "#| ~A |#~%#.(make-instance 'foo)"
          (kl:string-trim-whitespace  
            (kl:command-output "/usr/games/fortune"))))

(defvar *foo* (make-instance 'foo))

*foo*
=> #| It is a wise father that knows his own child.
   		-- William Shakespeare, "The Merchant of Venice" |#
   #.(make-instance 'foo)
=> #| A man was reading The Canterbury Tales one Saturday morning, when his
   wife asked "What have you got there?"  Replied he, "Just my cup and Chaucer." |#
   #.(make-instance 'foo)
=> #| Try to get all of your posthumous medals in advance. |#
   #.(make-instance 'foo)

CLでSRFI-2

| 21:58 | CLでSRFI-2 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-2 - わだばLisperになる

なんとなくSRFI全部を移植してみたくなってきた今日この頃ですが今回は、SRFI-2です。

and-let*はたまに使いたくなります。

使い方は、

(use-package :srfi-2)

(and-let* ((pair (assoc 'a '((b . 2)
                             (a . 1)))))
  (cdr pair))
;=> 1

位のところでしょうか。もっと色々できます。

似たようなところでは、アナフォリックマクロのAAND等があります。

暗黙に束縛されるITのような変数は気持ち悪い、という場合は、and-let*が良いのではないでしょうか。

2011-05-22

CLでSRFI-5

| 13:24 | CLでSRFI-5 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-5 - わだばLisperになる

SRFIにはLET系の拡張提案は多いようですが、SRFI-5は、名前付きLETの提案で、2種類の書法があるようです。

一つは良くみる形式ですが、もう一つはあまり見掛けません。

なんのためにCLに移植するのかは自分でも良く分かりませんが、移植することにしてみました。

SRFI-5だと下のような書き方ができます。

(shadowing-import 'srfi-5:let)

(let fib ((n 10))
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

(let (fib (n 10))
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

最初のものはいつもの名前付きLETですが、2番目は、括弧の位置が違います。

(define fib (lambda (n) ...))

(define (fib n) ...)

の二つの書式を名前付きLETにも、ということらしいです。

移植について

新しいLETを定義するわけですが、CL:LETとぶつからないようにするには、普段あまり気にしない名前の衝突について考えて作成したり使ったりする必要があります。

また、新しいLETを作る、といっても、CL:LETを上書きしなくても大丈夫です(上書きも一つの方法ですが)

CLパッケージにあるものとぶつかるような名前は、極力使わないようにする、というのがなんとなくの定石かなとは思いますが、CLのパッケージの仕組みは十分柔軟にできていて、パッケージの扱いを良く考えれば避ける必要もないのかなと個人的には思いました。

2011-05-19

CLでSRFI-86

| 20:51 | CLでSRFI-86 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-86 - わだばLisperになる

ボツになったSRFIを眺めていて、SRFI-92 alambdaという変なものをみつけ、これはボツになりそうだなーとか思っていたら、LAMBDAの形式ではなくLETの形式であるSRFI-86はボツになってなかったので、面白そうだということでCLに移植してみることにしました。

このSRFI-86ですが、これまでのLISP系に登場した束縛系の構文の全部盛りのような感じです。

多値 & 分配束縛

muとかnuとか謎ですが、VALUES-LISTみたいな感じでしょうか

(alet (a (mu 1 2)
        ((b c) (mu 3 4)))
  (list a b c))
;=> ((1 2) 3 4)

(alet (((a . b) (nu '(1 2 3 4))))
  (list a b))
;=> (1 (2 3 4))

(alet (((values a b)
        (floor 3  4)))
  (list a b))
;=> (0 3)

名前付きLET

名前付きLETもサポートしています。名前付きLETは構文の形から一つしか名前を持てないことが残念だったのか、束縛部の後ろに名前を持ってくるという方法で複数の関数が定義できるようです。そして入れ子にもできたりします。

(alet* tag ((a 1)
            (a b b c (mu (+ a 2) 4 5 6))
            ((d e e) b 5 (+ a b c)))
  (if (< a 10)
      (funcall tag a 10 b c c d e d)
      (list a b c d e)))
;=> (10 6 6 5 5)

(alet fact ((n 10)
            (a 1))
  (if (zerop n)
      a
      (funcall fact (1- n) (* a n))))
;=> 3628800

;; 名前が後ろにある形式の名前付きLET
(alet (((n 10)
        (a 1) . fact))
  (if (zerop n)
      a
      (funcall fact (1- n) (* a n))))
;=> 3628800

;; intagとtagで入れ子
(alet* ((a 1)
	((b 2)
         (b c c (mu 3 4 5))
         ((d e d (mu a b c)) . intag) . tag)
	(f 6))
  (if (< d 10)
      (funcall intag d e 10)
      (if (< c 10)
          (funcall tag b 11 c 12 a b d intag)
          (list a b c d e f))))
;=> (1 11 12 10 3 6)

継続関係

call/ccの糖衣構文で、let/ccなどがありますが、そういうのも取り込んだようです。

CLでは残念ながら脱出しかできないので、blockに変換することにしました。

SRFI-86の例をみると、継続を利用してリスタート的な機構も実現しようとしている様子…。

; 脱出(継続)
(alet lp ((win)
          (list '(1 2 3 4 5 6 7)))
  (cond ((= 3 (car list))
         (win (car list)))
        ('T (print (car list))
            (funcall lp (cdr list)))))
;->
;   1
;   2
;=> 3

制御構文関係

たまに欲しくなるSRFI-2のand-let*ですが、そういう制御構文系のもの取り込んでいるようです。

;; and-let*
(alet* ((alist '((a . 1) (b . 2) (c . 3)))
        (and (a (assoc 'b alist))))
  (cdr a))
;=> 2

lambda-list系

CLでいう&rest、&optional、&key関係ですが、その辺もサポート。CLのものより強力なのかもしれません。

;; キーワードで分配
(alet ((key '(b 20 a 10 c 30)
            (a :init)
            (b :init)
            (c :init)
            (d :init)))
  (list a b c d))
;=> (10 20 30 :INIT)

;; 比較/destructuring-bind
(destructuring-bind (&key ((a a) :init)
                          ((b b) :init)
                          ((c c) :init)
                          ((d d) :init))
                    '(b 20 a 10 c 30)
  (list a b c d))
;=> (10 20 30 :INIT)

;; もっとエグい
(alet ((key '(a 10 cc 30 40 b 20)
            (a 1) (b 2) ((c 'cc) 3) . d))
  (list a b c d))
;=> (10 2 30 (40 B 20))

(alet ((key '(:a 10 :cc 30 40 b 20)
            ((a :a) 1)
            ((b :b) 2)
            ((c :cc) 3) . d))
  (list a b c d))
;=> (10 2 30 (40 B 20))

;; 文字もキーにできる
(alet ((key '("a" 10 "cc" 30 40 b 20)
            ((a "a") 1)
            ((b "b") 2)
            ((c "cc") 3) . d))
  (list a b c d))
;=> (10 2 30 (40 B 20))

letrec系

名前付きLETが複数の名前を持てるように拡張されているのに、letrecに相当するものもサポート

(alet ((rec (fact (lambda (n)
                    (if (zerop n)
                        1
                        (* n (funcall fact (1- n))))))))
  (funcall fact 10))
;=> 3628800

その他

その他、使いたくなるのかどうか良く分からないもの

(let (a b)
  (alet ((a :a)
         (b :b)
         (() (setq a 100 b 200)))
    (list a b)))
;=> (:A :B)

≡
(let (a b)
  (setq a 100 b 200)
  (alet ((a :a)
         (b :b))
    (list a b)))
;=> (:A :B)
(let (a b)
  (alet* ((a :a)
          (b :b)
          (() (setq a 100 b 200)))
    (list a b)))
;=> (100 200)

≡
(let (a b)
  (alet* ((a :a)
          (b :b))
    (setq a 100 b 200)
    (list a b)))
;=> (100 200)
(alet ((cat '(1 -2 3)
            (a 0 (plusp a))
            (b 0 (plusp b))
            (c 0 (plusp c))
            . d))
  (list a b c d))
;=> (1 3 0 (-2))

色々複合した例

(let (m n)
  (alet* ((a (progn (princ "1st") 1))
          ((b c) 2 (progn (princ "2nd") 3))
          (() (setq m nil) (setq n (list 8)))
          ((d (progn (princ "3rd") 4))
           (key '(e 5 tmp 6) (e 0) ((f 'tmp) 55)) . p)
          g (nu (progn (princ "4th") 7) n)
          ((values . h) (apply #'values 7 (progn (princ "5th") n)))
          ((m 11) (n n) . q)
          (rec (i (lambda () (- (funcall j) 1)))
               (j (lambda ()  10)))
          (and (k (progn (princ "6th") m))
               (l (progn (princ "end") (terpri) 12)))
          (o))
    (if (< d 10)
        (funcall p 40 50 60)
        (if (< m 100)
            (funcall q 111 n)
            (progn (princ (list a b c d e f g h
                                (funcall i)
                                (funcall j)
                                k l m n))
                   (terpri))))
    (o (list 'o p q))
    (princ "This is not displayed")))
;-> 1st2nd3rd4th5th6thend
;   4th5th6thend
;   6thend
;   (1 2 3 40 50 60 (7 8) (7 8) 9 10 111 12 111 (8))
;
;=> (O #<CLOSURE (LAMBDA #) {101816E539}> #<CLOSURE (LAMBDA #) {101816F549}>)

移植について

移植は、define-syntaxがあるのでmbeを利用。

200行近い大きさのマクロが果して正しく動いてるかどうかは謎です。

テストのセットがあると良いのですが…。

オリジナルと違うところとしては、内部のletrec系の動作は、最初ローカル関数のlabelsでの定義に置き換えようとしていましたが、letrec+funcallにしてしまいました。

継続系は、脱出継続としてblockをあてはめました。リスタート的なものもできなくはないですが、もうちょっと構成が掴めてから挑戦してみたいと思っています。

どうもSRFI-86をサポートしているScheme処理系は少ないようですが、なんとなく分かる気もしました…。

2011-05-14

(どうでも良い)SBCLクイズ: 空ループの最適化 回答

| 20:27 | (どうでも良い)SBCLクイズ: 空ループの最適化 回答 - わだばLisperになる を含むブックマーク はてなブックマーク - (どうでも良い)SBCLクイズ: 空ループの最適化 回答 - わだばLisperになる

先日の(どうでも良い)SBCLクイズ: 空ループの最適化でしたが、最適化だけに最適化のレベルによって変ってくるようで環境によってはfoo-slowもfoo-fastも同じ、ということになるようです。

なるほど、すっかり設定に依存するということが頭から抜けていました…。

ということで、とりあえずここでは、(proclaim '(optimize (compilation-speed 0) (debug 3) (safety 0) (space 3) (speed 3)))のようなアグレッシブな設定で行く、ということにします。

それで回答ですが、自分は色々調べたり試してみたりして、最初に下のようなものを書きました

(defun foo-fast ()
  (let* ((numbers (coerce (- 0 1) 'number))
         (numbers (+ numbers (coerce 1 'number))))
    (declare (type number numbers))
    (tagbody
      LL
      (if (> numbers (* 10000 10000))
          (go END))
      (setq numbers (+ numbers (coerce 1 'number)))
      (go LL)
      END)
    nil))
(foo-fast)
;⇒ NIL
----------
Evaluation took:
  0.051 seconds of real time
  0.050000 seconds of total run time (0.050000 user, 0.000000 system)
  98.04% CPU
  120,854,475 processor cycles
  0 bytes consed

Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz
; disassembly for FOO-FAST
; 19C6CAF4:       31C9             XOR ECX, ECX               ; no-arg-parsing entry point
;      AF6:       EB0C             JMP L1
;      AF8:       90               NOP
;      AF9:       90               NOP
;      AFA:       90               NOP
;      AFB:       90               NOP
;      AFC:       90               NOP
;      AFD:       90               NOP
;      AFE:       90               NOP
;      AFF:       90               NOP
;      B00: L0:   4883C108         ADD RCX, 8
;      B04: L1:   4881F90008AF2F   CMP RCX, 800000000
;      B0B:       7EF3             JLE L0
;      B0D:       BA17001020       MOV EDX, 537919511
;      B12:       488BE5           MOV RSP, RBP
;      B15:       F8               CLC
;      B16:       5D               POP RBP
;      B17:       C3               RET
;      B18:       CC0A             BREAK 10                   ; error trap
;      B1A:       02               BYTE #X02
;      B1B:       18               BYTE #X18                  ; INVALID-ARG-COUNT-ERROR
;      B1C:       54               BYTE #X54                  ; RCX

これをDISASSEMBLEしてもカウンターの部分でCLの関数の+は使われず、

L0:   ADD RCX, 8
L1:   CMP RCX, 800000000
      JLE L0

のようにひたすらカウントアップしているのが分かります。

それで結局何が違うのかというと、SETQの位置が違うだけでFOO-SLOWは、

(defun foo-slow ()
  (let* ((numbers (coerce (- 0 1) 'number)))
    (declare (type number numbers))
    (tagbody
      LL
      (setq numbers (+ numbers (coerce 1 'number)))
      (if (> numbers (* 10000 10000))
          (go END))
      (go LL)
      END)
    nil))

IFの前にSETQがあるだけ、ということになります。

何が違ってくるのかは、結局のところ全然自分も追い切れていないのですが、どうもSB-C::MAYBE-INFER-ITERATION-VAR-TYPEという関数があって、コンパイル時に中身を走査して繰り返し用の変数をみつけたら最適化する、ということをやっているようです。

(例えば、(setq foo (+ foo x))のような形の場合fooは繰り返しのカウンターの可能性が高い、等々)

また、最初の回答以外にも繰り返し用の変数をFIXNUMにすることでも大体同じ結果になるようです。

(defun foo-fast ()
  (let* ((numbers (coerce (- 0 1) 'fixnum)))
    (declare (type fixnum numbers))
    (tagbody
      LL
      (setq numbers (+ numbers 1))
      (if (> numbers (* 10000 10000))
          (go END))
      (go LL)
      END)
    nil))

この場合は、どうやら上の最適化に加え、繰り返しの演算がFIXNUMになることによって高速化される、という微妙に別のルートの最適化のようです。

  • SETQを最適化しやすい位置に置く
L0:   ADD RCX, 8
L1    CMP RCX, 800000000
      JLE L0
  • 繰り返し変数をFIXNUMにする
L0:    ADD RCX, 8
       MOV RDX, RCX
       CMP RDX, 800000000
       JLE L0

以上、とりとめなく書き散らかしてしまいましたが、どうしてこの最適化をみつけたかというと、SBCLのLOOPの展開形と比較した際にSETQの位置しか違わなかった、というのがきっかけでした。

これ以外にも、知らないところで知らない機能が発動して最適化していることって結構あるんでしょうねー。

CLでSRFI-26

| 18:21 | CLでSRFI-26 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-26 - わだばLisperになる

f-underscoreのようなものもあるし、熱烈に使いたいということもなくなってきたSRFI-26ですが暇だったのでCLにまるごと移植してみました。

使い勝手の問題ですが、LISP-1とLISP-2の表記上の違いがあり、デフォルトを (cut list ...)のようにするか、 (cut #'list ...)のようにするかで迷いましたが、#'を付けることにしました。

#'を付けないで書けた方が良いのですが、付けないとすると、

(mapcar (cut #'list 1 2 <> 3)
        '(1 2 3 4))
;=> ((1 2 1 3) (1 2 2 3) (1 2 3 3) (1 2 4 3))

(let ((list #'list*))
  (mapcar (cut list 1 2 <> 3)
          '(1 2 3 4)))
;=> ((1 2 1 . 3) (1 2 2 . 3) (1 2 3 . 3) (1 2 4 . 3))

のような書き分けができなくなります。

まあ、こんなこともあまりしないので第一引数は、関数であると決め打ちにしてしまっても良いかなとは思います。その場合の改造も簡単にできると思います。

移植について

移植は、define-syntaxがあるのでmbeを利用。

mbeのお蔭で殆どソースコードはいじらなくても動きました。

2011-05-13

CLでSRFI-1

| 21:11 | CLでSRFI-1 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-1 - わだばLisperになる

自分的にたまーに欲しいと思うことがあるSRFI-1ですが思い切ってCLにまるごと移植してみました。

SRFI-1は過去のSchemeのライブラリやCommon Lispのリスト系の関数を調査して作成したとのことで、リスト操作で欲しそうなものは一通り揃っている気がします。

移植方法ですが、最初は、ちまちまdefineをdefunに直したりしてのんびり気長に行こうと思っていたのですが、途中で面倒になってdefineというマクロを定義してみたあたりから、オリジナルのソースをできるだけいじらない、という方針に切り替えました。

ということで字面的には、ほぼオリジナルのままです。(変更はcheck-argが微妙だったのでdeclareの型宣言で置き換えた位)

ありがちな書き換えとしては、

  • condのelse節を:elseと書くことでなんとなく対応
  • null?等をCLの関数のエイリアスとして作成
  • named letはマクロでlabelsに変形。末尾呼び出しの最適化は処理系に期待。
  • letrecは、labelsに形が近いので手書きで変形
  • defineの引数は、CLの&rest、&optionalをそのまま使う

書き換えにチャレンジしなかったところとしては、

  • functionの廃止 (lisp1化)
  • condを再定義して=>とelseが使えるようにする
  • named letを再帰除去してループに

というところです。

Scheme->CLのソースコードのトランスレータもどっかに落ちてそうなので探してみたいところではあります。

2011-05-10

lisp-criticでスタイルチェック

| 20:11 | lisp-criticでスタイルチェック - わだばLisperになる を含むブックマーク はてなブックマーク - lisp-criticでスタイルチェック - わだばLisperになる

最近LISPのスタイルチェッカーに興味があって色々調べてみたりしていますが、そういえばスタイルを批評してくれるツールがどっかにあったなと思い出して探し出してセットアップしてみました。

lisp-criticというツールなのですが大学でLISPを教える際の補助ツール的なもののようです。

どのように使うかというと、基本的にDEFUNのフォームをチェッカーに渡してチェックさせます。

(lisp-critic:critique
 (defun foo ()
   (defun bar ()
     (setq a 'b)))

のようなものを評価すると

----------------------------------------------------------------------
DEFUN's don't nest in CL like they do in Scheme.
   They're always top-level. FLET and LABELS can define local
   functions, but you don't need them here.
----------------------------------------------------------------------
GLOBALS!! Don't use global variables, i.e., A
----------------------------------------------------------------------

のような批評がでます。

配布されているパターン集が結構細かいところまで網羅されているのですが、自分でパターンを書いて拡張することもできます。

説明がなくて、セットアップがちょっと面倒なのでブログにエントリーついでにASDF化してgithubに上げてみました。

また、毎度CRITIQUEのフォームで囲うのも面倒なので、SLIMEのコンパイル時に一緒に実行するようなadviceを付けて使ってみるのも良いかなと思います。

(eval-after-load "slime"
  '(defadvice slime-compile-defun (before critique-advice activate)
    (slime-eval-async
        `(swank:eval-and-grab-output
          ,(format "(let ((*standard-output* *error-output*))
                      (lisp-critic:critique %s))"
                   (slime-defun-at-point))))))

ちょっと使ってみたところでは、CL入門者には結構良いかもしれないな、という感じです。

2011-05-07

CLでSRFI-42

| 23:10 | CLでSRFI-42 - わだばLisperになる を含むブックマーク はてなブックマーク - CLでSRFI-42 - わだばLisperになる

必要だった、ということは全くなかったのですが、Scheme版LOOPマクロという評判のSRFI-42をCLに移植してみました。

SRFI-42は、define-syntaxで書かれていて、CLのDEFMACROとは違うのですが、Drai Sitaram氏のmacro by example(mbe)を使ってみたところ殆ど修正もなく移植完了。

  • mbe
  • mbe (ASDF化してgithubに置いてみたもの)

srfi-42だとこんな感じに書けます

(defun palindrome-p (list)
  (every?-ec (:parallel (:- nom list)
                        (:- rev (reverse list)))
             (equal nom rev)))

(palindrome-p '(1 2 3 2 1))
;=> T

(defun flatten (list)
  (append-ec (:- e list)
             (if (listp e)
                 (flatten e)
                 (list e))))

(flatten '(1 2 3 (4 5 (6 (7 (8 (9 (((10((((((()))))))))))))))))
;=> (1 2 3 4 5 6 7 8 9 10)

(defun taxi-number (n)
  (list-ec (:- a 1 n)
           (:- b (+ a 1) n)
           (:- c (+ a 1) b)
           (:- d (+ c 1) b)
           (if (= (+ (expt a 3) (expt b 3))
                  (+ (expt c 3) (expt d 3))))
           (list a b c d)))

(taxi-number 100)
;=> ((1 12 9 10) (2 16 9 15) (2 24 18 20) (2 34 15 33) (2 89 41 86) (3 36 27 30) (3 60 22 59) (4 32 18 30) (4 48 36 40) (4 68 30 66) (5 60 45 50) (5 76 48 69)
     (6 48 27 45) (6 72 54 60) (7 84 63 70) (8 53 29 50) (8 64 36 60) (8 96 72 80) (9 34 16 33) (9 58 22 57) (10 27 19 24) (10 80 45 75) (11 93 30 92)
     (12 40 31 33) (12 51 38 43) (12 96 54 90) (15 80 54 71) (17 39 26 36) (17 55 24 54) (17 76 38 73) (18 68 32 66) (20 54 38 48) (20 97 33 96) (23 94 63 84)
     (24 80 62 66) (24 98 63 89) (29 99 60 92) (30 67 51 58) (30 81 57 72) (34 78 52 72) (35 98 59 92) (42 69 56 61) (47 97 66 90) (50 96 59 93) (51 82 64 75))

オリジナルと違うところとしては、 (: i 10)のようなものはCLでは不可なので、 (:- i 10)のようにして回避しました。

また、えぐいところとしては、キーワードシンボルにマクロが定義されることになります;(:- i 10)もマクロだったり。

ちなみに実行は関数呼び出しの連発になるので通常のLOOPと比べると25倍位遅い(SBCL調べ)ようですが、この辺りを高速化するのも盆栽的に面白いかなと思っています。

また、繰り返しは再帰なのですが、末尾再帰を最適化しない処理系では厳しいかもしれません。(SBCLは最適化するので大丈夫なようですが。)

(どうでも良い)SBCLクイズ: 空ループの最適化

| 17:04 | (どうでも良い)SBCLクイズ: 空ループの最適化 - わだばLisperになる を含むブックマーク はてなブックマーク - (どうでも良い)SBCLクイズ: 空ループの最適化 - わだばLisperになる

(defun foo-slow ()
  (let* ((numbers (coerce (- 0 1) 'number)))
    (declare (type number numbers))
    (tagbody
      LL
      (setq numbers (+ numbers (coerce 1 'number)))
      (if (> numbers (* 10000 10000))
          (go END))
      (go LL)
      END)
    nil))

というコードがあります。

これは、Series

(collect-ignore (scan-range :from 0 :upto (* 10000 10000)))

マクロの展開結果で、単に空のループを1億回実行するというものですが、実行スピードが LOOP マクロの同等のコードより10倍位遅いのが悔しいので、同じ位高速なfoo-fastを作成してください、というのが問題です。

実行速度

(foo-slow)
;⇒ NIL
----------
Evaluation took:
  0.520 seconds of real time
  0.520000 seconds of total run time (0.520000 user, 0.000000 system)
  100.00% CPU
  1,242,649,269 processor cycles
  0 bytes consed

Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz
(defun bar-fast ()
  (loop :repeat (* 10000 10000)))

(bar-fast)
;⇒ NIL
----------
Evaluation took:
  0.045 seconds of real time
  0.040000 seconds of total run time (0.040000 user, 0.000000 system)
  88.89% CPU
  106,853,454 processor cycles
  0 bytes consed

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

foo-slowのDISASSEMBLEの結果は、

; disassembly for FOO-SLOW
; 18029EF4:       48C7C3F8FFFFFF   MOV RBX, -8                ; no-arg-parsing entry point
;      EFB:       90               NOP
;      EFC:       90               NOP
;      EFD:       90               NOP
;      EFE:       90               NOP
;      EFF:       90               NOP
;      F00: L0:   BF08000000       MOV EDI, 8
;      F05:       488BD3           MOV RDX, RBX
;      F08:       4C8D1C25E0010020 LEA R11, [#x200001E0]      ; GENERIC-+
;      F10:       41FFD3           CALL R11
;      F13:       480F42E3         CMOVB RSP, RBX
;      F17:       488BDA           MOV RBX, RDX
;      F1A:       48895DF8         MOV [RBP-8], RBX
;      F1E:       BF0008AF2F       MOV EDI, 800000000
;      F23:       488BD3           MOV RDX, RBX
;      F26:       488D0C2544040020 LEA RCX, [#x20000444]      ; GENERIC->
;      F2E:       FFD1             CALL RCX
;      F30:       488B5DF8         MOV RBX, [RBP-8]
;      F34:       7ECA             JLE L0
;      F36:       BA17001020       MOV EDX, 537919511
;      F3B:       488BE5           MOV RSP, RBP
;      F3E:       F8               CLC
;      F3F:       5D               POP RBP
;      F40:       C3               RET
;      F41:       CC0A             BREAK 10                   ; error trap
;      F43:       02               BYTE #X02
;      F44:       18               BYTE #X18                  ; INVALID-ARG-COUNT-ERROR
;      F45:       54               BYTE #X54                  ; RCX

ですが、bar-fastのDISASSEMBLE結果は、

; disassembly for BAR-FAST
; 19357284:       B90008AF2F       MOV ECX, 800000000         ; no-arg-parsing entry point
;       89:       EB09             JMP L1
;       8B:       90               NOP
;       8C:       90               NOP
;       8D:       90               NOP
;       8E:       90               NOP
;       8F:       90               NOP
;       90: L0:   4883E908         SUB RCX, 8
;       94: L1:   4883F900         CMP RCX, 0
;       98:       7FF6             JNLE L0
;       9A:       BA17001020       MOV EDX, 537919511
;       9F:       488BE5           MOV RSP, RBP
;       A2:       F8               CLC
;       A3:       5D               POP RBP
;       A4:       C3               RET
;       A5:       CC0A             BREAK 10                   ; error trap
;       A7:       02               BYTE #X02
;       A8:       18               BYTE #X18                  ; INVALID-ARG-COUNT-ERROR
;       A9:       54               BYTE #X54                  ; RCX
;       AA:       CC0A             BREAK 10                   ; error trap
;       AC:       02               BYTE #X02
;       AD:       18               BYTE #X18                  ; INVALID-ARG-COUNT-ERROR
;       AE:       54               BYTE #X54                  ; RCX

です。foo-fastは

; disassembly for FOO-FAST
; 18229894:       31C9             XOR ECX, ECX               ; no-arg-parsing entry point
;       96:       EB0C             JMP L1
;       98:       90               NOP
;       99:       90               NOP
;       9A:       90               NOP
;       9B:       90               NOP
;       9C:       90               NOP
;       9D:       90               NOP
;       9E:       90               NOP
;       9F:       90               NOP
;       A0: L0:   4883C108         ADD RCX, 8
;       A4: L1:   4881F90008AF2F   CMP RCX, 800000000
;       AB:       7EF3             JLE L0
;       AD:       BA17001020       MOV EDX, 537919511
;       B2:       488BE5           MOV RSP, RBP
;       B5:       F8               CLC
;       B6:       5D               POP RBP
;       B7:       C3               RET
;       B8:       CC0A             BREAK 10                   ; error trap
;       BA:       02               BYTE #X02
;       BB:       18               BYTE #X18                  ; INVALID-ARG-COUNT-ERROR
;       BC:       54               BYTE #X54                  ; RCX

のようなものになると思われます。

2011-05-01

C.I.CLを眺める(14) TRANSPOSE

| 21:11 | C.I.CLを眺める(14) TRANSPOSE - わだばLisperになる を含むブックマーク はてなブックマーク - C.I.CLを眺める(14) TRANSPOSE - わだばLisperになる

今回は、C.I.CLのlist.lispから TRANSPOSE です。

名前からは具体的にどういう動作になるのかいまいち想像がつきませんが、ドキュメントによればツリーのCARとCDRを再帰的に交換するもののようです。

(import 'com.informatimago.common-lisp.list:transpose)

(transpose '(a b c d))
;=> ((((NIL . D) . C) . B) . A)

(transpose '((a . b) . (c . d)))
;=> ((D . C) B . A)

初心者の頃によく作りがちな失敗REVERSEの様な動作ですが、どういうところで使うのでしょうか。

定義は、

(DEFUN TRANSPOSE (TREE)
  "
RETURN: A tree where all the CAR and CDR are exchanged.
"
  (IF (ATOM TREE)
      TREE
      (CONS (TRANSPOSE (CDR TREE)) (TRANSPOSE (CAR TREE)))))

となっています。