2012年12月30日日曜日

Clojureでテキスト入出力

Clojureでテキスト入出力を行う方法のメモ。

1 テキストファイル

;; 出力
(spit "test.txt" "Hello, World")

;; 入力
(assert (= "Hello, World" (slurp "test.txt")))

2 文字列

(with-open [in (java.io.StringReader. "Hello")]
  (assert (= \H (char (.read in))))
  'ok)

(with-open [in (clojure.java.io/reader (.getBytes "Hello"))]
  (assert (= "Hello" (.readLine in)))
  'ok)

(with-in-str "hoge"
  (assert (= "hoge" (read-line))))

3 XML

;; [org.clojure/data.xml "0.0.6"]
(require '[clojure.data.xml :as xml])
(xml/parse-str "<x id='1'><y>a</y><y id='2'>b</y></x>")

;; [enlive "1.0.0"]
(require '[net.cgrand.enlive-html :as enlive])
(let [s "<x id='1'><y>a</y><y id='2'>b</y></x>"
      x (with-in-str s (enlive/xml-resource *in*))]
  (assert (= '("b") (:content (first (enlive/select x [:#2]))))))

4 CSV

;; [org.clojure/data.csv "0.1.2"]
(require '[clojure.data.csv :as csv])

(let [s "a,\"b,c\",d\ne,fg,h\n"]
  (println (csv/read-csv s))
  (csv/write-csv *out* (csv/read-csv s))
  (assert (= s (with-out-str
                 (csv/write-csv *out* (csv/read-csv s)))))
  'ok)

5 JSON

;; [org.clojure/data.json "0.2.0"]
(require '[clojure.data.json :as json])
(let [m (json/read-str "{\"k1\": 1, \"k2\": \"val\"}")]
  (println m)
  (assert (= m (json/read-str (json/write-str m))))
  (with-open [out (clojure.java.io/writer "tmp.json")]
    (json/write m out))
  (with-open [in (clojure.java.io/reader "tmp.json")]
    (assert (= m (json/read in))))
  'ok)

;; オプションとして :key-fn や :value-fn を指定すると read/write 時にキーと値を変換できる
(println (= {:key 1.0}
            (json/read-str "{\"key\" : 1}"
                           :key-fn keyword
                           :value-fn #(double %2))))

6 INIファイル

;; [clojure-ini "0.0.1"]
(require '[clojure-ini.core :as ini])

(spit "test.ini" "[a]\nb=c\nd=e\n")
(assert (= {:a {:b "c", :d "e"}}
           (ini/read-ini "test.ini" :keywordize? true)))

2012年12月16日日曜日

[メモ]衛星の高度から速度・周期を求める

衛星の高度から速度・周期を求める式が JAXAのページ に書いてありました。

6378[km]赤道半径
H [km]地表からの高度
V [km/s]速度
T [s]周期

$V[km/s] = (\frac{398600[km^3/s^2]}{(6378[km] + H[km])})^\frac{1}{2}$

$T[s] = \frac{2\pi(6378[km] + H[km])}{V[km/s]}$

(defn v [h]
  (Math/sqrt (/ 398600 (+ 6378 h))))

(defn t [h v]
  (/ (* 2 Math/PI (+ 6378 h)) v))

(defn h->t [h]
  (t h (v h)))
;; 静止軌道(35786km) で 23時間56分
user=> (h->t 35786)
86163.61830152525

user=> (/ *1 3600)
23.934338417090345

Racketのサンドボックス機能

Racketには評価時のリソースの利用を制限するサンドボックス機能があります。

このあたりを参照

使用可能なメモリを制限して式を評価するプログラムを書いてみます。

#lang racket
(require racket/sandbox)

(define e (parameterize ((sandbox-memory-limit 1)) ;; 1MByte
            (make-evaluator 'racket/base)))

;; 1KByteくらい (1MByte制限)
(printf "~s\n" (vector-length (e '(make-vector 1000))))
(flush-output)

;; 1MByteくらい (制限なし)
(printf "~s\n" (vector-length (make-vector 1000000)))
(flush-output)

;; 1MByteくらい (1MByte制限)
(printf "~s\n" (vector-length (e '(make-vector 1000000))))
(flush-output)
> racket test.rkt
1000
1000000
out of memory 
  context...:
   /usr/racket/collects/racket/sandbox.rkt:355:0: call-with-limits
   /usr/racket/collects/racket/sandbox.rkt:403:0: call-with-custodian-shutdown
   /usr/racket/collects/racket/private/more-scheme.rkt:146:2: call-with-break-parameterization
   /usr/racket/collects/racket/sandbox.rkt:760:5: loop

[メモ]C#で時刻文字列を扱う・XMLファイルを読み込む

C#で時刻文字列のパース・フォーマット指定して文字列に変換

using System;
using System.Globalization;

class Test
{
  public static void Main()
  {
    DateTime tmp = DateTime.Parse("2012-12-16T00:00:00Z");
    Console.WriteLine(TimeZoneInfo.ConvertTimeToUtc(tmp).ToString("yyyy/MM/dd HH:mm:ss"));
    return;
  }
}
2012/12/16 00:00:00

C#でXMLファイルをパース

// mono-csc xml.cs -r:System.Xml.Linq.dll
using System;
using System.Xml;
using System.Linq;
using System.Xml.Linq;
using System.Collections.Generic;

// test.xml
// <a>
//  <b>b1</b>
//  <b>b2</b>
//  <c>c1</c>
// </a>

class Test
{
  static void Main()
  {
    var doc = XElement.Load("test.xml", LoadOptions.SetLineInfo);
    var elems = 
      from x in doc.Descendants()
      select x;

    foreach(var e in elems)
      {
        var text = String.Format("{0}:{1}", ((IXmlLineInfo)e).LineNumber, e.Value);
        Console.WriteLine(text);
      }

    return;
  }
}
2:b1
3:b2
4:c1

Clojureのリテラルその他

リテラル
内容X(type 'X)
10進数2 => 2java.lang.Long
8進数010 => 8java.lang.Long
16進数0x10 => 16java.lang.Long
2進数2r10 => 2java.lang.Long
36進数36r10 => 36java.lang.Long
BigInt3N => 3Njava.lang.BigInt
小数1.1 => 1.1java.lang.Double
小数1.0E8 => 1.0E8java.lang.Double
BigDecimal2.2M => 2.2Mjava.math.BigDecimal
有理数22/7 => 22/7clojure.lang.Ratio
シンボルabc あいう !clojure.lang.Symbol
キーワード:a => :aclojure.lang.Keyword
キーワード::a => :user/aclojure.lang.Keyword
文字列"abc" "\t\n"java.lang.String
文字\a \あ \spacejava.lang.Character
リスト(1 2)clojure.lang.PersistentList
空リスト()PersistentList$EmptyList
ベクタ[1 2]clojure.lang.PersistentVector
マップ{:k1 :v1 :k2 :v2}clojure.lang.PersistentArrayMap
セット#{:a :b :c}clojure.lang.PersistentHashSet
nil (null)nilnil
truetruejava.lang.Boolean
falsefalsejava.lang.Boolean
正規表現#"\d{2}\w+"java.util.regex.Pattern
コンストラクタ#java.lang.Double[1.1]クラス・レコード・タイプのインスタンス


読み込み時に他のフォームに置き換えられる表現
内容X'X
Quote'a(quote a)
Deref@a(deref a)
typehint^String^{:tag String}
Var-quote#'a(var a)
無名関数#(…)(fn [args] (…))
S式コメント#_Xフォーム X をコメントとして扱う
Syntax-quote`(…)-
読み込み時の評価#=(+ 1 2)3

2012年12月13日木曜日

正規表現を利用して文字列を作成する

( Lisp Advent Calendar 2012 の13日目の記事です)

テストなどのために適当なデータを作成したいことがあります。
この時、データをランダムに作成できると、楽ができる上に 自分の考えていなかった入力パターンから問題を見つけることができて良さそうです。

作成したいデータが数値なら、疑似乱数生成用の関数(rand,randomなど)を使えば事足ります。
文字列を作成したい場合は、正規表現を利用すれば楽ができそうです。

Clojure には、正規表現からその正規表現にマッチするような文字列を作成してくれる re-rand という ライブラリがあります。

[re-rand "0.1.0"]
user> (require [re-rand :as r])

user> (repeatedly 3 #(r/re-rand #"\d{4}/\d{2}/\d{2} \d\d:\d\d:\d\d"))
("7511/27/85 13:37:43" "6728/87/88 96:68:15" "1536/63/37 90:23:02")

user> (repeatedly 3 #(r/re-rand #"[0-9零一二三四五六七八九]{1,10}"))
("六二零七" "1七8" "二三七八一2八1")

Common Lisp には・・・と思って調べて見ましたが、見つけることができませんでした。 仕方ないので自分で作りましょう。

幸い、一番大変そうな正規表現のパースは cl-ppcre の parse-string 関数で行えます。

(asdf:load-system :cl-ppcre)

(defpackage :random-string
  (:use :cl)
  (:export random-string
           *repeat-limit*
           *charset-every*
           *charset-digit*
           *charset-word*
           *charset-whitespace*))

(in-package :random-string)

(defvar *repeat-limit* 64)

(defvar *charset-everything*
  (lambda () (code-char (random 256) )))

(defvar *charset-digit* "0123456789")

(defvar *charset-word*
  (concatenate 'string
   "abcdefghijklmnopqrstuvwxyz"
   "ABCEFGHJIJKLMNOPQRSTUVWXYZ"
   "!\"#$%'()-=^~\\|[]{};:+*,.<>/?_"))

(defvar *charset-whitespace*
  (format nil "%c%c%c" #\space #\newline #\tab))

(defun one-of (obj)
  (if (functionp obj)
      (funcall obj)
      (let ((count (length obj)))
        (elt obj (random count)))))

(defun random-string (regexp)
  (generate (ppcre:parse-string regexp)))

(defmethod generate ((obj string))
  obj)

(defmethod generate ((obj character))
  (string obj))

(defmethod generate ((obj list))
  (generate/list (first obj) (rest obj)))

(defmethod generate ((obj (eql :digit-class)))
  (string (one-of *charset-digit*)))

(defmethod generate ((obj (eql :everything)))
  (string (one-of *charset-everything*)))

(defmethod generate ((obj (eql :whitespace-char-class)))
  (string (one-of *charset-whitespace*)))

(defmethod generate ((obj (eql :word-char-class)))
  (string (one-of *charset-word*)))

(defmethod generate/list ((cls (eql :sequence)) rest)
  (apply #'concatenate 'string (mapcar #'generate rest)))

(defmethod generate/list ((cls (eql :char-class)) rest)
  (string (one-of (mapcar #'generate rest))))

(defmethod generate/list ((cls (eql :range)) rest)
  (string
   (destructuring-bind (from to) rest
     (code-char
      (+ (char-code from)
         (random (1+ (- (char-code to) (char-code from)))))))))

(defmethod generate/list ((cls (eql :INVERTED-CHAR-CLASS)) rest)
  (error "unsupported expression: INVERTED-CHAR-CLASS"))

(defmethod generate/list ((cls (eql :greedy-repetition)) rest)
  (destructuring-bind (min max gen-cls) rest
    (let ((max (or max (+ min *repeat-limit*))))
      (apply #'concatenate 'string
             (loop :repeat (+ min (random (1+ (- max min))))
                :collect (generate gen-cls))))))

(defmethod generate/list ((cls (eql :register)) rest)
  (apply #'concatenate 'string (mapcar #'generate rest)))

(defmethod generate/list ((cls (eql :alternation)) rest)
  (generate (one-of rest)))

CL-USER> (random-string:random-string "b(an)+a")
"banananananananananananananananana"

CL-USER> (dotimes (_ 3)
           (print (random-string:random-string "[012]\\d{3}-((0[1-9])|(1[12]))-\\d{2}T\\d{2}:\\d{2}:\\d{2}Z")))
"2056-09-58T98:80:10Z" 
"2057-02-82T36:65:58Z" 
"1077-11-18T77:72:22Z"

CL-USER> (dotimes (_ 3)
           (print (random-string:random-string "[\\d零一二三四五六七八九]{1,5}")))

"二二四四" 
"五68" 
"二七"

文字集合の選択などで偏りが出てしまいますが、適当なデータを作成する程度なら十分利用できるかなぁ、と思います。

今回書いたコードでは、やりたいことの9割くらいを正規表現ライブラリのcl-ppcreが行ってくれています。
Lisp使いは「全部自分で書く」みたいなイメージがありますが、 leiningen や Quicklisp を使うとライブラリのインストールは簡単ですし、 やりたいことにマッチするライブラリがあったら、ありがたく使わせてもらいましょう。

2012年12月10日月曜日

Log4CLを使ってみる

( Common Lisp Libraries Advent Calendar の10日目の記事です )

最近やっと実感を得ましたが、(デバッグ)ログは大事ですね。 遠隔地にいるライブラリ製作者とやりとりする回数を減らせます。

ということで、Common Lispでログ出力するライブラリ、Log4CL を眺めてみます。

Log4CL は、CLikiの Current recommended libraries で紹介されています。
JavaのロギングライブラリであるLog4jを参考にして作られているようなので、Java使いの人にとっては使いやすいのかもしれません。

インストールは Quicklisp で行えます。

> (ql:quickload :log4cl)

正確な情報はgithubにあるREADME.mdおよびソースコードを読んで調べて頂くとして、 ざっと概要を説明してみます。

Log4CL は次の3つの構成要素から成ります。

  • ロガー : ログの出力先 (論理的)
  • アペンダ : ログの出力先(出力方法) (コンソール出力・ファイル出力など)
  • レイアウト : ログ出力の整形方法

論理的な出力先であるロガーに、実際の出力方法を定義したアペンダを対応づけ、 レイアウトで指定されたフォーマットでログを出力します。

ログレベルは、 fatal,error,warn,info,debug, user1 ~ user4, trace, user5 ~ user9 の15段階が指定できます。 ログレベルの名前に対応する出力関数(マクロ)が定義されています。

CL-USER> (log:fatal "fatal error")
[22:57:21] [fatal] <cl-user> - fatal error

CL-USER> (log:info "hello")
[22:57:51] [info] <cl-user> - hello

1文字の省略形も定義されています。

CL-USER> (log:i "helo")
[22:59:26] [info] <cl-user> - helo

CL-USER> (log:w "w")
[23:00:10] [warn] <cl-user> - w

「<cl-user>」 は現在のパッケージ名です。 ロガーを指定しない場合、デフォルトでカレントパッケージの名前がロガーとして利用されます。

ロガーの作成はmake-logger関数、あるいはmake関数で行えます。
ロガーは親子関係を持ちますが、キーワードシンボルを指定すると 親=カレントパッケージ名, 子=シンボル名 という 構造が作成されるようです。

ログ出力関数でロガーを指定する場合は、名前(シンボル)を直接指定するほうが短くて良さそうです。

CL-USER> (log:w (log:make-logger :child) "w")
[23:02:41] [warn] <cl-user:child> - w

CL-USER> (log:f (log:make-logger '(parent child)) "f")
[23:03:13] [fatal] <parent:child> - f

CL-USER> (log:e :child "e")
[23:04:17] [error] <cl-user:child> - e

ロガーが出力するログレベルを設定するには、 config 関数を使います。省略形は c です。
なお、親ロガーの設定を引き継ぐよう設定するには、:unsetを指定すれば良いようです。 デフォルトの設定は :unset です。

CL-USER> (log:debug "hoge")
; No value
CL-USER> (log:c :d)  ;; (log:config :debug) と同等
CL-USER> (log:debug "hoge")
[23:13:02] [debug] <cl-user> - hoge

ログレベルに対応する出力処理以外に、評価前の式と評価後の値を出力する expr 関数があります。 処理系が SBCL の場合は、どの関数の中でログが出力されたかまでロガー名に含めてくれるようです。

(defun foo (a)
           (flet ((bar (b)
                    (log:expr a b (+ a b))))
             (bar 10)))
(log:config :debug)

;; CCL
CL-USER> (foo 2)
[23:17:57] [debug] <cl-user> - A=2 B=10 (+ A B)=12 

;; SBCL
CL-USER> (foo 2)
[23:17:06] [debug] <cl-user:foo:bar> - A=2 B=10 (+ A B)=12 

その他、アペンダやレイアウトの対応づけや設定ファイルの読み込み等が可能ですが、 README.md 以上に有益なことを書ける気がしないので、ドキュメントにかかれていない アペンダの定義を行い、syslogにログを出力してみます。

(ql:quickload :cl-syslog)

;; アペンダを定義
(defclass syslog-appender (log4cl-impl:appender)
  ())

;; アペンダの出力方法を定義
(defmethod log4cl-impl:appender-do-append ((appender syslog-appender) logger level log-func)
  ;; 出力はcl-syslogに丸投げ。
  (cl-syslog:log "log4cl" :local7 :info
    (with-output-to-string (s)
      (log4cl-impl:layout-to-stream
       (slot-value appender 'log4cl-impl:layout) s logger level log-func))))

;; ロガーを作成
(defvar syslog-logger (log:make '(syslog)))

;; ロガーにアペンダを対応付ける
(log:add-appender syslog-logger (make-instance 'syslog-appender))

;; ログ出力
(log:i syslog-logger "from cl")
kurohuku@mypc:/var/log$ tail -1 syslog
Dec 10 23:49:36 mypc log4cl: INFO - from cl

Log4jと異なりデフォルトで定義されてるアペンダは少ないので、 コンソールやファイル以外に出力を行いたい場合は自分でアペンダを定義する必要がありますが、 expr関数(マクロ)などはデバッグに便利ですし、試しに使ってみると良いと思います。

なお、Quicklispで (ql:system-apropos "log") でライブラリを検索したところ、 他にもロギングライブラリっぽいものが見つかりました。

  • cl-log
  • hu.dwim.logger
  • log5
  • logv
  • (cl-syslog)
  • (irc-logger)

・・・見つかりましたが、数が多いので比較はしません。ごめんなさい。

2012年12月5日水曜日

はじめてのRacket(の#lang)

Lisp Reader Macro Advent Calendar 2012 の5日目の記事です。

この記事では、プログラミング言語 Racket を簡単に紹介してみます。

Racket は、Scheme(Lisp)をベースとしたプログラミング言語です。
WindowsでもLinuxでも実行できて、GUIアプリケーションも作れます。
もともとPLT Schemeという名前でしたが、色々あってRacketという名前になったようです。 (参考:http://racket-lang.org/new-name.html)
どうせならもっとググりやすい名前にしてほしかったなーと思わないでもないです。

インストール方法は公式サイトを見ていただくとして、 まず最初に典型的な入門プログラム、Hello Worldを書いてみましょう。

#lang algol60

begin
 printsln(`hello world');
end

hello.rktと言う名前でファイルに保存してコマンドラインから実行してみます。
コマンド名は racket です。引数としてファイル名を渡すと、プログラムを実行してくれます。

> racket hello.rkt
hello world

次はもう少し複雑な例として、フィボナッチ数を再帰処理で求めるプログラムを書いてみます。

#lang algol60

begin
  integer procedure fib(x);
    integer x;
  begin
    integer result;
    result := 0;
    if x = 0 then
      result := 0
    else
      begin
       if x = 1 then
         result := 1
       else
         result := fib(x - 1) + fib(x - 2)
      end;
    fib := result
  end;
  printnln(fib(10));
end

Lispは括弧が多いのが特徴の言語らしいですが、このプログラムの括弧の数はたったの10個。 案外少ないです。

> racket fib.rkt
55

以上、入門終わり。
「こんなのLisp(Scheme)じゃない」「algol60って書いてあるぢゃん」と思うかもしれませんが、 ちゃんと実行もできるRacketのプログラムです。

Racketにはソースコードの先頭にかかれた #lang foobar という1行で、 使用する言語を切り替える機能があります。

たとえば、ごく普通のRacketプログラムを書きたい場合は、次のようになります。

#lang racket
(printf "hello world\n")

先頭行の #lang racket は、初期状態としてracketモジュールをインポートした状態で プログラムを解釈してくれ、というような意味となります。

Racketではソースコードの読み込みを read や read-syntax といった関数で行っています。
そのため、#lang で指定された言語(モジュール)で定義されているread関数によっては、 最初のhello worldのようなLispとはかけ離れた見た目のプログラムも実行できるのです。

Racketインストール時についてくるalgol60 以外の言語としては、静的型付けな Typed Racket や

racket> (require typed/racket)
racket> (let ((a 0)) a)
- : Integer [generalized from Zero]
0
#lang typed/racket

;; typed-racket-test.rkt
(provide fib sum)

(: fib (Integer -> Integer))
(define (fib n)
  (cond
   ((<= n 0) 0)
   ((= n 1) 1)
   (else (+ (fib (- n 1)) (fib (- n 2))))))

(define: (sum [lst : (Listof Integer)]) : Integer
  (let loop ((rst lst) (acc 0))
    (if (null? rst)
        acc
        (loop (cdr rst) (ann (+ acc (car rst)) Integer)))))
racket> (load "typed-racket-test.rkt")
racket> (require (prefix-in t: 'typed-racket-test))
racket> (t:sum '(1 2 3))
6
racket> (t:fib 10)
55
#lang typed/racket

;; typed-racket-err.rkt
(provide sum average)

(define: (sum [lst : (Listof Integer)]) : Integer
  (let loop ((rst lst) (acc 0))
    (if (null? rst)
        acc
        (loop (cdr rst) (ann (+ acc (car rst)) Integer)))))

(define: (average [lst : (Listof Real)]) : Real
  ;; sum関数はIntegerのリストを想定しているが、ここではRealのリストが渡されている
  (/ (sum lst) (length lst)))
;; 型があっていないと、実行時ではなくロード時に怒られます。
 racket> (load "typed-racket-err.rkt")
 typed-racket-err.rkt:14:10: Type Checker: Expected (Listof Integer), but got (Listof Real)
  in: lst
  errortrace...:
  context...:
 /usr/racket/collects/typed-racket/typecheck/tc-toplevel.rkt:295:0: type-check
   success
 /usr/racket/collects/typed-racket/typed-racket.rkt:38:4
 /usr/racket/collects/errortrace/errortrace-lib.rkt:434:2: errortrace-annotate
 /usr/racket/collects/errortrace/errortrace-lib.rkt:480:4
 /usr/racket/collects/racket/private/misc.rkt:87:7

論理型言語 Datalog

#lang datalog

親(たかし, かあちゃん).
親(たけし, かあちゃん).
親(かあちゃん, ばあちゃん).
親(かあちゃん, じいちゃん).

先祖(A, B) :- 親(A, B).
先祖(A, B) :- 親(A, Z), 先祖(Z, B).
兄弟(A, B) :- 親(A, Z), 親(B, Z), A != B.

先祖(たけし, X)?

兄弟(たけし, X)?
> racket datalog-test.rkt 
先祖(たけし, かあちゃん).
先祖(たけし, じいちゃん).
先祖(たけし, ばあちゃん).
兄弟(たけし, たかし).

プレゼンのスライドを作成する言語 Slideshow といったものがあります。

#lang slideshow

;; 1枚目
(slide
 #:title "Title-1"
 (t "Hello"))

;; 2枚目
(slide
 #:title "Title-2"
 (item "1st")
 (item "2nd"))

他にも、 ドキュメント記述用の Scribble 、 遅延評価を行う Lazy Racket といった言語もあります。

自分で独自の言語を作りたい場合でも、read関数を自分で用意すればよいだけです。 parser-tools/lex や parser-tools/yacc を使えばコンパイラを作る講義も Racketだけで対応できそうです。

日本ではユーザーが少ないイメージのあるRacketですが、 読み込み処理以外にもいろいろいじれるので、試しに触って遊んでみると楽しいのではないでしょうか。

2012年11月29日木曜日

Clojure+Apache POI+Event API

Apache POIで普段使うのは'User API'というAPIのようですが、 このAPIを利用して大きなファイルを扱おうとすると大量のメモリを必要とし、OutOfMemoryが発生します。

この問題を回避するには、

  • ヒープ領域を増やして実行する
  • Event APIを使う
  • Streaming User APIを使う
  • xlsxファイルを解凍して中身のxmlファイルを処理する

といった解決方法があるようです。

ためしに、Clojure+Apache POIでEvent APIを利用したコードを書いてみます。
ぱっと見た限りではxlsxファイルを解凍して処理する手間の一部を省いてくれているだけのようです。

;; project.clj
(defproject poixml "0.1.0-SNAPSHOT"
  :description "dummy"
  :url "dummy"
  :license {:name "dummy"}
  :dependencies [[org.clojure/clojure "1.4.0"]
                 [org.apache.poi/poi "3.8"]
                 [org.apache.poi/poi-ooxml "3.8"]
                 [org.clojure/data.xml "0.0.6"]]
  :main poixml.core)
;; src/poixml/core.clj
(ns poixml.core
  (:gen-class))

;; @see http://poi.apache.org/spreadsheet/how-to.html

(require 'clojure.data.xml)

(import
 '(org.apache.poi.xssf.eventusermodel XSSFReader)
 '(org.apache.poi.xssf.model SharedStringsTable)
 '(org.apache.poi.xssf.usermodel XSSFSheet
                                 XSSFWorkbook
                                 XSSFRow
                                 XSSFCell
                                 XSSFRichTextString))

(defn call-with-cell-value [path f]
  (let [reader (XSSFReader. (org.apache.poi.openxml4j.opc.Package/open path))
        sst (.getSharedStringsTable reader)]
    (with-open [istream (.next (.getSheetsData reader))]
      (doseq [r (:content (first
                           (filter #(= :sheetData (:tag %))
                                   (:content (clojure.data.xml/parse istream)))))]
        (when (= :row (:tag r))
          (doseq [[col cell] (map vector (iterate inc 1) (:content r))]
                 (let [val (first (filter #(= :v (:tag %)) (:content cell)))]
                   (f (Integer/parseInt (:r (:attrs r))) ; 行番号
                      col ; 列番号
                      (if (= "s" (:t (:attrs cell)))
                          ;; 文字列はSharedStringsTableにある
                          (-> (.getEntryAt sst (bigint (first (:content val))))
                              XSSFRichTextString.
                              .toString)
                          (first (:content val)))))))))))

;; --------------------------------------------------
;; 適当にxlsxファイルを作成
(defn create-3x3 [path]
  (let [wb (XSSFWorkbook.)
        sh (.createSheet wb)]
    (dorun
     (for [y (range 3)]
       (.createRow sh y)))
    (dorun
     (for [x (range 3) y (range 3)]
       (-> (.createCell (.getRow sh y) x)
           (.setCellValue (str (* (inc x) (inc y)))))))
    (with-open [out (java.io.FileOutputStream. path)]
      (.write wb out))))

;; xlsxファイルの各セルを表示
(defn print-cells [path]
  (call-with-cell-value path
    (fn [row col val]
        (printf "[%d,%d] %s\n" row col val)
        (flush))))

;; 引数に作成するファイル名を指定
(defn -main
  [& args]
  (when (= (count args) 1)
    (let [path (first args)]
      (create-3x3 path)
      (print-cells path))))
> lein run test.xlsx 
Compiling poixml.core
[1,1] 1
[1,2] 2
[1,3] 3
[2,1] 2
[2,2] 4
[2,3] 6
[3,1] 3
[3,2] 6
[3,3] 9

2012年11月15日木曜日

Clojure+seesawでMigLayoutを利用する

ClojureのGUIライブラリseesawでMigLayoutを使ってみます。
簡単なツールを作ったときにGUIをでっちあげるのに使えそうです。

(ns seesaw-test.core
  (:use [seesaw core chooser mig])
  (:gen-class))

(defn set-filename [root target]
  (choose-file
   :success-fn #(text! (select root [target])
                       (.getAbsolutePath %2))))

(defn run []
  (let [root (frame :title "mig-layout test"
                    :on-close :exit
                    :size [400 :by 200])]
    (config!
     root
     :content (mig-panel
               ;; [Layout Row Column]
               :constraints ["fillx" "[][grow,fill][]" ""]
               :items  ; [ウィジェット 設定(省略可)]
               [["名前:"]
                ;; wrap で次の行へ進む
                [(text :id :name :text "name") "wrap"]

                ["ファイル:"]
                [(text :id :file :text "file")]
                [(action :name "選択"
                         :handler (fn [_] (set-filename root :#file)))
                 "wrap"]

                [(action :name "OK"
                         :handler (fn [_]
                                    (alert
                                     (str
                                      "Name:" (text (select root [:#name]))
                                      "\n"
                                      "File:" (text (select root [:#file]))))))
                 "span 3, center"]]))
    root))

(defn -main
  [& args]
  (native!)
  (invoke-later (show! (pack! (run)))))

2012年11月13日火曜日

お酒に関する用語:単位・量

酒に関する用語のうち、単位や量に関するもののメモ。

  • 適量
    飲酒するときの適量はアルコール量でだいたい20mlくらいらしい。
    一般的な度数で考えると、飲酒量換算は以下のようになると思われる。
    ビール (5%)20ml * 100/5 = 400ml
    ワイン (13%)20ml * 100/13 = 153ml
    日本酒 (15%)20ml * 100/15 = 133ml = 1合(180ml)程度
    焼酎(25%)20ml * 100/25 = 80ml
    ウィスキー (40%)20ml * 100/40 = 50ml = シングル(30ml) ~ ダブル(60ml)
  • アルコール度数
    酒の容量のうちどの程度がアルコール(エタノール)かを表す割合。
  • プルーフ proof
    アルコール容量の単位。アルコール度数1度 = 2 proof。
  • パイント(pint)
    体積の単位。イギリスでは570ml(20英液量オンス)、アメリカでは470ml(16米液量オンス)。
  • シングル
    主に洋酒を飲むときのお酒1杯あたりの容量。だいたいの場合30ml。
  • ダブル
    シングルの倍の容量。60ml。
  • 合(ごう)
    尺貫法の体積の単位で1/10升。主に日本酒で使う。1合=180mlくらい。
    日本酒の瓶の小さめのものは4合瓶なので720ml入り。
  • 升(しょう)
    尺貫法の体積の単位で10合。1升=10合=1800mlくらい。
    日本酒の瓶の大きいものは1升瓶なので1800ml入り。
  • ドロップ(drop)
    カクテルのレシピに書いてある量。1滴。
  • ダッシュ(dash)
    カクテルのレシピに書いてある量。1ダッシュは5,6滴(1ml)くらい。
  • ティースプーン(tsp)
    カクテルのレシピに書いてある量。1tspは小さじ1杯(5ml)くらい。
  • 日本酒度
    日本酒の甘口・辛口の目安。+になるほど糖分が少なく(辛口)、-になるほど糖分が多い(甘口)。
    日本酒を15℃にしたときに4℃の蒸留水と同じ重さなら日本酒度0で、以下の用な関係式になる(Wikipedia情報)
    日本酒度 = ((1/比重) - 1) x 1,443
  • 甘辛度
    日本酒の甘口・辛口の目安。+になるほど甘い。 計算式は以下のとおり(Wikipedia情報)
    0.86 x ブドウ糖濃度 - 1.16 x 酸度 - 1.31 または
    (193,593 / (1,443 + 日本酒度)) - 1.16 x 酸度 - 132.57
  • 国際苦味単位 (IBU: International Bitterness Units)
    ビールの苦味の単位。

2012年11月10日土曜日

オイラーの贈物(1.2)とLispと順列

二項展開(binomial expansion)の展開後の各項の係数(二項係数(binomial coefficient))は 階乗(factorial)を利用して以下の用に書けます。

${}_n C _r \equiv \frac{n!}{r!(n - r)!}$
latexの数式
${}_n C _r \equiv \frac{n!}{r!(n - r)!}$
;; Common Lisp

(defun recursive-factorial (n)
  (check-type n (integer 0 *))
  (if (zerop n)
      1
      (* n (recursive-factorial (1- n)))))

(defun factorial (n)
  (check-type n (integer 0 *))
  (if (zerop n)
      1
      (loop
         :named loop
         :for i from 1 to n
         :for result = i then (* i result)
         :finally (return-from loop result))))

(defvar *memoized-factorial* (make-hash-table))
(setf (gethash 0 *memoized-factorial*) 1)
(setf (gethash 1 *memoized-factorial*) 1)
(defun memoized-factorial (n)
  (check-type n (integer 0 *))
  (let ((x (gethash n *memoized-factorial*)))
    (if x
        x
        (let ((y (* n (memoized-factorial (1- n)))))
          (setf (gethash n *memoized-factorial*) y)
          y))))

(defun binomial-coefficient (n r)
  (check-type n (integer 0 *))
  (check-type r (integer 0 *))
  (assert (<= r n))
  ;; n! / r!(n - r)!
  (/ (memoized-factorial n)
     (* (memoized-factorial r)
        (memoized-factorial (- n r)))))

この式はn個の中からr個を取る組み合わせ(combination)の数を求める式でもあります。

要素の順番も考慮する順列(permutation)の数の場合は、以下のようになります。

${}_n P _r \equiv \frac{n!}{(n - r)!}$
latexの数式
$ {}_n P _r \equiv \frac{n!}{(n - r)!}$
(defun permutation (n r)
  (check-type n (integer 0 *))
  (check-type r (integer 0 *))
  (assert (<= r n))
  ;; n! / (n - r)!
  (/ (memoized-factorial n)
     (memoized-factorial (- n r))))

多くのプログラミング言語では順列を生成するための機能が用意されているようです。

RubyのArrayクラス(array.cで定義)とC++のstd::next_permutationを使ってみます。

> p [1, 2, 3].permutation(2).to_a
[[1, 2], [1, 3], [2, 1], [2, 3], [3, 1], [3, 2]]

## nPr = 3P2 = 3! / (3-2)! = 3! = 6
> p [1, 2, 3].permutation(2).to_a.size
6

> p [1, 2, 3].combination(2).to_a
[[1, 2], [1, 3], [2, 3]]

## nCr = 3C2 = 3! / 2!(3-2)! = 3! / 2 = 3
> p [1, 2, 3].combination(2).to_a.size
3
#include <algorithm>
#include <cstdio>

void print_array(int arr[3]){
        printf("%d, %d, %d\n", arr[0], arr[1], arr[2]);
}

int main(void){
        int arr[3] = {1, 2, 3};
        std::sort(arr, arr+3);
        int count = 0;
        do {
                print_array(arr);
                count++;
        } while(std::next_permutation(arr, arr+3));

        printf("count = %d\n", count);
        return 0;
}

// 1, 2, 3
// 1, 3, 2
// 2, 1, 3
// 2, 3, 1
// 3, 1, 2
// 3, 2, 1
// count = 6

これらのアルゴリズムをCommon Lispで書いてみます。

なお、Common Lispには順列を操作するためのライブラリとして cl-permutation があります。 プログラム中で順列を生成したりしたい場合はわざわざ自作せずありがたく利用させて頂きましょう。

;; from Ruby (array.c)
(defun permute0 (n r p index used vals result)
  (dotimes (i n)
    (when (zerop (bit used i))
      ;; 順列のindex番目の要素として元の配列のi番の要素を選択
      (setf (svref p index) i)
      (if (< index (1- r))
          (progn
            ;; 選択済みの要素に対応するフラグをONにする
            (setf (bit used i) 1)
            (permute0 n r p (1+ index) used vals result)
            ;; 選択済みフラグをOFFにする
            (setf (bit used i) 0))
          (progn
            ;; 添字の配列から値の配列を作成して結果配列に追加
            (vector-push 
             (loop :for j :across p :collect (elt vals j))
             result))))))

(defun permute (seq r)
  (let* ((n (length seq))
         (result (make-array (permutation n r) :fill-pointer 0 :adjustable t))
         (used (make-array n :element-type 'bit :initial-element 0))
         (p (make-array r :element-type '(integer 0 *))))
    (permute0 n r p 0 used seq result)
    result))
> (permute '(1 2 3) 2)
#((1 2) (1 3) (2 1) (2 3) (3 1) (3 2))
;; from C++ (std::next_permutation)
(defun next-permutation (arr)
  (let ((len (length arr)))
    (unless (or (= len 0) (= len 1))
      (loop
         :for pos :from (1- len) :downto 1
         :when (< (aref arr (1- pos)) (aref arr pos))
         :do (progn
               (rotatef (aref arr (1- pos))
                        (aref arr
                              (position-if
                               #'(lambda (x) (< (aref arr (1- pos)) x))
                               arr
                               :from-end t)))
               (setf (subseq arr pos)
                     (nreverse
                      (make-array (- len pos)
                                  :displaced-to arr
                                  :displaced-index-offset pos)))
               (return-from next-permutation t))))))
> (defmacro do-while (test &body body)
          `(loop
              :do (progn ,@body)
              :while ,test))
> (let ((tmp (vector 0 1 2)))
          (do-while (next-permutation tmp)
            (print tmp)))
#(0 1 2) 
#(0 2 1) 
#(1 0 2) 
#(1 2 0) 
#(2 0 1) 
#(2 1 0)

他にも色々なアルゴリズムが存在するようです。 その中のひとつとして、階乗進数 を利用したプログラムを書いてみます。

(defun factoradic-permutation (n width)
  (let ((fact (make-array width :initial-element 1))
        (mantissa (make-array width :initial-element 0)))
    ;; 階乗を計算して配列に設定
    (loop
       :for i :from 1 :below width
       :for acc := i :then (* acc i)
       :do (setf (aref fact i) acc))
    ;; 階乗進数の仮数を計算して配列に設定
    (loop
       :for i :from (1- width) :downto 1
       :for acc := n :then (mod acc (aref fact (1+ i)))
       :do (setf (aref mantissa i)
                 (floor acc (aref fact i))))
    ;; 階乗進数を利用して順列を作成 (配列mantissaを使いまわす)
    (let ((tmp (loop :for i :from 0 :below width :collect i)))
      (loop
       :for i :from (1- width) :downto 0
       :for x := (aref mantissa i)
       :do (setf (aref mantissa i) (nth x tmp)
                 tmp (delete (nth x tmp) tmp))))
    (nreverse mantissa)))
> (dotimes (n 6)
>  (print (factoradic-permutation n 3)))
#(0 1 2) 
#(0 2 1) 
#(1 0 2) 
#(1 2 0) 
#(2 0 1) 
#(2 1 0)

2012年10月25日木曜日

オイラーの贈物とLisp(1.1.1)

オイラーの贈物 を読みながら、登場する数式などをCommon Lispで書いてみます。

1.1.1 自然数と素数(P6)より、有名なエラトステネスの篩と、 Wikipediaの 素数の項目 に載っていたウラムの螺旋を出力するコードです。 画像の作成には Vecto を利用しました。

(defun eratosthenes-sieve (n)
  "Return a sequence which indicates whether index is the prime number or not."
  ;; `n' is greater than or equal to 2
  (check-type n (integer 2 *))
  (let ((seq (make-array (1+ n) :initial-element t)))
    (setf (svref seq 0) nil) ; 0 is not a prime number.
    (setf (svref seq 1) nil) ; 1 is not a prime number.
    ;; The outer loop can stop at the square root of `n'.
    (loop :for i :from 2 :to (floor (sqrt n))
       :when (svref seq i)
       :do
       ;; The inner loop can start at the square of `i'.
       ;; (Multiples of `i' which are less than the square of `i' are already set to `nil'.)
       (loop :for j :from (* i 2) :to n :by i
          :do (setf (svref seq j) nil)))
    seq))


(ql:quickload "vecto")

(defun draw-uram-spiral (edge-length output-file-name &key (pixel 2))
  (assert (<= 1 edge-length))
  (let* ((limit (expt edge-length 2))
         (primes (eratosthenes-sieve (expt edge-length 2)))
         (picture-edge-length (* pixel edge-length)))
    (vecto:with-canvas
        (:width picture-edge-length :height picture-edge-length)
      (vecto:set-rgb-fill 1.0 1.0 1.0)
      (vecto:rectangle 0.0 0.0 picture-edge-length picture-edge-length)
      (vecto:fill-path)
      (vecto:set-rgb-fill 0.0 0.0 1.0)
      (let ((idx 2)
            (step 0)
            (x (floor edge-length 2))
            (y (floor edge-length 2)))
        (loop
           :while (<= idx limit)
           :do 
           (dotimes (_ (1+ (floor step 2)))
             (when (<= idx limit)
               (case (mod step 4)
                 (0 (incf x))
                 (1 (decf y))
                 (2 (decf x))
                 (3 (incf y)))
               (when (svref primes idx)
                 (vecto:rectangle (* x pixel) (* y pixel) pixel pixel)
                 (vecto:fill-path))
               (incf idx)))
           (incf step)))
      (vecto:save-png output-file-name))))
> (draw-uram-spiral 100 "uram.png")

2012年10月16日火曜日

coutへの出力をstringstreamへの出力に切り替える

標準出力(std::cout)への出力を別のストリーム(std::stringstream)への出力に切り替えてみます。

#include <iostream>
#include <sstream>

int main(void){
  std::stringstream ss;
  std::streambuf *backup = std::cout.rdbuf();

  // 標準出力への出力をstringstreamへの出力に切り替える
  std::cout.rdbuf(ss.rdbuf());

  std::cout << "A";

  std::cout.rdbuf(backup);
  std::cout << "stringstream = " << ss.str() << std::endl;
  return 0;
}

C++ならrdbuf、C言語ならfreopenなどを使えば良さそうです。

scratchバッファをorg-modeにする

org-babelがとても便利なので、scratchバッファをデフォルトでorg-modeにしてみます。

Emacsの終了時に自動的にファイルに保存されるようにしておけば、 ものぐさでorg-rememberを使いこなせない私でも日々org-modeを活用できそうです。

(defvar *scratch-file* "~/.scratch.org")

;; 初期化時の処理
(defun init-scratch-buffer ()
  (let ((buf (get-buffer "*scratch*")))
    (when buf
      (save-excursion
        (with-current-buffer buf
          (erase-buffer)
          (org-mode)
          (insert
           (format "* [%s]"
                   (format-time-string "%Y/%m/%d %H:%M:%S"))))))))
;; 終了時、バッファ削除時にバッファの内容を保存する処理
(defun save-scratch-buffer ()
  (let ((buf (get-buffer "*scratch*")))
    (when buf
      (save-excursion
        (with-current-buffer buf
          (append-to-file (point-min) (point-max) *scratch-file*))))))

(defun save-scratch-kill-emacs-hook ()
  (save-scratch-buffer))

(defun save-scratch-kill-buffer-hook ()
  (when (equal (current-buffer) (get-buffer "*scratch*"))
    (save-scratch-buffer)))

;; hook登録
(add-hook 'after-init-hook 'init-scratch-buffer)
(add-hook 'kill-emacs-hook 'save-scratch-kill-emacs-hook)
(add-hook 'kill-buffer-hook 'save-scratch-kill-buffer-hook)

2012年9月22日土曜日

Haskell入門書的クイックソート

Haskellの入門書に乗っていそうなクイックソートをClojureとCommon Lispで書いてみます。

- Clojure
;; defnやletで分配束縛ができます
;; group-byで関数を適用した結果の値によってグループ分けができます
;; ハッシュテーブル(map)は指定されたキーに対応する値を取得する関数にもなります
(defn qsort [cmp [piv & rst :as coll]]
  (if (empty? coll) []
    (#(concat (qsort cmp (%1 true)) [piv] (qsort cmp (%1 false)))
     (group-by #(boolean (cmp %1 piv)) rst))))

- Common Lisp
;; remove-if-not (filter)
(defun qsort-1 (cmp lst)
  (when lst
    (destructuring-bind (piv &rest rest) lst
      (flet ((f (x) (funcall cmp x piv)))
 (append (qsort-1 cmp (remove-if-not #'f rest))
  (list piv)
  ;; (remove-if-not (complement #'f) rest)
  (qsort-1 cmp (remove-if #'f rest)))))))

;; loopマクロ
(defun qsort-2 (cmp lst)
  (when lst
    (loop
       :with piv = (first lst)
       :for x in (rest lst)
       :if (funcall cmp x piv)
       :collect x into lesser
       :else
       :collect x into greater
       :finally (return
    (append (qsort-2 cmp lesser)
     (list piv)
     (qsort-2 cmp greater))))))

2012年9月10日月曜日

Clojure+leiningen+Apache POI

いつか業務でこっそり使うことを夢見てExcelをいじってみます。

1. leiningenでプロジェクト作成
 lein new poitest

2. 作成されたプロジェクトのディレクトリのproject.cljを編集
(defproject poitest "0.1.0-SNAPSHOT"
  :description "Apache POI Test"
  :dependencies [[org.clojure/clojure "1.4.0"]
                 [org.apache.poi/poi "3.8"]
                 [org.apache.poi/poi-ooxml "3.8"]]
  :main poitest.core)

3. 依存解決
 lein deps

4. コードを書く
(ns poitest.core
  (:gen-class))

(import '(org.apache.poi.xssf.usermodel
          XSSFSheet
          XSSFWorkbook
          XSSFRow
          XSSFCell)
        '(org.apache.poi.ss.usermodel
          WorkbookFactory))

(import '(java.io
          FileInputStream
          FileOutputStream))

(defn load-workbook [path]
  (-> path FileInputStream. WorkbookFactory/create))

(defn rows [^XSSFSheet  sheet]
  (let [nrows (.getPhysicalNumberOfRows sheet)]
    (letfn [(f [i]
              (if (<= nrows i)
                nil
                (cons (.getRow sheet i)
                      (lazy-seq (f (inc i))))))]
      (f 0))))

(defn create-9x9 [path]
  (let [wb (XSSFWorkbook.)
        sh (.createSheet wb)]
    (dorun
     (for [y (range 9)]
       (.createRow sh y)))
    (dorun
     (for [x (range 9) y (range 9)]
       (-> (.createCell (.getRow sh y) x)
           (.setCellValue (str (* (inc x) (inc y)))))))
    (.write wb (FileOutputStream. path))))


(defn -main
  "9x9を書き込んだExcelファイルを作成->ファイルを読み込み3列目の要素を表示"
  [& args]
  (create-9x9 "test.xlsx")
  (let [wb (load-workbook "test.xlsx")
        sh (.getSheetAt wb 0)]
    (dorun 
     (for [r (rows sh)]
       (println (-> (.getCell r 2) .getStringCellValue))))))

5. 実効したりコンパイルしたり
 lein run
 lein uberjar
※ 9/22 追記
こちらのほうがシンプルそう
(defn rows [sheet]
  (keep #(.getRow sheet %)
        (range
         (.getFirstRowNum sheet)
         (inc (.getLastRowNum sheet)))))

2012年9月9日日曜日

Clojure + Emacs環境を作る

いつのまにかすごく簡単にできるようになってました。

leiningen のインストール。Clojure本体もダウンロードしてくれるらしいです。
  1. leiningenのスクリプト(lein or lein.bat)をダウンロードしてくる
  2. 実効パスの通った場所に置いて、実効権限付与(chmod u+x)
  3. leinスクリプトを実行する。(lein self-install)(要 curl or wget)
 Emacs の設定。swank-clojureのGithubのページに、新しいユーザはnreplかRitzを使うと良い、と書いてあるので、nrepl.elを入れてみます。
  1. package.elのレポジトリとしてmarmaladeを登録する
  2. package-list-packagesでパッケージ一覧を表示する
  3. clojure-modeとnreplをインストールする
  4. M-x nrepl-jack-in  でemacsの中でleiningenのreplが起動

※9/9追記

clojure-modeのバッファでeldocを有効化

(add-hook 'clojure-mode-hook
   (lambda ()
     (nrepl-eldoc-enable-in-current-buffer)))

2012年7月11日水曜日

[CommonLisp]Internal Server Errorをフックする

Web系がさっぱりわからないので、勉強がてらなにか書いてみようと思いました。
 Webアプリケーションを書く前に、プログラム中で発生した例外をフックして、Internal Server Errorとしてブラウザに表示させるようにしてみます。
(asdf:load-system :clack)
;; swank:backtraceのほうがみやすい?
(asdf:load-system :trivial-backtrace)

(defpackage :mw-debug
  (:use :cl :clack))

(in-package :mw-debug)

(defun mw-debug-debugger-hook (c hook)
  (declare (ignore hook))
  (let ((restart (find-restart 'mw-debug-restart)))
    (when (not restart)
      (error "mw-debug-restart not found"))
    (invoke-restart restart c (trivial-backtrace:print-backtrace c :output nil))))

(defclass <mw-debug> (<middleware>)
  ())

(defmethod call ((this <mw-debug>) env)
  (let ((*debugger-hook* #'mw-debug-debugger-hook))
    (restart-case (call-next this env)
      (mw-debug-restart (c bt)
 `(500
   (:content-type "text/plain")
   (,(format nil "Internal Server Error~%~%")
     ,(format nil "-- Error -------------------------------~%")
     ,(with-output-to-string (*standard-output*)
       (describe c))
     ,(format nil "-- Backtrace ---------------------------~%")
     ,bt))))))
(defun b (tmp)
  ;; 未定義の関数を呼び出す。
  (c))
(defun a ()
  (b 2))
(defun run (port)
  (clackup
   (wrap (make-instance '<mw-debug>)
  (lambda (env)
    (a)))
   :port port))

;; (run 9999)

2012年7月9日月曜日

[Gauche]CiSEでFizzBuzz

CiSE(C in S-Expression)でFizzBuzzってみます。
;; cise-compile.scm
(use gauche.cgen)
(use gauche.cgen.cise)
(use gauche.parseopt)

(define (main args)
  (let-args (cdr args)
    ((infile "i=s" #f)
     (outfile "o=s" #f))

    (unless (and infile outfile)
      (display #`"usage: gosh ,(car args) -i 'input-file' -o 'output-file'\n")
      (exit -1))
    
    (call-with-input-file infile
      (^ (in)
  (call-with-output-file outfile
    (^ (out)
       (cise-translate in out)))))))
;; cise-test.cise
(.include <stdio.h>)

(define-cfn main (argc::int argv::char**) ::int
  (dotimes (i 30)
    (case (% (+ i 1) 15)
      ((0) (printf "FizzBuzz\n"))
      ((3 6 9 12) (printf "Fizz\n"))
      ((5 10) (printf "Buzz\n"))
      (else (printf "%d\n" (+ i 1)))))
  (return 0))
 > gosh cise-compile.scm -i cise-test.cise -o cise-test.c
 > gcc -o cise-test cise-test.c

2012年7月5日木曜日

[CommonLisp]MOPを使って型指定子によりメソッドを特定する

Wikipedia日本語版の「列挙型」の項目に、CommonLispの型指定子はメソッドの引数特定には使えませんよ、と書いてあったので、無理やり実現する方法を考えてみました。
マクロを使うと負けな気がするので、MOPを利用してみます。
(asdf:load-system :closer-mop)

(defpackage type-spec-class
  (:use :cl)
  (:export
    <type-spec-meta>
    <type-spec-gf>
    define-type-spec))

(in-package :type-spec-class)

(defclass <type-spec-meta> (c2mop:standard-class)
  ((spec :initarg :spec :reader type-spec-of)))

(defmethod c2mop:validate-superclass ((cls <type-spec-meta>)
          (super c2mop:standard-class))
  t)

(defclass <type-spec-gf> (c2mop:standard-generic-function)
  ()
  (:metaclass c2mop:funcallable-standard-class))

(defmethod c2mop:validate-superclass ((cls <type-spec-gf>)
          (super c2mop:standard-generic-function))
  t)

(defmacro define-type-spec (name spec)
  `(progn
     (deftype ,name () ,spec)
     (c2mop:ensure-class-using-class
      (make-instance '<type-spec-meta> :spec ,spec)
      ',name)))

(defmethod c2mop:compute-discriminating-function :around
    ((gf <type-spec-gf>))
  (let ((org-fn (call-next-method)))
    (lambda (&rest args)
      (let* ((methods (c2mop:generic-function-methods gf))
             (m (find-type-spec-method methods args)))
       (if m
         (apply (c2mop:method-function m) args)
         (apply org-fn args))))))

(defun find-type-spec-method (methods args)
  (loop
     :for m in methods
     :for s = (c2mop:method-specializers m)
     :do (when (applicable-type-spec-method-p s args)
           (return-from find-type-spec-method m))))

(defun applicable-type-spec-method-p (specifier args)
  (flet ((type-spec-class-p (cls)
    (subtypep (class-of cls) '<type-spec-meta>)))
    (when (some #'type-spec-class-p specifier)
      (loop
        :for cls in specifier
        :for a in args
        :do (unless (or (and (type-spec-class-p cls)
                             (typep a (type-spec-of cls)))
                        (typep a cls))
              (return-from applicable-type-spec-method-p nil)))
      t)))
以下のようにして使います。
(in-package :cl-user)

(type-spec-class:define-type-spec color '(member :red :blue :green))

(defgeneric what-is (obj)
  (:generic-function-class type-spec-class:<type-spec-gf>))

(defmethod what-is ((obj t))
  "unknown")
  
(defmethod what-is ((obj symbol))
  "symbol")

(defmethod what-is ((obj color))
  (format nil "color ~A" obj))

(what-is :red)
;; => "color RED"
(what-is :hoge)
;; => "symbol"
(what-is 2)
;; => "unknown"
 
<type-spec-meta>のインスタンス(であるクラスのインスタンス)を引数にとるメソッドは通常のメソッドよりも優先度が高くなっていますが、 最初に見つかったものを呼び出しているだけなので、<type-spec-meta>のインスタンス間での優先度は扱っていません。

[graphviz]consセルを描く

graphviz(DOT言語)についてのメモ。
(a (b . c) d) という内容のコンスセルを描画してみます。

// (a . ((b . c) . (d . nil)))
// (a (b . c) d)
digraph {
  graph [rankdir = LR]; // 横向き

  // ノードの定義。
  // record型にするとlabelをバー(|)で区分けできる。
  // {}で囲うと並べる向きを変えられる。
  // 先頭を<xxx>とすると要素への接続ポート名を定義できる。
  cons1 [shape = record, label = "{a|*}"];
  cons2 [shape = record, label = "{*|*}"];
  cons3 [shape = record, label = "{b|c}"];
  cons4 [shape = record, label = "{d|nil}"];

  // コロン区切りで接続ポートを指定することで、
  // エッジの指す先が要素の位置になる。
  cons1:cdr -> cons2:car;
  cons2:car -> cons3:car;
  cons2:cdr -> cons4:car;

  // ノードcons2とcons3を同じランク(並ぶ位置)にする
  {rank = same; cons2; cons3}; 
}
ファイル"cell.dot"に保存して、以下のコマンドで画像ファイルを作成できます。
 > dot -Tpng cell.dot > cell.png
作成される画像は以下。

2012年7月4日水曜日

[Racket]スタンドアローンな実行ファイルを作成する

Racketで作成したプログラムをパッケージ化したり実行ファイルにしたりするには、Racketのインストール時についてくるracoというツールを使います。
たとえば、画面に"はろーわーるど"と表示するだけのGUIプログラムを書いてみます。
#lang racket

(require racket/gui/base)

(define top-level
  (new frame%
       [label "GUI Test"]
       [min-width 200]))

(define hello
  (new message%
       [parent top-level]
       [label "はろーわーるど"]
       [min-height 20]))

(send top-level show #t)
このソースコードのファイル名を"guitest.rkt"すると、コマンドラインから
> racket guitest.rkt
と入力すれば実行できます。

このソースコードを実行ファイルにする場合は、racoコマンドを実行します。
> raco exe --gui guitest.rkt
raco exeコマンドの実行結果として、"guitest.exe"という実行ファイルが作成されます。(Windowsの場合)
さらに、実行ファイルを他のマシンでも実行できるようにするために再度racoコマンドを実行します。
> raco distribute dirname guitest.exe
raco distributeコマンドの実行結果として、"dirname"ディレクトリが作成され、ディレクトリ以下には"guitest.exe"と必要なライブラリ類がまとめられます。
これで、"dirname"ディレクトリの内容を他のマシンにコピーして実行可能となります。(たぶん)

参考:

2012年6月27日水曜日

[Python]help関数とpydoc

Pythonの情報を得たい場合、help関数やpydocコマンドが便利なようです。
 ドキュメントの調べ方を知っていると、ググれない空間にとらわれても安心ですね。 

Pythonインタプリタでhelp("モジュール名やキーワード、トピック")としてhelp関数を呼び出すと、 対応するドキュメントが閲覧できます。
# ビルトイン関数のドキュメントを表示
>>> help("__builtin__")
# open関数のドキュメントを表示
>>> help("open")
pydocコマンドを使うとhelp関数と同じようなドキュメント閲覧をコマンドラインから行えます。
# モジュールのドキュメントを表示
pydoc glob
pydoc ctypes
# モジュール一覧を表示
pydoc modules
# キーワード一覧を表示(with,raiseなど)
pydoc keywords
# シンボル一覧を表示(+, u"など)
pydoc symbols
# トピック一覧を表示(DEBUGGING, LOOPINGなど)
pydoc topics
また、pydocはオプションを指定することでドキュメントをHTML形式にして出力したり、 Webサーバーを立ち上げてブラウザで閲覧できるようにしてくれたりするようです。
# ポート番号を指定してWebサーバーを起動
pydoc -p 9999
# HTMLで出力
pydoc -w os

2012年6月26日火曜日

[CL]Windowsでselect

CCL + CFFIでWindows上でselectしてみます。
(asdf:load-system :usocket)
(asdf:load-system :bordeaux-threads)
(asdf:load-system :cffi)

(defconstant FD-SETSIZE 64)

(cffi:defcstruct timeval
  (tv-sec :ulong)
  (tv-usec :ulong))

(cffi:defcstruct fd-set
  (fd-count :uint)
  (fd-array :uint :count 64))

(cffi:defcfun ("select" win-select) :int
  (nfds :int)
  (readfds :pointer)
  (writefds :pointer)
  (exceptfds :pointer)
  (timeout :pointer))

(defun fd-zero (set)
  (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) 0))

(defun fd-set (fd set)
  (when (< (cffi:foreign-slot-value set 'fd-set 'fd-count) FD-SETSIZE)
    (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array)
    :uint
    (cffi:foreign-slot-value set 'fd-set 'fd-count))
   fd)
    (incf (cffi:foreign-slot-value set 'fd-set 'fd-count))))

(defun fd-isset (fd set)
  (cffi:foreign-funcall "__WSAFDIsSet" :uint fd ::pointer set :int))

(defun fd-clr (fd set)
  (loop
     :with count = (cffi:foreign-slot-value set 'fd-set 'fd-count)
     :with i = 0
     :while (<  i count)
     :if (= (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i) fd)
     :do (loop :while (< i (1- count))
     :do
     (setf (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint i)
    (cffi:mem-aref (cffi:foreign-slot-pointer set 'fd-set 'fd-array) :uint (1+ i)))
     (incf i))
     (decf count)
     :else
     :do (incf i)
     :finally (setf (cffi:foreign-slot-value set 'fd-set 'fd-count) count)))


(defun test ()
  (let* ((listener (usocket:socket-listen "localhost" 8888 :reuse-address t))
  (listener-fd (ccl:socket-os-fd (usocket:socket listener)))
  (fds (list listener-fd))
  (fd-obj `((,listener-fd ,listener))))
    (format t "Listener Fd:~A~%" listener-fd)
  (cffi:with-foreign-object (set 'fd-set)
    (loop
       (fd-zero set)
       (dolist (fd fds) (fd-set fd set))
       (unless (= 0 (win-select
       (apply #'max fds)
       set
    (cffi:null-pointer) (cffi:null-pointer) (cffi:null-pointer)))
  (dolist (fd fds)
    (when (fd-isset fd set)
      (if (= fd listener-fd)
   (let* ((sock (usocket:socket-accept listener))
   (sock-fd (ccl:socket-os-fd (usocket:socket sock))))
     (format t "Accept~%")
     (force-output t)
     (push sock-fd fds)
     (push (list sock-fd sock) fd-obj))
   (progn
     (format t "ReadLine:~A~%"
      (read-line (usocket:socket-stream (second (assoc fd fd-obj)))))
     (force-output t))))))))))


;; (defparameter th (bordeaux-threads:make-thread #'test))
;; (defparameter *con* (usocket:socket-connect "localhost" 8888))
;; (format (usocket:socket-stream *con*) "Hello, World~%")
;; (force-output (usocket:socket-stream *con*))
;; (bordeaux-threads:destroy-thread th)

2012年6月23日土曜日

[Racket]クリップボードにある画像をファイルに保存する

クリップボードにあるデータが画像である場合に、ファイルに保存させてみます。
#lang racket

(require racket/gui/base
  (prefix-in srfi19: srfi/19))

(define (make-filename)
  (format "~A~A.png"
   "C:/path_to_save_dir/"
   (srfi19:date->string
    (srfi19:current-date)
    "~Y~m~d_~H~M~S_~N")))

(define (save-clipboard-bitmap)
  (let ((bm (send the-clipboard get-clipboard-bitmap 0)))
    (and bm
  (send bm save-file (make-filename) 'png))))

(exit
 (if (save-clipboard-bitmap) 0 1))
AutoHotKeyを使って適当なキーにこのプログラムの実行を割り当てれば、 PrintScreen+ファイル保存を1つのキーで実行できます。
実行可能ファイルの作成は raco exe や raco distribute で行えます。

> raco exe capture.rkt
> raco distribute directory_name capture.exe
Numpad0::                      ; テンキーの「0」に割り当て
  Send, {PrintScreen}          ; PrintScreen実行
  Run, "C:/path_to_exe_dir/capture.exe" ; プログラム実行
  Return

2012年6月21日木曜日

[Racket]MzCOMを利用してPowerShellからRacketを利用する

MzCOMを利用するとRacketをCOMオブジェクトとして利用できます。
たとえば以下のようにしてPowerShellからRacketの関数を呼び出せます。
$a = New-Object -ComObject "MzCOM.MzObj"
$a.Eval('(require racket/gui)')
$a.Eval('(message-box "title" "MzCom ")')
ただし、文字コードの扱いがうまくできていないっぽいです(バージョン5.2.1)

[Racket]OpenGLでテクスチャ

球にテクスチャを貼り付けてみます。掲示板やgistにあったコードを参考にしました。
#lang racket

(require sgl sgl/gl sgl/gl-vectors)
(require racket/gui)

;; argbをrgbaに変換
(define (argb->gl-rgba argb)
  (let* ((len (bytes-length argb))
   (buf (make-gl-ubyte-vector len)))
    (for ((i (in-range 0 len 4)))
  (gl-vector-set! buf (+ i 0) (bytes-ref argb (+ i 1)))
  (gl-vector-set! buf (+ i 1) (bytes-ref argb (+ i 2)))
  (gl-vector-set! buf (+ i 2) (bytes-ref argb (+ i 3)))
  (gl-vector-set! buf (+ i 3) (bytes-ref argb (+ i 0))))
    buf))

;; bitmapからargbのバイト列を取得
(define (bm->argb bm)
  (let* ((w (send bm get-width))
  (h (send bm get-height))
  (mask (send bm get-loaded-mask))
  (buf (make-bytes (* w h 4) 255)))
    (send bm get-argb-pixels 0 0 w h buf #f)
    (when mask
      (send bm get-argb-pixels 0 0 w h buf #t))
    buf))

;; テクスチャ読み込み
(define (load-texture path)
  (gl-enable 'texture-2d)
  (let* ((bm (make-object bitmap% path))
  (w (send bm get-width))
  (h (send bm get-height))
  (vec (argb->gl-rgba (bm->argb bm)))
  (tex (gl-vector-ref (glGenTextures 1) 0)))
    (glBindTexture GL_TEXTURE_2D tex)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
    (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
    (gluBuild2DMipmaps GL_TEXTURE_2D GL_RGBA w h GL_RGBA GL_UNSIGNED_BYTE vec)
    tex))

(define current-texture #f)


;; OpenGLによる描画
(define (draw-gl)
  (gl-clear 'color-buffer-bit)
  (gl-push-matrix)
  (glBindTexture GL_TEXTURE_2D current-texture)
  (let ((q (gl-new-quadric))
 (list-id (gl-gen-lists 1)))
    (gl-quadric-texture q #t)
    (gl-quadric-draw-style q 'fill)
    (gl-new-list list-id 'compile)
    (gl-sphere q 0.5 20 20)
    (gl-end-list)
    (gl-call-list list-id))
  (gl-pop-matrix)
  (gl-flush))

(define gl-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)
    ;; on-paintをオーバーライド
    (define/override (on-paint)
      (with-gl-context
       (lambda ()
  (draw-gl)
  (swap-gl-buffers))))
    ;; on-sizeをオーバーライド
    (define/override (on-size w h)
      (with-gl-context
       (lambda ()
  (gl-viewport 0 0 w h))))
    
    ;; canvas%のスタイルにglを指定
    (super-new [style '(gl)])))

(define top-level-frame
  (new frame%
       [label "OpenGL test"]
       [width 400]
       [height 400]))

(define canvas
  (new gl-canvas%
       [parent top-level-frame]))

(set! current-texture
 (send canvas with-gl-context
       (lambda () (load-texture "./texture.jpg"))))

(send top-level-frame show #t)

2012年6月20日水曜日

[Racket]GUIの中でOpenGLを利用する

RacketのGUIでは、canvas%クラスを利用してOpenGLによる描画を行えます。
#lang racket

(require sgl sgl/gl sgl/gl-vectors)
(require racket/gui)

;; OpenGLによる描画.
;; 関数やパラメータの形式にはRacket-StyleとC-Styleがある.
(define (draw-gl)
  (gl-clear 'color-buffer-bit)
  (gl-color 1.0 1.0 0.0)
  (gl-begin 'line-loop)
  (gl-vertex -0.9 -0.9)
  (gl-vertex 0.9 -0.9)
  (gl-vertex-v (gl-float-vector 0.9 0.9))
  (gl-vertex -0.9 0.9)
  (gl-end)
  (gl-flush))

(define gl-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)
    ;; on-paintをオーバーライド
    (define/override (on-paint)
      (with-gl-context
       (lambda ()
  (draw-gl)
  (swap-gl-buffers))))
    ;; canvas%のスタイルにglを指定
    (super-new [style '(gl)])))

(define top-level-frame
  (new frame%
       [label "OpenGL test"]
       [width 400]
       [height 400]))

(define canvas
  (new gl-canvas%
       [parent top-level-frame]))

(send top-level-frame show #t)

2012年6月18日月曜日

gccの拡張機能無効化

日ごろ書いているのは'正しい'Cではない可能性が高いということに気付きました。 gccで拡張機能を無効にするには-pedanticオプションをつければよいようです。
gcc -pedantic test.c

2012年6月10日日曜日

[PowerShell]ExcelのシートをCSV形式で保存する

Excelのファイル中の各シートをCSV形式で保存します。
$xl = New-Object -ComObject Excel.Application
$xCSV = 6
$i = 0
$wb = $xl.Workbooks.Open("file")
foreach($sh in $wb.Sheets){
  $sh.Select()
  $wb.SaveAs("file" + $i + ".csv", $xCSV)
  $i += 1
}
$wb.Close()
$xl.Quit()

FFIを利用してWindows上でメッセージボックスを表示する

FFI(Foreign Function Interface)を利用して、Windows上でメッセージボックスを表示してみます。

注意点
  • APIにはAscii用のMessageBoxAとUnicode用のMessageBoxWがある
  • Unicodeの符号化形式はUTF-16LE

Common Lisp

FFIは処理系依存です。各処理系の差異を吸収してくれる、CFFIというライブラリがあります。 CFFIはQuicklispでインストール可能です。 文字列のエンコードを直接指定しない場合は, cffi:*default-foreign-encoding* に設定されている値が利用されます。
;; ffi-test.lisp
(asdf:load-system :cffi)

(defpackage :ffi-test
  (:use :cl :cffi)
  (:export message-box))

(in-package :ffi-test)

(load-foreign-library "user32.dll")

(defcfun ("MessageBoxW" message-box) :int32
  (hWnd :pointer)
  (lpText (:string :encoding :utf-16le))
  (lpCaption (:string :encoding :utf-16le))
  (uType :uint))
> (load "ffi-test.lisp")
> (ffi-test:message-box (cffi:null-pointer) "hello" "わーるど" 0)
または
(cffi:foreign-funcall 
   "MessageBoxW"
   :pointer (cffi:null-pointer)
   (:string :encoding :utf-16le) "hello"
   (:string :encoding :utf-16le) "わーるど"
   :uint 0
   :int32)

Racket

Racketではffi/unsafeライブラリを利用すればよさそうです。
#lang racket
;; ffi-test.rkt
(require ffi/unsafe)
(provide message-box)

(define user32 "user32.dll")

(define message-box
  (get-ffi-obj
   "MessageBoxW" user32
   (_fun _pointer
  _string/utf-16
  _string/utf-16
  _uint32
  -> _int32)
   #f))
> (load "ffi-test.rkt")
> (require 'ffi-test)
> (message-box #f "hello" "わーるど" 0)

Ruby

RubyでWindowsのDLLの関数を呼び出すには、Win32APIライブラリを利用すればよさそうです。
# -*- coding: utf-8 -*-
require "Win32API"
require "nkf"

class String
  def to_utf16le
    NKF.nkf("-w16L0", self)
  end
end

msgbox = Win32API.new('user32', 'MessageBoxW', %w(p p p i), 'i')
msgbox.call(0, "hello".to_utf16le, "わーるど".to_utf16le, 0)

Python

Pythonではctypesライブラリを利用すればよさそうです。
# -*- coding: utf-8 -*-
import ctypes

user32 = ctypes.windll.user32

user32.MessageBoxW(None, "hello", "わーるど", 0)

2012年6月2日土曜日

[Common Lisp] cl-annotで契約による設計のようななにか

cl-annotのアノテーションを利用して、契約による設計(Design By Contrat)っぽいことを行ってみます。

(asdf:load-system :cl-annot)
(asdf:load-system :alexandria)

(defpackage net.phorni.contract
  (:use :cl)
  (:export
   ;; annotation
   contract
   ;; condtion
   contract-error
   pre-contract-error
   post-contract-error
   ;; macro
   with-contract
   def/contract))

(in-package :net.phorni.contract)

(define-condition contract-error (error)
  ((expr :reader contract-expr :initarg :expr))
  (:report (lambda (condition stream)
      (format stream
       "~A: ~A"
       (type-of condition)
       (contract-expr condition)))))
(define-condition pre-contract-error (contract-error)
  ())
(define-condition post-contract-error (contract-error)
  ())

;; type-specifierの判別は処理系依存らしい
(defun type-specifier-p (x)
  (or
   #+CCL (ccl:type-specifier-p x)))

(defmacro contract-check (contract-type expr)
  (let ((gsym (gensym)))
    `(let ((,gsym ,expr))
       (if ,gsym
    ,gsym
    (error ,contract-type
    :expr ',expr)))))

(defun parse-contract-body (body)
  (loop
     :for expr in body
     :if (and (listp expr) (eq :pre (car expr)))
     :collect expr into pre
     :else :if (and (listp expr) (eq :post (car expr)))
     :collect expr into post
     :else
     :collect expr into parsed-body
     :finally (return (list pre post parsed-body))))

(defun pre-contract-expand (pre-list)
  `(progn
     ,@(loop
   :for pre in pre-list
   :collect
   `(contract-check 'pre-contract-error ,(second pre)))))

(defun post-contract-expand (vars post-list)
  `(progn
     ,@(loop
   :for post in post-list
   :collect
   `(contract-check 'post-contract-error
      (apply
       (lambda ,(cadr post)
         ,@(cddr post))
       ,vars)))))

(defmacro with-contract (&body body)
  (destructuring-bind
 (pre post parsed-body)
      (parse-contract-body body)
    (let ((gtmp (gensym)))
      `(progn
  ,(pre-contract-expand pre)
  (let ((,gtmp (multiple-value-list (progn ,@parsed-body))))
    ,(post-contract-expand gtmp post)
    (values-list ,gtmp))))))

(defun multiple-value-result-contract-spec? (x)
  (and (listp x)
       (eq :values (car x))
       (every #'type-specifier-p (cdr x))))

(defun check-multiple-value-num (result num)
  (= (length result) num))

(defmacro def/contract ((&rest args-contract) result-contract orig-def)
  (dolist (a args-contract)
    (unless (and (listp a)
   (= (length a) 2)
   (symbolp (first a))
   (type-specifier-p (second a)))
      (error "invalid pre-contract spec: ~A" a)))
  (when (and (not (multiple-value-result-contract-spec? result-contract))
      (type-specifier-p result-contract))
    (setf result-contract (list :values result-contract)))
  (unless (multiple-value-result-contract-spec? result-contract)
    (error "invalid post-contract spec: ~A" result-contract))  
  (let ((def (nth 0 orig-def))
 (name (nth 1 orig-def))
 (args (nth 2 orig-def))
 (body (nthcdr 3 orig-def))
 (gresult (gensym)))
    (multiple-value-bind
   (parsed-body declares doc)
 (alexandria:parse-body body :documentation t)
      `(,def ,name ,args
  ,doc
  ,@declares
  (with-contract
    ,@(loop
  :for a in args-contract
  :collect `(:pre (typep ,(first a) ',(second a))))
    (:post (&rest ,gresult)
    (and (check-multiple-value-num 
   ,gresult
   ,(length (cdr result-contract)))
         (every #'identity 
         (mapcar #'typep 
          ,gresult
          ',(cdr result-contract)))))
    ,@parsed-body)))))

(cl-annot:defannotation contract (args result def) (:arity 3)
  `(def/contract ,args ,result ,def))

;; ex

(def/contract ((n (integer 0 *)) (m (integer 1 *))) number
  (defun my-div-1 (n m)
    (/ n m)))
;; (my-div-1 2 3) => 2/3
;; (my-div-1 -1 1) => PRE-CONTRACT-ERROR: (TYPEP N '(INTEGER 0 *))

(cl-annot:enable-annot-syntax)

@contract ((n (integer 0 *)) (m (integer 1 *))) number
(defun my-div-2 (n m)
  (/ n m))
;; (my-div-2 4 2) => 2
;; (my-div-2 4 0) => PRE-CONTRACT-ERROR: (TYPEP M '(INTEGER 1 *))