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 |

2008-03-22

read-lineが多値を返すのを有効利用したい

| 13:36 | read-lineが多値を返すのを有効利用したい - わだばLisperになる を含むブックマーク はてなブックマーク - read-lineが多値を返すのを有効利用したい - わだばLisperになる

何気なくLispマシン(LMI Lambda)のソースコードを眺めていたのですが、

(DEFUN SXHASH-FILE (FILENAME &OPTIONAL &KEY (CHUNK-SIZE 1024))
  (LET ((BUFFER (MAKE-STRING CHUNK-SIZE)))
    (WITH-OPEN-FILE (INPUT FILENAME)
      (DO ((END)
           (EOFP)
           (HASHSUM 0 (PROGN (MULTIPLE-VALUE-SETQ (END EOFP) (SEND INPUT :STRING-IN NIL BUFFER))
                             (COMPILER::%SXHASH-SUBSTRING BUFFER #o377 0 END))))
          (EOFP
           HASHSUM)))))

というコードに遭遇しました。

DOで入出力のループを回すと、read系の関数を2回書くことになったりするのが、DO派の悩みですが、この方法だと1回で済み、また、ループから抜ける判定も同時にこなしてるのが、何だか素敵なので真似して他に応用できないか考えてみることにしました。

とはいえ、

(SEND INPUT :STRING-IN NIL BUFFER)

がFlavors(CLOS以前にメジャーだったオブジェクトシステム)なのが問題で、憶測ですが、bufferに値をセットして、返り値は、ファイルポジションと、EOFに遭遇したか否かを多値で返すとか、そんな感じじゃないでしょうか。

(DEFUN SXHASH-FILE (FILENAME &OPTIONAL &KEY (CHUNK-SIZE 1024))
  (with-output-to-string (BUFFER)
    (WITH-OPEN-FILE (INPUT FILENAME)
      (DO ((END)
           (EOFP)
           (HASHSUM 0 (PROGN (MULTIPLE-VALUE-SETQ (END EOFP) (read-line input nil))
                             (COMPILER::%SXHASH-SUBSTRING BUFFER #o377 0 END))))
          (EOFP
           HASHSUM)))))

みたいな。

そんなこんな考えるうちに、DOが多値に対応すれば、何か素敵なことができるんじゃないかと思ったので、multiple-value-doを作ってみることにしました。

;; ファイルの読み込み
(with-open-file (in "/tmp/foo.txt")
  (multiple-value-do (((line eofp) (values) (read-line in nil)))
      (eofp 'done)
    (and line (write-line line))))

;=> abcdef ....... EOF

;; 他になんかできないか…。
(defun my-gcd (n m)
  (multiple-value-do (((n m) (values n m) (values m (rem n m))))
      ((zerop m) n)))

しかし、read系は、read-lineのようにEOFの検出を2値目で知らせてくれるのかと思ったら、read-lineだけでした。そう言われてみればそうだったんですが、行単位で扱うから多値を返すんでしょうか…。

そうすると、実質 MULTIPLE-VALUE-DO を書いた意味がない…

他にも色々試してみましたが、「残念ながら、MULTIPLE-VALUE-DOはあまり役に立ちそうもない」というのは議論の余地のない given な事実として淀みなく会話は流れる、というのが一般的になりそうです。

(defpackage :mv 
  (:use :cl)
  (:export :multiple-value-psetq
           :multiple-value-do))

(in-package :mv)

(defmacro MULTIPLE-VALUE-DO ((&rest varlist) (test &rest finally) &body body)
  (let ((vars (mappend #'car varlist))
        (inits (mappend #'cadr varlist))
        (tag (gensym)))
    `(BLOCK NIL
       (MULTIPLE-VALUE-BIND ,vars ,inits
         (TAGBODY
            (MULTIPLE-VALUE-PSETQ ,@(mappend (fn ((x y z)) `(,x ,y))
                                             varlist))
       ,tag (WHEN ,test
              (RETURN-FROM NIL (PROGN ,@finally)))
            ,@body
            (MULTIPLE-VALUE-PSETQ ,@(mappend (fn ((x y z)) `(,x ,z))
                                             varlist))
            (GO ,tag))))))

;; --

(defmacro FN ((&rest args) &body body) ;; Arcから拝借
  (let ((g (gensym)))
    `(LAMBDA (&rest ,g)
       (DESTRUCTURING-BIND ,args ,g
         (DECLARE (IGNORABLE ,@(metatilities:flatten args)))
         ,@body))))

(defun MAPPEND (fn &rest lists)
  (reduce #'append (apply #'mapcar fn lists)))

(defmacro MULTIPLE-VALUE-PSETQ (&rest pairs)
  (cond ((cddr pairs) `(SETF (VALUES ,@(car pairs))
                             (MULTIPLE-VALUE-PROG1 ,(cadr pairs)
                               (MULTIPLE-VALUE-PSETQ ,@(cddr pairs)))))
        ((cdr pairs) `(SETF (VALUES ,@(car pairs)) ,@(cdr pairs)))
        ('T (error "Odd number of args."))))

2008-02-14

Arcでcond

| 17:42 | Arcでcond - わだばLisperになる を含むブックマーク はてなブックマーク - Arcでcond - わだばLisperになる

どうもArcのifには我慢できなくなったのでマクロでcondを作ってみることにしました。

ちょちょっと作業をしてみたのですが、SLIMEに馴れ切った自分にはSLIMEの助けが無いとマクロが書けないことに、はたと気付いてしまいました。

つまりマクロの展開形が簡単に確認できないと無計画にマクロを書けなということですね…。

そういうわけで遠回りながら、まず簡単にmacex1の結果が見れるようにしてみました。

といっても、Emacsのlisp-eval-region関数をちょっといじっただけのものを作っただけです。

EmacsのArc-modeが待ち遠しい…。

(defun arc-mecex1-region (start end &optional and-go)
  (interactive "r\nP")
  (comint-send-string (inferior-lisp-proc) "(ppr (macex1 '")
  (comint-send-region (inferior-lisp-proc) start end)
  (comint-send-string (inferior-lisp-proc) "))\n")
  (if and-go (switch-to-lisp t)))

これで気休め程度はマクロが書きやすくなったので、condの作成

;; そのまんまバージョン
(mac cond body
  `(if ,@(mappend [list car._ `(do ,@cdr._)] body)))

;; elseも使えるバージョン
(mac cond body
  `(if ,@(mappend [list (let x _.0 (or is!else.x x)) `(do ,@cdr._)]
		  body)))

;; 動作
(cond (a b)
      (c d)
      (else e))
;マクロ展開 =>
;(if a (do b) c (do d) t (do e))

新しい構文も取り入れて書いてみましたが、ArcはどんどんPerl化して行っている気がする!

2008-02-09

EmacsのCommon Lispインデント

| 04:02 | EmacsのCommon Lispインデント - わだばLisperになる を含むブックマーク はてなブックマーク - EmacsのCommon Lispインデント - わだばLisperになる

EmacsでCommon Lispのコードを編集する時には、cl-indentを使用しているのですが、割とprogと、loopの時に思ったようにインデントしてくれないので、色々調整してみているのですが、どうも簡単な方法がみつからず結局、cl-indent.elの関数を変更することにしてみました。とはいえ、後で自作の関数を読み込みさせるだけですが…。

どういう風にインデントされて欲しいかというと、

(loop :for i = 0 :then (incf i)
      :if (< 10 i)
	:do (print "End.")
            (return res)
      :else
	:collect i :into res
      :end)

(prog (foo)
      (setq foo '(foo bar baz))
   L  (cond ((endp foo) (return)))
      (pop foo)
      (go L))

みたいな感じです。まあ、いまどきPROG使う人もいないと思うんですが、PROGの時はずらっと括弧の位置が揃ってると気持ち良いんですよね。

LOOPはとりあえず、2行目以降、7カラム目に揃ってれば良いんですが、doのときに、2つ字下げしてるのをLispマシンのマニュアルで発見したので、そういう風なのも良いかなと。

とりあえず、無理矢理な感じですが、設定をでっち上げました。

;; Common Lisp - インデント関係の設定
;; tagbody / prog
(setq lisp-prog-tag-indentation 3
      lisp-prog-tag-body-indentation 6
      lisp-tag-indentation 1
      lisp-tag-body-indentation 3)

;; lisp-indent-tagbodyをほんのちょっと改造
(defun lisp-indent-prog (path state indent-point sexp-column normal-indent)
  (if (not (null (cdr path)))
      normal-indent
    (save-excursion
      (goto-char indent-point)
      (beginning-of-line)
      (skip-chars-forward " \t")
      (list (cond ((looking-at "\\sw\\|\\s_")
                   ;; a tagbody tag
                   (+ sexp-column lisp-prog-tag-indentation))
                  ((integerp lisp-prog-tag-body-indentation)
                   (+ sexp-column lisp-prog-tag-body-indentation))
                  ((eq lisp-prog-tag-body-indentation 't)
                   (condition-case ()
                       (progn (backward-sexp 1) (current-column))
                     (error (1+ sexp-column))))
                  (t (+ sexp-column lisp-body-indent)))
            (elt state 1)))))

(put 'prog 'common-lisp-indent-function 'lisp-indent-prog)

;; loop
(defun common-lisp-loop-part-indentation (indent-point state)
  "Compute the indentation of loop form constituents."
  (let* ((loop-indentation (save-excursion
			     (goto-char (elt state 1))
			     (current-column))))
    (goto-char indent-point)
    (beginning-of-line)
    (cond ((looking-at "^\\s-*:?\\(do\\|collect\\)\\(\\s-\\|\(\\)\\(\\s-*\\|;\\)")
	   (+ loop-indentation lisp-loop-keyword-indentation 2))
	  ((looking-at "^\\s-*\\(:?\\sw+\\|;\\)")
	   (+ loop-indentation lisp-loop-keyword-indentation))
	  (t
	   (+ loop-indentation lisp-loop-forms-indentation))))))

(setq lisp-loop-forms-indentation 6
      lisp-loop-keyword-indentation 6
      loop-indentation 6)

(put 'loop 'common-lisp-indent-function 'common-lisp-loop-part-indentation)

;; (cl-indent 名前 手本)
(defun cl-indent (sym indent)
  (put sym 'common-lisp-indent-function
       (if (symbolp indent)
	   (get indent 'common-lisp-indent-function)
	 indent)))

(cl-indent 'iterate 'let)
(cl-indent 'collect 'progn)
(cl-indent 'mapping 'let)
(cl-indent 'define-syntax 'let)

PROGは、まあまあこれでできたのですが、LOOPが

(loop :for i = 0 :then (incf i)
      :if (< 10 i)
	:do (print "End.")
      (return res)
      :else
	:collect i :into res
      :end)

のようになるので、doの範囲を自分で字下げしないといけないという…。あと、lisp-indent-lineでは字下げしてくれますが、indent-regionとか、indent-sexpでは、doとかcollectは字下げしてくれないので、これも面倒だという。

何か簡単に調整してくれるEmacs Lispとか配布されてないんですかねー。

皆さんはどうされているのでしょう。

2008-02-06

日本語プログラミングとLISP

| 01:18 | 日本語プログラミングとLISP - わだばLisperになる を含むブックマーク はてなブックマーク - 日本語プログラミングとLISP - わだばLisperになる

今日は、お茶を飲みながら、「初心者に優しい」ということと、LISPについて考えていました。

FORTHなどのスタック言語の文法と日本語文法とは非常に相性が良いことは良く知られていると思うのですが、LISPもリスト構造をひっくりかえしてしまえば、スタック言語の構造に非常に近い見た目になるかと思います。

そんなこんなで初心者に優しい日本語LISPのことを考えていたら、どういう訳か谷川俊太郎の詩が頭に浮んで来たので、そのインスピレーションをそのままLISPのコードに叩きつけてみました。

当初は、もう少し野心的な作りだったのですが、割とすんなり動かず、デバッグしているうちに、なんだかどんどん悲しくなってきたので、簡単なところで切り上げました。

;; 動作

;; 関数定義など
(with-俊太郎
  (("とがつてる" "月へゆくロケツトそつくり" というリスト)というのは公には おちんちん)

  (((100 通りのあてずっぽう)90 より大きいですか?)というのが おにがめかくし)

  ((((とべ とべ)
     ((おちんちん というのはどんなもの?)を 書け)
     (おにがめかくし)してるまに)
    とべ とべとべ)
   というのが 男の子のマーチ))

;; 定義した関数の実行
(男の子のマーチ)
; =>
;("月へゆくロケツトそつくり" "とがつてる") 
;("月へゆくロケツトそつくり" "とがつてる") 
;("月へゆくロケツトそつくり" "とがつてる") 
;("月へゆくロケツトそつくり" "とがつてる") 
;("月へゆくロケツトそつくり" "とがつてる") 
;("月へゆくロケツトそつくり" "とがつてる") 

;; 定義
(defpackage :俊太郎 (:use :cl))

(in-package :俊太郎)

(defun super-reverse1 (lst acc)
  (cond ((atom lst) acc)
	((atom (car lst)) 
	 (super-reverse1 (cdr lst) (cons (car lst) acc)))
	('T (super-reverse1 (cdr lst) (cons (super-reverse1 (car lst) () ) acc)))))

(defun super-reverse (lst) (super-reverse1 lst () ))

(defun super-remove (item lst)
  (remove item
	  (mapcar (lambda (x)
		    (if (consp x) (super-remove item x) x))
		  lst)))

(setf (symbol-function '通りのあてずっぽう) #'cl:random
      (symbol-function '書け) #'cl:print
      (symbol-function 'より大きいですか?) #'cl:>
      (symbol-function 'というリスト) #'cl:list
      (symbol-function 'してるまに) (macro-function 'cl:when)
      (symbol-function 'というのが) (macro-function 'cl:defun)
      (symbol-function 'というのはどんなもの?) (symbol-function 'cl:values)
      (symbol-function 'とべ) (symbol-function 'cl:go))

(defmacro というのは公には (var val) `(defparameter ,var ,val))
(defmacro とべとべ (&body body) `(prog () ,@body))

(defmacro with-俊太郎 (&body body)
  `(progn
     ,@(mapcar (lambda (x) (s->cl (super-reverse x)))
	       body)))

(defun s->cl (expr)
  (let ((expr (remove-てにをは expr)))
    (cond 
      ;; defun
      ((eq 'というのが (cadr expr))
       `(,(cadr expr) ,(car expr) nil ,@(cddr expr)))
      ;; defparameter
      ((eq 'というのは公には (cadr expr))
       `(,(cadr expr) ,(car expr) ,@(cddr expr)))
      ('T expr))))

(defun remove-てにをは (expr)
  (reduce (lambda (res x) (super-remove x res))
	  '(て に を は で)
	  :initial-value expr))
;

2008-01-22

俺Arc祭り 2008冬 (8)

| 08:10 | 俺Arc祭り 2008冬 (8) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (8) - わだばLisperになる

やっと最後まで辿り着きました、俺Arc祭りこと、生後3週間目のArc追っかけ。

最後に来て、ラムダパラメータリストについてです。

keyの代わりに、db(ハッシュ)を使用することにし、また、分割代入をサポートするとのこと。

キーワードを一々指定するのは面倒だから、ハッシュテーブルを引数として食べさせるってことでしょうか。

便利なような便利でないような…。

ノープランで頭から作っていただけに、let、with、def、macro(mac)は定義し直し。

また、変数の分割代入ですが、混み入ってくると正しい文法なのかどうか怪しいです。

;; 動作
(def foo (x (ds (i j)) (get m n) (opt q 'a) . z)
  (list x i j m n q z))

(foo 1 '(red green) (db m 'a n 'b) 'hel 'lo)
;-> (1 RED GREEN A B HEL (LO))

(let x 5
     x)
;-> 5

(with (x 5 y 6)
  (list x y))
;-> (5 6)

(let (ds (x y (z))) '(1 2 (3))
     (list x y z))
;-> 1 2 3

(with ((ds (x y z)) '(1 2 3) a 5)
  (list x y z a))
;-> 1 2 3 5

;; これはアリなのだろうか?
(let (a . b) '(1 2 3 4)
     (list a b))
;->(1 (2 3 4))

;; これで良いのか?
(let (ds ((a b) . rest)) '((1 2) 3 4)
     (list a b rest))
;->(1 2 (3 4))

(with ((ds ((a b) . rest)) '((1 2) 3 4)
       x 10)
  (list a b rest x))
;->(1 2 (3 4) 10)

;; おれおれ定義
(cl:defmacro let (var val cl:&body body)
  `(cl:destructuring-bind ,(remove-ds 
			    (opt-to-&optional
			     (dotex-to-&rest `(,var))))
       (list ,val)
     (declare (ignorable ,@(metatilities:flatten (remove-ds `(,var)))))
     ,@body))

(cl:defmacro with (spec &body body)
  (reduce (fn (x res) `(let ,@x ,res))
	  (loop :for i :on spec :by #'cddr 
	        :collect (metatilities:firstn 2 i))
	  :initial-value `(progn ,@body)
	  :from-end 'T))

(cl:defmacro def (name args cl:&body body)
  (multiple-value-bind (spec /ds /syms) 
      (replace-specs (opt-to-&optional (dotex-to-&rest args)))
    (if /ds
	`(cl:defun ,name ,spec
	   (destructuring-bind ,/ds ,/syms
	     ,@body))
	`(cl:defun ,name ,spec
	   ,@body))))

;; 他のエッセイを読んだら、macroじゃなくて、macになってたのでついでに変更してみる
(cl:defmacro mac (name args cl:&body body)
  (multiple-value-bind (spec /ds /syms) 
      (replace-specs (opt-to-&optional (dotex-to-&rest args)))
    (if /ds
	`(cl:defmacro ,name ,spec
	   (destructuring-bind ,/ds ,/syms
	     ,@body))
	`(cl:defmacro ,name ,spec
	   ,@body))))

;; ラムダパラメータ分解ユーティリティ
(cl:defun opt-to-&optional (expr)
  (loop :for x :in expr
        :nconc (if (eq 'opt (metatilities:car-safe x))
		   `(&optional ,(if (cl:= 2 (length x))
				    (cadr x)
				    (cdr x)))
		   (list x))))

(cl:defun dotex-to-&rest (expr)
  (cl:cond ((atom expr) `(&rest ,expr))
	   ((tailp () expr) expr)
	   ('T (cl:let ((x (copy-list expr)))
		 (rplacd (last x) (list '&rest (cdr (last x))))
		 x))))

(cl:defun replace-specs (expr)
  (loop :with ds :and vars
     :for x :in expr
     :collect (cl:cond ((eq 'ds (metatilities:car-safe x))
			(cl:let ((sym (gensym "DS-")))
			  (push sym vars)
			  (push (cadr x) ds)
			  sym))
		       ((eq 'get (metatilities:car-safe x))
			(cl:let ((sym (gensym "DB-")))
			  (push (cdr x) ds)
			  (push `(list ,@(mapcar (cl:lambda (x) `(get ,x ,sym)) (cdr x))) vars)
			  sym))
		       ('T x))
     :into specs
     :finally (return (values specs ds `(list ,@vars)))))

(defun remove-ds (expr)
  (loop :for x :in expr
        :collect (if (eq 'ds (metatilities:car-safe x))
		     (cadr x)
		     x)))

俺Arc祭り 2008冬 (7)

| 02:46 | 俺Arc祭り 2008冬 (7) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (7) - わだばLisperになる

もう少しで終了の俺Arc祭り。知らぬ間に世の中では、俺Scheme/Lisp祭りが始まっている様子。

今年、Schemeは盛り上がりそうだなー。

Common Lispも、意味なく盛り上がんないかな。

Common Lisp面白いと思うんだけどなあ。

それはさておき、

16. Overloading

クラスを作るときに関数を指定して実行時に指定した関数をオーバーロードするとのことですが、ギブアップです(;´Д`)

 (= pt (class nil 'x 0 'y 0 pr my-pr))

とかすると、ptの呼び出しでは、prじゃなくて、my-prが呼び出される、ということでしょうか。

どうすれば良いのか検討もつかないなあ。

17. DBs are hashes/alists

dbというものが定義されて、これは、連想リストや、ハッシュ的なものだそうです。

  • newdb、db、get

newdbで新規のdbを作成、dbは簡略版で、問い合わせのテストにeqを過程するものだそうです。

getで、キーを指定して値を取り出します。

また、問い合わせに失敗した場合は、大域変数*fail*を返すとのこと。

;;
;; 動作
;(newdb eq 'x 'a 'y 'b)

(= foo (db x 'a y 'b))

(get x foo)
;-> a

(each x (db x 1 y 2)
   (pr x)
   (keep key))
;12
;(X Y)

;; おれおれ定義
(cl:defmacro newdb (test &rest keys-&-vals)
  `(loop :with ht = (make-hash-table :test #',test)
         :for kv :on ',keys-&-vals :by #'cddr
         :do (setf (cl:gethash (car kv) ht) (%unquote (cadr kv)))
         :finally (return ht)))

(cl:defmacro db (&rest keys-&-vals)
  `(newdb eq ,@keys-&-vals))

(shadow 'get)

(defparameter *fail* nil)

(cl:defmacro get (key db)
  `(multiple-value-bind (val test) (cl:gethash ',key ,db)
     (cl:if test val '*fail*)))

;; dbを扱えるようにeachを拡張。禁斷のeval発動…。
(macro each body
  (if (hash-table-p (eval (cadr body)))
      `(with-keep-or-sum 
	 (each/hash ,@body))
      `(with-keep-or-sum 
	 (each1 ,@body))))

(cl:defun %keys+values (ht)
  (loop :for k :being :the :hash-keys :in ht :using (:hash-value v)
        :collect k :into ks
        :collect v :into vs
        :finally (return (values (coerce ks 'vector) (coerce vs 'vector)))))

(cl:defmacro each/hash (var ht cl:&body body)
  (with (/v (gensym) /k (gensym) /cnt (gensym))
    `(multiple-value-bind (,/k ,/v) (%keys+values ,ht)
       (cl:let (,var key)
	 (declare (ignorable key ,var))
	 (to1 ,/cnt (length ,/k)
	   (setq ,var (aref ,/v ,/cnt) key (aref ,/k ,/cnt))
	   ,@body)))))

;; with-keep-or-sumの定義が変だったので変更
(cl:defmacro with-keep-or-sum (&body body)
  (with (s (x-finder 'sum body) k (x-finder 'keep body))
    (cl:cond ((and s k) (error "SUMとKEEPはどちらかでお願いしたい。"))
	     (s `(with-sum
		   ,@body))
	     (k `(with-keep
		   ,@body))
	     ('T `(progn ,@body)))))

2008-01-20

俺Arc祭り 2008冬 (6)

| 20:35 | 俺Arc祭り 2008冬 (6) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (6) - わだばLisperになる

惰性で続けております、俺Arc祭り。気力が無くなってまいりました。

15. Classes and Objects

クラスとオブジェクトです。単一継承にする予定とのこと。

あんまり詳しく説明はされてません。

基本的に名前の付け替えで逃げました。(++ (p1 'x))というのは逃げきれませんでした。

意味的には(incf (slot-value p1 'x))ということだと思うんですが…。

切ったり貼ったりの無理矢理風味に出来上がりました。

;;
;; 動作
(= pt (class nil 'x 0 'y 0)) ;ptというクラスを作る?

(type pt (x 0) (y 0)) ; 上記の簡便な方法?

(= p1 (new pt))    ;インスタンスをnewで作ってp1に代入

(p1 'y)    ; p1は自動的にメソッドの名前にもなり、スロットを読み出せる。
;=> 0

(++ (p1 'x)) ;読み出して、値をセット
;=> 1

;; おれおれ定義
(cl:defun %unquote (sym)
  (if (and (consp sym) (eq 'quote (car sym)))
      (cadr sym)
      sym))

(shadow 'class)
(cl:defmacro class (name &body body)
  `(cl:defclass ,(if name name (gensym)) ()
     ,(loop :for l :on body :by #'cddr 
	    :collect `(,(%unquote (car l)) :initform ,(cadr l)))))

;; classと、newのために拡張
(cl:defmacro = (place val)
  (cl:cond ((and (consp val) (eq 'class (car val)))
	    `(progn
	       (cl:setf ,place (class ,place ,@(cddr val)))
	       (defmethod ,place (slot)
		 (slot-value ,place slot))))
	   ((and (consp val) (eq 'new (car val)))
	    `(progn
	       (cl:setf ,place ,val)
	       (defmethod ,place (slot)
		 (slot-value ,place slot))))
	   ('T `(cl:setf ,place ,val))))

(shadow 'type)
(cl:defmacro type (name &body body)
  `(cl:defclass ,name ()
     ,(mapcar (cl:lambda (x) `(,(car x) :initform ,(cadr x)))
	      body)))

(cl:defmacro new (class)
  `(make-instance ',class))

2008-01-19

俺Arc祭り 2008冬 (5)

| 03:05 | 俺Arc祭り 2008冬 (5) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (5) - わだばLisperになる

12. Data Types

データの型について

  1. シンボル
  2. 数(Common Lispと同じ)
  3. コンス
  4. 文字
  5. 文字列
  6. 配列
  7. クラス、オブジェクト
  8. データベース(ハッシュ/連想リスト)
  9. 関数
  10. マクロ
  11. その他

だそうです。マクロってのが光ってはいますね。

13. Compounds = Functions on Indices

複合したデータをインデックス付きの関数とみなす試みとのこと。

これも無理目なので、funcallみたいな、obcallというものをでっち上げて代用することにしてみました。


;; 動作
(obcall "hello" 2) 
;=> #\l

(obcall '(foo bar baz) 1)
;=> bar

(map #'pr '(3 4 1 2))
;=> 3412

(map "carpet" '(3 4 1 2))
;=> (#\p #\e #\a #\r)

;; ---- 定義 
(defun obcall (obj index)
  (elt obj index))

(defun map (fn &rest args)
  (if (functionp fn)
      (apply #'cl:mapcar fn args)
      (apply #'cl:mapcar (fn (x) (obcall fn x)) args))) ;複数の引数の場合は?

14. Strings Work Like Lists

文字列をリストに見立てるとのこと。TAO/ELISって文字列をリストとして扱えたらしいというのをどっかで読んだ記憶があるのですが、こういうこともできたんでしょうか。マニュアルには載ってないので、記憶違いかもしれませんが…。

色々と夢が広がりまくりなのですが、適当にできそうなものだけ作ってみました。


;; 動作
(car "abc")
;=> #\a

(cons #\a "bc")
;=> "abc"

;; ---- 定義
(defmethod car ((obj string))
  (aref obj 0))

(defmethod cdr ((obj string))
  (subseq obj 1))

(shadow 'cons)
(defgeneric cons (x y)
  (:method ((x string) (y string)) 
    (cl:concatenate 'string x y))
  (:method ((x character) (y character))
    (cl:concatenate 'string (string x) (string y)))
  (:method ((x string) (y character)) 
    (cl:concatenate 'string x (string y)))
  (:method ((x character) (y string)) 
    (cl:concatenate 'string (string x) y))
  (:method (x y)
    (cl:cons x y)))

俺Arc祭り 2008冬 (4)

| 02:22 | 俺Arc祭り 2008冬 (4) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (4) - わだばLisperになる

Lisp系言語には繰り返し構文が色々ありすぎる位ですが、Arcでも新しい構文を導入するようです。

10. Iteration

  • for, each, to, while

Common LispのDOはわかりづらい!とのこと。自分は、DO大好きなので、全然そう思わないのですが、多分少数派なんでしょう。そういう意見しか目にしたことないし…。繰り返し機構が付いたLETだと思えば、そんなに難解でもないと思うんですが、どうなんでしょう。あと、LOOPは色々話題にのぼるんですが、DOって話題になるとしても「気持ち悪い」で終わることが多いですね(笑)

さっと見た感じでは、ArcではCというかPerlの機構を取り入れてみたようです。どうもこの時のArcは、思い切りPerlの方向に進んでいるような。すべての言語はLispに向かうんじゃなかったのか!

11. Iteration Captures

繰り返し時にsumとか、keepとかitに値を束縛するという試み。加えてwhileは、itを束縛するとのこと。

loopのsum、collect、Perlの、$_とか、そういう感じでしょうか。

keepはリストに蓄え、sumは数を合計します。どうしてかは知りませんが、keepと、sumは二者択一だそうです。

下記のコードはCommon Lispと俺Arcの組み合わせで記述していることもあいまって非常にごちゃごちゃしています。

しかし、どうも括弧の足りないcondは好きになれないな…。


;; 動作
(for (= i 0) (< i 10) (++ i)
  (pr i))

;-> 123456789
NIL

(each x '(1 2 3 4 5) 
      (pr x)
      (sum x))

(each x '("al" "bob" "joe")
   (if (> (len x) 2) (keep x)))
;=> ("bob" "joe")

(to x 5
  (sum x)
  (pr x))
;->01234
10

(let i 0
   (pr (while (< (++ i) 10) (pr i) (keep i)))))
;123456789(1 2 3 4 5 6 7 8 9)

;; 定義

;; for
;;predが受け付けるのは、任意の式なのか、決まった形式か分からないので、
;;predの変数多重評価問題放置
(macro for (init pred then . body) 
  (with (tag (gensym))
    `(do ,init
	 (block nil
	   (tagbody 
	      ,tag
	      (unless ,pred
		(return))
	      ,@body
	      ,then
	      (go ,tag))))))

;; ++
(shadow 'incf)
(shadow '++)
(macro ++ body
  `(cl:incf ,.body))

;; to
(macro to body
  `(with-keep-or-sum to1
     ,.body))

(macro to1 (var limit . body)
  (with (/limit (gensym) /tag (gensym))
    `(let ,/limit ,limit
	  (do (= ,var 0)
	      (block nil
		(tagbody 
		   ,/tag
		   (unless (< ,var ,/limit)
		     (return))
		   ,@body
		   (++ ,var)
		   (go ,/tag)))))))

;; each
(macro each body
  `(with-keep-or-sum each1
     ,@body))

(macro each1 (var obj . body)
  (with (/i (gensym) /obj (gensym))
    `(with (,/obj (coerce ,obj 'vector) ,var nil)
       (to1 ,/i (length ,/obj)
	 (setq ,var (aref ,/obj ,/i))
	 ,@body))))

;; while
(macro while body
  `(with-keep-or-sum while1
     ,.body))

(macro while1 (pred . body)
  (let tag (gensym)
       `(block nil
	  (tagbody
	     ,tag
	     (if ,pred
		 (do ,.body
		     (go ,tag))
		 nil)))))

(macro with-keep-or-sum (fn . body)
  (with (s (x-finder 'sum body) k (x-finder 'keep body))
    (cond (and s k) (error "SUMとKEEPはどちらかでお願いしたい。")
	  s `(with-sum
	       (,fn ,.body))
	  k `(with-keep
	       (,fn ,.body))
	  `(,fn ,.body))))

(macro with-keep body
  (let /tem (gensym)
       `(let keep (list ())
	     (declare (ignorable keep))
	     (let ,/tem keep
		  (cl:macrolet ((keep (var) 
				  `(rplacd (cl:last ,',/tem) (list ,var))))
		    ,@body))
	     (cl:cdr keep))))

(macro with-sum body
  `(let sum 0
     (declare (ignorable sum))
     (cl:macrolet ((sum (var) `(++ sum ,var)))
       ,@body)
     sum))


俺Arc祭り 2008冬 (3)

| 00:55 | 俺Arc祭り 2008冬 (3) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (3) - わだばLisperになる

だんだん疲れて来てしまいました。俺Arc祭り。段々恥ずかしい駄目駄目なコードを晒すのも恥ずかしくなってまいりました。

実際のところは駄目なところが分からないのと、恥ずかしいところが分からない自分が恥かしいのですが。

それはさておき、

9. Binding

  • with, let

Arcの変数束縛機構ですが、letは、変数を一組しかとらないことにするみたいです。Gaucheのlet1と同じ感じ。

複数の場合には、withを使用するとのこと。

また、(let x 3 (foo x))は((fn (x) (foo x) ) 3)に展開されるんだそうです。letがlambdaに展開されるってことでしょうか。

色々深いんだと思いますが、単にletに展開するだけにしました。


;; 動作
(with (x 'a y 'b)
  (list x y))
;=> (A B)

(let x 'a
     (cons x 5))
;=> (A . 5)

;; 定義
(cl:defmacro with ((&rest spec) &body body)
  `(cl:let ,(cl:do ((s spec (cddr s)) res)
		   ((endp s) (nreverse res))
		   (push `(,(car s) ,(cadr s)) res))
	   ,@body))

(shadow 'let)
(cl:defmacro let (var val &body body)
  `(cl:let ((,var ,val))
	   ,@body))

俺Arc祭り 2008冬 (2)

| 00:18 | 俺Arc祭り 2008冬 (2) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (2) - わだばLisperになる

だらだら続いております。俺Arc祭り。

自分の書いているものが、非常に読み辛く、また書いてても良く分からなくなって来たので、小分けにして行くことにしました。

8. Functions and Macro

  • fn

lambdaは、fnと書くそうです。


(macro fn body
  `(cl:lambda ,@body))

非常に安直に…。(funcall (fn (x) (+ x 3)) 3)としないと動きません…。

((fn (x) (+ x 3) ) 3)みたいにして動くようにする簡単な方法ってあるんでしょうか。

  • rfn

labels(再帰可能なローカル関数定義)は、rfnと書くとのこと。

rfnは、多分トップレベルでも使えるんだろうとは思いますが、色々大変そうなので、doに埋め込むことにしました。

段々と定義するのにパッケージを指定するのが面倒になってきたので、my-arcパッケージを定義するために、my-arc-defというパッケージを作成し、そこからインポートすることにしてみます。

  • no

doの例で出てきたので、nullの一般化されたものと勝手に解釈して適当に定義。


;; 動作
(do (= x '(foo bar baz))
    (rfn len (x) (if (no x) 0 (+ 1 (len (cdr x)))))
    (pr 1)
    (rfn fact (n) (if (no n) 1 (* n (fact (1- n)))))
    (pr 2)
    (= y (len x))
    (list x y (fact 10)))

;->1 2
;=> ((FOO BAR BAZ) 3 3628800)

;; 上記のマクロ展開
(let (y x)
     (declare (ignorable y x))
     (setq x '(foo bar baz))
     (labels ((len (x)
		(let ((it (no x)))
		     (if it 0 (+ 1 (len (cdr x))))))
	      (fact (n)
		(let ((it (no n)))
		     (if it 1 (* n (fact (1- n)))))))
       (pr 1)
       (pr 2)
       (setq y (len x))
       (list x y (fact 10))))

;; ごちゃごちゃ定義
(in-package :my-arc-def)

(defun rfn-expander (body)
  (do ((b body (cdr b)) res)
      ((endp b) (nreverse res))
    (if (eq 'rfn (alexandria:ensure-car (car b)))
	(multiple-value-bind (fn bo) (rfn+body b)
	  (return `(,@(nreverse res)
		      (labels ,fn
			,@bo))))
	(push (car b) res))))

(defun rfn+body (body)
  (let (fn bo)
       (dolist (b body (values (nreverse fn)
			       (nreverse bo)))
	 (if (eq 'rfn (car b))
	     (push (cdr b) fn)
	     (push b bo)))))

(in-package :my-arc)

(macro do body
  (let vars (x-finder '= body)
    `(cl:let ,vars
	  (declare (ignorable ,@vars))
	  ,@(rfn-expander
	     body))))

(defmethod no ((obj null)) t)
(defmethod no ((obj string)) (equal obj ""))
(defmethod no ((obj character)) (equal obj #\Nul))
(defmethod no ((obj number)) (zerop obj))
(defmethod no ((obj vector)) (equalp obj #()))
(defmethod no (obj) nil)

  • マクロはファーストクラスオブジェクト

局所マクロを作るのは単に変数に束縛するだけ。

これは無理なのでスルー。

しかし、マクロがファーストクラスオブジェクトだとどういう風にプログラミングスタイルが変わるんでしょうね。

例示されているmacroの例なんですが、


(macro (test . body)
  `(if ,test (do ,.body))) 

;; when?
(macro when (test . body)
  `(if ,test (do ,.body)))

;; 動作
(when 33
  'foo 'bar 'baz it)
;=> 33

これってタイポでwhenが抜けてるんですかね? whenだと合点が行くのですが…。

ひたすら続きます…。

2008-01-18

俺Arc祭り 2008冬 (1)

| 10:17 | 俺Arc祭り 2008冬 (1) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (1) - わだばLisperになる

ポール・グレアム氏のArcが、この冬に公開されるらしいとのこと。

それでそのArc公開のニュースなんですが、存外、話題にもなってない様子です。

もっとドッカンドッカン騒がれるのかと思ったんですが…。

Arcの計画が世に現われたのは、2001年の11月位とのことなので、早6年。

話の流れ的には、全くつながっていないのですが、この6年前のアイディアを、そのままCommon Lispのマクロで書いて俺Arcを作ってみることにしました。

多分、結構試してみた方は結構いるんじゃないかと思うんですが、へんてこ俺Arcを作って実物のArcに思いを馳せることができるの残り僅かかも知れません。

また、俺Arcを作ってみることで、本物のArcへの理解も深まるかもしれません。

Arcはまさに今が旬なのです!

ということで、早速、ノープランでこの2001年の発表を頭から順番に作っていってみます。

下準備

とはいえなんとなく必要そうなものは予め作ってみます。


(defpackage :my-arc
  (:use :cl))

(in-package :my-arc)

(cl:defmacro macro (cl:&body body)
  (cl:if (cl:consp (second body))
	 `(cl:defmacro ,@body)
	 `(cl:defmacro ,(first body) (cl:&body ,(second body)) ,@(cddr body))))

(cl:defmacro def (cl:&body body)
  (cl:if (cl:consp (second body))
	 (cl:if (tailp body ())
		`(cl:defun ,@body)
		`(cl:defun ,(first body) ,(%add-rest (second body)) ,@(cddr body)))
	 `(cl:defun ,(first body) (cl:&rest ,(second body)) ,@(cddr body))))

(cl:defun %add-rest (expr)
  (cl:let ((l (copy-list expr)))
     (cl:let ((tail (last l)))
	     (rplacd tail `(&rest ,(cdr tail)))
	     l)))

パッケージ名は安直に、my-arc。defmacroと、defunに、macro、defという名前を付け直してみました。&restパラメータは取らないそうなので、適当にSchemeのlambdaみたいにすることにしました。割と悲しげに仕上がりました。

4. Other Principles

Arcはポリモーフィックだそうで、+で文字列の連結とかするそうです。総称関数にしようかとも思いましたが、etypecaseで分けました。これは結構やってる人は多そうです。


;; 動作
(+ "foo" "bar")
;=>"foobar"

(pr (+ #(foo) "bar"))
;#(FOO b a r)
(+ '(foo bar) '(baz))
;(foo bar baz)

(+ 0 pi)
;3.141592653589793d0

;; 定義
(def + (arg . args)
  (etypecase arg
    (string (apply #'concatenate 'string arg args))
    (vector (apply #'concatenate 'vector arg args))
    (list (apply #'concatenate 'list arg args))
    (number (apply #'cl:+ arg args))))

5. Syntax

Arcでは、文法を定義して、foo.barのような呼び出しを可能にしてみる、とのことですが、これは当然ながらしんどいので中途半端に挑戦して諦めることにしました。

fn.y => (fn y)

fn:y => (fn 'y)

[+ _ 1] => (fn (x) (+ x 1))

だそうです。

角カッコのやつは、リーダマクロでできそうです。


;; 存在しないものを捏造
(macro arcall (expr)
  (arc-to-cl expr))

;; 定義
(let ((foo -33.5))
   (arcall truncate.abs.foo))
;=> 33, 0.5

(defun arc-to-cl (expr)
  (reduce #'list
	  (map #'read-from-string (ppcre:split "\\." (string expr)))
	  :from-end 'T))

6. Arc Core

condの括弧が多いので、減らすそうです。

自分はlet、do、condの括弧は割と苦にならないタイプなんですが、そういうのは少数派なんでしょうか…。(とはいえ、もう一段階ネストした、Schemeのmatch-letはわけがわかりませんが…。)

とりあえず、安直にボディを適当に振り分けて、itを使うためにkmrclのacondに展開することにしてみました。

ちなみにここで、Lisp 1.5のcondの暗黙のprognについて語られてますが、エミュレータのLisp 1.5で試した限りでは、Lisp 1.5のcondは暗黙のprognじゃないみたいなんですよね。lambdaのボディも暗黙のprognじゃないみたいで、Lisp 1.5は謎が多いです…。

それと、nilへのcar、cdrの適用は、エラーとのこと。


;; 動作
(cond (probe-file "/tmp/") (do (pr "it -> ") (pr it) (terpri))
      nil)
;it -> /tmp/

;; 定義
(shadow 'cond)

(macro cond body
  (cl:let ((cond-body (cl:do ((b body (cl:cddr b))
			      res)
			     ((endp b) (nreverse res))
			(cl:if (cl:cdr b)
			       (push `(,(cl:car b) ,(cl:cadr b)) res)
			       (push `(t ,(cl:car b)) res)))))
	  `(kmrcl:acond ,@cond-body)))

(shadow 'car)
(shadow 'cdr)

(defmethod car ((obj null))
  (error "The value ~S is not of type LIST." obj))

(defmethod car ((obj cons))
  (cl:car obj))

(defmethod cdr ((obj null))
  (error "The value ~S is not of type LIST." obj))

(defmethod cdr ((obj cons))
  (cl:cdr obj))

7. Assignment (Scope)

ローカル変数は値を代入すると暗黙に作られて、まだ宣言されていない変数に値を代入すると、現在のブロックの残りの部分までを有効範囲とする局所変数が作られるとのこと。

ブロックは、主にdoで作成。

=は、setfに相当するとのこと。

ArcdoはCommon LispのprognでprはCommon Lisp のprincだそうです。

変数を束縛しないのは、justdoになるとのこと。ってことは、do = prognなくて、justdo = prognなんでしょうか。

とりあえず、無理矢理letに変換することにしました。


(do (= x 5)
    (cons x 'a))
;=:> (5 . A)

(do (= x 5)
  (do (= y 6)
      (list x y)))
;=> (5 6)

;; 定義
(shadow 'do)

(macro do body
  (cl:let ((vars (%x-finder '= body)))
	  `(cl:let ,vars
		   (declare (ignorable ,@vars))
		   ,@body)))

(cl:defun %x-finder (sym form &optional taglist)
  (and form
       (if (eq sym (car form))
	   (push (cadr form) taglist)
	   (dolist (c (remove-if-not #'consp form) 
		    (delete-duplicates taglist))
	     (cl:let ((tem (%x-finder sym c taglist)))
		     (cl:when tem
		       (setq taglist tem)))))))

(shadow '=)

(macro = args
  `(cl:setf ,@args))

(macro justdo body
  `(progn ,@body))

(shadow 'princ)

(setf (symbol-function 'pr) #'cl:princ)

大した内容でもないのに長くなってしまいました。まだまだあるので、続きは別エントリにします…。

2008-01-16

last.fmと連携するなにかを作りたい: 執着篇

| 00:21 | last.fmと連携するなにかを作りたい: 執着篇 - わだばLisperになる を含むブックマーク はてなブックマーク - last.fmと連携するなにかを作りたい: 執着篇 - わだばLisperになる

cl-audioscrobblerをみつけたので、もう自作する必要はないのですが、ちゃんと機能するクライアントをみつけたということもあり、自作のものは一体どの辺がおかしくて認証を通らなかったのかを確かめてみることにしました。

結論からいうと、ケアレスミスで、 md5sum-sequenceが返す#(1 2 3 255 255)のようなベクタを"010203ffff"のような文字列に変換する際に、0でパディングするのを忘れて、"123ffff"としていた、というものでした。なるほど、そりゃ駄目ですわな…。

修正したら自作のものもポストできるようになりました。とりあえず、すっきりした…。

(require :url-rewrite)
(require :drakma)
(require :md5)

(defpackage :last.fm
  (:use #:cl #:drakma #:url-rewrite))

(in-package :last.fm)

(defclass user ()
  ((name :initarg :name :accessor name :initform "")
   (password :initarg :password :accessor password :initform "")))

(defun make-get-scrobbler-uri-string (clientid clientver user)
  (let ((base "http://post.audioscrobbler.com/?hs=true&p=1.1"))
    (concatenate 'string base 
                 "&c=" clientid
                 "&v=" clientver
                 "&u=" user)))

(defun handshake-one (clientid clientver user)
  (http-request 
   (make-get-scrobbler-uri-string clientid clientver user)))
   
(defun decode-handshake-one (clientid clientver user)
  (let ((response 
         (http-request (make-get-scrobbler-uri-string clientid clientver user))))
    (destructuring-bind (uptodatep md5-challenge post-url interval) (ppcre:split "\\n" response)
      (list (string-equal "uptodate" uptodatep)
            md5-challenge
            post-url
            (ppcre:register-groups-bind (wait) ("INTERVAL ([0-9]+)" interval)
              (values (parse-integer wait :junk-allowed 'T)))
            user))))

(defun string-to-md5-string (str)
  (string-downcase 
   (apply #'concatenate 'string
          (map 'list (lambda (x) (format nil "~2,'0,X" x))
               (md5:md5sum-sequence str)))))

(defun make-md5-response (password md5-challange)
  (string-to-md5-string
   (concatenate 'string (string-to-md5-string password) md5-challange)))

(defun current-time-string ()
  (multiple-value-bind (s m h d mo y) (decode-universal-time (get-universal-time) 0)
    (format nil "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D" y mo d h m s)))

(defmethod make-submit-uri ((user user) (artist string) (track string) (album string) (length integer))
  (destructuring-bind (uptodatep md5 post-url interval username)
      (decode-handshake-one "tst" "1.0" (name user))
    (declare (ignore uptodatep))
    (values 
     (concatenate 'string 
                  post-url
                  "?u=" username
                  "&s=" (make-md5-response (password user) md5)
                  "&" (url-encode "a[0]") "=" (url-encode artist)
                  "&" (url-encode "b[0]") "=" (url-encode album)
                  "&" (url-encode "t[0]") "=" (url-encode track)
                  "&" (url-encode "m[0]") "=" ;mbid
                  "&" (url-encode "l[0]") "=" (prin1-to-string length)
                  "&" (url-encode "i[0]") "=" (url-encode (current-time-string)))
     interval)))

(defun scrobble-current-song (user &key artist track album length)
  (multiple-value-bind (uri wait)
      (make-submit-uri user
                       artist
                       track
                       album
                       length)
    (sleep wait)
    (http-request uri)))

;; テスト
(setq me (make-instance 'user :name "user" :password "password"))

(print (scrobble-current-song 
        me
	:artist "Bonnie Pink"
	:track "Private Laughter"
	:album "Even So"
	:length 179))

2008-01-06

last.fmと連携するなにかを作りたい: 頓挫篇

| 23:43 | last.fmと連携するなにかを作りたい: 頓挫篇 - わだばLisperになる を含むブックマーク はてなブックマーク - last.fmと連携するなにかを作りたい: 頓挫篇 - わだばLisperになる

レトロなLispも良いけど何か普段使うツールのようなものを何か作りたいなあと思い、アカウントを作ったものの、あまり利用していないlast.fm用の簡単なクライアントをCommon Lispで書けないものかと、ちょっと調べてみました。

サーバとの通信の手順は、解説ページにまとまっていました。

ということで、何の考えもなく、そのページを頭から読みつつ、ガチャガチャコードを書きながら動作を確認してゆくことに。

曲情報の投稿までの流れとしては、

  1. クライアント、ユーザの情報をサーバに投げる。
  2. サーバから認証用のキーと投稿用URLと待機時間が送られてくる
  3. 送られて来た情報とパスワードをMD5でエンコードし、曲の情報と一緒にして投げる

という風な感じです。

途中までは順調だったのですが、サーバとの認証のところでどうもMD5でエンコードしたものの結果が違うらしく引っ掛かってしまい、BAD AUTHとなり先に進めず。

説明では、

The MD5 response is md5(md5(your_password) + challenge),
where MD5 is the ascii-encoded, lowercase MD5 representation,
and + represents concatenation.
MD5 strings must be converted to their hex value before concatenation
with the challenge string and before submission to the final MD5 response.

ということなのですが、md5(md5(your_password) + challenge)なので、一回目のハンドシェイクで送られて来たMD5のキーとMD5でエンコードしたパスワードをくっつけ、さらにそれをMD5でエンコードする、という風に読めるのですが、どうも上手く行かず。MD5のエンコードが違ったりするのかなと思い、md5sumで確認してみても生成されるキーは同一で、それ自体には問題はない様子。うーん、それとも、認証じゃなくて全然違うところで引っ掛かってしまっているのか。

こうなると他の言語での実装を調べてみるしかなさそうな気配。

しかし、他の言語は殆ど読めないのだよなあ(;´Д`)


(defpackage :last.fm
  (:use #:cl #:drakma #:url-rewrite #:md5))

(in-package :last.fm)

(defun make-get-scrobbler-uri-string (clientid clientver user)
  (let ((base "http://post.audioscrobbler.com/?hs=true&p=1.1"))
    (concatenate 'string base 
		 "&c=" clientid
		 "&v=" clientver
		 "&u=" user)))

(defun handshake-one (clientid clientver user)
  (http-request 
   (make-get-scrobbler-uri-string clientid clientver user)))
   
(defun decode-handshake-one (clientid clientver user)
  (let ((response 
	 (http-request (make-get-scrobbler-uri-string clientid clientver user))))
    (destructuring-bind (uptodatep md5-challenge post-url interval) (ppcre:split "\\n" response)
      (list (string-equal "uptodate" uptodatep)
	    md5-challenge
	    post-url
	    (ppcre:register-groups-bind (wait) ("INTERVAL ([0-9]+)" interval)
	      (values (parse-integer wait :junk-allowed 'T)))
	    user))))

(defun string-to-md5-string (str)
  (apply #'concatenate 'string
	 (map 'list (lambda (x) (string-downcase (write-to-string x :base 16)))
	      (md5sum-sequence str))))

(defun make-md5-response (password md5-challange)
  (string-to-md5-string
   (concatenate 'string (string-to-md5-string password) md5-challange)))

; - UTC date/time in YYYY-MM-DD hh:mm:ss format
(defun current-time-string ()
  (multiple-value-bind (s m h d mo y) (get-decoded-time)
    (format nil "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D" y mo d h m s)))

(defun make-submit-uri (data artist track album length)
  (destructuring-bind (uptodatep md5 post-url interval user) data
    (declare (ignore uptodatep))
    (values 
     (concatenate 'string 
		  post-url
		  "?u=" user
		  "&s=" (make-md5-response "password" md5)
		  "&a0=" (url-encode artist)
		  "&t0=" (url-encode track)
		  "&b0=" (url-encode album)
		  "&m0="		;mbid
		  "&l0=" length
		  "&i0=" (url-encode (current-time-string)))
     interval)))

(defun scrobble-current-song (artist track album length)
  (multiple-value-bind (uri wait)
      (make-submit-uri (decode-handshake-one "tst" "1.0" "g000001")
		       artist
		       track
		       album
		       length)
    (sleep wait)
    (http-request uri)))

;; TEST
(print (scrobble-current-song "Bonnie Pink"
			      "Private Laughter"
			      "Even So"
			      "179"))

2007-12-27

PLEACの空き地

| 18:39 | PLEACの空き地 - わだばLisperになる を含むブックマーク はてなブックマーク - PLEACの空き地 - わだばLisperになる

どう書く.orgはマルチリンガルなクックブックも狙っているそうなのですが、そういえば、そのものズバリのマルチリンガルクックブックの実現を目指しているサイトが確かあった筈と思い出し、検索してみたところ、Perlのクックブックのレシピを色んな言語で実装しようというPLEAC - Programming Language Examples Alike Cookbookというサイトがみつかりました。

自分の記憶でも確かこのサイトです。

Common Lispのエントリもあって、現在は30%強の達成度で、SchemeはGuileでのエントリとなりますが50%弱の達成度です。

割と面白そうなので、空き地をみつけて挑戦してみることにしました。

とはいえ、できそうなところだけですが…。

16章の「プロセス管理とプロセス間通信」ってところが0%なので、なんとなくこれにあたってみることにします。

レシピ16.1 プログラムの出力を収集する

;; $output = `program args`;   # collect output into one multiline string
;; ----------------------------------------------------------------

(let ( (output (kmrcl:command-output "ls -l")))
  output)
;; command-outputはformatのように書ける。
(kmrcl:command-output "~A ~A" "/bin/ls" "-l")

;; @output = `program args`;   # collect output into array, one line per element
;; ----------------------------------------------------------------
(let ( (output (ppcre:split "\\n" (kmrcl:command-output "ls -l"))))
  output)

シェルコマンドの出力を取り込むということですが、KMRCLパッケージのcommand-outputが使えるので、それで。

配列への格納は、CL-PPCREのSPLITを使って改行文字で分解して一つのリストに纏めるということにしてみました。これには色んな方法があるとは思います。

レシピ16.2 別のプログラムを起動する

;; $status = system("vi $myfile");
(let ( (myfile "bar.txt"))
  (let ( (status (kmrcl:run-shell-command "vi ~A" myfile)))
    status))

viを起動するってのは、色々面倒なことが多いかもしれませんが、ls等であればまず問題なくいけると思います。

レシピ16.4 別のプログラムと読み書きする

;; 文字限定:出力を読む
;; ----------------------------------------------------------------
(let ( (cmd "ls -l"))
  (with-input-from-string (readme (kmrcl:command-output "ls -l"))
    (series:iterate ( (line (series:scan-stream readme #'read-line)))
    #|
     行を処理
    ...|# ))

;; 文字限定:文字列をcmdに渡す
;; ----------------------------------------------------------------
(let ( (cmd "tr 'a-z' 'A-z'")
      (tempfile (format nil "/tmp/~A" (gensym "tempfile-"))))
  (with-open-file (out tempfile :direction :output)
    #| 
    (print "foo" out)
    (print "bar" out)
    (print "こんにちは" out))
    ...|#
  (kmrcl:awhen (probe-file tempfile)
    (prog1 (kmrcl:command-output "cat ~A|~A" tempfile cmd)
           (delete-file kmrcl:it))))

別のプログラムというのは、シェルで実行するコマンドなわけですが、文字列限定ってことで書いてみました。

どうも難しい。どういう書法が定石なんでしょうか。バイナリの読み書きもどうしたもんかと。

レシピ16.11 名前付きパイプを使ってプロセスをファイルのように見せる

(defun pipe-reader (pipe &optional (output *standard-output*))
  (with-open-file (fifo pipe)
    (series:iterate ( (line (series:scan-file fifo #'read-line)))
      (write-line line output))))

(defun pipe-writer (mesg pipe)
  (with-open-file (fifo pipe :direction :output :if-exists :append)
    (write-line mesg fifo)))

(let ( (named-pipe "/tmp/named.pipe"))
  (kmrcl:run-shell-command "mkfifo ~A" named-pipe)
  ;; 別スレッドで待ち受け
  (princ "Got: ")
  (portable-threads:spawn-thread 'pipe (lambda ()
                                         (pipe-reader named-pipe #.*standard-output*)))
  ;; FIFO経由で書き込み
  (pipe-writer "Smoke this." named-pipe)
  (force-output))

パイプへ書き込む関数と読み出す関数を定義して、別スレッドで実行することにしてみました。

変なところで改行されたりされなかったりしますが、表示のさせ方を考えれば多分大丈夫なのではないかと。

まとめ

という感じで、できそうなところに挑戦してみました。

いやいや、そういう書き方は変だよ、とか、こう書くとスマートだよね、とか、これ実装してみたよ、等々ありましたら、グループで専用の掲示板を作ってみましたので、良かったら、お気軽に書き込んでみて下さい!(→cadr group) もちろんここへのトラックバックも大歓迎ですし、直接PLEACに投稿してみるというのも良いと思います。自分は、数が溜ったら投稿してみようかなと思っています。(PLEACのメーリングリストに参加して、コードをレビューしてもらって掲載という流れのようです。)

2007-12-18

祝Pitmanual改訂版発表ということでdesetqをつくってみる

| 03:23 | 祝Pitmanual改訂版発表ということでdesetqをつくってみる - わだばLisperになる を含むブックマーク はてなブックマーク - 祝Pitmanual改訂版発表ということでdesetqをつくってみる - わだばLisperになる

どうしてなのかは知りませんが、急に12/16日の日曜日にMacLISPのマニュアルの改訂版(The Revised Maclisp Manual (The Pitmanual))が発表されました。

結構前からMACLISP infoというサイトはありまして、Maclispの情報が纏められるサイト予定地ということだったんですが、ずっとコンテンツは不在でした。

作者のKent M. Pitman氏は特にどっかに完成を発表したという訳でもないようでcomp.lang.lispにタレこみがあって初めて周知された様子。

しかし、仕上がりは結構気合いが入っていて、原稿をHTMLに直しただけでは全然なく、Common Lispとの比較や現在の視点からの考察が加えられています。

需要と供給のバランスからすれば、かなりの過剰供給っぷり。

製作には、奥さんと娘さんと本人が当たったということで、これまた不思議な家族。

ということで、なんとなく記念にMaclispのdesetqを作って遊んでみることにしました。

こないだ、Maclispのletの分割代入版を作ったときに、desetqも作ろうと思っていたのですが、こっちは放置してました。

desetqは、setqに分割代入機能が付いたものでPitmanualでの解説はThe Pitmanual: Control Formsです。

Pitman+Manualで、Pitmanual、これの前のDavid Moon氏が作ったのは、Moonualと呼ばれていたとのことで、その辺の文化を継承してるみたいです。

動作としては、

(let ((a 1) (b 2) (c 3) (d 4) (e 5) (f 6))
  (desetq (((a) b . c) d e f)  (list (list* (list a) b c) d e f) )
  (list a b c d e f))
;==> (1 2 3 4 5 6)

という感じになります。

(defmacro desetq (&rest bind-specs)
  (unless (evenp (length bind-specs))
    (error "Too many arguments in form ~S." bind-specs))
  (do ((l bind-specs (cddr l)) 
       body vars)
      ((endp l) `((lambda ,vars ,@body) ,@(mapcar (constantly ()) vars)))
    (let ((var (car l)) (val (cadr l)))
      (if (consp var)
	  (let ((tem (gensym)))
	    (multiple-value-bind (varlist vallist) (des- var tem)
	      (setq vars `(,@vallist ,@vars ,tem))
	      (setq body `(,@body (setq ,tem ,val) ,@varlist))))
	  (setq body `(,@body (setq ,var ,val)))))))

(defun des- (bind sym)
  (let (vars)
    (values 
     (labels ((frob (bind sym)
		(cond ((null bind) nil)	
		      ((atom bind)
		       `((setq  ,bind ,sym)))
		      ((null (car bind))
		       `((setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ((and (atom (car bind)) (null (cdr bind)))
		       `((setq ,(car bind) (car ,sym)))) ;last -1
		      ((atom (car bind))
		       `((setq ,(car bind) (car ,sym))
			 (setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ('T (let ((carcons (gensym)))
			    (push carcons vars)
			    `((setq ,carcons (car ,sym))
			      ,@(frob (car bind) carcons)
			      (setq ,sym (cdr ,sym))
			      ,@(frob (cdr bind) sym)))))))
       (frob bind sym))
     vars)))

  • 動作
(desetq (((a) b . c) d e f)  (list (list* (list a) b c) d e f))
;==>

((LAMBDA (#:G2 #:G1 #:G0)
   (SETQ #:G0 (LIST (LIST* (LIST A) B C) D E F))
   (SETQ #:G1 (CAR #:G0))
   (SETQ #:G2 (CAR #:G1))
   (SETQ A (CAR #:G2))
   (SETQ #:G1 (CDR #:G1))
   (SETQ B (CAR #:G1))
   (SETQ #:G1 (CDR #:G1))
   (SETQ C #:G1)
   (SETQ #:G0 (CDR #:G0))
   (SETQ D (CAR #:G0))
   (SETQ #:G0 (CDR #:G0))
   (SETQ E (CAR #:G0))
   (SETQ #:G0 (CDR #:G0))
   (SETQ F (CAR #:G0)))
 NIL NIL NIL)

と展開されます。

オリジナルのものはもうすこし綺麗に展開されるのですが、若干面倒なので、これで良しとしました。

2007-12-02

古えの分割代入機構的let

| 00:20 | 古えの分割代入機構的let - わだばLisperになる を含むブックマーク はてなブックマーク - 古えの分割代入機構的let - わだばLisperになる

いつものごとく、古いソースを眺めていて、古えのletの分割代入バージョンが詳しい説明付きソースをみつけました。

letが登場したのは、1979年位らしいですが、その当時からdestructuring-bindみたいな需要はあったらしく、このファイルでは、分割代入できるletが、そのままletという名前で、setqのバージョンがdesetqという名前で実装されています。

とりあえず、

(LET ((((A (B C) () . D) E () . F) (MUMBLIFY))
      TEMP
      (KEYNO '35)
      ANOTHER-TEMP)
  (DECLARE (SPECIAL F KEYNO))
  (COGITATE (LIST D E) A B C F))
  
; ==>

((LAMBDA (G0005 TEMP KEYNO ANOTHER-TEMP F E D C B G0007 A G0006) 
   (DECLARE (SPECIAL F KEYNO))
   (SETQ G0006 (CAR G0005))
   (SETQ A (CAR G0006))
   (SETQ G0006 (CDR G0006))
   (SETQ G0007 (CAR G0006))
   (SETQ B (CAR G0007))
   (SETQ G0007 (CDR G0007))
   (SETQ C (CAR G0007))
   (SETQ G0006 (CDR G0006))
   (SETQ D (CDR G0006))
   (SETQ G0005 (CDR G0005))
   (SETQ E (CAR G0005))
   (SETQ G0005 (CDR G0005))
   (SETQ F (CDR G0005))
   (COGITATE (LIST D E) A B C F))
 (MUMBLIFY) () '35 () () () () () () () () ())

という変換をするマクロで一時変数に値を移し移ししているのが面白いと思ったので、とりあえず、この説明を参考に自作して遊んでみました。


(defun des (bind sym)
  (let (vars)
    (values 
     (labels ((frob (bind sym)
		(cond ((null bind) nil)	
		      ((atom bind)
		       (push bind vars)
		       `((setq  ,bind ,sym)))
		      ((null (car bind))
		       `((setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ((and (atom (car bind)) (null (cdr bind)))
		       (push (car bind) vars)
		       `((setq ,(car bind) (car ,sym)))) ;last -1
		      ((atom (car bind))
		       (push (car bind) vars)
		       `((setq ,(car bind) (car ,sym))
			 (setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ('T (let ((carcons (gensym)))
			    (push carcons vars)
			    `((setq ,carcons (car ,sym))
			      ,@(frob (car bind) carcons)
			      (setq ,sym (cdr ,sym))
			      ,@(frob (cdr bind) sym)))))))
       (frob bind sym))
     vars)))

(defun cadrat (item)
  (if (consp item) (cadr item) nil))

(defmacro dlet ((&rest bind-specs) &body body)
  (let (cons-binds cons-vars) 
    (let ((vars (mapcar (lambda (item)
			  (if (consp item)
			      (if (consp (car item))
				  (let ((gs (gensym "VAR-")))
				    (multiple-value-bind (bf bv) (des (car item) gs)
				      (push bf cons-binds)
				      (push bv cons-vars))
				    gs)
				  (car item))
			      item))
			bind-specs))
	  (vals (mapcar #'cadrat bind-specs)))
      (let ((cons-vars (apply #'append cons-vars)) ;rebind
	    (cons-binds (apply #'append cons-binds)))
	`((lambda (,@vars ,@cons-vars)
	    ,@(if (eq (caar body) 'declare) ; declareを先頭に
		  `(,(pop body) 
		     ,@cons-binds
		     ,@body)
		  `(,@cons-binds ,@body)))
	  ,@(append vals (mapcar (constantly nil) cons-vars)))))))
;; マクロ展開
(dLET ((((A (B C) () . D) E () . F) (MUMBLIFY))
      TEMP
      (KEYNO '35)
      ANOTHER-TEMP)
  (DECLARE (SPECIAL F KEYNO))
  (COGITATE (LIST D E) A B C F))

;==>
((LAMBDA (#:VAR-3340 TEMP KEYNO ANOTHER-TEMP F E D C B #:G3342 A #:G3341)
   (DECLARE (SPECIAL F KEYNO))
   (SETQ #:G3341 (CAR #:VAR-3340))
   (SETQ A (CAR #:G3341))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ #:G3342 (CAR #:G3341))
   (SETQ B (CAR #:G3342))
   (SETQ #:G3342 (CDR #:G3342))
   (SETQ C (CAR #:G3342))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ #:G3341 (CDR #:G3341))
   (SETQ D #:G3341)
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ E (CAR #:VAR-3340))
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ #:VAR-3340 (CDR #:VAR-3340))
   (SETQ F #:VAR-3340)
   (COGITATE (LIST D E) A B C F))
 (MUMBLIFY) NIL '35 NIL NIL NIL NIL NIL NIL NIL NIL NIL)

;; 実行
(dlet ((((a (b c) () . d) e () . f) '((1 (2 3) () . 4) 5 () . 6))
      temp
      (keyno '35)
      another-temp)
  (declare (special f keyno))
  (list (list d e) a b c (symbol-value 'f) keyno another-temp temp))

;=>
((4 5) 1 2 3 6 35 NIL NIL)

いつもの如く行き当たりばったりなコード。

letだと名前がぶつかって厄介なので、dletという名前にしました。

元のソースは参考にしないで作りましたが、なんとなく仕組は分かったので、元はどうやって問題を解決しているのか探ってみたいと思います。

それと確かOn Lispにも似たようなものがあったのと思ったのでそっちも勉強したいです。

2007-11-30

YouTubeのFLVダウンローダー

| 18:02 | YouTubeのFLVダウンローダー - わだばLisperになる を含むブックマーク はてなブックマーク - YouTubeのFLVダウンローダー - わだばLisperになる

最近PCを新しくして、Ubuntuで64bit環境にしてみたのですが、64bit版Flash PlayerがないためYouTube等は工夫しないと見れなくなってしまいました。元々YouTubeはあんまり見てないんないですが、観れないとなると観たくなってきました。

YouTubeの動画は、FLVという形式らしく、ダウンロード可能とのことで、動画ページに含まれるswfArgsという行のvideo_idとtをyoutube.com/get_video.phpというページにGETで送れば、FLVが取得できる仕組みとのこと(11/30日現在の仕様)ということなので、idの取得は、cl-ppcreで適当に抽出し、FLVのダウンロードは、以前letterさんのletter: Common Lisp でニコニコ動画ダウンローダーという記事を目にしていたので、記事を参考にさせて頂きました。

そんなこんなで、拙いですがFLVダウンローダーをでっち上げてみました。一応動きますが、flvファイル名の付けなおし等はいまいちな出来です。

一応ソース(youtube.lisp)も置いてみます。

;;; 動画ページのJavaScriptにある、swfArgsからvideo_idとtを取得し、両方をhttp://youtube.com/get_video.phpにGETで送りFLVを取得
;;; 
;;; 使用例
;;; (mapc (lambda (u)
;;; 	(format t "~A Started...~%" u)
;;; 	(get-flv-to-file-interactive u (merge-pathnames "Desktop/" (user-homedir-pathname)))
;;; 	(format t "Done...~%"))
;;;       '("http://jp.youtube.com/watch?v=E4PYJhh8ooo" ...))

(defpackage #:setagaya.youtube.mc
  (:nicknames #:youtube)
  (:use #:cl #:series #:drakma)			;and cl-ppcre
  (:export #:get-flv-to-file 
	   #:get-flv-to-file-interactive ;インタラクティブというよりちょっと状況を表示してくれるだけ
	   #:extruct-links))

(in-package #:youtube)

(defun get-video_id-&-title (uri)
  (with-input-from-string (line (http-request uri))
    (let ((id-scanner (ppcre:create-scanner "video_id:'\([0-9A-z\-_]{11}\)'.*,t:'\([0-9A-z\-_]{32}\)'"))
	  (title-scanner (ppcre:create-scanner "vidTitle\">\(.*\)</div>")))
      (flet ((rl () (read-line line nil :eof))
	     (latch (data scanner line)
	       (or data (nth-value 1 (ppcre:scan-to-strings scanner line)))))
	(do ((l (rl) (rl))
	     (id+tee nil (latch id+tee id-scanner l))
	     (title nil (latch title title-scanner l)))
	    ((eq :eof l))
	  (when (and id+tee title)
	    (let ((video_id (aref id+tee 0))
		  (tee (aref id+tee 1))
		  (title (ppcre:regex-replace-all "/" (aref title 0) "-"))) ;ファイル名の"/"をエスケープ
	      (return (values video_id tee title)))))))))

(defun decode-flv-uri (uri)
  (multiple-value-bind (id tee title ) (get-video_id-&-title uri)
    (values (concatenate 'string "http://youtube.com/get_video.php" "?video_id=" id "&t=" tee) title)))

(defun get-flv-to-file (uri path)
  (with-open-stream (in (http-request (decode-flv-uri uri) :want-stream t))
    (with-open-file (out path :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
      (collect-stream out (scan-stream in #'read-byte) #'write-byte))))

(defun get-flv-to-file-interactive (uri dir)
  (multiple-value-bind (flv-uri title) (decode-flv-uri uri)
    (with-open-stream (in (http-request flv-uri :want-stream t))
      (print "connect...")
      (with-open-file (out (merge-pathnames (concatenate 'string title ".flv") dir)
			   :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
	(collect-stream out (scan-stream in #'read-byte) #'write-byte))
      (print "Done..."))))

;; 検索結果等のページからflvへのリンクを抽出
(defun extruct-links (uri)
  (with-input-from-string (line (http-request uri))
    (let ((scanner (ppcre:create-scanner "watch\\?v=")))
      (flet ((rl () (read-line line nil :eof)))
	(do ((l (rl) (rl))
	     res)
	    ((eq :eof l) (nreverse res))
	  (let ((v (nth-value 1 (ppcre:scan-to-strings scanner l))))
	    (when v
	      (pushnew (concatenate 'string "http://jp.youtube.com"
				    (aref (nth-value 1 (ppcre:scan-to-strings ".*\(/watch\\?v=.{11}\)\".*" l)) 0))
		       res :test #'equal))))))))

;; 使用例
;; (get-flv-to-file-interactive URL 保存場所
;;
;; (mapc (lambda (u)
;; 	(format t "~A Started...~%" u)
;; 	(get-flv-to-file-interactive u (merge-pathnames "Desktop/" (user-homedir-pathname)))
;; 	(format t "Done...~%"))
;;       (extruct-links "http://jp.youtube.com/results?search_query=jerry+bergonzi&search=%E6%A4%9C%E7%B4%A2"))

2007-11-28

はてなグループでLisp関係のグループを作ってみました。

| 22:51 | はてなグループでLisp関係のグループを作ってみました。 - わだばLisperになる を含むブックマーク はてなブックマーク - はてなグループでLisp関係のグループを作ってみました。 - わだばLisperになる

はてなグループという機能があることを知ったので早速Lisp関係のグループを探してみました。

既に一つlispグループというグループがあるのですが、ポール・グレアム氏のANSI Common Lispをxyzzyを使って読むグループということで、Lisp関係とはいえあまり勝手なことを書き散らかす訳にもいかない気がしたので、自分で作ってみることにしました。2番目なので、名前は、cadrグループです。

このグループはLisp的なことであれば特に限定するものではありません。

個人的にはキーワード機能を利用して関数のクロスリファレンス的なものが作れないかを試してみたいと思っています。

また、処理系のインストール記事や、最近のCommon Lisp開発環境ではなくてはならないSLIMEASDF周辺の情報も集められたら良いなと思っています。

自分自身いまいち、はてなグループの利用方法が分かっていないのですが、どなたでも参加できるように設定したつもりですので、ご興味ありましたらお気軽に参加して頂ければと思います。

String#to_procの真似ごと

| 00:36 | String#to_procの真似ごと - わだばLisperになる を含むブックマーク はてなブックマーク - String#to_procの真似ごと - わだばLisperになる

Matzにっきさん経由で、String#to_procというアイディアを知りました。

Rubyは全く書けませんが、何だか面白そうなので真似して遊んでみました。

元記事だともっと多彩なことができるようですが、複雑になると大変そうなので端折りに端折って気分だけ。

;; to-proc
(defmacro to-proc ((&rest args) string)
  (let ((fn (gensym "FN-")))
    `(let ,args
       (macrolet ((,fn () (read-from-string ,string)))
	 (,fn)))))
;; 動作
(to-proc ((x 3)) "(print x)")
;-> 3

(defun square (x)
  (to-proc ((x x)) "(* x x)"))

(square 3)
;=> 9

(to-proc ((x 2) (y 3)) "(+ x (* 2 y))")
;=> 8

(to-proc ((x 3) (y 2)) "(+ x (* 2 y))")
;=> 7

(mapcar (lambda (x y) (to-proc ((x x) (y y)) "(+ x (* 2 y))")) 
	'(1 2 3) '(10 20 30))

;=> (21 42 63)

to_procをletみたいな形式で実現するのは、ちょっと違うのかなと思いつつ、どっちにしろ引数の指定はすることになるようなので安直にletみたいな感じで…。

使いたい場面がありそうな、なさそうな…。