2009/06/08

clg で twitter クライアントを作ってみた

Common Lisp もいろいろそろってきた。そろそろ GUI かなと思った。 OpenGL でツールキット作れたらいいな。Squeak みたいなのを。と思うのだけど clg を動かしてみる。

例のごとく twitter クライアントを作ってみた。

シグナル(イベント)のハンドラをクロージャで書くから1つの大きな関数ができあがってしまう。こんな作り方でいいのかと思いつつ、Mudballs に負けて cl-smoke を動かせなかった。

clg の雰囲気が多少なりとも分かったので、よしとする。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :gtk)
(require :cl-twitter)
(require :net-telent-date))

(gtk:clg-init)

(setf drakma:*drakma-default-external-format* :utf-8)

(defvar *auth*
(with-open-file (in (merge-pathnames ".twitter.lisp"
(user-homedir-pathname)))
(read in)))

(defun dispay-create-at (tweet)
(multiple-value-bind (second minute hour date month)
(decode-universal-time
(net.telent.date:parse-time (twitter:tweet-created-at tweet)))
(format nil "~02,'0d/~02,'0d ~02,'0d:~02,'0d:~02,'0d"
month date hour minute second)))

(defun update-timeline (last-id store)
(let ((new-timeline (twitter:friends-timeline :since-id last-id)))
(print new-timeline)
(if new-timeline
(progn
(loop with iter = (make-instance 'gtk:tree-iter)
for i in (reverse new-timeline)
do (gtk:list-store-append
store
(list :user (twitter:twitter-user-screen-name
(twitter:tweet-user i))
:text (twitter:tweet-text i)
:time (dispay-create-at i))
iter))
(twitter:tweet-id (car new-timeline)))
last-id)))

(defun send-text (text-buffer)
(let ((text (gtk:text-buffer-text text-buffer)))
(unless (string= "" text)
(twitter:send-tweet text)
(gtk:text-buffer-set-text text-buffer ""))))

(defun main ()
(apply #'twitter:authenticate-user *auth*)
(let* ((last-id 1)
(store (make-instance 'gtk:list-store
:column-types '(string string string)
:column-names '(:user :text :time)))
(tree (make-instance 'gtk:tree-view :model store
:expand t :fill t))
(text-view (make-instance 'gtk:text-view))
(buffer (gtk:text-view-buffer text-view))
(scrolled-window (make-instance 'gtk:scrolled-window
:child tree))
(timer nil))
(labels ((update ()
(setf last-id (update-timeline last-id store)))
(scroll-to-bottom (&rest args)
(print args)
(let ((adjustment (gtk:scrolled-window-vadjustment
scrolled-window)))
(setf (gtk:adjustment-value adjustment)
(- (gtk:adjustment-upper adjustment)
(gtk:adjustment-page-size adjustment))))))
(gtk:signal-connect (gtk:scrolled-window-vadjustment scrolled-window)
:changed
#'scroll-to-bottom)
(update)
(setf timer (gtk:timeout-add 60000 #'update))
(loop for (title index sizing) in '(("ユーザ" :user :autosize)
("さえずり" :text :fixed)
("いつ" :time :autosize))
do (let ((column (make-instance 'gtk:tree-view-column :title title
:expand (eq :fixed sizing)
:resizable t
:sizing sizing))
(cell (make-instance 'gtk:cell-renderer-text)))
(gtk:cell-layout-pack column cell :expand nil)
(gtk:cell-layout-add-attribute
column cell 'text (gtk:tree-model-column-index store index))
(gtk:tree-view-append-column tree column)))
(gtk:within-main-loop
(make-instance
'gtk:window
:default-width 900
:default-height 700
:title "clg で twitter"
:border-width 2
:visible t :show-children t
:signal (list :delete-event
(lambda (event)
(declare (ignore event))
(gtk:timeout-remove timer)
nil))
:child (make-instance
'gtk:v-box
:child (list scrolled-window :expand t :fill t)
:child (list
(make-instance
'gtk:h-box
:child (list text-view)
:child (list (make-instance
'gtk:button
:label "投稿する"
:signal (list 'clicked
(lambda ()
(send-text buffer)
(update))))
:fill nil :expand nil)
:border-width 2)
:fill nil :expand nil)))))))

;;(main)

0 件のコメント: