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 |

2007-08-30

.22

| 18:41 | .22 - わだばLisperになる を含むブックマーク はてなブックマーク - .22 - わだばLisperになる

日課練習、日課練習。毎日書いてはいるんだけども、ブ

ログ更新するのが億劫で、そうすると、コードが溜って、

そうすると、大量にアップすることになるので、長大に

なるのもどうかなと思ったり、アップすること自体が更

に面倒になったり。

ということで、Common Lispで簡単に更新できるような

仕組を作ってみたいという妄想を抱く。

今回のお題は、TAOのloop。Common Lispのloopとは全然

違ってprogの使用感に近い。

色々謎なところは多いが、マニュアルから想像で適当に

作成。

ちなみにマニュアルの中の例は、中間記法で書いてあっ

たりして、TAOの混沌さが堪能できますが、Common Lisp

だと

(defun f (n)
  (loop (&aux c result)
        (:init (setq c 0) (setq result 1))
        (:until (= c n) result)
        (setq result (* (incf c) result)) ))

のようになります。

(shadow 'loop)

(defmacro tao::loop (&body body)
  "loop                                   関数[#!subr]

<説明>
  形式 : loop [exit-id] [(&aux var ...)]
                        [(:init init-form ...)]
        		[(:until pred exit-form1 exit-form2 ...)]
 			[(:while pred exit-form1 exit-form2 ...)]
 			form1 form2 ... formN
TAO の基本的な繰り返しの機能。
&aux で loop の中だけで有効な補助変数を宣言する。
:init があれば init-form を最初に一度だけ評価する。
:until の述語が成立するか、または :while の述語が成立しなくなるまで 
form1 form2 ... を順に評価する。そして、:until 文が成立、または :while
文が成立しなくなった時、対応する exit-form1 ... を順に評価して loop 
から抜け、最後の exit-form の値を返す。
:until や :while は何回でも使えるし省略可能。 exit-form は省略可能。

<例>
        (de f (n)
            (loop (&aux c result)
                  (:init (!c 0) (!result 1))
                  (:until (c = n) result)
                  (!result ((inc c) * result)) ))
        n の階乗を計算する。"
  (let ((exit-id (and (atom (car body)) (pop body)))
	(loop-tag (gensym))
	aux init newbody)
    (dolist (l body)
      (case (car l)
	(&aux   (setq aux (cdr l)))
	(:init  (push (cdr l) init))
	(otherwise (push l newbody))))
    `(block ,exit-id
       (let (,@aux)
	 (tagbody
	    ,@(mapcar (lambda (x) `(progn ,@x)) init)
	    ,loop-tag
	    ,@(mapcar 
	       (lambda (x) 
		 (cond ((eq :while (car x))
			`(or ,(cadr x) (return-from ,exit-id (progn ,@(cddr x)))))
		       ((eq :until (car x))
			`(and ,(cadr x) (return-from ,exit-id (progn ,@(cddr x)))))
		       ('T x)))
	       (nreverse newbody))
	    (go ,loop-tag))))))

2007-08-26

.1

| 23:10 | .1 - わだばLisperになる を含むブックマーク はてなブックマーク - .1 - わだばLisperになる

自分も「どう書く?org」に参加してみたくなってアカ

ウントを作成してみた。しかし自分の解けそうな問題が

あまりない…。

投稿するにはなんとなく旬を過ぎてしまったので、ここ

に載せてみるのだった…。

;; ================================================================
;; 隣り合う二項の差
;; ================================================================
(defun diff (list)
  (mapcar #'- (cdr list) list))

(defun diff (list)
  (do ((l list (cdr l))
       (r () (cons (- (cadr l) (car l)) r)))
      ((endp (cdr l)) (nreverse r))))

;; ================================================================
;;重複無し乱数リスト
;; ================================================================
(defun bingo (n)
  (let ((l (loop for i from 1 to n collect i)))
    (dotimes (i n l)
      (rotatef (nth i l) (nth (random n) l)))))

;; ================================================================
;; ビンゴの結果を整形表示 
;; ================================================================
(defun format-bingo (n)
  (let* ((keta (1+ (truncate (log n 10))))
	 (fstr (format nil "~{~A~}" (list "~{~" (1+ keta) "@A~}~%" 
					  "~{~" (1+ keta) "@A~}~%~%"))))
    (do ((cnt n (- cnt 10))
	 (l (bingo n) (nthcdr 10 l))
	 (idx (loop for i from 1 to n collect i) (nthcdr 10 idx)))
	((endp l))
      (if (<= 10 cnt)
	  (format t fstr (subseq idx 0 10) (subseq l 0 10))
	  (format t fstr idx l)))))

2007-08-19

.21

| 13:12 | .21 - わだばLisperになる を含むブックマーク はてなブックマーク - .21 - わだばLisperになる

日課練習、日課練習、色々書いてみたりしているのです

が、現在TAOの関数をマニュアルを参照しつつ想像で実

装して遊んでいます。

結構、変った関数が転がってますが、その中でも、

progiは光ってると思います。

prognの中の式に^(TAOではトガと呼ぶらしい)で印をつ

けることができて、印がついた一番最後の式の値を返す

というもの。

(defmacro progi (&body body)
  "progi                                  関数[#!subr]

<説明>
  形式 : progi &rest progi-id form1 form2 ...
form1 form2 ... を順に評価し、最後の トーガ (^) を持つ式の値を返す。
トーガを持つ式がないときは最後の式の値を返す。
form1 form2 ... はリストかアトム。
progi-id は、関数 exit-progi による脱出のためのマーク。

<例>
        (progi 1 2 3 ^4 5 6 ^7 8 9) -> 7
        (progi 1 2 3 4 5 6 7 8 9) -> 9
        (progi ^(car x) (!x (cdr x))) = (pop x)"
  (let ((progi-id (and (symbolp (car body))
		       (not (boundp (car body)))
		       (pop body)))
	(cache (gensym "TOGA-CACHE-")))
    `(block ,progi-id
       (let (,cache)
	 ,@(mapcar (lambda (x) (if (togap x) `(setq ,cache ,x) x)) (butlast body))
	 (if (or (togap ',@(last body))
		 (null ,cache))
	     (setq ,cache ,@(last body)) 
	     ,@(last body))
	 ,cache))))

(defmacro exit-progi (&optional val progi-id)
  "exit-progi                             関数[#!subr]

<説明>
  形式 : exit-progi &opt val progi-id
progi-id を持つ progi 節から強制的に脱出させる。
val が指定されると val を返し、省略されると {undef}0 を返す。
progi-id が省略された時は、最も内側にある progi 節から脱出させる。

<例>
        (progi qwe 1 2 (exit-progi 3 qwe) 4 5) -> 3
        (progi 1 2  (exit-progi 3) 4 5) -> 3"
  `(return-from ,progi-id ,val))

(defmacro toga (obj)
  obj)

(defun togap (expr)
  (and (eq 'toga (and (consp expr) (car expr)))))

(set-macro-character #\^
		     #'(lambda (stream char)
			 (declare (ignore char))
			 (list 'toga (read stream t nil t))))

2007-08-06

SRFI-87 case

| 14:35 | SRFI-87 case - わだばLisperになる を含むブックマーク はてなブックマーク - SRFI-87 case - わだばLisperになる

日課練習、SRFI-87 caseの=>拡張

マクロでペタペタ。

(defmacro case87 (&body form)
  (let ((clauses (cdr form)))
    (if (=>-finder clauses)
	(let ((eform)
	      (gs (gensym))
	      (key (car form)))
	  (dolist (clause clauses `(let ((,gs ,key)) (case ,key ,@(nreverse eform))))
	    (if (eq '=> (second clause))
		(destructuring-bind (key => receiver) clause
		  (declare (ignore =>))
		  (push `(,key ((lambda (x) (funcall ,receiver x)) ,gs)) eform))
		(push clause eform))))
	`(case ,@form))))

(defun =>-finder (form)
  (dolist (x form nil)
    (and (find '=> x :test #'eq)
	 (return-from =>-finder t))))

2007-08-03

.18

| 00:02 | .18 - わだばLisperになる を含むブックマーク はてなブックマーク - .18 - わだばLisperになる

日課練習、SRFI-26 cutとcute

マクロで切った貼ったで作成。ぐちゃぐちゃな感じ。

schemeじゃないので、

(funcall (cut list <> 2 <> 4 <...>) 1 2 3 4 5 6 7 8)

になりますわな。

((cut if <> 0 1) #f)

が駄目な理由が良く分からなかったので、

(funcall (cut if <> 0 1) nil)

もエラーにしてませんわな。

(defmacro cut (&body form)
  (let ((form (if (member '<...> form :test #'eq)
		  (if (eq '<...> (car (last form)))
		      `(apply (function ,(car form)) ,@(cdr form))
		      (error "CUT:found garbage in lambda list when expecting a `<...>': ~S" (car (last form))))
		  form))
	(result)
	(gss))
    (dolist (item form `(lambda ,(nreverse gss) ,(nreverse result)))
      (case item
	(<> 
	 (let ((gs (gensym)))
	   (push gs result)
	   (push gs gss)))
	(<...> 
	 (let ((gs (gensym)))
	   (push gs result)
	   (push '&rest gss)
	   (push gs gss)))
	(cut)
	(otherwise
	 (push item result))))))

(defmacro cute (&body form)
  (let ((form (if (member '<...> form :test #'eq)
		  (if (eq '<...> (car (last form)))
		      `(apply (function ,(car form)) ,@(cdr form))
		      (error "CUT:found garbage in lambda list when expecting a `<...>': ~S" (car (last form))))
		  form))
	(result)
	(gss)    
	(binds))
    (dolist (item form `(let ,binds (lambda ,(nreverse gss) ,(nreverse result))))
      (case item
	(<> 
	 (let ((gs (gensym)))
	   (push gs result)
	   (push gs gss)))
	(<...>
	 (let ((gs (gensym)))
	   (push gs result)
	   (push '&rest gss)
	   (push gs gss)))
	(cut)
	(otherwise
	 (if (symbolp item)
	     (push item result)
	     (let ((gs (gensym)))
	       (push `(,gs ,item) binds)
	       (push gs result))))))))