opengl-text

http://github.com/Ramarren/opengl-text/tree/master

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cl-glut)
  (require :opengl-text))

(defvar *font-loader*
  (zpb-ttf:open-font-loader
   #p"/usr/share/fonts/truetype/vlgothic/VL-PGothic-Regular.ttf"))

(defclass string-window (glut:window)
  ((opengl-text :initform (make-instance 'opengl-text:opengl-text
                                         :font *font-loader*
                                         :emsquare 64)))
  (:default-initargs :title "OpenGL Text"
    :mode '(:single :rgb :depth)))

(defmethod glut:keyboard ((window string-window) key x y)
  (declare (ignore x y))
  (case key
    ((#\Esc #\q) (glut:destroy-current-window))))

(defmethod glut:reshape ((window string-window) w h)
  (gl:viewport 0 0 w h)
  (gl:matrix-mode :projection)
  (gl:load-identity)
  (gl:ortho 0 w 0 h -1 1))

(defmethod glut:display-window :before ((w string-window))
  (gl:clear-color 0 0 0 0))              ; 次の clear で使う色

(defmethod glut:display ((window string-window))
  (with-slots (opengl-text) window
    (gl:clear :color-buffer-bit)        ; クリア
    (%gl:color-3f 1 1 1)                ; 描画に使う色
    (gl:enable :texture-2d)
    (gl:enable-client-state :vertex-array)
    (gl:enable-client-state :texture-coord-array)
    (gl:matrix-mode :modelview)
    (gl:load-identity)
    (gl:scale 24 24 1)                  ; 24 x 24 ピクセル
    (gl:translate 0 0 0)                ; デフォルト左下に表示
    (opengl-text:draw-gl-string "まみむめも♪" opengl-text)
    (gl:flush)))

(defun run ()
  (glut:display-window (make-instance 'string-window)))
(run)

[Common Lisp] Lingr

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :quek)
  (require :drakma)
  (require :cl-json)
  (use-package :quek)
  (use-package :drakma))

(defpackage for-with-json)

(defmacro! with-json (o!json &body body)
  (let* (($-symbols (collect-$-symbol body))
         (json-symbols (mapcar #'to-json-symbol $-symbols)))
    `(json:json-bind ,json-symbols ,g!json
       (let ,(mapcar #`(,_a (if (stringp ,_b) (remove #\cr ,_b) ,_b))
              $-symbols json-symbols)
         ,@body))))

(eval-always
  (defun $-symbol-p (x)
    (and (symbolp x)
         (char= #\$ (char (symbol-name x) 0))))

  (defun to-json-symbol (symbol)
    (intern (substitute #\_ #\-
                        (subseq (symbol-name symbol) 1))
            :for-with-json))

  (defun collect-$-symbol (body)
    (let ($-symbols)
      (labels ((walk (form)
                 (if (atom form)
                     (when ($-symbol-p form)
                       (pushnew form $-symbols))
                     (progn
                       (walk (car form))
                       (walk (cdr form))))))
        (walk body))
      $-symbols))
  )

(defvar *key* "xxxxxxxxxxxxxxxxxxxxxxxxxxxxx")

(defun check-status (res)
  (let ((json (json:decode-json-from-string res)))
    (with-json res
      (when (string/= "ok" $status)
        (error "~a" res)))
    json))

(defun session-create (&optional (key *key*))
  (with-json
      (http-request "http://www.lingr.com/api/session/create"
                    :method :post
                    :parameters `(("api_key" . ,key)
                                  ("format" . "json")))
    $session))

(defvar *session* nil)

(defun room-enter (id nickname &key (session *session*))
  (with-json
      (http-request "http://www.lingr.com/api/room/enter?format=json"
                    :method :post
                    :parameters `(("session" . ,session)
                                  ("id" . ,id)
                                  ("nickname" . ,nickname)))
    $ticket))

(defun room-get-messages (ticket counter &key
                                 user-messages-only
                                 (session *session*))
  "observe を使いましょう。"
  (check-status
   (http-request
    "http://www.lingr.com/api/room/get_messages?format=json"
    :parameters `(("session" . ,session)
                  ("ticket" . ,ticket)
                  ("counter" . ,(princ-to-string counter))
                  ("user_messages_only" . ,(if user-messages-only
                                               "true"
                                               "false"))))))

(defun room-observe (ticket counter &key (session *session*))
  (check-status
   (http-request "http://www.lingr.com/api/room/observe?format=json"
                 :parameters `(("session" . ,session)
                               ("ticket" . ,ticket)
                               ("counter" . ,(princ-to-string counter))))))

(defmacro! do-observe ((room nickname) &body body)
  `(let* ((*session* (session-create))
          (,g!ticket (room-enter ,room ,nickname)))
     (with-json (room-get-messages ,g!ticket -1)
       (loop with ,g!counter = $counter
             do (with-json (room-observe ,g!ticket ,g!counter)
                  (when $counter ; ((:status "ok")) のみの場合があるので
                    ,@body
                    (setf ,g!counter $counter)))))))

#|
(do-observe ("room" "nickname")
  (loop for i in $messages
        do (with-json i
             (format t "~&~a: ~a" $nickname $text))))
|#

■

[Common Lisp] 書きかけ

(in-package :you.example)

(defmacro with-default-template ((&key (title "TODO")) &body body)
  `(html (:head (:title ,title))
         (:body ,@body)))

(defaction todo ()
  (with-default-template (:title "TODO リスト")
    (:h1 "TODO リスト")
    (:form :action 'todo
           (:input :type :text :name :q)
           (:input :type :submit :value "しぼりこみ"))
    (:table
     :border 1
     (do-query
         ((append #q(select * from todo)
                  (when @q #q(where content like :param))
                  #q(order by id))
          :param (string+ "%" @q "%"))
       (html (:tr (:td $id)
                  (:td (:a :href (url 'todo-edit :id $id) $content))
                  (:td $done)))))
    (:h2 "登録")
    (:form
     :action 'todo-add :method :post
     (:table
      (:tr
       (:td "ID")
       (:td (:input :type :text :name :id :value @id)))
      (:tr
       (:td "内容")
       (:td (:input :type :text :name :content :value @content)))
      (:tr
       (:td (:input :type :submit :value "登録")))))))

(defaction todo-add ()
  (html*
    (execute-sql
     #q(insert into todo(id, content, done) values(:id, :content, 'f'))
     :id @id :content @content))
  (todo))


(defaction todo-edit ()
  (html*
    (setf s@id @id)
    (do-query (#q(select * from todo where id = :id) :id @id)
      (with-default-template (:title "更新")
        (:div "更新しますよ。")
        (:form
         :action 'todo-edit-confirm :method :post
         (:table
          (:tr
           (:td "内容")
           (:td (:input :type :text :name :content :value $content)))
          (:tr
           (:td :rowspan 2 (:input :type :submit :value "更新")))))))))

(defaction todo-edit-confirm ()
  (html*
    (setf s@content @content)
    (with-default-template (:title "確認画面")
      (:div "この内容でいいですか？")
      (:div "内容 " @content)
      (:form :action 'todo-edit-done :method :post
             (:input :type :submit :value "はい")
             " "
             (:input :type :button :value "いいえ"
                     :onclick "history.back()")))))

(defaction todo-edit-done ()
  (with-default-template (:title "完了")
    (execute-sql #q(update todo set content = :c where id = :i)
                 :c @content :i @id)
    (:div "更新しました")
    (:a :href 'todo "一覧へ")))

clbuild

clbuild は Common Lisp のライブ
ラリをインストールしたりアップデートしたりするスクリプト。
各ライブラリのリポジトリから最新バージョンを自動的にチェックアウトしてくる。
常に unstable. Debian と一緒。

インストールはシェルで次のように行なう。CVS, Darcs, Subversion, Git をあらたじめインストールしておく。

~/letter/lisp% darcs get http://common-lisp.net/project/clbuild/clbuild
~/letter/lisp% cd clbuild
~/letter/lisp/clbuild% chmod +x clbuild
~/letter/lisp/clbuild% ./clbuild update --all-projects

あとはひたすら待つ。結構時間がかかる。--all-projects じゃなくて必要なプロジェクトを指定した方がいいと思われる。
./clbuild update cl-ppcre のように。

途中で取得できないライブラリがあったら、ディレクトリを作成して update --resume すれば次にすすめる。
./clbuild skip cl-fad
./clbuild update --resume の方が正しいと思われる。
例えば cl-pdf の取得で失敗した場合は

~/letter/lisp/clbuild% mkdir source/cl-pdf/
~/letter/lisp/clbuild% ./clbuild update --resume

インストールがおわったら、./clbuild slime で Emacs 起動 Slime 実行とか、
./clbuild run climacs で Climacs 起動とかしてくれる。

他にも欲しいライブラリがある場合は my-projects に追記すればいいらしい。

Verify Your Account by SMS

携帯の SMS で認証認証コードを受信しなければならないらしい。
携帯で？
絶望した。
終了。
これで Python ともお別れだね。元気でね。さようなら。

Forth Programmer's Handbook (3rd Edition) 届いた

amazon.com で注文していた http://www.amazon.com/Forth-Programmers-Handbook-Elizabeth-Rather/dp/1419675494/ref=pd_bbs_sr_1?ie=UTF8&s=books&qid=1210036429&sr=8-1 が届いた。
注文したのが4/18。到着予定は5/15だったけど早く着いたんだ。
どうやら2、3日前に家の宅配ボックスの中に入っていたらしい。

Common Lisp での ANSI Common Lisp にあたる本かな。
On Lisp にあたる本があるといいのだけど。