2011年5月31日火曜日

バイト列を画像に変換する

目grepはできませんが、画像を作るくらいならできそうなのでやってみました。

入力を1バイトずつ、値に応じた色のピクセルに変換して画像を作成します。値と表示色の関係はbin2colorをいじると変更できます。

ひさびさにPythonを使ってみました。

#!/usr/bin/python

import sys
import os.path
import Image

argvs = sys.argv
argc = len(argvs)

if (argc != 3) :
print 'Usage : %s [input-file] [output-file]' % argvs[0]
quit()

in_file = argvs[1]
out_file = argvs[2]

filesize = os.path.getsize(in_file)

x = 160
y = filesize/x + 1

print 'filesize %d , x = %d, y = %d' % (filesize, x, y)


def bin2color(bin):
bin = ord(bin)
if bin == 0 :
return (255, 255, 255)
elif bin <= 0x80 :
return (255, 0, 0)
else :
return (0, 0, 0)

img = Image.new("RGB", (x, y), (255, 255, 255))

try:
f = open(in_file, "rb")
n = 0
while n < y-1:
line = f.read(x)
for i in range(x):
img.putpixel((i,n), bin2color(line[i]))
n = n + 1
line = f.read(filesize - (x * n))
for i in range(filesize - (x * n)):
img.putpixel((i,n), bin2color(line[i]))
finally:
f.close()

img.save(out_file, "BMP")

2011年5月28日土曜日

リストの作成

F#のyieldやyield!っぽいなにかを書いてみました。値を集めることしかしませんが、 loopマクロよりもリストを作りやすいのではないか、という気はします。

(defmacro yielding (&body body)
(let ((gtail (gensym))
(ghead (gensym))
(garg (gensym))
(gtmp (gensym)))
`(let* ((,ghead (cons nil nil))
(,gtail ,ghead))
(macrolet
((yield (,garg) `(setf (cdr ,',gtail) (cons ,,garg nil)
,',gtail (cdr ,',gtail)))
(yield! (,garg) `(loop :for ,',gtmp :in ,,garg :do (yield ,',gtmp))))
,@body
(cdr ,ghead)))))

> (yielding (yield 2))
(2)
> (yielding (dotimes (i 3) (yield i)) (yield! (sort (list 1 2) #'>)))
(0 1 2 2 1)

2011年5月18日水曜日

F#入門

F#はじめました。とりあえずFizzBuzz。

let fizzbuzz1 (tgt : int) =
[1..tgt]
|> List.map
(fun n -> if n % 15 = 0
then printf "FizzBuzz\n"
else if n % 5 = 0
then printf "Buzz\n"
else if n % 3 = 0
then printf "Fizz\n"
else printf "%d\n" n)
|> ignore

let fizzbuzz2 (tgt : int) =
[1..tgt]
|> List.iter
(fun n ->
match n with
| _ when n % 15 = 0 -> printf "FizzBuzz\n"
| _ when n % 5 = 0 -> printf "Buzz\n"
| _ when n % 3 = 0 -> printf "Fizz\n"
|_ -> printf "%d\n" n)
|> ignore

いちおうプログラミングF#は流し読みしたけれど、 9割がた抜け落ちてるのでコードを書きつつ読み直してみる。

2011年5月12日木曜日

cl-annotを使ってインターフェースと実装を分離する

cl-annotを使ってみるテストその2。

機能を表す名前(関数名)と実際の実装を分離して、利用する際はアノテーションで実装を選択させてみます。

試しにソケットを利用するための関数(インターフェース)を定義し、 2種類のライブラリを用いた実装(バックエンド)を作成して利用するようにしてみました。

(asdf:load-system :cl-annot)
(use-package :cl-annot)

(defun mk-impl-annot-name (sym)
(values
(intern (format nil "~A-IMPL" (symbol-name sym)))))

(defun mk-use-annot-name (sym)
(values
(intern (format nil "USE-~A" (symbol-name sym)))))

(defun setup-interface (interface-name clauses)
(setf (get interface-name
:interface-function-clauses)
clauses))

(defun set-impl-function (interface-name
impl-name
interface-fn-name
impl-fn-name)
(unless (find impl-name (get interface-name :impl-name-list))
(push impl-name (get interface-name :impl-name-list)))
(setf (get impl-name interface-fn-name) impl-fn-name))

(defun get-interface-function-names (interface-name)
(mapcar
#'second
(remove
nil
(mapcar
#'(lambda (clause)
(when (and (listp clause) (eq (car clause) :function))
clause))
(get interface-name :interface-function-clauses)))))


(defun replace-symbol (fn sexp &key (test (constantly t)))
(typecase sexp
(symbol (if (funcall test sexp) (funcall fn sexp) sexp))
(atom sexp)
(t ; cons
(if (eq 'quote (car sexp))
sexp
(cons (replace-symbol fn (car sexp) :test test)
(if (null (cdr sexp))
(cdr sexp)
(replace-symbol fn (cdr sexp) :test test)))))))

(defun replace-interface-symbol (interface-name impl-name form)
(let ((names (get-interface-function-names interface-name)))
(replace-symbol
#'(lambda (sym)
(if (find sym names)
(get impl-name sym)
sym))
form)))


(defmacro definterface (name &body clauses)
(let ((g-form (gensym))
(g-impl-name (gensym))
(g-interface-fn-name (gensym))
(g-defun-name (gensym)))

`(progn
(setup-interface ',name ',clauses)

;; @[name]-impl impl-name interface-function-name defun-form
(defannotation ,(mk-impl-annot-name name)
(,g-impl-name ,g-interface-fn-name ,g-form) (:arity 3)
(let ((,g-defun-name (nth 1 ,g-form)))
`(progn
,,g-form
(set-impl-function
',',name ',,g-impl-name ',,g-interface-fn-name ',,g-defun-name)
',,g-defun-name)))

;; @use-[name] impl-name form
(defannotation ,(mk-use-annot-name name)
(,g-impl-name ,g-form) (:arity 2)
(replace-interface-symbol ',name ,g-impl-name ,g-form))


,@(remove
nil
(mapcar
#'(lambda (clause)
(when (and (listp clause)
(eq (car clause) :function))
(destructuring-bind
(_ fn-name lambda-list)
clause
`(defun ,fn-name ,lambda-list
,(format nil "interface function `~A'" fn-name)
(error "interface function is invoked")))))
clauses))
t)))



;; example


(definterface tcp-socket
(:function tcp-socket-connect (host port))
(:function tcp-socket-listen (host port))
(:function tcp-socket-accept (listen-sock))
(:function tcp-socket-read-line (sock))
(:function tcp-socket-write-line (sock line))
(:function tcp-socket-close (sock)))

(enable-annot-syntax)


;; usocket
(asdf:load-system :usocket)

@tcp-socket-impl usocket tcp-socket-connect
(defun usocket-socket-connect (host port)
(usocket:socket-connect host port))

@tcp-socket-impl usocket tcp-socket-listen
(defun usocket-socket-listen (host port)
(usocket:socket-listen host port :reuseaddress t))

@tcp-socket-impl usocket tcp-socket-accept
(defun usocket-socket-accept (listen-sock)
(usocket:socket-accept listen-sock))

@tcp-socket-impl usocket tcp-socket-read-line
(defun usocket-socket-read-line (sock)
(read-line (usocket:socket-stream sock)))

@tcp-socket-impl usocket tcp-socket-write-line
(defun usocket-socket-write-line (sock line)
(write-line line (usocket:socket-stream sock)))

@tcp-socket-impl usocket tcp-socket-close
(defun usocket-socket-clsoe (sock)
(usocket:socket-close sock))


;; acl-compat.socket
(asdf:load-system :aserve)

@tcp-socket-impl acl-compat tcp-socket-connect
(defun acl-tcp-socket-connect (host port)
(acl-compat.socket:make-socket :remote-host host :remote-port port))

@tcp-socket-impl acl-compat tcp-socket-listen
(defun acl-tcp-socket-listen (host port)
(acl-compat.socket:make-socket :remote-host host
:local-port port
:connect :passive))

@tcp-socket-impl acl-compat tcp-socket-accept
(defun acl-tcp-socket-accept (sock)
(acl-compat.socket:accept-connection sock))

@tcp-socket-impl acl-compat tcp-socket-read-line
(defun acl-tcp-socket-read-line (sock)
(read-line sock))

@tcp-socket-impl acl-compat tcp-socket-write-line
(defun acl-tcp-socket-write-line (sock line)
(write-line line sock))

@tcp-socket-impl acl-compat tcp-socket-close
(defun acl-tcp-socket-close (sock)
(close sock))


;; test
@use-tcp-socket usocket
(defun run-echo-server-1 (port)
(let ((listen-sock (tcp-socket-listen "localhost" port)))
(unwind-protect
(progn
(format t "listen-sock: port ~A~%" port)
(let ((sock (tcp-socket-accept listen-sock)))
(unwind-protect
(progn
(format t "accept-sock~%")
(let ((line (tcp-socket-read-line sock)))
(format t "recv-line:~A~%" line)
(tcp-socket-write-line sock line)
(format t "write-line:~A~%" line)))
(tcp-socket-close sock))))
(tcp-socket-close listen-sock))))

@use-tcp-socket acl-compat
(defun run-echo-server-2 (port)
(let ((listen-sock (tcp-socket-listen "localhost" port)))
(unwind-protect
(progn
(format t "listen-sock: port ~A~%" port)
(let ((sock (tcp-socket-accept listen-sock)))
(unwind-protect
(progn
(format t "accept-sock~%")
(let ((line (tcp-socket-read-line sock)))
(format t "recv-line:~A~%" line)
(tcp-socket-write-line sock line)
(format t "write-line:~A~%" line)))
(tcp-socket-close sock))))
(tcp-socket-close listen-sock))))

cl-annotを使ってみる

Common Lispでアノテーションを付け加えるライブラリ、cl-annotを使って遊んでみました。

`注釈'でどこまでコードをいじっていいのかよく分からないので、便利なリーダマクロな扱いになってしまっているような。

(asdf:load-system :cl-annot)
(use-package :cl-annot)

(defpackage a
(:use)
(:export curry
replace-symbol
subst-symbol
with-dot-slot-value-syntax))


;;;; シンボルの置き換えを行う

(defun replace-symbol (fn sexp &key (test (constantly t)))
(typecase sexp
(symbol (if (funcall test sexp) (funcall fn sexp) sexp))
(atom sexp)
(t ; cons
(if (eq 'quote (car sexp))
sexp
(cons (replace-symbol fn (car sexp) :test test)
(if (null (cdr sexp))
(cdr sexp)
(replace-symbol fn (cdr sexp) :test test)))))))

;; form 中に from のシンボルが現れたら to に置き換える
(defannotation a:subst-symbol (from to form) (:arity 3)
(replace-symbol
(lambda (x)
(declare (ignore x))
to)
form
:test (lambda (x) (eq x from))))

;; すべてのシンボルを関数fnの呼び出し結果で置き換える
(defannotation a:replace-symbol (fn form) (:arity 2)
(replace-symbol fn form))

;; ドット区切りのシンボルをスロットアクセスに変換する
(defun symbol-separated? (str sym)
(let ((name (symbol-name sym)))
(when (>= (length name) (+ 2 (length str)))
(and (search str (subseq name 1 (1- (length name))) )
t))))
(defun separate-symbol (str sym)
(let* ((name (symbol-name sym))
(trimmed-name (subseq name 1 (1- (length name))))
(first-char (char name 0))
(last-char (char name (1- (length name))))
(str-len (length str)))
(labels
((recur (tgt acc)
(let ((pos (search str tgt)))
(if pos
(recur (subseq tgt (+ pos str-len))
(cons
(subseq tgt 0 pos)
acc))
(nreverse
(cons
(format nil "~A~C" tgt last-char)
acc))))))
(let ((result (recur trimmed-name nil)))
(mapcar #'intern
(cons
(format nil "~C~A" first-char (car result))
(cdr result)))))))

(defun list->slot-value-access-form (lst)
(if (null (cdr lst))
(car lst)
(list->slot-value-access-form
(cons `(slot-value ,(car lst) ',(cadr lst))
(cddr lst)))))

(defannotation a:with-dot-slot-value-syntax (form) (:arity 1)
(replace-symbol
(lambda (sym)
(list->slot-value-access-form
(separate-symbol "." sym)))
form
:test (lambda (x) (symbol-separated? "." x))))


;;;; カリー化(引数の部分的用)を行える関数クラスを作成する

(asdf:load-system :closer-mop)

(defclass curry-function-class ()
((arity :reader arity-of :initarg :arity)
(function :reader function-of :initarg :function)
(args :reader args-of :initarg :args))
(:default-initargs
:arity (error "require :arity keyword value")
:function (error "require :function keyword value")
:args nil)
(:metaclass closer-mop:funcallable-standard-class))

(defmethod initialize-instance :after ((this curry-function-class) &rest args)
(declare (ignore args))
(closer-mop:set-funcallable-instance-function
this
#'(lambda (&rest curry-args)
(with-accessors
((arity arity-of)
(fn function-of)
(args args-of))
this
(let ((curry-args-num (length curry-args))
(args-num (length args)))
(cond
((= (+ curry-args-num args-num) arity)
(apply fn (append args curry-args)))
((< (+ curry-args-num args-num))
(make-instance 'curry-function-class
:arity arity
:function fn
:args (append args curry-args)))
(t (error "too many arguments. arity ~D, but ~D."
arity
(+ curry-args-num args-num)))))))))

(defmacro define-curry-function (name arity (&rest lambda-list) &body body)
`(progn
(setf (symbol-function ',name)
(make-instance 'curry-function-class
:arity ,arity
:function (lambda ,lambda-list ,@body)))))

;; defun を define-curry-function に置き換える
(defannotation a:curry (arity defun-form) (:arity 2)
(unless (and (listp defun-form)
(eq (car defun-form) 'cl:defun))
(error "annotation `curry' require `defun' form"))
`(define-curry-function
,(nth 1 defun-form) ; name
,arity
,@ (nthcdr 2 defun-form)))


;;;; example

(enable-annot-syntax)

;;; @subst-symbol
;;; シンボルを置き換える
@a:subst-symbol mvb multiple-value-bind
(defun test-1 (lst)
(mvb (a b) (values (car lst) (cadr lst))
(list a b)))
(test-1 (list 2 3))
;; => (2 3)

;;; @replace-symbol
;;; 関数を利用してシンボルを置き換える
(defun a->1 (a) (if (eq a 'a) 1 a))
@a:replace-symbol a->1
(defun test-2 (x)
(+ x a))
(test-2 3)
;; => 4

;;; @with-dot-slot-value-syntax
;;; ドット区切りのシンボルをslot-valueに展開する
(defclass hoge ()
((a :initarg :a)
(b :initarg :b)))

@a:with-dot-slot-value-syntax
(let ((obj (make-instance 'hoge :a 2 :b 3)))
(list obj.a obj.b))
;; => (2 3)

;;; @curry
;;; defunをカリー化できる関数を定義するマクロに置き換える
@a:curry 2
(defun hoge (a b)
(list a b))

(funcall (hoge 2) 3)
;; => (2 3)

funcallable-objectをまともに使えている気がします。たぶん気のせいですが。

2011年5月5日木曜日

矢印でメソッドチェイン風に記述する

なんどか似たようなネタでコードを書いている気がします。

矢印シンボルを用いて括弧の数を減らしてみます。矢印の`>'の個数で式を挿入する位置を決定するようにしてみました。

(defun arrow-symbol? (sym)
(when (symbolp sym)
(let ((name (symbol-name sym)))
(and (<= 2 (length name))
(= (+ (count #\- name)
(count #\> name))
(length name))
(string= (sort (copy-seq name) #'char<)
name)))))

(defun arrow-count (sym)
(count #\> (symbol-name sym)))

(defun collect-arrow-clauses (body)
(do ((rest (reverse body))
(result nil))
((null rest) result)
(let ((pos (position-if #'arrow-symbol? rest)))
(when (null pos)
(error "arrow symbol not found"))
(push (reverse (subseq rest 0 (1+ pos))) result)
(setf rest (subseq rest (1+ pos))))))

(defmacro arrow (obj &body body)
(labels
((expand (rest prev)
(if rest
(let ((insert-pos (arrow-count (caar rest))))
(expand
(cdr rest)
(append
(subseq (cdar rest) 0 insert-pos)
(list prev)
(subseq (cdar rest) insert-pos))))
prev)))
(expand (collect-arrow-clauses body) obj)))

;;; 実効
(arrow "afscd"
-> copy-seq
-> sort #'char<
->>> format t "sorted:~A~%")

;;; マクロ展開後のコード
(FORMAT T "sorted:~A~%" (SORT (COPY-SEQ "afscd") #'CHAR<))

;;; 出力
sorted:acdfs

deftypeとtypecaseを使ってfizzbuzz

Common Lispのdeftypeを利用してみます。

fizz,buzz,fizzbuzzをdeftypeで型として定義して、 typecaseを使って値を判別します。

(defun fizz? (n)
(zerop (mod n 3)))
(defun buzz? (n)
(zerop (mod n 5)))

;;; 型定義
;; fizz型は0以上の整数かつ関数fizz?に引数として渡すと真を返す値であると定義
(deftype fizz ()
'(and (integer 0 *) (satisfies fizz?)))
(deftype buzz ()
'(and (integer 0 *) (satisfies buzz?)))
(deftype fizzbuzz ()
'(and
(integer 0 *)
(satisfies fizz?)
(satisfies buzz?)))

;;; 実効
(loop for i from 1 to 30
do (print
(typecase i
(fizzbuzz 'fizzbuzz)
(fizz 'fizz)
(buzz 'buzz)
(t i))))
;;; 出力
1
2
FIZZ
4
BUZZ
FIZZ
7
8
FIZZ
BUZZ
11
FIZZ
13
14
FIZZBUZZ
16
17
FIZZ
19
BUZZ
FIZZ
22
23
FIZZ
BUZZ
26
FIZZ
28
29
FIZZBUZZ