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)