2009/05/23

10分でコーディング x 2 〜リストの破壊的操作篇に挑戦

10分でコーディング x 2 〜リストの破壊的操作篇〜 - わだばLisperになる - cadrグループ をやってみた。

まずは完成したコード

(defun nalist-to-plist (alist)
(loop for x on alist by #'cddr
do (rotatef (caar x) (cdar x) (cdr x) (car x)))
alist)
(defun nplist-to-alist (plist)
(loop for x on plist
do (rotatef (cddr x) (cadr x) (car x) (cdr x)))
plist)

nalist-to-plist の方は40分くらいかかってしまった。破壊的操作は難しい。。。 nplist-to-alist の方は4分ほど。

で気づいたのが rotatef の挙動が微妙。

(rotatef (caar x) (cdar x) (cdr x) (car x))

(rotatef (cdr x) (car x) (caar x) (cdar x))

と書くと動かない。 SBCL、CCL、CLISP、ABCL ともに動かない。だけど ACL では動いた。

SBCL で (rotatef (cdr x) (car x) (caar x) (cdar x)) をマクロ展開したのが次のコード

(LET* ((#:TMP892 X) (#:TMP894 X) (#:G895 X) (#:G897 X))
(MULTIPLE-VALUE-BIND
(#:NEW891)
(CAR #:TMP894)
(MULTIPLE-VALUE-BIND
(#:NEW893)
(CAAR #:G895)
(MULTIPLE-VALUE-BIND
(#:G896)
(CDAR #:G897)
(MULTIPLE-VALUE-BIND
(#:G898)
(CDR #:TMP892)
(SB-KERNEL:%RPLACD #:TMP892 #:NEW891)
(SB-KERNEL:%RPLACA #:TMP894 #:NEW893)
(SB-KERNEL:%RPLACA (CAR #:G895) #:G896)
(SB-KERNEL:%RPLACD (CAR #:G897) #:G898)
NIL)))))

SB-KERNEL:%RPLACA の引数のところで car を使うのは駄目な気がする。

ACL で同じコードをマクロ展開したら次のコードになる。

(LET ((#:G5705 X))
(LET ((#:G5707 X))
(MULTIPLE-VALUE-BIND (#:G5704)
(CAR #:G5707)
(LET ((#:G5709 (CAR X)))
(MULTIPLE-VALUE-BIND (#:G5706)
(CAR #:G5709)
(LET ((#:G5711 (CAR X)))
(MULTIPLE-VALUE-BIND (#:G5708)
(CDR #:G5711)
(MULTIPLE-VALUE-BIND (#:G5710)
(CDR #:G5705)
(PROGN (EXCL::.INV-CDR #:G5705 #:G5704)
(EXCL::.INV-CAR #:G5707 #:G5706)
(EXCL::.INV-CAR #:G5709 #:G5708)
(EXCL::.INV-CDR #:G5711 #:G5710))
NIL))))))))

こっちは #:G5709 は事前に car されている。

バグかな。。。

2009/05/21

SERIES を使わない場合

SERIES を使わない場合は、cl-ppcre 使うのに何の罪悪感もない。ずっとコードもわかりやすい。

(defun who-can-see2 (user-names allowed-data report-data)
(loop for user in user-names
for allowed in allowed-data
if (every (lambda (x)
(ppcre:scan (format nil "\\b~a\\b" x) allowed))
report-data)
collect user))

2009/05/20

ついついやってみた SERIES でね

と、はやっているようなのでやってみた。

もちろん SERIES で。ppcre:split を使ったのが負けてる気がするが、そもそも30分くらいかかった時点で。。。

もっと簡単に書けそうな気がするし。。。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-ppcre)
(require :series)
(use-package :series))

(series::install)

(defun who-can-see (user-names allowed-data report-data)
(choose
(#M(lambda (allowed)
(collect-and
(#M(lambda (reprot)
(collect-or
(#M(lambda (allowed)
(string= reprot allowed))
(scan (ppcre:split " " allowed)))))
report-data)))
allowed-data)
user-names))
#|
(who-can-see #z("userA" "userB" "userC")
#z("data1 data3" "data2 data4" "data3 data5 data6")
#z("data1"))

(who-can-see #z("joe" "nick" "ted")
#z("clients products" "products orders" "clients orders")
#z("clients" "products"))

(who-can-see #z("kathy" "john" "dan" "steve" "cheryl" "tony")
#z("users data" "data orders" "users permissions" "system users controls" "default" "admin users")
#z("users"))

(who-can-see #z("jim" "scott" "barbara")
#z("users order products" "products shipping" "tracking products orders")
#z("admin"))
|#

2009/05/17

タイフェスティバル

昨日のことだが、タイフェスティバルに行ってきた。去年も行ったので、今年で二回目。今年はあまり食べられなかった。としかねぇ。カオマンガイが美味しかった。マンゴーはとびきり美味しかった。

タイフェスティバルの後は KO 氏の家へ。ちゃんと胡瓜をきざんで、冷やし中華をごちそうしてくれた。ごちそうさまでした。おいしかったです。

まさかこんな日がこようとはねぇ。

みんなやってたんだ

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :series)
(use-package :series))

(defun deal (players deck)
(mapcar (lambda (x)
(collect 'string x))
(multiple-value-list
(chunk players players (scan deck)))))
ごめんなさい。 series:chunk が使いたかっただけです。

2009/05/05

GW のまとめ

3日

合同お祝い会。誕生日3人にこどもの日。

4日

Dvorak 配列での l の位置は絶対に失敗だと思うから l と ; の位置を入れ替えた。まだ慣れない。

Chaton Gauche が楽しそうで、自分でもちょこっと作ってみた。

5日

ラ・フォル・ジュルネ にうちの家族とKM氏で行ってきた。バッハです。なんて楽しげにバイオリンを弾くんだろう。

KO氏は綺麗で大人になった感じがした。

その他の日

仕事。リスク管理できてないよね。

;;;;-*- coding: utf-8 -*-
(in-package :you.example.chat)

(defvar *js*
(hunchentoot:create-folder-dispatcher-and-handler
"/js/" (merge-pathnames "js/" (directory-namestring *load-truename*))))

(pushnew *js* hunchentoot:*dispatch-table*)

(defmacro with-default-template ((&key (title "チャット")) &body body)
`(html (:html
(:head
(:script :type "text/javascript" :src "/js/jquery-1.3.2.js")
(:link :rel "stylesheet" :href "default.css" :type "text/css")
(:title ,title))
(:body
(:div :id :main
,@body)
(:div :id :footer "Powered by Common Lisp")))))

(defaction default.css ()
(setf (hunchentoot:content-type*) "text/css")
(html "
.name {
font-size: 0.8em;
}
.say-ts {
float: right;
align: right;
color: gray;
font-size: 0.7em;
}
.content {
margin-bottom: 0.3em;
}
#list {
width: 80%;
height: 10em;
overflow: auto;
}
#footer {
text-align: right;
font-size: 0.6em;
}
"
))


(defvar *loop-process* nil)

(defaction index.html ()
(unless *loop-process*
(setf *loop-process* (spawn (loop-process))))
(with-default-template ()
(:h1 "チャット")
(:div :id :list)
(:form :onsubmit (ps (return (say)))
(:div (:textarea :id :content :rows 3 :cols 50))
(:div (:submit :value "話す")
" 名前:" (:text :id :name :value "かめ")))
(:script
(ps (defun say ()
($.post "say" (create :content ((@ ($ "#content") val))
:name ((@ ($ "#name") val)))
(lambda (data)
((@
((@ ($ "#content") val) "")
focus))))
(return false))
(defun refresh ()
(let ((id ((@ ($ "#list div.entry:last") attr) "id")))
($.post "refresh" (create :id (if id id ""))
(lambda (data)
(if (!= data "")
((@ ((@ ($ "#list") append) data)
scroll-top) 99999))
(set-timeout refresh 100)))))
((@ ($ "#content") keyup) (lambda (e)
(if (= e.key-code 13)
(say))))
($(refresh))))))

(defun generate-id ()
(format nil "~s~a" (get-universal-time) (gensym)))

(defun loop-process ()
(loop for data = (process-receive)
with wait = nil
do (if (eq data :say)
(progn (mapc (lambda (x)
(process-send x t))
wait)
(setf wait nil))
(push data wait))))

(defaction say ()
(unless (or (q:emptyp @name) (q:emptyp @content))
(execute-sql #q(insert into chat(id, name, content, say_ts)
values(:id, :name, :content, current_timestamp))
:id (generate-id)
:name @name
:content @content))
(process-send *loop-process* :say))

(defaction refresh ()
(do-query (#q(select count(*) as count from chat where id > :id)
:id @id)
(when (zerop $count)
(process-send *loop-process* *current-thread*)
(process-receive :timeout 30)))
(html
(do-query (#q(select * from chat where id > :id order by say_ts)
:id @id)
(html (:div :id $id :class :entry
(:div :class :say-ts $say_ts)
(:div :class :name $name)
(:div :class :content $content))))))

#|
(you::with-db clsql-sys:*default-database*
(execute-sql #q(delete from chat)))
|#

2009/05/03

clbuild で新しいプロジェクトを作成する

clbuid では次のコマンドで新しいプロジェクトを作成することができる。

./clbuild make-project newproj

newproj がプロジェクト名になる。

自動的にプロジェクトディレクトリ clbuild/source/newproj/ が作成され次のファイルができる。

.git/ newproj.asd newproj.lisp newproj.sh package.lisp

おまけに git でリポジトリを作って上記のファイルのインポートまでやってくれてる。これは便利だ。

darcs じゃなくて git なのね、とちょっと思ったけどさ。