SERIES で scan-file 系を実装するとき

今夜も Common Lisp の SERIES.

SERIES で scan-file 系は encapsulated と defS のどちらを使って実装すべきなんだろうか?

producing は with-open-file(unwind-protect) のために使えないと思うから、 encapsulated と defS のどちらかを使うんだろうと思うのだけれど。

あっ、defS の方の最後の ,external-format のところ、これでいいのか分からない。

(defun scan-line2-wrap (file name external-format body)
  `(with-open-file (,file ,name :external-format ,external-format) ,body))

(defmacro scan-line2 (name &optional (external-format :default))
  (let ((file (gensym)))
    `(encapsulated #'(lambda (body)
                       (scan-line2-wrap ',file ',name ',external-format body))
                   (scan-fn t
                            (lambda () (read-line ,file nil))
                            (lambda (_) (declare (ignore _)) (read-line ,file nil))
                            #'null))))

;;(scan-line2 "~/.sbclrc")
;;(scan-line2 "~/.sbclrc" :utf-8)
;;(collect (scan-line2 "~/.sbclrc"))
;;(collect (scan-line2 "~/.sbclrc" :utf-8))


(series::defS scan-line (name &optional (external-format :default))
  "(scan-line file-name &key (external-format :default))"
  (series::fragl
   ((name) (external-format)) ((items t))
   ((items t)
    (lastcons cons (list nil))
    (lst list))
   ()
   ((setq lst lastcons)
    (with-open-file (f name :direction :input :external-format external-format)
      (loop
        (cl:let ((item (read-line f nil)))
          (unless item
            (return nil))
          (setq lastcons (setf (cdr lastcons) (cons item nil))))))
    (setq lst (cdr lst)))
   ((if (null lst) (go series::end))
    (setq items (car lst))
    (setq lst (cdr lst)))
   ()
   ()
   :context)
  :optimizer
  (series::apply-literal-frag
   (cl:let ((file (series::new-var 'file)))
     `((((external-format)) ((items t))
        ((items t))
        ()
        ()
        ((unless (setq items (read-line ,file nil))
           (go series::end)))
        ()
        ((#'(lambda (code)
              (list 'with-open-file
                    '(,file ,name :direction :input :external-format ,external-format)
                    code)) :loop))
        :context)
       ,external-format))))

SERIES の producing

今日、千葉さんに producing を教えてもらったので、 cl-ppcre:split を series にしてみた。

どうも multiple-value-bind の中の setq は拾ってくれないらしく、ダミーの setq を書いて回避した。

これで Clojure の何でもシーケンスみたいに、何でもシリーズができそうだ。

(defun scan-re-split (regex string)
  (declare (optimizable-series-function))
  (producing (z) ((r regex) (s string) (scan-start 0) subseq-start subseq-end)
    (loop
      (tagbody
         ;; multiple-value-bind の中での setq は認識されないのでダミーで setq する。
         (setq scan-start scan-start
               subseq-start subseq-start
               subseq-end subseq-end)
         (multiple-value-bind (start end) (ppcre:scan r s :start scan-start)
           (unless start
             (if (< (length s) scan-start)
                 (terminate-producing)
                 (setq start (length s)
                       end (1+ start))))
           (setq subseq-start scan-start
                 subseq-end start
                 scan-start end))
         (next-out z (subseq s subseq-start subseq-end))))))

(assert (equal '("a" "b" "c") (collect (scan-re-split "/" "a/b/c"))))
(assert (equal '("") (collect (scan-re-split "/" ""))))
(assert (equal '("" "") (collect (scan-re-split "/" "/"))))
(assert (equal '("" "a") (collect (scan-re-split "/" "/a"))))
(assert (equal '("" "a" "") (collect (scan-re-split "/" "/a/"))))
(assert (equal '("" "" "a" "" "") (collect (scan-re-split "/" "//a//"))))
(assert (equal '("a" "b" "cc" "d") (collect (scan-re-split "\\s+" "a b   cc
d"))))

(collect (scan-re-split "/" "a/b/c")) をマクロ展開すると次のようになる。

(COMMON-LISP:LET* ((#:OUT-1354 "a/b/c"))
  (COMMON-LISP:LET ((#:SCAN-1349 0)
                    (#:SUBSEQ-1348 NIL)
                    (#:SUBSEQ-1347 NIL)
                    #:Z-1350
                    (#:LASTCONS-1344 (LIST NIL))
                    #:LST-1345)
    (DECLARE (TYPE CONS #:LASTCONS-1344)
             (TYPE LIST #:LST-1345))
    (SETQ #:LST-1345 #:LASTCONS-1344)
    (TAGBODY
     #:LL-1355
      (PROGN
       (SETQ #:SCAN-1349 #:SCAN-1349)
       (SETQ #:SUBSEQ-1348 #:SUBSEQ-1348)
       (SETQ #:SUBSEQ-1347 #:SUBSEQ-1347))
      (MULTIPLE-VALUE-CALL
          #'(LAMBDA (&OPTIONAL (START) (END) &REST #:G12-1346)
              (DECLARE (IGNORE #:G12-1346))
              (IF START
                  NIL
                  (PROGN
                   (IF (< (LENGTH #:OUT-1354) #:SCAN-1349)
                       (GO SERIES::END)
                       (PROGN
                        (SETQ START (LENGTH #:OUT-1354))
                        (SETQ END (1+ START))))))
              (PROGN
               (SETQ #:SUBSEQ-1348 #:SCAN-1349)
               (SETQ #:SUBSEQ-1347 START)
               (SETQ #:SCAN-1349 END)))
        (CL-PPCRE:SCAN "/" #:OUT-1354 :START #:SCAN-1349))
      (SETQ #:Z-1350 (SUBSEQ #:OUT-1354 #:SUBSEQ-1348 #:SUBSEQ-1347))
      (SETQ #:LASTCONS-1344 (SETF (CDR #:LASTCONS-1344) (CONS #:Z-1350 NIL)))
      (GO #:LL-1355)
     SERIES::END)
    (CDR #:LST-1345)))

画像のリサイズは mogrify

ImageMagick は便利。

repl へのアイコン表示用なので trivial-shell:shell-command での mogrify 呼出で十分。

これいタイムラインを眺めるにはひざの上の猫くらいのものができた。

https://github.com/quek/twitter-client

(defun %get-profile-image (image-url local-path)
  (unless (probe-file local-path)
    (ensure-directories-exist local-path)
    (with-open-file (out local-path :direction :output :element-type '(unsigned-byte 8))
      (write-sequence (drakma:http-request image-url) out))
    ;; ImageMagic に頼る。
    (trivial-shell:shell-command #"""mogrify -resize 32x32 #,local-path""")))

collect-ignore の方が

(series::install :implicit-map t) していると collect-ignore の方がいいね。

(iterate ((x (scan-file "~/.sbclrc" #'read-line)))
  (write-line x))

(collect-ignore (write-line (scan-file "~/.sbclrc" #'read-line)))


;; これはもうちょっと。。。
(defun query-message ()
  (collect-fn 'string (constantly "") (^ format nil "~a~&~a" _a _b)
              (until-if (^ string= "." (if (string= "\\q" _)
                                           (return-from query-message nil)
                                           _))
                        (scan-stream *terminal-io* #'read-line))))

SLIME の repl でアイコンを表示できるようになった

Common Lisp で Twitter の User Streams の続きで、アイコンを表示できるようにした。

swank::eval-in-emacs を使うと Common Lisp から Emacs に eval させることができる。それを使って Emacs で (iimage-mode 1) を実行して表示させている。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :series)
  (require :cl-oauth)
  (require :drakma)
  (require :cl-json)
  (require :quek)
  (require :net-telent-date))

;; 対 drakma 用おまじない
(setf drakma:*drakma-default-external-format* :utf-8)
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)

(defpackage :repl-twitter-client
  (:use :cl :series :quek)
  (:shadowing-import-from :series let let* multiple-value-bind funcall defun)
  (:export #:tweet
           #:reply
           #:timeline))

(in-package :repl-twitter-client)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (series::install :pkg :repl-twitter-client :implicit-map t))

(defparameter *profile-image-directory* (ensure-directories-exist "/tmp/repl-twitter-client-images/"))

(defun query-message ()
  (string-right-trim
   #(#\Space #\Cr #\Lf #\Tab)
   (with-output-to-string (out)
     (loop for line = (read-line *terminal-io*)
           until (string= "." line)
           if (string= "\\q" line)
             do (return-from query-message nil)
           do (write-line line out)))))

(macrolet ((m ()
             (let ((sec (collect-first (scan-file "~/.twitter-oauth.lisp"))))
               `(defparameter *access-token*
                  (oauth:make-access-token :consumer (oauth:make-consumer-token
                                                      :key ,(getf sec :consumer-key)
                                                      :secret ,(getf sec :consumer-secret))
                                           :key ,(getf sec :access-key)
                                           :secret ,(getf sec :access-secret))))))
  (m))

(defun update (message &key reply-to)
  (when message
    (json:decode-json-from-string
     (oauth:access-protected-resource
      "http://api.twitter.com/1/statuses/update.json"
      *access-token*
      :request-method :post
      :user-parameters `(("status" . ,#"""#,message #'求職中""")
                         ,@(when reply-to `(("in_reply_to_status_id" . ,(princ-to-string reply-to)))))))))

(defun tweet ()
  (let ((message (query-message)))
    (update message)
    message))

(defun reply (in-reply-to-status-id)
  (let ((message (query-message)))
    (update message :reply-to in-reply-to-status-id)
    message))

(defun created-at-time (x)
  (multiple-value-bind (s m h) (decode-universal-time  (net.telent.date:parse-time x))
    (format nil "~2,'0d:~2,'0d:~2,'0d" h m s)))

(defun print-tweet (json-string)
  (ignore-errors
    (json:with-decoder-simple-clos-semantics
      (let ((json:*json-symbols-package* :repl-twitter-client))
        (let ((x (json:decode-json-from-string json-string)))
          (with-slots (text user id created--at) x
            (with-slots (name screen--name profile--image--url id) user
              (let ((path (get-profile-image id profile--image--url)))
                (format
                 *query-io*
                  #"""~&#,path #,screen--name (#,name,) #,(created-at-time created--at) #,id,~&#,text,~%""")))))))))

(defun timeline ()
  (bordeaux-threads:make-thread
   (^ with-open-stream (in (oauth:access-protected-resource
                            "https://userstream.twitter.com/2/user.json"
                            *access-token*
                            :drakma-args '(:want-stream t)))
      (loop for line = (read-line in nil)
            while line
            do (print-tweet line)))
   :name "https://userstream.twitter.com/2/user.json"))


(defun local-profile-image-path (user-id profile-image-url)
  (merge-pathnames (file-namestring (puri:uri-path (puri:uri profile-image-url)))
                   #"""#,*profile-image-directory*,/#,user-id,/"""))

(defun %get-profile-image (image-url local-path)
  (unless (probe-file local-path)
    (ensure-directories-exist local-path)
    (with-open-file (out local-path :direction :output :element-type '(unsigned-byte 8))
      (loop for i across (drakma:http-request image-url
                                :external-format-out :utf-8
                                :external-format-in :utf-8)
            do (write-byte i out)))))

(defun refresh-repl ()
  (sleep 0.1)
  (swank::with-connection ((swank::default-connection))
          (swank::eval-in-emacs '(save-current-buffer
                                  (set-buffer (get-buffer-create "*slime-repl sbcl*"))
                                  (save-excursion
                                    (iimage-mode 1))))))

(defvar *profile-image-process*
  (spawn (loop
           (receive ()
             ((profile-image-url local-path)
              (%get-profile-image profile-image-url local-path)
              (refresh-repl))))))

(defun get-profile-image (user-id profile-image-url)
  (let ((local-path (local-profile-image-path user-id profile-image-url)))
    (send *profile-image-process* (list profile-image-url local-path))
    local-path))

連日同じコードを貼り付けてるな。

https://github.com/quek/twitter-client にある。

近況報告

今月いっぱいで退職することになりました。

次はまだ決っていません。

求職中です。

と、ブログに書いてどうするつもりなんだろう。

Common Lisp で Twitter の User Streams

昨日 の続きのようなもの。 SLIME の REPL にタイムラインを流しっぱなしにする。細かいことは ignore-errors でにぎりつぶす。

できたらアイコンも表示したいけど、Emacs での画像の表示方法が分からない。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :series)
  (require :cl-oauth)
  (require :drakma)
  (require :cl-json)
  (require :quek))

;; 対 drakma 用おまじない
(setf drakma:*drakma-default-external-format* :utf-8)
(pushnew '("application" . "json") drakma:*text-content-types* :test #'equal)

(defpackage :repl-twitter-client
  (:use :cl :series :quek)
  (:shadowing-import-from :series let let* multiple-value-bind funcall defun)
  (:export #:tweet
           #:timeline))

(in-package :repl-twitter-client)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (series::install :pkg :repl-twitter-client :implicit-map t))


(defun query-message ()
  (string-right-trim
   #(#\Space #\Cr #\Lf #\Tab)
   (with-output-to-string (out)
     (loop for line = (read-line *terminal-io*)
           until (string= "." line)
           if (string= "\\q" line)
             do (return-from query-message nil)
           do (write-line line out)))))

(macrolet ((m ()
             (let ((sec (collect-first (scan-file "~/.twitter-oauth.lisp"))))
               `(defparameter *access-token*
                  (oauth:make-access-token :consumer (oauth:make-consumer-token
                                                      :key ,(getf sec :consumer-key)
                                                      :secret ,(getf sec :consumer-secret))
                                           :key ,(getf sec :access-key)
                                           :secret ,(getf sec :access-secret))))))
  (m))

(defun home-timeline ()
  (json:decode-json-from-string
   (oauth:access-protected-resource
    "http://api.twitter.com/1/statuses/home_timeline.json"
    *access-token*)))

(defun tweet (&optional (message (query-message)))
  (when message
    (json:decode-json-from-string
     (oauth:access-protected-resource
      "http://api.twitter.com/1/statuses/update.json"
      *access-token*
      :request-method :post
      :user-parameters `(("status" . ,#"""#,message #'求職中"""))))
    message))

(defun print-tweet (json-string)
  (ignore-errors
    (json:with-decoder-simple-clos-semantics
      (let ((json:*json-symbols-package* :repl-twitter-client))
        (let ((x (json:decode-json-from-string json-string)))
          (with-slots (text user) x
            (with-slots (name screen--name) user
              (format *query-io* "~&  ~%~a (~a)~&~a~%" screen--name name text))))))))

(defun timeline ()
  (bordeaux-threads:make-thread
   (^ with-open-stream (in (oauth:access-protected-resource
                            "https://userstream.twitter.com/2/user.json"
                            *access-token*
                            :drakma-args '(:want-stream t)))
      (loop for line = (read-line in nil)
            while line
            do (print-tweet line)))
   :name "https://userstream.twitter.com/2/user.json"))