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

目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")

リストの作成

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)

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割がた抜け落ちてるのでコードを書きつつ読み直してみる。

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をまともに使えている気がします。たぶん気のせいですが。

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

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

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

(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