LISPUSER

LISPMEMOLisp is like a ball of mud - you can throw anything you want into it, and it's still Lisp. -- Anonymous

(top)  (memo)  (rss)

PNM (PBM, PNM, PPM) 形式の画像とか CSV ファイルとか

はてなで Lisper を発見。

というわけで、私もチャレンジ。

ここで作った Common Lisp 用 text.csv モジュール 置いておきます (Gauche の text.csv の移植)。 ドキュメント書いたら CLiki にでも載せようかな。

PNM フォーマット

PNM フォーマットは Emacs から閲覧できるので結構使いやすいです。ビットマップ(白黒)の PBM, グレースケールの PGM, カラーの PPM ですね。 この三種類をまとめて PNM と呼びますので、PNM クラスの実装として PBM, PGM, PPM クラスを用意します。 方針は、image クラスで操作のプロトコル (OO でいうインターフェース) を定義して、詳細な実装をおこなうことにします。 プロトコルは点を打つ plot とファイルに保存する save だけです。

;; 目標: 宣言的にフォーマットを定義できるようにしたい
(define-pnm-format pbm
   :magic-number "P4"
   :bits-per-pixel 1
   :plot-method (:method ((image pbm) x y r g b) ...)) 
(define-pnm-format ppm
   :magic-number "P5"
   :bits-per-pixel 8
   :plot-method (:method ((image pbm) x y r g b) ...))
(define-pnm-format ppm
   :magic-number "P6"
   :bits-per-pixel 24
   :plot-method (:method ((image pbm) x y r g b) ...))

で、これを実現するために汚ない部分はマクロにがんばってもらいます。マクロをあえてぐちゃっとさせるため、 bits-per-pixel が 1 の PBM の場合には内部のデータ保存にビットベクタを利用してます。

中身が多少きたなくても、宣言部分が意図を表現できてればいいんです。無理にビットベクタを使わずに unsigned-byte にしよう、というような 実装の詳細は使ってくうちに手を入れることになるし。と正当化。

この例だと define-pnm-format マクロにまとめる前に一回全部正直に手でコーディングしてますが。

(defpackage :util.image (:use :cl) (:nicknames :image))
(in-package :util.image)

(defclass image ()
  ((width :initarg :width)
   (height :initarg :width)
   (buffer :initform 0)))

(defmethod plot ((image image) x y R G B)
  (declare (ignorable image x y R G B))
  (error "Not implemented"))

(defmethod save ((image image) filename)
  (declare (ignorable image filename))
  (error "Not implemented"))

;; "http://www.not-enough.org/abe/manual/command/netpbm/ppm.html"
(defclass pnm (image) ())

(defmacro define-pnm-format (name &key bits-per-pixel magic-number plot-method)
  `(progn
     (defclass ,name (pnm) ())
     (defmethod initialize-instance ((image ,name) &key width height &allow-other-keys)
       (setf (slot-value image 'width)  width
             (slot-value image 'height) height
             (slot-value image 'buffer) (make-array (* ,(if (<= bits-per-pixel 8) 1 (floor bits-per-pixel 8)) width height)
                                                    :initial-element 0
                                                    :element-type ',(if (= bits-per-pixel 1) 'bit '(unsigned-byte 8)))))
     (defmethod plot ,@(cdr plot-method))
     (defmethod save ((image ,name) file)
       (with-slots (width height buffer) image
         (with-open-file (s file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
           (write-sequence (excl:string-to-octets
                            ,(if (= bits-per-pixel 1)
                                 `(format nil "~A~%~D ~D~%" ,magic-number width height)
                                 `(format nil "~A~%~D ~D~%~D~%" ,magic-number width height 255))) s)
           ,(if (= bits-per-pixel 1)
                '(loop with n = 0
                       with byte = 0
                       for bit across buffer
                       do
                       (setf byte (logxor byte (ash bit n) (- 7 n)))
                       (when (= n 7)
                         (write-byte byte s)
                         (setf byte 0 n -1))
                       (incf n)
                       finally
                       (unless (= n 0)
                         (write-byte byte s)))
                '(write-sequence buffer s))))
       image)))

(define-pnm-format pbm
   :magic-number "P4"
   :bits-per-pixel 1
   :plot-method (:method ((image pbm) x y r g b)
                  (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
                  (with-slots (width height buffer) image
                    (setf (aref buffer (+ x (* y width)))
                          (if (>= (logand (floor (+ (* 0.299 r) (* 0.587 g) (* 0.114 b)) 1) #xFF) 128) 1 0)))))

(define-pnm-format pgm
   :magic-number "P5"
   :bits-per-pixel 8
   :plot-method (:method ((image pgm) x y r g b)
                  (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
                  (with-slots (width height buffer) image
                    (setf (aref buffer (+ x (* y width)))
                          (logand (floor (+ (* 0.299 r) (* 0.587 g) (* 0.114 b)) 1) #xFF)))))

(define-pnm-format ppm
   :magic-number "P6"
   :bits-per-pixel 24
   :plot-method (:method ((image ppm) x y R G B)
                  (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
                  (with-slots (width height buffer) image
                    (setf (aref buffer (+ (* x 3) 0 (* y 3 width))) (logand r #xFF)
                          (aref buffer (+ (* x 3) 1 (* y 3 width))) (logand g #xFF)
                          (aref buffer (+ (* x 3) 2 (* y 3 width))) (logand b #xFF)))))

あとはノイズ画像でも作りましょう。

(defun test (&optional (type 'pbm))
  (let* ((width 320)
         (height 240)
         (image (make-instance type :width width :height height)))
    (dotimes (y height)
      (dotimes (x width)
        (plot image x y (random #xFF) (random #xFF) (random #xFF))))
    (save image "foo.pnm")
    image))

でインラインイメージサポートの Emacs で find-file すると即プレビューできて嬉しいです。

ちなみに PBM や PGM のほうが遅いという手抜きっぷりです。この式だと浮動小数点演算で boxing おこりまくりなんで。 近似の整数演算で高速化するか、plot-gray のような API を追加すべきでしょう。あと無理にビットベクタを使わずに内部を (unsigned-byte 8) のベクタにしとけば write-sequence で書き出せますね。

理想としては、ベクタのフォーマットや書き出すときのフィルタ (LZW 圧縮するとか BPM みたいに上下逆転してるやつとかに対応するため) を定義したら嬉しいかもしれません。

(define-image-format GIF
   :bits-per-pixel 8
   :encoder :lzw
   ...)

あとは、ヘッダは文字列で、データ部はバイナリの形式ですが、 simple-stream を実装している AllegroCL (SBCL も?) では ストリームに format して、さらに write-sequence でベクタも書き込めますが CLISP なんかは simple-stream のサポートがない ので文字列を format で組み立てて string-to-octets (同等の関数は CLISP, SBCL にも存在しているので) で unsigned-byte の ベクタに展開してから write-sequence してます。

CSV

クォートを考慮しないなら↓のようなものが簡単かもしれません。

(defun csv->list-1 (file &key (filter #'identity))
  (with-open-file (stream file :direction :input)
    (loop for line = (read-line stream nil :eof)
          until (eq line :eof)
          collect (mapcar filter (ppcre:split "," line)))))

ppcre を使いたくなければ↓のように手動で区切ってもはやいかもしれません。

(defun csv->list-2 (file &key (filter #'identity))
  (flet ((process-line (line)
           (mapcar filter
                   (loop with pos = 0
                         for c across line
                         for n from 0
                         for lastp = (= n (1- (length line)))
                         if (or (char= c #\,) lastp)
                         collect (prog1
                                     (subseq line pos (if lastp (1+ n) n))
                                   (setf pos (1+ n)))))))
    (with-open-file (stream file :direction :input)
      (loop for line = (read-line stream nil :eof)
            until (eq line :eof)
            collect (process-line line)))))

数値として読みたいなら parse-integer とかを使うと良いとおもいます。``*read-eval*`` を nil にバインドしとかないと ``#.`` で任意コードが実行されちゃいますからね。

最後は正攻法。でもなんとなく裏技。Gauche の text.csv モジュールから移植 :-) 微妙に挙動があやしいので dirty hack で逃げましたが、 string-prefix? とか scan-string を作ったほうがよさそう。

(defun make-csv-reader (separator &optional (quote #\") (newline (format nil "~%")))
  #'(lambda (stream)
      (labels ((start (line fields)
                 "初期状態"
                 (if (eql line :eof)
                     (nreverse fields)
                     (let ((next (string-trim " " line)))
                       (if (and (string/= next "") (char= (char next 0) quote))
                           (quoted (subseq next 1) fields '())
                           (noquote next fields)))))
               (noquote (line fields)
                 "クォートされていないフィールドを読み取る"
                 (let ((index (position separator line)))
                   (if index
                       (start (subseq line (1+ index))
                              (cons (string-right-trim " " (subseq line 0 index)) fields))
                       (nreverse (cons (string-right-trim " " line) fields)))))
               (quoted (line fields partial)
                 "クォートされているフィールドを読み取る"
                 (cond ((eql line :eof)
                        (error "unterminated quoted field"))
                       ((string= line "")
                        (quoted (read-line stream nil :eof) fields (cons newline partial)))
                       (t
                        (let ((index (position quote line)))
                          (if index
                              (let ((this (subseq line 0 index))
                                    (next (subseq line (1+ index))))
                                (if (char= (char next 0) quote)
                                    (quoted (subseq next 1) fields (nconc (list (coerce (list quote) 'string) this) partial))
                                    (let ((index2 (position quote next))
                                          (f (apply #'concatenate (cons 'string (nreverse (cons this partial))))))
                                      (when (and (null index2) (string/= next ""))
                                        (setf index2 1))
                                      (if index2
                                          (start (subseq next index2) (cons f fields))
                                          (nreverse (cons f fields))))))
                              (quoted (read-line stream nil :eof) fields 
                                      (cons newline (cons line partial)))))))))
        (let ((line (read-line stream nil :eof)))
          (if (eql line :eof)
              line
              (start line ()))))))

(defun make-csv-writer

でもまぁ、大筋こんな感じの移植で↓のように複数行の要素も読み取れました。

 CSV> (with-input-from-string (s "1,2,3,4,\"5,6,7\",\"1:aaa
 2:にほんご
 3:日本語
 4:\"\"ddd\"\"\",   777")
           (funcall (make-csv-reader #\,) s))
 ("1" "2" "3" "4" "5,6,7" "1:aaa
 2:にほんご
 3:日本語
 4:\"ddd\""
  "777")

しかしいかにも Scheme なコードなのでループと状態マシンに書き直すとかの高速化の余地がありますね。

ついでに回答。

replace-char old-char new-char str 
   str内のold-charをnew-charに変えます。標準であってもおかしく無い関数なので、知らないだけかもです。^^; 

スルドイ読みですね。私は Lisp 始めて 1 年くらいは substitute とか subst とかあるとはかけらも思いいたらずに余裕で自作してました。 しかもバグってた苦い思い出が。で substitute がズバリそれです。

CL-USER> (substitute #\a #\b "abcedbb")
"aacedaa"

substitute はシーケンスに対する操作で、 subst はツリーに対する操作です。自作 subst デバッグ中に subst みつけて脱力したなぁ。

Ruby 方面から

■[ruby]RubyはもっとLispっぽくなれれば 19:14   
現在の状態をイメージファイルに落としたり、構文木をいじるマクロがあればいいな。真の多値(1.9にあるっけ?)やキーワード引数も恋しい。それと高速なネイティブコンパイラ。

たぶん、それは Ruby じゃなくなっちゃいます。Ruby の統一感、気持ち良さ、感情移入というのは随所に Matz Way が込められているからであって、 構文をユーザー定義できたら良さが薄れちゃう気がします。一人の人間の一貫した意図がないとあの一貫した使い心地にはならないでしょう。

もし、構文木をいじる方向やネイティブコンパイラを意識した方向に進化したりすると、Ruby の各実装がバラバラに進化しはじめて、コンパイラに対応するために実行時とかコンパイル時の概念が導入されたりして、いろんなコンパイラが乱立して、仕様の違いでユーザーが混乱して、結局みんなで集って ANSI Common Ruby を策定するはめになって、巨大な仕様とか叩かれて、Matz さん独自路線のシンプル Matz Ruby と二派に分かれて微妙にお互い仲悪いみたいな関係になったらどうします?

 ■[lisp]SBCLの日本語解説@lispuser.net 19:14   
 http://lispuser.net/commonlisp/sbcl.html
 もう1.0.6出てますよー。

http://lispuser.net/commonlisp/sbcl.html を更新しようと思いましたが、途中で眠くなって力尽きます。 1.0.7 出てるし、お手軽カバレッジな sb-cover は是非紹介したいし。また次回更新時に…

http://lispuser.net/commonlisp/clisp.html のごった煮版も SLIME が私のホームディレクトリを作るというクレームを見かけたので修正したつもりだけどああぁだめだねむい

posted: 2007/06/29 01:12 | permanent link to this entry | Tags: LISP

(top)  (memo)  (rss)