ラベル haskell の投稿を表示しています。 すべての投稿を表示
ラベル haskell の投稿を表示しています。 すべての投稿を表示

2015年1月27日火曜日

JavaScript で素数の無限リストを作ってみる

もうだいぶ前になるが、Erlang で素数の無限リストを作った。今度は JavaScript で同じものを書いてみる。

方針は、前回同様、Priority Queue (Pairing Heap)を用いた Wheel Sieve を遅延リストで実装するというもの。

まず遅延リスト。以下のような感じになった。
// 遅延リストのコンストラクタ。head は先頭要素、next は残りの要素。
function LL(head, next) {
  this.head = head;
  this.next = next;
}
//空の遅延リスト
LL.emptyLL = { empty: true };
//先頭要素と別の遅延リストから新しい遅延リストを作る関数
LL.construct = function (car, cdr) {
  return new LL(car, function() { return cdr; });
}
//可変個の引数とって遅延リストに変える
LL.of = function() {
  var arr = Array.prototype.slice.call(arguments);
  return (arr.length == 0) ? LL.emptyLL 
       : (arr.length == 1) ? new LL(arr[0]) 
       : LL.construct(arr[0], LL.of.apply(this, arr.slice(1)));
}
LL.hasNext = function(list) { return list && list.next; }

LL.prototype.empty = false;

//index番目の要素を返す関数
LL.prototype.nth = function(index) {
  var primes = this;
  for (i = 0; i < index; i++) primes = primes.next();
  return primes.head;
}
次に倍数リストを保持する Priority Queue。
// Priority Queueのコンストラクタ。compositesは倍数リスト、lowersは
// このキューより優先度の低いキューの遅延リスト。
function PQ(composites, lowers) {
  this.composites = composites;
  this.lowers     = lowers ? lowers : LL.emptyLL; 
}
PQ.prototype.empty = false;

//他のキューより優先度が高いか判別する
PQ.prototype.lessThan = function(another) {
  return this.composites.head < another.composites.head;
}
PQ.emptyQueue = { empty: true };
PQ.empty = function(pq) { return !pq || pq.empty; }

PQ.prototype.join = function(lower) {
  return new PQ(this.composites, LL.construct(lower, this.lowers));
}
//2つのキューをマージする
PQ.merge = function(pq1, pq2) {
  return PQ.empty(pq1) ? pq2
       : PQ.empty(pq2) ? pq1
       : pq1.lessThan(pq2) ? pq1.join(pq2)
       :                     pq2.join(pq1);
}
// キューの遅延リストをまとめてマージする
PQ.mergeAll = function(queues) {
  if (queues.empty) return PQ.emptyQueue;
  if (!LL.hasNext(queues)) return queues.head;

  var rest = queues.next();
  var next = LL.hasNext(rest) ? rest.next():LL.emptyLL;
  return PQ.merge(PQ.merge(queues.head, rest.head), PQ.mergeAll(next));
}
//合成数の遅延リストと別のPriority Queue(オプション)から新しいキューを作る
PQ.enqueue = function(composites, q) {
  return PQ.merge(new PQ(composites), !q ? PQ.emptyQueue : q);
}
// 素数候補のの遅延リストから合成数の遅延リストを作る
PQ.composites1 = function(candidates) {
  return PQ.composites3(candidates.head, candidates.head, candidates);
}
PQ.composites2 = function(primes, candidates) {
  return PQ.composites3(primes, candidates.head, candidates);
}
PQ.composites3 = function(primes, candidate, candidates) {
  return new LL(primes * candidate, function() {
      return PQ.composites2(primes, candidates.next()); 
    }); 
}
上で書いた遅延リストとキューを使って、素数を生成するコードが以下。

前にやった時と同様に(また Haskell の Data.Numbers.Primes と同様に)ホイールを使うが、ホイールを生成するコード自体はここでは省略する。
// 始まりの数とホイールから数列を生成する関数
function spin(prev, wheel) {
  return new LL(prev, function() { return spin3(prev, wheel, wheel); });
}
function spin3(prev, wheel, original) {
  if (wheel.empty) return spin3(prev, original, original);
  var next = prev + wheel.head;
  return new LL(next, function() {
      var nextWheel = LL.hasNext(wheel) ? wheel.next() : LL.emptyLL;
      return spin3(next, nextWheel, original);
    });
}
// JavaScriptの配列と遅延リストを連結する関数
function concat(array, lazyList) {
  return (!array.length)
       ? lazyList
       : new LL(array[0], function() { return concat(array.slice(1), lazyList); });
}
// 候補となる数列と合成数の優先度付きキューから素数の遅延リストを生成する関数
function sieve(ns, pq) {
  if (!pq) return new LL(ns.head, function() {
      return sieve(ns.next(), PQ.enqueue(PQ.composites1(ns)));
    });
  var ms = pq.composites;
  if (ns.head %lt; ms.head) return new LL(ns.head, function() {
      return sieve(ns.next(), PQ.enqueue(PQ.composites1(ns), pq)); 
    });
  var updated = PQ.enqueue(ms.next(), PQ.mergeAll(pq.lowers));
  return (ns.head > ms.head) ? sieve(ns, updated) : sieve(ns.next(), updated);
}
//初期の素数リスト[2,3,5,7]と固定のホイール[4,2,4,2,4,6,2,6]から素数の遅延リストを生成する関数
function primes() {
  var wheel = spin(7, LL.of(4,2,4,2,4,6,2,6));
  return sieve(concat([2,3,5], wheel));
}
//100万番目の素数を標準出力
console.log(primes().nth(999999));
上記のコードを一個のファイルにまとめて実行してみると以下のような結果になった。
$ time node prime-test.js
15485863

real 1m13.130s
user 1m12.862s
sys 0m0.280s
うちのマシンでだいたい1分13秒。

Erlang でやった時とほぼ同じ時間だが、同じロジックの Haskellコードより圧倒的に遅い。コード量に関しても、かなり大差で JavaScript > Erlang > Haskell となる。

遅延評価がデフォルトではない言語で、無理やり遅延リストをやってるわけだから無理もないが、遅延がデフォの Haskellに比べると審美的な観点からもどんどん劣化していく。

とはいえ、JavaScript のウォーミングアップとしては、かなり良かった。

最初、関数をコンストラクタの中で定義していたりして、数時間かけても計算が終わらなかったり、メモリが足りなくなって落ちたりしていたが、いろいろ工夫して1分ちょいで終わるようになった。

2014年12月4日木曜日

EC2 (Ubuntu) に Yesod を入れてみたメモ

AWSの EC2インスタンス上で、Yesod を動かすのに手間取ったので、メモしておく。

----
EC2 は、Ubuntu を使ってみた。Ubuntu Server 14.04 LTS (HVM), SSD Volume Type - ami-e74b60e6 というものを使用。

Security Group の設定では、TCP の 3000を 開けておく。キーペアもちゃんとログインできる奴を指定する。ちなみに Ubuntu の場合、ユーザ名は ec2-user ではなくて ubuntu になる。

ここまでが前提。以下、本題。

■ Haskell Platform のインストール
まずバイナリを持ってきて、チェックサムを確認する。
$ wget https://www.haskell.org/platform/download/2014.2.0.0/haskell-platform-2014.2.0.0-unknown-linux-x86_64.tar.gz
$ sha256sum haskell-platform-2014.2.0.0-unknown-linux-x86_64.tar.gz
tar の中身が、絶対パスになっているので、/ に移動してから展開する。展開したら、activate-hs を実行する。
cd /
sudo tar xvf /home/ubuntu/haskell-platform-2014.2.0.0-unknown-linux-x86_64.tar.gz
sudo /usr/local/haskell/ghc-7.8.3-x86_64/bin/activate-hs
ここまで、Haskell Platform の指示に従った。

■ 追加ライブラリ等のインストール
Haskell Platform の 指示の中に、「追加のライブラリのインストールが必要かも知れない」、「libgmp.so.10 は必要だ」などとある。いろいろ試行錯誤したところ、以下の追加インストールで上手くようだ。
cd ~
sudo apt-get update
sudo apt-get install gcc
sudo apt-get install libgmp3-dev
sudo apt-get install libz-dev

■ Yesod のインストール
cabal update して、指示通りに cabal-install を入れなおし、yesod-bin をインストールする。

基本的には Yesod サイトの quick start guide の記述と同じだが、--force-reinstalls を指定している。このオプションを付けないと、「--force-reinstalls を付けてやり直せ」といった内容のメッセージと共にインストールが失敗する。

しばらく待つとインストールが終わるが、パスが通ってないので設定しておく。
cabal update
cabal install cabal-install
cabal install yesod-bin --force-reinstalls --max-backjumps=-1 --reorder-goals
PATH=$PATH:/home/ubuntu/.cabal/bin

■ scaffoldを起動してみる
まず適当にワークスペースを作っておく。
mkdir workspace
cd workspace/
yesod init を実行すると、プロジェクト名と永続化のタイプを聞いてくる。ここでは yesod01 、simple とした。
yesod init
yesod init が終わると、最後に起動するためのコマンドが表示されるが、ここでは敢えて別けて実行してみた(意味は変わらない)。
まず生成されたディレクトリに入って、次にビルド。ビルドできたら実行。
cd yesod01/
cabal install -j --enable-test --max-backjumps=-1 --reorder-goals
yesod devel
上手く行けば、コンソールにポート3000で起動したというログが出力され、ブラウザを開くと Welcome to Yesod! のページが表示されるはず。

----
本当は、hsenv か cabal sandbox で動かすつもりだったけど難航したので、とりあえず素で動かしてみた。サンドボックス環境が上手くいったら、続きを書く。

2012年8月12日日曜日

Haskell で平面ルービックキューブ (2)

今年の正月に、Haskell で 平面ルービックキューブを書いてみた。「Haskell で平面ルービックキューブ

この時は、Haskell の GUI コーディングはどんなものかと、Gtk2Hs を調べるついでに書いただけなので、シャッフルくらいできるようにしても良いなと思いつつ、放置していた。それを今日は書き足してみた。

====

シャッフルというのは、Esc キーを押すと、6面揃った状態から指定の回数分だけ、ランダムな面と方向で90度回転させるというもの。回数は起動時パラメータで指定する。

下の画像は、Escキーを押した直後。起動時に 3を渡しているので、3回かき回している。

これをよく見て、青を反時計回り(B)、赤を時計回り(r)、白を時計回り(w)と、3回操作すると 6面が揃う。

ソースはこんな感じになる(ブログに貼るにはチト長いが…)

module Main where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Gdk.Drawable
import Graphics.UI.Gtk.Gdk.Events as Evt
import Data.IORef
import Control.Monad
import System
import System.Random

--図形と色
data SquareColor = G|R|W|Y|O|B deriving Show
color G = Color 0x0000 0xE000 0x0000
color R = Color 0xE000 0x0000 0x0000
color W = Color 0xFFFF 0xFFFF 0xFFFF
color Y = Color 0xFFFF 0xFFFF 0x0000
color O = Color 0xF000 0x5000 0x0000
color B = Color 0x0000 0x0000 0xD000

initialSurface = map (replicate 9) [G,R,W,Y,O,B]

v60    = (18, -10)
v120   = (18,  10)
v180   = (0,   21)
angles = [[(-108,-30), v120,v180],
          [(-108,-30), v60, v120],
          [(-54,   0), v60, v180],
          [(0,   -30), v60, v180],
          [(0,    33), v60, v120],
          [(54,  -60), v120,v180]]
allParas = concatMap createParas angles
createParas v = map toPara $
    map (\n -> dupV v n) [0..2] >>= (\x -> map (\n ->dupH x n) [0..2])
toPara = (\[(ox,oy), (x1,y1), (x2,y2)] ->
  [(ox,oy), (ox+x1-1, oy+y1-1),
  (ox+x1+x2-2, oy+y1+y2-2),(ox+x2-1, oy+y2-1)])
dupH = (\[(ox,oy), v1@(x1,y1), v2] n -> [(ox+x1*n, oy+y1*n), v1, v2])
dupV = (\[(ox,oy), v1, v2@(x2,y2)] n -> [(ox+x2*n, oy+y2*n), v1, v2])

centering _ [] = []
centering size (angle: angles) =
  (map (centeringPoint size) angle): (centering size angles)

centeringPoint (w, h) (x, y) = (x + (div w 2), y + (div h 2))

--main とウィンドウ操作
main = do
    currentSurfaceIORef <- newIORef initialSurface
    initialSurfaceIORef <- newIORef initialSurface

    initGUI
    Just xml     <- xmlNew "rcube.glade"
    window       <- xmlGetWidget xml castToWindow "window1"
    entry        <- xmlGetWidget xml castToEntry "entry1"
    drawingArea  <- xmlGetWidget xml castToDrawingArea "drawingarea1"

    onDestroy window mainQuit
    onExposeRect drawingArea (const $ do
        dw       <- widgetGetDrawWindow drawingArea
        gc       <- gcNew dw
        surface  <- readIORef currentSurfaceIORef
        size     <- widgetGetSize drawingArea
        drawCube dw gc size surface)
    onEditableChanged entry $ do
        seq      <- get entry entryText
        surface  <- readIORef initialSurfaceIORef
        writeIORef currentSurfaceIORef $ rotateAll surface seq
        widgetQueueDraw drawingArea
    onKeyPress entry (\event -> do
        if 65307 == Evt.eventKeyVal event
        then do
            args <- getArgs
            s <- shuffle $ read $ args!!0
            let shuffled = rotateAll initialSurface s
            writeIORef initialSurfaceIORef shuffled
            writeIORef currentSurfaceIORef shuffled
            widgetQueueDraw drawingArea
            entrySetText entry ""
            return True
        else return False)

    widgetShowAll window
    mainGUI
  where
    drawCube d g size x = do
      drawParas d g (foldl (++) [] x) $ centering size allParas
    drawParas d g _ [] = return ()
    drawParas d g (x:xs) (p: ps) = do
      gcSetValues g $ newGCValues { foreground = color x }
      drawPolygon d g True p
      drawParas d g xs ps
    shuffle n = replicateM n
              $ getStdRandom (randomR (0,11)) >>= (return.(!!) "rgbywoRGBYWO")

-- 回転操作
rotateAll p [] = p
rotateAll p (x:xs) = rotateAll (rotate p x) xs
g2r [g,r,w,y,o,b] = [r6 o,r3 g,r3 w,r3 r,y,   r9 b]
r2g [o,g,w,r,y,b] = [r9 g,r9 r,r9 w,y,   r6 o,r3 b]
w2r [g,r,w,y,o,b] = [r9 g,w,   r3 o,r3 y,r3 b,r6 r]
r2w [g,w,o,y,b,r] = [r3 g,r6 r,w,   r9 y,r9 o,r9 b]
y2r [g,r,w,y,o,b] = [r9 w,y,   o,   r3 b,r3 g,r9 r]
r2y [w,y,o,b,g,r] = [r9 g,r3 r,r3 w,y,   o,   r9 b]
o2r [g,r,w,y,o,b] = [r6 b,r6 o,r6 y,r6 w,r6 r,r6 g]
r2o [b,o,y,w,r,g] = [r6 g,r6 r,r6 w,r6 y,r6 o,r6 b]
b2r [g,r,w,y,o,b] = [r9 y,b,   r9 o,r3 g,r3 w,r]
r2b [y,b,o,g,w,r] = [r9 g,r,   r9 w,r3 y,r3 o,b]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,              (b1:b2:b3:bs)] 'r' =
       [(w1:w2:w3:gs), [r7,r4,r1,r8,r5,r2,r9,r6,r3],
        (y1:y2:y3:ws), (b1:b2:b3:ys),
        o,              (g1:g2:g3:bs)]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,             (b1:b2:b3:bs)] 'R' =
       [(b1:b2:b3:gs), [r3,r6,r9,r2,r5,r8,r1,r4,r7],
        (g1:g2:g3:ws), (w1:w2:w3:ys),
        o,             (y1:y2:y3:bs)]
rotate p 'g' =r2g (rotate (g2r p) 'r')
rotate p 'G' =r2g (rotate (g2r p) 'R')
rotate p 'w' =r2w (rotate (w2r p) 'r')
rotate p 'W' =r2w (rotate (w2r p) 'R')
rotate p 'y' =r2y (rotate (y2r p) 'r')
rotate p 'Y' =r2y (rotate (y2r p) 'R')
rotate p 'o' =r2o (rotate (o2r p) 'r')
rotate p 'O' =r2o (rotate (o2r p) 'R')
rotate p 'b' =r2b (rotate (b2r p) 'r')
rotate p 'B' =r2b (rotate (b2r p) 'R')
rotate p _ = p
r3 [s1,s2,s3,s4,s5,s6,s7,s8,s9] = [s7,s4,s1,s8,s5,s2,s9,s6,s3]
r6 x = r3 $ r3 x
r9 x = r6 $ r3 x
onKeyPress の辺りを書き足した。Hackage がダウンしていてドキュメントが見られないというアクシデントがあったが、割と簡単に直感で書けてしまう。

2012年6月16日土曜日

余りが1になる割り算から元の数を求める方法

1000003 × B ÷ 1000000 = q 余り 1 となる最小のBは何か?

これを素朴に求めると、B=1から開始して初めて余りが 1になるまでBをインクリメントするような事になるが、ずっと効率的なやり方があったのでメモっておく。

以下、euler 134 のネタバレあり

==== ==== ==== ====

project euler に、与えられた素数 p1, p2 について、末尾が p1 で、なおかつ p2 で割りきれる数 S をもの凄く大量に計算する問題があった。

合同式で書くとこうなる

S ≡ 0 (mod p2)
S ≡ p1 (mod m) (m はp1を越える最小の10の正数乗)

実は合同式自体あまり詳しくないので、"連立 合同"でググってみると、連立合同式の解法を紹介しているサイトがあった。

これをよく読んで、上の問題に当てはめてみると、

  S ≡ p1*p2*B (mod p2*m)
  ただし、B は p2*B ≡ 1 (mod m) を満たす整数)
を解けば良い事がわかる。

試しにやってみると、
p1 = 19, p2 = 23
23*B ≡ 1 (mod 100) より、B = 87
(19 × 23 × 87) ÷ (23 × 100) = 16 余り 1219
答え: 1219
となり、一応計算できてることが分かる。

ただし困ったのが、B を求めるやり方で、素朴にやると以下のようになるけど(Haskell)

ghci> find (\a ->1==mod (23*a) 100) [1..]
Just 87
これだと冒頭であげた1000000近辺の数だとかなり時間がかかる。

そこで更に調べてみると、「逆元(inverse)」なるものを求める方法があって、どうやらこれが使えそう。

ググりまわって Wikipedia でこの擬似コードを見つけた

remainder[1] := f(x)
remainder[2] := a(x)
auxiliary[1] := 0
auxiliary[2] := 1
i := 2
while remainder[i] > 1
    i := i + 1
    remainder[i] := remainder(remainder[i-2] / remainder[i-1])
    quotient[i] := quotient(remainder[i-2] / remainder[i-1])
    auxiliary[i] := -quotient[i] * auxiliary[i-1] + auxiliary[i-2]
inverse := auxiliary[i]
これを、以下のように解釈して、表計算ソフトに打ち込んでみる。
nraq
1m0-
2p21-
・・・
iMOD(ri-2, ri-1) = - qi * ai-1 + ai-2 = DIV( ri-2, ri-1)
で、r が1 になったときの a が求める数字らしい。

試しに 1000003 でやってみると以下のようになる。

10000000
10000031
100000000
311
1-333333333333

-333333 が負数になっているので、mod (-333333,1000000)としてみると 666667 が得られる。 1000003 × 666667 = 666669000001で、確かに 1000000 で割ると余りが 1 になる事が分かる。

もの凄く計算量が減ってる。ははは、これは面白い。

上の問題に戻って、p1 = 999983, p2 = 1000003 としてみると、mod (999983 * 1000003 * 666667) (1000003000000) = 666662999983 となり、1000003 で割りきれて末尾が 999983 になる数が確かに得られた。

上手く行きそうなので、表計算ソフトに書いた事を以下のような Haskell コードに置き換えてみる。

inverse a m = mod (f m 0 0 a 1 0) m where
    f 1  a  _  _  _  _  = a
    f r1 a1 q1 r2 a2 q2 = f r a q r1 a1 q1
      where r = mod r2 r1
            q = div r2 r1
            a = -q*a1 + a2
euler 134 に適用してみると、1秒で正答が得られた。(ちなみに「余り1になるB」をインクリメントしながら計算すると、4時間くらいかかった。)

2012年6月13日水曜日

ピタゴラス数の小ネタ

今までプログラマやってきて特に気にすることもなかったけど、project euler を始めてみるとピタゴラス数に関連する問題に出会うことがある。で、いろいろ調べてみると、ちょっと面白いネタというか Tips が見つかった。


■ 原始ピタゴラス数の無限リスト
このサイトで原始ピタゴラス数(primitive Pythagorean triple (PPT))を次々に生成する行列が紹介されている。こんな行列。
( -1  -2  2)
( -2  -1  2)
( -2  -2  3)
この行列に符号を3通りに変えたピタゴラス数を掛けると、子のピタゴラス数が3つ生成される。例えば(3,4,5)から始めると以下のようになる。
(-1 -2 2) (-3)   ( 5)
(-2 -1 2) ( 4) = (12) 
(-2 -2 3) ( 5)   (13)

(-1 -2 2) ( 3)   (15)
(-2 -1 2) (-4) = ( 8) 
(-2 -2 3) ( 5)   (17)

(-1 -2 2) (-3)   (21)
(-2 -1 2) (-4) = (20) 
(-2 -2 3) ( 5)   (29)
算出された子のピタゴラス数から、さらに3つずつの孫を作ることができ、これを再帰的に繰り返すとピタゴラス数の無限リストを作ることができる。Haskell で書くとこんな感じになる。
pyt1 (a,b,c) = ((-1)*a+(-2)*b+2*c,(-2)*a+(-1)*b+2*c,(-2)*a+(-2)*b+3*c)
pyt2 (a,b,c) = [pyt1(-a,b,c), pyt1(-a,-b,c), pyt1(a,-b,c)]
pyt3 ts = ts ++ pyt3 (concatMap pyt2 ts)
以下のような結果になる。
ghci< pyt3 [(3,4,5)]
[(3,4,5),(5,12,13),(21,20,29),(15,8,17),(7,24,25),(55,48,73),(45,28,53),(39,80,89),(119,120,169),(77,36,85),(33,56,65),(65,72,97),(35,12,37),(9,40,41),(105,88,137),(91,60,109),(105,208,233),(297,304,425),(187,84,205),(95,168,193),(207,224,305),(117,44,125),(57,176,185),(377,336,505),(299,180,349),(217,456,505),(697,696,985),(459,220,509),(175,288,337),(319,360,481),(165,52,173),(51,140,149),(275,252,373),(209,120,241),(115,252,277),(403,396,565),(273,136,305),(85,132,157),(133,156,205),(63,16,65),(11,60,61),(171,140,221),(153,104,185),(203,396,445),(555,572,797),・・・



■ 高さ=底辺の二等辺三角形に漸近する漸化式
このサイトでは、ピタゴラス数を直角二等辺三角形に近づけていく漸化式が紹介されていた。直角を構成する辺 a と b の差を1に こんな式。
an+2 = 6*an+1 - an + 2  a1 = 3, a2 = 20
cn+2 = 6*bn+1 - bn - 2  b1 = 4, b2 = 21
cn+2 = 6*bn+1 - cn      c1 = 5, c2 = 29
で、ここから類推して高さ=底辺の二等辺三角形(の片側の三角形)に漸近する漸化式もきっとあるだろうなと思って探してみた(きっかけは euler 138)。

まず直角を構成する2辺のうち長い辺と短い方を二倍したものとの差が1であるものを何個か探す。これは上述の無限リストに対して、条件に合うものをフィルタリングした。以下のようなものが見つかった(これ以上は数が大きくなりすぎて難しい)。
(15,8,17)
(273,136,305)
(4895,2448,5473)
(87841,43920,98209)
(1576239,788120,1762289)
(28284465,14142232,31622993)
(507544127,253772064,567451585)
(9107509825,4553754912,10182505537)
で見つかったピタゴラス数から連立方程式を立ててこれを解いた。手で計算するのは面倒なので、ネット上の連立方程式を解くプログラムを使った。例えば、斜辺ならこんな式を解けば良い。
305*x + 17y + z = 5473
5473*x + 305*y + z= 98209
98209*x + 5473*y + z =1762289

解)x=18, y=-1, z=0
で、c1 = 17, c2 = 305, cn+2 = 18*cn+1 - cn という漸化式が得られる。Haskell で書くとこうなる。
l = 17:305:zipWith (\a b->18*b-a) l (tail l)
同様に、直角を構成する2辺についても漸化式が得られる。 a1 = 15, a2 = 273, an+3 = 17*an+2 + 17*an+1 - an (bも同様)

試しに20番目の要素を見てみると、a= 10151021471800938910964641, b = 5075510735900469455482320, c = 11349187026003431978487841)で、a2 + b2 = c2, 1 = |2b-a| が確かに成立する。

==== ==== ==== ====

さっき problem 138 を解いて、euler project を150問解いた事になる。簡単な問題を選んでやってきたが、そろそろ難しくなってきた。かなり頑張ったけど、まだ半分にも至ってないのか…

2012年5月2日水曜日

Pell方程式を解くための実装メモ

Project Euler をやってると、Pell方程式 X2-DY2=1 に関連する問題をたまに見かける。これを解くとき、連分数を使うやり方がよく使われるようだけど、半分位の手数で解が得られるやり方がここで紹介されていたので、Haskell で実装してみた。

■ やり方
だいたいこんな感じ
g-1=0g0=0gn+1 = -gn + knhn
h-1=0h0=1hn+1 = (D - gn+12)/hn
k-1=0k0=[√D]kn+1 = [(k0 + gn)/hn]
x-1=0x0=1xn+1 = gnyn + hnyn-1
y-1=0y0=0yn+1 = yn-1 + knyn
で、gn とgn+1 で同じ値が連続したら、
X = (xn2 + Dyn2)/hn
Y = 2xnyn/hn
hn とhn+1 で同じ値が連続したら、
X' = (xnxn+1 + Dynyn+1)/hn
Y' = (xnyn+1 + xn+1yn)/hn
X = X'2 + DY'2
Y = 2X'Y'

■ 例
D = 23の場合
nghkxy
-100001
001410
147141
232351
3371194
24 = (52 + 23*12)/2
5 = 2*5*1/2
D = 29の場合
nghkxy
-100001
001510
154251
2351112
32511613
70 = (11*16 + 29*2*3)/5
13 = (11*3 + 16*2)/5
9801 = 702 + 29*132
1820 = 2*70*13

■ コード
pell d=pell' d (0,0,0,0,1) (0,1,floor(sqrt(fromIntegral d)),1,0) 
  where 
   pell' d (g,h,k,x,y) n@(gn,hn,kn,xn,yn)
    | g'== gn    = let xr = div (xn^2 + d*yn^2) hn
                       yr = div (2*xn*yn) hn
                   in (xr, yr)
    | h'== hn    = let xr = div (x'*xn + d*y'*yn) hn
                       yr = div (x'*yn + xn*y') hn
                   in (xr^2 + d*yr^2, 2*xr*yr)
    | otherwise  = pell' d n (g',h',k',x',y')
    where k0 = floor$sqrt$fromIntegral d
          g' = (-gn) + kn*hn
          h' = div (d - g'^2) hn
          k' = div (k0 + g') h'
          y' = y + kn*yn
          x' = g'*y' + h'*yn

■ 結果
ghci> let isNotSquare n= (round . sqrt $ fromIntegral n) ^ 2 /= n
ghci> mapM_ (\n->print$(n,pell n)) $filter isNotSquare [2..15]
(2,(3,2))
(3,(2,1))
(5,(9,4))
(6,(5,2))
(7,(8,3))
(8,(3,1))
(10,(19,6))
(11,(10,3))
(12,(7,2))
(13,(649,180))
(14,(15,4))
(15,(4,1))
ghci> maximumBy (\a b->(on compare (snd.snd))a b )$ map (\n->(n,pell n)) $filter isNotSquare [2..2000]
(1621,(6298101812493732343034974500091457815529942308667051412857352310169665125001,156429324369979112128445583345098338627552043874824108399177922442751050500))
Problem 66 で、D≦1000でXが最大になるものを求める問題があるけど、D≦10000でもすぐに答えが出てくる。

2012年3月27日火曜日

ブルートフォース癖

ガウスがちっちゃい頃の逸話で、先生が算数の時間に、生徒達に1から100までの合計を計算させて、その間に雑用か何かを片付けようとしてたら、ガウスが101 * 50 = 5050と瞬時に答えをだしたので先生が驚いたってのを聞いたことがある。

プログラマたるもの大いに見習わなきゃならんなと常々思っていたけど、最近、Project Euler を始めてみて、かなり自分にブルートフォース癖があるのに気づいて反省。

例えば Problem 169 の以下のような問題がある(それほど難しくないと言われている)。

Define f(0)=1 and f(n) to be the number of different ways n can be expressed as a sum of integer powers of 2 using each power no more than twice.

For example, f(10)=5 since there are five different ways to express 10:

    1 + 1 + 8
    1 + 1 + 4 + 4
    1 + 1 + 2 + 2 + 4
    2 + 4 + 4
    2 + 8

What is f(10^25)?

これを解くのに、可能な手をそれぞれ試行してからルールに合わないものをふるい落とすなんてやり方(試行回数を減らす工夫はしてるつもりだけど)だと、いつまで経っても終わらない。

途中の計算結果をキャッシュでもしてみようかとも思ったけど、もうそんなのは止めておこうと思い至り、初めから再考する事にした。

で、改めてよく考えてみると、「1」を使わない部分の合計を x としたとき、n が奇数ならば必ず「x + 1」の形になる。ここで x 部分のバリーション数は f (n div 2) で、これが即ち f(n)と等しいということが分かる。

次に n が偶数のときを考えると、表記法のバリエーションは「x」か「x + 1 + 1」のいずれかのパターンに分類され、前者の表記法の数は f (n div 2) で、後者は f ((n-2) div 2)となるから、f (n) = f (n div 2) + f ((n-2) div 2)となる。

ここまでを問題文にある f(0)=1 を考慮してまとめると以下の様になる。
n = 0     ⇒ f(n) = 1
n ∈ odd  ⇒ f(n) = f(n')
n ∈ even ⇒ f(n) = f(n') + f(n'-1)
※ n' = n div 2

うん、本当は、この辺りまで公式化してから、さて実装はどうしようかと考えるべきなんだよなあ。

改めて「分析」ってやっぱ大事だなと思う。実際の開発現場では、重量プロセスで必死になって大量にドキュメントを書いてるくせして、「分析」が全然なされてなされてなかったりするし、下手糞なアジャイルもどきの開発でも、「後でなんぼでもリファクタできるから」的なノリで実装を進めて、変な方向にはまり込んで引き返せなくなったりもする。ちゃんと分析しようやと。

話を戻すと、実は上の公式をそのまんま実装しても、二重再帰が含まれてるのでものすごく遅い。だから、ここからが実装の話になるけど、これを防ぐには、一回の f(n) の計算で f(n) とf(n-1)の両方を返すようにすれば良い。以下の表を観察すると規則性が見えてくる。

1 2 3456789101112
f(n) 121323143525
f(n-1)112132314352

n が奇数のとき f(n-1) は f(n')+f(n'-1) になっていて、偶数ならば f(n-1) は f(n'-1)になっている。例えば、f(9-1)=f(8)=f(4)+f(4-1)で、f(10-1)=f(9)=f(5)+f(5-1)。ここまで分かれば、f(n) と f(n-1)を同時に返して末尾再帰させるコードを簡単に書ける。自分書いた4行ばかりの Haskellコードは、実行すると瞬時に正答が算出された(二重再帰版は未だに帰ってこない)。

2012年3月12日月曜日

Monoid をちょっと調べてみる自習

Monoid というのが、なんか地味っぽいけどよく使われているみたいなので、調べてみる。

◆ Data.Monoid

ghci で :i Monoidとやると、Data.Monoid で定義されているインスタンスがたくさん表示されてくるので、ソースを見ながら一個ずつ調べてみる。(「⇨」の左辺に ghci への入力、右辺に ghci の出力を書いてみた)

■ Any、All

Bool値をとる Monoid。
mempty::Any ⇨ Any {getAny = False}
Any False `mappend` Any False `mappend` Any True ⇨ Any {getAny = True}
mconcat [Any False, Any True, Any False] ⇨ Any {getAny = True}
All はこれの反対で、類推は容易。

■ Ordering

これがちょっとおもしろい。LT、EQ、GTの三つの値があって、EQ の優先度が低く、LT と GTでは早い者勝ちという感じ。
mempty::Ordering ⇨ EQ
mconcat [LT,LT] ⇨ LT, mconcat [LT,EQ] ⇨ LT, mconcat [LT,GT] ⇨ LT
mconcat [EQ,GT] ⇨ GT, mconcat [EQ,EQ] ⇨ EQ, mconcat [EQ,GT] ⇨ GT
mconcat [GT,LT] ⇨ GT, mconcat [GT,EQ] ⇨ GT, mconcat [GT,GT] ⇨ GT
mconcat [EQ,EQ,GT,LT] ⇨ GT

■ ()

() は、mempty、mappend、mconcat ともに ()

■ [a]

これも大体想像通り。mconcat では空リストが無くなる。
mempty::[Int] ⇨ []
[3] `mappend` [1,4] ⇨ [3,1,4]
mconcat [[3,1],[],[4]] ⇨ [3,1,4]

■ First a、Last a

First は Maybe a 型の値を持つ Monoid で、Nothing 以外の値で早い者勝ち。Last はその逆。
mempty::First Int ⇨ First {getFirst = Nothing}
mconcat[mempty, First Nothing, First (Just 27), mempty, First (Just 18)]
  ⇨ First {getFirst = Just 27}
mempty::Last Int ⇨ Last {getLast = Nothing}
Last (Just 27) `mappend` Last (Just 18) ⇨ Last {getLast = Just 18}
Last (Just 27) `mappend` mempty `mappend` Last (Just 18) `mappend` Last Nothing
  ⇨ Last {getLast = Just 18}

■ Endo a

なんだか endomorphism というものに関係があるらしい。wikipedia を引くと自己準同型とか自己射なるものの事らしいけど、正直、今のところよくからない。まあソースを読めば関数の合成に関係がある事はなんとなくわかるけど・・・
instance Monoid (Endo a) where
    mempty = Endo id
    Endo f `mappend` Endo g = Endo (f . g)
appEndo (Endo (*2) `mappend` mempty `mappend` Endo (+1)) 3 ⇨ 8
appEndo (mconcat [Endo (+3), Endo (+1), Endo (+4)]) 3 ⇨ 11
Foldable のソースでも使われていたりする。

■ Sum a、Product a …(a は Num)

文字通り、Sum が足し算で、Product が掛け算。
mempty::Sum Int ⇨ Sum {getSum = 0}
Sum 3 `mappend` Sum 1 `mappend` Sum 4 ⇨ Sum {getSum = 8}
getSum $mconcat [Sum 3, Sum 1, Sum 4] ⇨ 8
mempty::Product Int ⇨ Product {getProduct = 1}
Product 3 `mappend` Product 1 `mappend` Product 4 ⇨ Product {getProduct = 12}
mconcat [Product 3, Product 1, Product 4] ⇨ Product {getProduct = 12}

■ Maybe a …(a は Monoid)

中身が Monoid の Maybe が Monoid になるつう事なんだろうか。
Just [2,7] `mappend` Just [1,8] ⇨ Just [2,7,1,8]
Just EQ `mappend` Just LT ⇨ Just LT
Nothing `mappend` (Just $Sum 1) ⇨ Just (Sum {getSum = 1})
Nothing `mappend` Just GT ⇨ Just GT

■ Dual a …(a は Monoid)

なんかひっくり返すらしい。「双対」というものに関係がありそうだけど、詳細はよくわからない。Foldable の foldl の実装で使われてた。
mempty::Dual [Int] ⇨ Dual {getDual = []}
Dual [3,1] `mappend` Dual [4,1] ⇨ Dual {getDual = [4,1,3,1]}
mconcat [Dual [3], Dual [1], Dual [4]] ⇨ Dual {getDual = [4,1,3]}

■ (a -> b) …(b が Monoid)

Monoid を返す関数を Monoid として扱うって事か。
:t mempty::Monoid b =>(Int->b)
   ⇨ mempty::Monoid b =>(Int->b) :: Monoid b => Int -> b
 
(mempty::(a->String)) 333 ⇨ ""
(mempty::(a->())) "hello" ⇨ ()
((:"!") `mappend` (:"?")) '@' = "@!@?"
((compare 1) `mappend` (compare 10)) 5 ⇨ LT
(((\a b->[a + b]) `mappend` (\a b->[a * b])) 3) 10 ⇨ [13,30]

■ (a, b...) …(a から最大 e まで Monoid)

Monoid を値に持つタプルを Monoid として見て、縦に並べて計算する感じ。
5個分まで定義。
mempty:: (String, Maybe (Sum Int)) ⇨ ("",Nothing)
("Hello, ", Sum 0.3) `mappend` ("World!", Sum 0.014)
   ⇨ ("Hello, World!",Sum {getSum = 0.314})
(GT, Sum 0.3) `mappend` mempty ⇨ (GT, Sum {getSum = 0.3})

◆ 試しに書いてみる

mconcat はデフォルト実装があるので、mempty と mappend だけ書けばいいらしい(参考URL)。

ただし Monoid law に気をつける必要がある。
mempty `mappend` x = x
x `mappend` mempty = x
(x `mappend` y) `mappend` z = x `mappend` (y `mappend` z)

とりあえず「範囲」を Monoidとして書いてみた。

mappend は 両方の範囲を含む最小の範囲とした。左辺が右辺より大きくなる Range も作れてしまうが、両辺ともに mempty でない場合の mappend で正規化するようにした。(mempty をふくむ mappend でこれをやると Monoid law が成立しなくなる)

data Range a = NullRange | Range (a, a) deriving (Show, Read, Eq)

instance Ord a => Monoid (Range a) where
    mempty                        = NullRange
    NullRange `mappend` range     = range
    range     `mappend` NullRange = range
    range1    `mappend` range2    =
        let Range (l1, r1) = canonicalize range1
            Range (l2, r2) = canonicalize range2
        in  Range (min l1 l2, max r1 r2)
        where canonicalize (Range (l,r)) =
          Range (min l r, max l r)
GHCI に読ませてちょっと試してみる。
ghci> mempty::Range Int
NullRange
ghci> Range (3, 6) `mappend` Range (4, 10)
Range (3,10)
ghci> mconcat [Range (2,8), NullRange, Range (13,5), Range (5,5)]
Range (2,13)
でさらに、Writer に Monoid の制約があるので、これと組み合わせて使ってみる。
printRange :: (Ord a, Show a) => (Range a) ->WriterT (Range a) IO ()
printRange range = do
    tell range
    liftIO $ print range

main = runWriterT $ do
    printRange $ Range ('g', 'u')
    printRange $ Range ('l', 'r')
    printRange $ Range ('t', 'w')
printRange は、受け取った範囲を標準出力に書き出しながら、Writer にも出力する関数。これを連続的に実行すると、最終的に「ログ」の部分は全ての範囲を含む最小の範囲になる。
ghci> :main
Range ('g','u')
Range ('l','r')
Range ('t','w')
((),Range ('g','w'))

◆ 雑感

Endo Monoid のところで、どうやら自己射/自己準同型というものに関係があるらしいと書いたけど、そもそも Monoid からして(もちろん Monad も)圏論周辺の数学用語らしいので、普通に Haskell を使う分には数学は不要とは言うけど、やっぱりある程度理解しておく必要はあるのかなと思う。

2012年3月3日土曜日

Haskell で三目並べ (2)

前回のつづきで三目並べ。
マシン側の指し手の選択を、少しだけ知的にしてみる。

以前の記事で、ルール言語の Drools を使って、下記のようなルールで三目並べを書いた。
  1. 後一手で列が完成する盤面なら、その列を完成して終了。
  2. ユーザが後一手で一列完成できる盤面なら、それをブロックする。
  3. 後一手で二方向の王手が作れる盤面なら、それを作る。
  4. ユーザが後一手で二方向の王手が作れる盤面なら、ブロックする。
  5. 中央が空いていたら、そこに置く。
  6. 相手が角を取っていて対角が空いていたら、そこに置く。
  7. 角が空いていたらそこに置く。
  8. 空いているマスがあったら、そこに置く。
これを Haskell で書いてみたい。(参考wiki

◆ 方針

前回の暫定実装した、マシンの指し手を選択する関数をこんな風に書き換えてみる。
machinesTurn :: StateT Board IO Int
machinesTurn = do
    board <- get
    let idx = fromJust $ select board
    updateBoard Machine idx
    return idx
  where
    select = 
        findWinPos       <||>
        findBlockPos     <||>
        findForkPos      <||>
        findForkBlockPos <||>
        tryCenter        <||>
        findAnyBlank
    f1 <||> f2 = mplus <$> f1 <*> f2
select 以下に並べられた findWinPos から findAnyBlank までの関数は、盤面 Board を取って、指し手を Maybe Intとして返すもの。

これらの関数そのものを「(->) r」というタイプの Applicative とみなして合成する演算子を、<||> として定義した。MonadPlus としての Maybe の振る舞いを利用している。

結果として合成された select 関数は、ある関数に盤面を与えて、指し手が得られたらそれを返し、ダメなら次の関数に盤面を与えるという計算を数珠つなぎにしたものになる。 ※((->) r)を Functor や Applicative として扱う手法はこのあたりの記事に詳しい。Applicative 一般の入門としても、超絶わかりやすく解説されている。

◆ コード全体

findWinPos 〜 findAnyBlank の実装は以下のようなものになる(前回書いた部分も含めて全部晒してしまうことにした)。
import Control.Monad.State
import Control.Applicative
import Data.List
import Data.Functor.Identity
import Control.Monad.List
import Data.Maybe
import qualified Data.List.Utils as LU
import System

data Mark = User|Machine|Blank deriving Eq
instance Show Mark where
  show User    = "U"
  show Machine = "M"
  show Blank   = " "

type Board = [Mark]

main :: IO ()
main = do
    args <- getArgs
    let machineFirst = 0 < length args && "m"==args!!0
    evalStateT (play machineFirst) initialBoard >>= putStrLn

initialBoard :: Board
initialBoard = take 9 $ repeat Blank

printBoard :: Board -> IO ()
printBoard board =
    putStrLn $ unlines $ LU.join ["-+-+-"] $ map showRow [0..2]
  where
    showRow row = [LU.join "|" $ map show $ cells row]
    cells   row = take 3 $ snd $ splitAt (row * 3) board

play :: Bool -> StateT Board IO String
play isMachinesTurn = do
    if isMachinesTurn then machinesTurn
                      else usersTurn
    board <- get
    liftIO $ printBoard board
    case judge board of
        Nothing     -> (play $ not isMachinesTurn)
        Just result -> return result

judge :: Board -> Maybe String
judge board
    | wonBy User board                 = return "won by user."
    | wonBy Machine board              = return "won by machine."
    | Nothing == elemIndex Blank board = return "drawn."
    | otherwise                        = Nothing

wonBy :: Mark -> Board -> Bool
wonBy mark board = any threeInRow rows
  where
    threeInRow indices = all (mark==) $ rowStates indices
    rowStates indices  = map (board!!) indices

rows :: [[Int]]
rows = [[0,3,6],[1,4,7],[2,5,8],
        [0,1,2],[3,4,5],[6,7,8],
        [0,4,8],[2,4,6]]

updateBoard :: Mark -> Int -> StateT Board IO ()
updateBoard mark pos = get >>= put.(update mark pos)

update :: Mark -> Int -> Board -> Board
update mark pos board =
    let (f, (x:xs)) = splitAt pos board in f ++ (mark:xs)

usersTurn :: StateT Board IO Int
usersTurn = do
    position <- liftIO getDigit
    board    <- get
    if Blank /= board!!position
        then (liftIO $putStrLn "wrong position") >> usersTurn
        else updateBoard User position >> return position
  where
    getDigit = do
        ch <- getChar
        putStrLn ""
        if elem ch ['0'..'8']
            then return (read [ch])
            else putStrLn "wrong input" >> getDigit

machinesTurn :: StateT Board IO Int
machinesTurn = do
    board <- get
    let idx = fromJust $ select board
    updateBoard Machine idx
    return idx
  where
    select =
      findWinPos       <||>
      findBlockPos     <||>
      findForkPos      <||>
      findForkBlockPos <||>
      tryCenter        <||>
      findAnyBlank
    f1 <||> f2 = mplus <$> f1 <*> f2

findWinPos :: Board -> Maybe Int
findWinPos   = findWinPos' Machine

findBlockPos :: Board -> Maybe Int
findBlockPos = findWinPos' User

findWinPos' :: Mark -> Board -> Maybe Int
findWinPos' mark board =
    ff ([mark, mark, Blank], 2) `mplus`
    ff ([mark, Blank, mark], 1) `mplus`
    ff ([Blank, mark, mark], 0)
  where
    ff (css, idx) = do findPattern css board >>= return.(!!idx)

findForkPos      :: Board -> Maybe Int
findForkPos      = findForkPos' Machine

findForkBlockPos :: Board -> Maybe Int
findForkBlockPos = findForkPos' User

findForkPos':: Mark -> Board -> Maybe Int
findForkPos' mark brd = do
    let posibles = elemIndices Blank brd
    idx <- findIndex (\pos->containsFork (update mark pos brd)) posibles
    return $ posibles!!idx
  where
    containsFork  b = (2<=) $ length $ findTwoInARow b
    findTwoInARow b = findIndices (matchTwoInARow b) rows
    matchTwoInARow b row =
        let stts = map (b!!) row
        in 2 == (countState mark stts) && 1 == (countState Blank stts)

findOppositeCorner :: Board -> Maybe Int
findOppositeCorner brd = do
    let pairs = [(0,8), (8,0), (2,6), (6,2)]
    r' <- findIndex (\(f,s)-> brd!!f==User && brd!!s==Blank) pairs
    return $ snd $ pairs!!r'

findBlankCorner :: Board -> Maybe Int
findBlankCorner = findBlankCell [0, 2, 8, 6]

findBlankCell   :: [Int] -> Board -> Maybe Int
findBlankCell candidate board =
    findIndex ((Blank==).(board!!)) candidate
    >>= return.(candidate!!)

findAnyBlank :: Board -> Maybe Int
findAnyBlank board = elemIndex Blank board

tryCenter     :: Board -> Maybe Int
tryCenter brd = if Blank == brd!!4 then Just 4 else Nothing

findPattern :: [Mark] -> Board -> Maybe [Int]
findPattern pattern board = do
    idx <- elemIndex pattern $ map (\row->map (\idx->board!!idx) row) rows
    return $ rows!!idx

countState :: Mark -> [Mark] -> Int
countState state cells = length $elemIndices state cells

◆ まとめ

  • 実は、上のアルゴリズムではユーザ先手で 0, 8, 6 と指すと、ユーザが勝ってしまう。三目並べはちゃんとやると引き分けになるんだけど、ちょっと手抜きをしている(ユーザのフォークをマシンが防ぐ辺り)。三目並べ自体が目的ではないので、割愛した。
  • 少し書いては直し、また書いては直しと常時リファクタしているが、コンパイルが通るだけで、感覚的には JUnit で 6割くらいのコード・カバレッジがあるくらいの安定感がある。この 150行弱のコードだと、デグレ的な事は一回も起きなかった。
  • 上で少し触れたサイト、「Learn You a Haskell for Great Good!」の、Functor 〜 Applicative 〜 Monado の解説(この順序で説明されている)が、ものすごくわかりやすくて感動。

Haskell で三目並べ (1)

Haskell の Monad transformer が大体わかってきたので、State と IO を組み合わせる練習コードを書いてみる。題材として、三目並べ(Tic-Tac-Toe)を選んでみた。

こんな仕様でやってみる。
  • コンソールアプリとする
  • 実行時引数で"m"を渡したらマシン、でなければユーザの先手
  • 0から8の文字で位置を指定する(左上が0、Enter不要)。
  • 不正入力時、その旨表示して再入力を促す。
  • マシン/ユーザ双方の指し手の後に盤面を表示する。
  • 決着が着いたら、結果を表示する

====

◆ 盤面の表現

盤面は九つのマスから成り、それぞれ U(ユーザ)か M(マシン)か空のいずれかの状態
data Mark = User|Machine|Blank deriving Eq
instance Show Mark where
  show User    = "U"
  show Machine = "M"
  show Blank   = " "

type Board = [Mark]

initialBoard :: Board
initialBoard = take 9 $ repeat Blank
下記のような関数で、盤面を文字列化してコンソールに表示できる。(LU は Data.List.Utilsのエイリアス)
printBoard :: Board -> IO ()
printBoard board =
    putStrLn $ unlines $ LU.join ["-+-+-"] $ map showRow [0..2]
  where
    showRow row = [LU.join "|" $ map show $ cells row]
    cells   row = take 3 $ snd $ splitAt (row * 3) board
タテ、ヨコ、ナナメの列を表すためのインデクスの配列は以下のように書いた。計算で導出することもできるけど、却ってわかりにくかったの明示的な定数として書き直した。
rows :: [[Int]]
rows = [[0,3,6],[1,4,7],[2,5,8],
        [0,1,2],[3,4,5],[6,7,8],
        [0,4,8],[2,4,6]]

◆ ゲームの流れの表現

main は、先手を判別してゲームを開始し、結果を表示する。
main :: IO ()
main = do
    args <- getArgs
    let machineFirst = 0 < length args && "m"==args!!0
    evalStateT (play machineFirst) initialBoard >>= putStrLn

play が実際のゲームを進行する関数で、状態としての盤面を保持しながらユーザ入力を受け付けたりする。というわけで型としては State Board と IO を組み合わせた StateTになっている。

ユーザの指し手とマシンの指し手を交互に取得しながら、盤面の状態を更新・再表示した上で勝敗を判定。決着が着けばこれを結果とし、着かなければ play に再帰するという形になる。
play :: Bool -> StateT Board IO String
play isMachinesTurn = do
    if isMachinesTurn then machinesTurn
                      else usersTurn
    board <- get
    liftIO $ printBoard board
    case judge board of
        Nothing     -> (play $ not isMachinesTurn)
        Just result -> return result

judge :: Board -> Maybe String
judge board
    | wonBy User board                 = return "won by user."
    | wonBy Machine board              = return "won by machine."
    | Nothing == elemIndex Blank board = return "drawn."
    | otherwise                        = Nothing

wonBy :: Mark -> Board -> Bool
wonBy mark board = any threeInRow rows
  where
    threeInRow indices = all (mark==) $ rowStates indices
    rowStates indices  = map (board!!) indices

◆ ユーザの指し手の取得

標準入力から一文字取得して、指し手を得る。既にマークのあるマスに置こうとしたり、0〜8以外のキーを押下するとエラー。問題なければ盤面を更新して、得られた指し手を結果とする。
usersTurn :: StateT Board IO Int
usersTurn = do
    position <- liftIO getDigit
    board    <- get
    if Blank /= board!!position
        then (liftIO $putStrLn "wrong position") >> usersTurn
        else updateBoard User position >> return position
  where
    getDigit = do 
        ch <- getChar
        putStrLn ""
        if elem ch ['0'..'8']
            then return (read [ch])
            else putStrLn "wrong input" >> getDigit
盤面の更新はこんな関数を使う。update 関数は、後で 非Monad な文脈でも使えるように切り出した。
updateBoard :: Mark -> Int -> StateT Board IO ()
updateBoard mark pos = get >>= put.(update mark pos)

update :: Mark -> Int -> Board -> Board
update mark pos board =
    let (f, (x:xs)) = splitAt pos board in f ++ (mark:xs)

◆ マシンの指し手の決定(暫定)

長くなってきたので、詳細は後で別に書くことにして、盤上左上から開いているマスを探して見つかり次第返すだけの暫定実装で、とりあえず動かしてみる。
machinesTurn :: StateT Board IO Int
machinesTurn = do
    board <- get
    let idx = fromJust $ elemIndex Blank board
    updateBoard Machine idx
    return idx
ここまでのコードを、適切に import 文を追加した上で一個のファイルにまとめて、ghci に読ませると、プロンプトから下のように実行できる。
ghci> :main
0
U| | 
-+-+-
 | | 
-+-+-
 | | 

U|M| 
-+-+-
 | | 
-+-+-
 | | 

4
U|M| 
-+-+-
 |U| 
-+-+-
 | | 

U|M|M
-+-+-
 |U| 
-+-+-
 | | 

8
U|M|M
-+-+-
 |U| 
-+-+-
 | |U

won by user.
ghci> 

◆ ここまでのまとめ

まあ、マシン側の指し手が全く勝つ気も守る気もない暫定実装だけど、ここまででも一応、対話的に入力を受け付けながら状態を管理していくやり方が、だいたいわかった。もっと上達した後に見直したら、いろいろツッコミどころがあるんだろうけど、とりあえず先に進んでみる

2012年2月18日土曜日

手計算で monad を理解してみる

去年の秋頃から、暇なときにちょこちょこ Haskell をいじっているけど実に面白い。

やっぱり一番おいしいところは、Monad をはじめとする計算のやり方なんだろうけど、一行に収まるくらいの短い式を書いて、手書きで計算してみると意外と理解に役立つ事に気がついた。

例えば、runCont (return "hello") (++"!") を計算すると "hello!" になるけど、たぶん慣れてる人には自明過ぎるようなこんな計算でも、初めての時は何だか分かったような分かってないようなあやふやな感じがする。

これをこんな風に手計算してみる。(関数等の定義は「All About Monads」のここを参考にした。)

runCont (return "hello") (++"!")
= runCont(Cont $ \k->k "hello")) (++"!") … ①
= (\k->k "hello")) (++"!") … runCont の定義より
= (++"!") "hello"
= "hello!" 

① return の定義、return a = Cont $ \k -> k a より
個人的には、これであやふやな感じが解消してスッキリする。

続けて更に Cont から別の例を出してみると、callCC なんかも下の定義だけだは、何がどうなるのかよく分からない。
callCC f = Cont $ \k -> runCont (f (\a -> Cont $ \_ -> k a)) k

この辺りのサンプルコードを読むと、使い方が何となく分かるが、どういう仕組みでそうなるのか腑に落ちずモヤモヤする。

例えば 「runCont (callCC (\ex -> do {ex "bye"; return "hi"})) (++"!") 」みたいな式で、なんで "hi!" にならないのか不思議だったりする。

こんなのも手で計算してみると、細かいところがはっきりする。

  runCont (callCC (\ex -> do {ex "bye"; return "hi"})) (++"!")
= runCont (callCC (\ex -> ex "bye" >>= (\f -> return "hi"))) (++"!")
= runCont (Cont $ \k -> (\_ -> (k "bye")) k) (++"!") … (a)
= (\k -> (\_ -> (k "bye")) k) (++"!")
= (\_ -> ((++"!") "bye")) (++"!")
= (++"!") "bye"
= "bye!"

(a)
callCC f = Cont $ \k-> runCont (f(\a-> Cont $ \_->k a)) k より

  callCC (\ex->ex "bye">>=(\f->return "hi"))
= Cont $ \k-> runCont ((\ex -> ex "bye">>=(\_ -> return "hi")) (\a-> Cont $ \_ -> k a)) k
= Cont $ \k-> runCont (((\a -> Cont $ \_ -> k a) "bye") >>= (\_ -> return "hi")) k
= Cont $ \k-> runCont ((Cont $ \_ -> k "bye") >>= (\_ -> return "hi")) k
= Cont $ \k-> runCont (Cont $ \_ -> (k "bye")) k … (b)
= Cont $ \k-> (\_ -> (k "bye")) k

(b)
(Cont c) >>= f = Cont $ \k' -> c (\a -> runCont (f a) k') より

  (Cont $ \_->k "bye") >>= (\_ -> return "hi")
= Cont $ \k' -> (\_ -> k "bye") (\a -> runCont (f a) k')
= Cont $ \_ -> (k "bye")

実は最初、遅延評価に変にこだわってしまって手こずっていたんだけど、参照透明なんだから好きな順序で計算しても結果は変わらないわけで、手計算のときは余り気にする必要が無いと開き直って簡単になった。

2012年1月7日土曜日

Haskell で平面ルービックキューブ

急に、ルービックキューブをプログラムで解いてみたい衝動にかられたが、手元にブツが無い。近所のコンビニにも無かったので、作ってみることにした。

以下のような方針

  • 極力シンプルに。本物に近い操作感とか立体性とか別にいらないので、二次元の図形で表現する。
  • 中央の小正方形は動かさない事にする。
  • 操作はテキストボックスへの入力とする。色を表す文字一文字により、その色が中央となる面の回転を表し、小文字なら時計回り、大文字ならその逆とする。
  • 現在、テキストボックスに入力されている文字列全体が反映された結果を描画する。
  • 図形は中央に描画する。
  • Haskell でやってみる

結果から示すと、以下が実際の様子。まず初期表示


初期表示

赤い面を時計回りに2回、青い面を時計回りに1回、赤い面を反時計まわりに1回、青い面を反時計まわりに1回、それぞれ90度回転させた結果。

コードは以下のような感じになる。
module Main where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Gdk.Drawable
import Graphics.UI.Gtk.Gdk.Events as Evt
import Data.IORef

--図形
data SquareColor = G|R|W|Y|O|B
color G = Color 0x0000 0xE000 0x0000
color R = Color 0xE000 0x0000 0x0000
color W = Color 0xFFFF 0xFFFF 0xFFFF
color Y = Color 0xFFFF 0xFFFF 0x0000
color O = Color 0xF000 0x5000 0x0000
color B = Color 0x0000 0x0000 0xD000

initialState = map (replicate 9) [G,R,W,Y,O,B]

v60    = (18, -10)
v120   = (18,  10)
v180   = (0,   21)
angles = [[(-108,-30), v120,v180],
          [(-108,-30), v60, v120],
          [(-54,   0), v60, v180],
          [(0,   -30), v60, v180],
          [(0,    33), v60, v120],
          [(54,  -60), v120,v180]]
allParas = concatMap createParas angles 
createParas v = map toPara $
    map (\n -> dupV v n) [0..2] >>= (\x -> map (\n ->dupH x n) [0..2])
toPara = (\[(ox,oy), (x1,y1), (x2,y2)] ->
  [(ox,oy), (ox+x1-1, oy+y1-1),
  (ox+x1+x2-2, oy+y1+y2-2),(ox+x2-1, oy+y2-1)])
dupH = (\[(ox,oy), v1@(x1,y1), v2] n -> [(ox+x1*n, oy+y1*n), v1, v2])
dupV = (\[(ox,oy), v1, v2@(x2,y2)] n -> [(ox+x2*n, oy+y2*n), v1, v2])

centering _ [] = []
centering size (angle: angles) =
  (map (centeringPoint size) angle): (centering size angles)

centeringPoint (w, h) (x, y) = (x + (div w 2), y + (div h 2))

--ウィンドウ操作
main = do
    initGUI
    surfaceIORef <- newIORef initialState
    Just xml     <- xmlNew "rcube.glade"

    window       <- xmlGetWidget xml castToWindow "window1"
    onDestroy window mainQuit

    drawingArea  <- xmlGetWidget xml castToDrawingArea "drawingarea1"
    onExposeRect drawingArea (const $ do
        dw       <- widgetGetDrawWindow drawingArea
        gc       <- gcNew dw
        surface  <- readIORef surfaceIORef
        size     <- widgetGetSize drawingArea
        drawCube dw gc size surface)

    entry        <- xmlGetWidget xml castToEntry "entry1"
    onEditableChanged entry $ do 
        n <- get entry entryText
        writeIORef surfaceIORef $ rotateAll initialState n
        widgetQueueDraw drawingArea

    widgetShowAll window
    mainGUI
  where
    rotateAll p [] = p
    rotateAll p (x:xs) = rotateAll (rotate p x) xs
 
    drawCube d g size x = do
      drawParas d g (foldl (++) [] x) $ centering size allParas
    drawParas d g _ [] = return ()
    drawParas d g (x:xs) (p: ps) = do
      gcSetValues g $ newGCValues { foreground = color x }
      drawPolygon d g True p
      drawParas d g xs ps

-- 回転操作
g2r [g,r,w,y,o,b] = [r6 o,r3 g,r3 w,r3 r,y,   r9 b]
r2g [o,g,w,r,y,b] = [r9 g,r9 r,r9 w,y,   r6 o,r3 b]
w2r [g,r,w,y,o,b] = [r9 g,w,   r3 o,r3 y,r3 b,r6 r] 
r2w [g,w,o,y,b,r] = [r3 g,r6 r,w,   r9 y,r9 o,r9 b] 
y2r [g,r,w,y,o,b] = [r9 w,y,   o,   r3 b,r3 g,r9 r]
r2y [w,y,o,b,g,r] = [r9 g,r3 r,r3 w,y,   o,   r9 b]
o2r [g,r,w,y,o,b] = [r6 b,r6 o,r6 y,r6 w,r6 r,r6 g]
r2o [b,o,y,w,r,g] = [r6 g,r6 r,r6 w,r6 y,r6 o,r6 b]
b2r [g,r,w,y,o,b] = [r9 y,b,   r9 o,r3 g,r3 w,r]
r2b [y,b,o,g,w,r] = [r9 g,r,   r9 w,r3 y,r3 o,b]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,              (b1:b2:b3:bs)] 'r' =
       [(w1:w2:w3:gs), [r7,r4,r1,r8,r5,r2,r9,r6,r3],
        (y1:y2:y3:ws), (b1:b2:b3:ys),
        o,              (g1:g2:g3:bs)]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,             (b1:b2:b3:bs)] 'R' =
       [(b1:b2:b3:gs), [r3,r6,r9,r2,r5,r8,r1,r4,r7],
        (g1:g2:g3:ws), (w1:w2:w3:ys),
        o,             (y1:y2:y3:bs)]
rotate p 'g' =r2g (rotate (g2r p) 'r')
rotate p 'G' =r2g (rotate (g2r p) 'R')
rotate p 'w' =r2w (rotate (w2r p) 'r')
rotate p 'W' =r2w (rotate (w2r p) 'R')
rotate p 'y' =r2y (rotate (y2r p) 'r')
rotate p 'Y' =r2y (rotate (y2r p) 'R')
rotate p 'o' =r2o (rotate (o2r p) 'r')
rotate p 'O' =r2o (rotate (o2r p) 'R')
rotate p 'b' =r2b (rotate (b2r p) 'r')
rotate p 'B' =r2b (rotate (b2r p) 'R')
rotate p _ = p
r3 [s1,s2,s3,s4,s5,s6,s7,s8,s9] = [s7,s4,s1,s8,s5,s2,s9,s6,s3]
r6 x = r3 $ r3 x
r9 x = r6 $ r3 x

画面定義は、GtkWindow に GtkVBox を置いて、その上側に GtkDrawingArea、下側に GtkEntryを置いたものを、Glade 3.8.1 で適当に作っておく。

====

一応、ルービックキューブにはなったが、遊ぶにはシャッフルする機能を追加する必要がある。あと、そもそもの目的だった、解く方のコードも書こうと思うのだけど、なんかここまでの作業で変にコーディング欲が充足されてしまって、当初のモチベーションが既に半減してしまった。なんだかなあ。

====

--2012/08/12 追記:シャッフルできるようにした

2012年1月1日日曜日

Haskell でソケット通信をやってみる

Haskell で ソケットを使ったクライアント-サーバ通信をやってみる。

Haskell を使ったネットワーク・プログラミングの入り口が分かればいいので、クライアントから受け取った文字列をひっくり返して返すだけの、簡単なお題とする。

まず、サーバはこんな感じ。
import Network
import System.IO 

main :: IO ()
main = withSocketsDo $ do 
    hSetBuffering stdout NoBuffering
    server `catch` (const $ putStrLn "Exception caught.")
    putStrLn "Connection closed."

server :: IO ()
server = do
    sock <- listenOn (PortNumber 8001)
    repeats (receive sock)
    sClose sock

repeats :: Monad m => m Bool -> m () 
repeats x =
    x >>= (\x' -> if x' then (return ()) else repeats x)

receive :: Socket -> IO Bool
receive sock = do
    (h,host,port) <- accept sock
    hSetBuffering h LineBuffering
    msg <- hGetLine h           
    putStrLn msg 
    hPutStrLn h $ reverse msg 
    return $ null msg
クライアントはこんな感じ。
import Network
import System.IO 

sendMessage msg = withSocketsDo $ do 
        hSetBuffering stdout NoBuffering 
        h <- connectTo "127.0.0.1" (PortNumber 8001)
        hSetBuffering h LineBuffering
        hPutStrLn h msg
        hGetLine h >>= putStrLn
        hClose h
実行は GHCi でやってみる。
以下、サーバ側
ghci> :load server.hs
[1 of 1] Compiling Main             ( server.hs, interpreted )
Ok, modules loaded: Main.
ghci> main
Loading package bytestring-0.9.1.10 ... linking ... done.
 ・・・略・・・
Loading package network-2.3.0.7 ... linking ... done.
hello
1234

Connection closed.
ghci> 
以下、クライアント側
ghci> :load client.hs
[1 of 1] Compiling Main             ( client.hs, interpreted )
Ok, modules loaded: Main.
ghci> sendMessage "hello"
Loading package bytestring-0.9.1.10 ... linking ... done.
 ・・・略・・・
Loading package network-2.3.0.7 ... linking ... done.
olleh
ghci> sendMessage "1234"
4321
ghci> sendMessage ""
ghci> 

思ったより難しくない。次は、マルチスレッド化かなあ。

2011年12月18日日曜日

gtk2hs で落書きしてみる

前回の書き込みで、gtk2hs の準備ができたので、もう一歩進めてみる。

10年以上前、Visual C++を使ってた頃、MFC のチュートリアルで Scribble というのがあった。これを、Haskell で試してみた。

ただし、MDI とか ドキュメントの保存とかは割愛して、とりあえず描画の API とマウスイベントのハンドリングだけを気にすることにした。

仕組みは簡単で、マウスボタンが押下されたときから放されるまでのマウスポインタの軌跡を記録し、ウィンドウ描画時に各点を線でつないでいくというもの。コードは以下のようになる。

import qualified Graphics.UI.Gtk as G
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Gdk.Events
import Data.IORef
import Graphics.UI.Gtk.Gdk.Drawable

main = do
    G.initGUI
    w <- G.windowNew
    G.onDestroy w G.mainQuit

    da <- G.drawingAreaNew

    isDrawingIORef <- newIORef False
    figuresIORef   <- newIORef [[]]

    G.onExposeRect da (const $ do dw <- G.widgetGetDrawWindow da
                                  gc <- gcNew dw
                                  f <- readIORef figuresIORef
                                  drawFigure dw gc f)

    G.onMotionNotify da True $ \Motion {eventX = x, eventY = y}-> do
      isDrawing <- readIORef isDrawingIORef
      case isDrawing of
        True  -> do  modifyIORef figuresIORef (\f->addPoint f x y)
                     G.widgetQueueDraw da
        _     -> return ()
      return True
  
    G.onButtonPress da $ \Button {eventX = x, eventY = y}-> do
      writeIORef isDrawingIORef True
      modifyIORef figuresIORef (\f->[point x y]: f)  
      return True

    G.onButtonRelease da $ \Button {eventX = x, eventY = y}-> do
      writeIORef isDrawingIORef False
      modifyIORef figuresIORef (\f->addPoint f x y)
      return True
  
    G.containerAdd w da
    G.widgetShowAll w
    G.mainGUI

  where
    point x y = (round x, round y)
    addPoint figures x y = (point x y: head figures): tail figures
    drawFigure _ _ [] = return ()
    drawFigure d g (f:fs) = do {
      G.drawLines d g f; drawFigure d g fs }

Haskell 自体にまだ慣れていないので、いかにも未熟な感じだけど、イベント処理と描画の作法がなんとなく分かってきた。ネット上で API を調べる事にも、だんだん慣れてきた。

ただ、IORef というのが、なんだかしっくり来ない。結局、状態を持ってしまってる事になり、どうも気持ち悪い。初心者なりに勝手に純粋関数型言語に期待していたのは、もっと、引数と戻り値だけでつながっていく感じなんだけど、まだまだ勉強が足りないのかもしれない。

結果としては、マウスボタンの判別をしていないので、右でも左でも書けてしまうけど、一応思ったとおりに動作するものができた。スプーの絵もこんな風に書く事ができる(頭頂部の突起がやや足りない事を除けば、我ながらよく描けたと思う)。

gtk2hs と Glade の相性

gtk2hs を Glade と組み合わせて使うときのメモ。

Haskell の GUI プログラミングを試したくて、テキストボックスに文字列を入れて Enter を押したらラベルに表示されるような簡単なプログラム echo を、gtk2hs を使って書く実験をしてみた。

で、まず Glade というツールで GUI を定義する XMLを生成して、これを適当に書いた Haskell プログラムに読ませたら、こんなエラーが出た

$ ./echo 

(echo:4887): libglade-WARNING **: Expected <glade-interface>.  Got <interface>.

(echo:4887): libglade-WARNING **: did not finish in PARSER_FINISH state
echo: user error (Pattern match failure in do expression at echo.hs:8:5-12)

なんか Glade が生成した GUI定義XML の形式に問題があるっぽい。

調べてみると、Glade の出力形式には libglade と GtkBuilder の二通りの方法があり、gtk2hs が対応しているのは前者という事らしいのだが、ファイルを保存するときに libglade を選んでも、事態は全然変わらない。

さらに調べてみると Glade の3.8系 と 3.10系 で大きな違いがあって、出力XML に関してだと 3.10系では libglade 形式が無くなってるらしい。自分は、特に意識しないまま 3.10 を使っていた模様。

この2つのバージョン間で、保存時のダイアログに以下のような違いがある。

3.10系
3.8系
XML出力の違いは以下のような感じ
3.10系
<?xml version="1.0" encoding="UTF-8"?>
<interface>
  <requires lib="gtk+" version="2.24"/>
  <object class="GtkWindow" id="window1">
    <property name="can_focus">False</property>
    <child>
    …
3.8系
<?xml version="1.0" encoding="UTF-8"?>
<glade-interface>
  <widget class="GtkWindow" id="window1">
    <property name="can_focus">False</property>
    <child>
    …

というわけで、Glade の 3.8 系を使えば、gtk2hs がちゃんと処理できる形式の XML になる。

ただし、うちの環境で使ってる Fedora16 なんかでは、「ソフトウェアの追加/削除」から普通に Glade をインストールすると 3.10系が入って来てしまう。従って、この場合 3.8系を別途インストールする必要がある。

これは、ここから glade3-3.8.1.tar.xz を落としてきて、tar Jxf glade3-3.8.1.tar.xz -> ./configure -> make -> make install のようにすれば、/usr/local/bin/glade-3 が使えるようになる。

ちなみに、以下が実験で使った Haskellコード

module Main where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.Gdk.Events as Evt

main = do
    initGUI
    Just xml    <- xmlNew "echo.glade"
    window      <- xmlGetWidget xml castToWindow "window1"
    onDestroy window mainQuit
    label       <- xmlGetWidget xml castToLabel "label1"
    entry       <- xmlGetWidget xml castToEntry "entry1"
    onKeyPress window $ \(Evt.Key _ eventSent _ _ _ _ _ _ name _) -> do
      keyPressHandler label entry name
      return eventSent
    widgetShowAll window
    mainGUI

keyPressHandler :: Label -> Entry -> String -> IO ()
keyPressHandler label entry "Return" = do
  name <- get entry entryText
  set label [labelText := name]
keyPressHandler _ _ _ = return ()
たかだかこれだけのコードを書くのに、かなり骨を折るが、いちおう動作する。

2011年12月11日日曜日

Haskell+HDBC+MySQL で Hello World

Haskell で MySQL を使ってみるウォーミングアップ。

こんな環境
  • Fedora16
  • GHC 7.0.4
  • MySQL 5.5.18

====

まずテーブルを準備する。適当に mysql で MySQL に接続して以下のようにする。

mysql> create database hdbc_test;
mysql> connect hdbc_test;
mysql> create table greeting (id int not null auto_increment, text varchar(50), primary key(id));
mysql> insert into greeting(text) values ('Hello, world!');
mysql> select * from greeting;
+-----+---------------+
| id  | text          |
+-----+---------------+
|   1 | Hello, world! |
+-----+---------------+
1 row in set (0.00 sec)
テーブルの準備ができたら、次は使用するモジュールだけど、この サイトによると、Haskell から DB を使うには、HDBC、HSQL、HaskellDBと言った選択肢があるらしい。とりあえず HDBC でいってみる。
$cabal install HDBC
$cabal install HDBC-mysql

※ cabal 自体は、Fedora のアプリケーションの追加/削除でインストールした。
※ ghc-pkg という低レベルのコマンドもある。
※ MySQL以外に HDBC でサポートされてるやつを調べるにはここ

できたら、MySQL に接続してみる。
まず ghci を立ち上げて、モジュールを取り込んでからDB接続を取得する。

ghci>  :m +Database.HDBC Database.HDBC.MySQL
ghci> conn <- connectMySQL MySQLConnectInfo{mysqlHost="localhost", mysqlDatabase="hdbc_test", mysqlUser="root",mysqlPassword="XXXX", mysqlPort=3306, mysqlUnixSocket="/var/lib/mysql/mysql.sock"}
ghci>

mysqlUnixSocket に設定するファイル名は、/etc/my.conf に書いてあるのでそれを指定すればいい。成功したら、上のようにエラーメッセージなしで次のプロンプトに移る。

ちなみに、省略時値が既に設定されている defaultMySQLConnectInfo を使えば、この場合だと mysqlHost, mysqlUser, mysqlPort を省略して以下のようにできる。

ghci> conn <- connectMySQL defaultMySQLConnectInfo{mysqlDatabase="hdbc_test", mysqlPassword="XXXXX", mysqlUnixSocket="/var/lib/mysql/mysql.sock"}

※ソースを読みたかったら、ここで見られる

接続が得られたら、いよいよ HelloWorld。

ghci> quickQuery' conn "SELECT * from greeting" []
[[SqlInt32 1,SqlByteString "Hello, world!"]]
うん。できたっぽい。

ちなみに エラー無しで取得できたと思った Connection を、いざ使おうとしたら "No instance for (IConnection Connection)"なんて言われる事がある。自分もそうなったけど HDBC 関連のパッケージを更新したら解消した(参考URL

====

ついでに、もうちょい他の事もやってみる。

■ prepared statement

ghci> stmt <- prepare conn "INSERT INTO greeting(text) VALUES (?)"
ghci> executeMany stmt [[toSql "Good-bye, world..."], [toSql "Hello, another world2!"]]
ghci> quickQuery' conn "select * from greeting"[]
[[SqlInt32 1,SqlByteString "Hello, world!"],[SqlInt32 2,SqlByteString "Good-bye, world..."],[SqlInt32 3,SqlByteString "Hello, another world!"]]
ghci> commit conn
JDBC やってるのと同じだね。

■ メタ情報

ghci> describeTable conn "greeting"
[("id",SqlColDesc {colType = SqlIntegerT, colSize = Nothing, colOctetLength = Nothing, colDecDigits = Nothing, colNullable = Just False}),("text",SqlColDesc {colType = SqlVarCharT, colSize = Nothing, colOctetLength = Nothing, colDecDigits = Nothing, colNullable = Just True})]
うーん…colType は良いけど、colSize がNothing になってるのはどういう訳だろう。ここは varchar (50) を反映していてほしかった。 標準SQL の INFORMATION_SCHEMA で、普通にメタ情報を得ることも、もちろんできる。

■ 日本語

ghci> run conn "UPDATE greeting SET text='こんにちは' WHERE id=1" []
ghci> quickQuery' conn "select * from greeting where id=1"[]
[[SqlInt32 1,SqlByteString "S\147kao"]]
ははは、文字化けした。mysql で見ても化けてる。面倒そうだから後で考えよっと。

--2012/08/12: 同じSQLを prepared statement でやったら問題なく「こんにちは」となる
--2012/08/12: ghci> run conn "UPDATE greeting SET text=? WHERE id=1" [toSql "こんにちは"] で上手く行く

気になるところが幾つかあったけど、最初の試行としてはこんなものだろう。

====

最後に豆知識メモ。

ghci のプロンプトを変えるには、":set prompt "ghci> "と入力すればいい。これを永続化するには、~/.ghc/ghci.conf に同じ事を書く。ただし、どういうわけか、ファイルのパーミッションで、グループに w が付いていると無視される。無視されないようにするには、"chmod g-w .ghc .ghc/ghci.conf "として、書き込み権限を取り除いておけばいい。

あと、いろいろググってると、HaskellDB と HSQL と HDBC とで、似て非なる事柄が一緒くたに引っかかってくるので、酒を飲みながら作業してたりすると、 HDBC.MySQL のソースのつもりで HaskellDB.HDBC.MySQL のソースを読んで小一時間頭をかきむしって苦しむ事になったりする。

2011年12月6日火曜日

Jaskell このやろう!

名前だけはずいぶん前から知ってたけど、あまり興味が無くて放置していた Jaskell。

『プロダクティブ・プログラマ』で紹介されて高評価だったから、さぞかし有望株なのだろうと思いきや…

誰も使ってる気配がない…

まあダウンロードはできるから、ちょっと試してみようとしたけど、そもそも動いてくれない。

Exception in thread "main" java.lang.NoSuchMethodError: jfun.parsec.Parsers.plus(Ljfun/parsec/Parser;Ljfun/parsec/Parser;)Ljfun/parsec/Parser;
 at jfun.jaskell.JaskellParser.(JaskellParser.java:299)
 at jfun.jaskell.JaskellParser.instance(JaskellParser.java:1377)
 at jfun.jaskell.JaskellParser.parseExprOrLib(JaskellParser.java:1436)
 at jfun.jaskell.Jaskell.parseExprOrLib(Jaskell.java:2356)
 at jfun.jaskell.Jaskell.parseExprOrLib(Jaskell.java:2376)
 at jfun.jaskell.Jaskell.eval(Jaskell.java:2469)
 at jfun.jaskell.Jaskell.evalInputStream(Jaskell.java:2657)
 at jfun.jaskell.Jaskell.evalResource(Jaskell.java:2555)
 at jfun.jaskell.Jaskell.evalResource(Jaskell.java:2531)
 at jfun.jaskell.Jaskell.importPrelude(Jaskell.java:1990)
 at jfun.jaskell.shell.Shell.getShellRuntime(Shell.java:42)
 at jfun.jaskell.shell.Shell.main(Shell.java:35)
ちなみにこの例外は、java コマンドから Jaskell Shell を起動しようとしたときにも、Jaskell インスタンスを生成してそいつにスクリプトを読ませようとしたときにも、 どっちでも発生する。

第一、起動の仕方らしきものにたどり着くまでだいぶかかった。プロダクティブ・プログラマで紹介されている URL、「http://jaskell.codehaus.org/」 は、Jaskell でググっても一番上にくるやつだけど、動かし方がどこにも全然書いてない。

jaskell-1.0.jar を実行したら何か起こるだろうと思ったけど、うんともすんとも言わない。MANIFEST.MFにも、やっぱなんも書いてなかった。

しょうがないから、JavaDoc を読んでたら Jaskell クラスというのがあって、こいつが文字列やファイルを評価する eval () メソッドを持ってるから、インスタンス作って eval() したら、上の例外。

半泣きでググってたら、Jaskell Shell というのを見つけるが、トップページからリンクされてる訳でもなく、どこが本物のプロジェクトページだか、訳が分からない。で、動かしてみたら、また上の例外。

まあ、何個かある jar の組み合わせを変えてみるとか、再コンパイルしてみるとかで、解決しない事もないんだろうけど、もういい。心折れた。降りるわ。

それにしても Neal Ford さんは、なんでこんなの紹介したんだ…。
普通に、Haskell 勉強して行こうやって結論しか出てこない。