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

１０分でコーディング 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 されている。

バグかな。。。

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))

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

• JAVA５．０でGO!!｜プログラミングに自信があるやつこい！！
• 15 分のもやってみた - kozima の日記 - cadrグループ
• 「１５分でコーディング」を１８分で - わだばLisperになる - cadrグループ
• データが扱える人を探せ！　再考 - 象徴ヶ淵

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

もちろん 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"))
|#

タイフェスティバル

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

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

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

みんなやってたんだ

• http://cadr.g.hatena.ne.jp/lkozima/20090515/1242387770
• http://cadr.g.hatena.ne.jp/g000001/20090515/1242395351

(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 が使いたかっただけです。

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)))
|#

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

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

./clbuild make-project newproj

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

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

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

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

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