HaskellでGUI #2 FliptItの改良:FFIの利用
28 / Feb 2010(今回は GUI というより FFI な気がする.でも目的は GUI だからいいか.)
前回作成した GUI の FlipIt を改良した.
改良は以下の2点
- 周期を増加.
- 解を表示.
目次
周期の増加
前回は
マスの変化が
白→黒→白→黒→…
だったが,今回はこの周期を変更できるようにした.
白→灰→黒→白→灰→黒→…
内部的には Bool の2次元配列を Int の2次元配列に変更しただけ.
描画の色を少し調整した程度.
ただ,解を求める際にガウスの消去法を使用するので,周期は素数でないと問題が生じる.
また,周期が大きすぎても,わけわかめになるだけなので,最大周期は7に設定している.
解を表示
ガウスの消去法をやるだけといえば,それだけ.
ただ,以前にC++で書いたことがある.
そこで,今回は Haskell の FFI(Foreign Function Interface) を使って外部コードを利用してみた.
しかし,C++ の関数を利用するのは C に比べて難しそうなので, 少しコードを書き換えて C の関数を利用することにした.
C++ の関数利用について
Cxx foreign function interface – HaskellWiki
CPlusPlus from Haskell – HaskellWiki
GHC/Using the FFI – HaskellWiki
C の関数を利用する
GHC/Using the FFI – HaskellWiki
FFI Introduction – HaskellWiki
C の関数の用意
flipItSolver.h
#include “finiteGauss.h”int solve(int *x, int *b, int n, int q);
上の関数 solveで
int *x,[出力]解を記録するための配列
int *b, [入力]盤面の状態が記録された配列
int n, [入力]盤面のサイズ
int q, [入力]mod q で考える
という仕様.
上の関数 solve を Haskellで呼び出すには
{-# LANGUAGE ForeignFunctionInterface #-} import Foreign.C.Types (CInt) import Foreign.Ptr (Ptr)foreign import ccall “flipItSolver.h solve” c_solve :: Ptr CInt -> Ptr CInt -> CInt -> CInt -> IO CInt
とすれば良い.
Int -> CInt, CInt -> Int の変換は fromIntegral で可能.
しかし,ここで疑問が
(1) Ptr CIntってどうやって生成するのさ?
(2) Ptr CInt からどうやって値を読む?
(3) CInt にどうやって値を書く?
(4) 配列の場合は?
Haskell の Ptr の扱い
(1) Ptr a の作成
Foreign.Marshal.Alloc を使いましょう.
malloc と free があるのでそれを使う.C と同じ感覚だと思う.
malloc :: Storable a => IO (Ptr a) free :: Ptr a => IO ()
(2)(3) Ptr a の読み書き
Foreign.Storable を使いましょう.
peek :: Ptr a -> IO a poke :: Ptr a -> a -> IO ()
ちなみに,
peek は チラ見,のぞき見
poke は 突っ込む
という意味らしい. 関数の動作とも一致する.
(4) 配列の場合
Ptr a が 配列の場合には便利なインターフェースが用意されている.
mallocArray :: Storable a => Int -> IO (Ptr a) newArray :: Storable a => [a] -> IO (Ptr a) peekArray :: Storable a => Int -> Ptr a -> IO [a] pokeArray :: Storable a => Ptr a -> [a] -> IO ()
これを使えば,[a] で書き込んだり,読んだりできる.
実際に,C の関数を Haskell で利用する
updateAns :: Board -> Board -> Int -> IO () updateAns board ans m = do n <- size board b <- newArray.map fromIntegral =<< getElems board x <- mallocArray $ n * n csolve x b (fromIntegral n) (fromIntegral m) xs <- peekArray (n * n) x bounds <- getBounds ans zipWithM (writeArray ans) (range bounds) (map fromIntegral xs) free b free x
newArray と mallocArray で Ptr CInt を作成.
c_solve で C の関数 solve を呼びだして,解を x に記録.
x から [CInt] を読みだして,それを xs に格納.
xs の値を ans に zipWithM_ つかって書き込み.
free で確保したポインタを開放.
コンパイル
コンパイルが若干面倒.
今までは,ghc –make で特に何も考えずに楽々コンパイルできたが,Cの関数を使っている
それに対応しなくていはいけない.
といっても,gcc で C をコンパイルするだけ.
今回は
gcc -c finiteGauss.c gcc -c flipItSolver.c ghc –make -O2 GFlipIt.hs flipItSolver.o finiteGauss.o -o flipIt
(finiteGauss は flipItSolverで利用している.)
ソースコード
http://dl.dropbox.com/u/662567/flipIt.tar.xz
FlipIt.hs
{-# LANGUAGE ForeignFunctionInterface #-} module FlipIt (Board, size, inBoard, flipPanel, reset, shuffle) where import Control.Monad (liftM, when, forM, replicateM, zipWithM) import Data.Array.IO (IOUArray, readArray, writeArray, getBounds, range, getElems) import System.Random (randomRIO) import Foreign.C.Types (CInt) import Foreign.Ptr (Ptr) import Foreign.Marshal.Alloc (free) import Foreign.Marshal.Array (newArray, mallocArray, peekArray)– Monadic when and if whenM :: Monad m => m Bool -> m () -> m () whenM b f = b >>= flip when f
type Board = IOUArray (Int, Int) Int
size :: Board -> IO Int size = liftM (succ.fst.snd).getBounds
inBoard :: Board -> (Int, Int) -> IO Bool inBoard board (x, y) = do n <- size board return $ 0 <= x && x < n && 0 <= y && y < n
flipPanel :: Board -> Board -> Int -> (Int, Int) -> IO () flipPanel board ans m (x, y) = flipPanel_ board m (x, y) >> updateAns board ans m
flipPanel_ :: Board -> Int -> (Int, Int) -> IO () flipPanel_ board m (x, y) = do whenM (inBoard board (x, y)) $ forM_ [(x, y), (x+1, y), (x, y+1), (x-1, y), (x, y-1)] $ \ix -> whenM (inBoard board ix) $ writeArray board ix.(
mod
m).succ =<< readArray board ixreset :: Board -> Board -> IO () reset board ans = do bounds <- getBounds board forM_ (range bounds) $ \ix -> writeArray board ix 0 >> writeArray ans ix 0
shuffle :: Board -> Board -> Int -> IO () shuffle board ans m = do n <- size board r <- randomRIO (n, n*n) [xs, ys] <- replicateM 2.replicateM r $ randomRIO (0, n-1) mapM_ (flipPanel_ board m) $ zip xs ys updateAns board ans m
foreign import ccall “flipItSolver.h solve” c_solve :: Ptr CInt -> Ptr CInt -> CInt -> CInt -> IO CInt
updateAns :: Board -> Board -> Int -> IO () updateAns board ans m = do n <- size board b <- newArray.map fromIntegral =<< getElems board x <- mallocArray $ n * n csolve x b (fromIntegral n) (fromIntegral m) xs <- peekArray (n * n) x bounds <- getBounds ans zipWithM (writeArray ans) (range bounds) (map fromIntegral xs) free b free x
GFlipIt.hs
import Graphics.UI.Gtk hiding (fill) import Graphics.UI.Gtk.Gdk.EventM (EventM, EButton) import Graphics.Rendering.Cairo import Control.Monad (liftM, when, forM_) import Data.IORef import Data.Array.IO (newArray, readArray) import System.Environment (getArgs) import FlipIt (Board, size, flipPanel, reset, shuffle)updateCanvas :: DrawingArea -> Board -> Board -> Int -> IORef Bool -> EventM any Bool updateCanvas area board ans m cheat = do liftIO $ do win <- widgetGetDrawWindow area renderWithDrawable win $ drawBoard area board ans m cheat return True
updateBoard :: DrawingArea -> Board -> Board -> Int -> IORef Bool -> EventM EButton Bool updateBoard area board ans m cheat = do liftIO $ do (x, y) <- widgetGetPointer area (sw, sh, pw, ph) <- boardGetLength area board flipPanel board ans m (div x (floor $ sw + pw), div y (floor $ sh + ph)) updateCanvas area board ans m cheat
drawBoard :: DrawingArea -> Board -> Board -> Int -> IORef Bool -> Render () drawBoard area board ans m cheat = do setSourceRGB 0.5 0.5 0.5 paint (sw, sh, pw, ph) <- liftIO $ boardGetLength area board n <- liftIO $ size board c <- liftIO.readIORef $ cheat forM_ (sequence $ replicate 2 [0..n-1]) $ [i’, j’] -> do let [i, j] = map fromIntegral [i’, j’] x <- liftIO.readRatio board $ (i’, j’) if x == 1 then setSourceRGB 1 1 1 else setSourceRGB (0.7 * x) (0.7 * x) x rectangle (sw * (i+1) + pw * i) (sh * (j+1) + ph * j) pw ph fill when c $ do y <- liftIO.readRatio ans $ (i’, j’) when (y < 1) $ do setSourceRGB (1 - y) 0.9 (0.6 - 0.6 * y) rectangle (sw * (i+6) + pw * i) (sh * (j+6) + ph * j) (pw - 10sw) (ph - 10 sh) fill where ratio x = fromIntegral (m - 1 - x) / fromIntegral (m - 1) readRatio array = liftM ratio.readArray array
boardGetLength :: DrawingArea -> Board -> IO (Double, Double, Double, Double) boardGetLength area board = do (_w, _h) <- widgetGetSize area n <- liftM fromIntegral $ size board let w = fromIntegral _w h = fromIntegral _h space = 0.05 / (n + 1) panel = 0.95 / n return (space * w, space * h, panel * w, panel * h)
run :: Int -> Int -> IO () run _m n = do let m | notElem _m [2,3,5,7] = 2 | otherwise = _m initGUI – win (Window) – +— vbox (VBox) – +— can (DrawingArea) – +— hbox (HBox) – +– cls (Button) – +– rst (Button) – +– shf (Button) – +– cht (Button) win <- windowNew win
set
[windowTitle := “FlipIt!”, windowDefaultWidth := n * 50, windowDefaultHeight := n * 50 + 40, containerBorderWidth := 0] winonDestroy
mainQuit vbox <- vBoxNew False 0 can <- drawingAreaNew hbox <- hBoxNew False 0 cls <- buttonNewWithLabel “Close” rst <- buttonNewWithLabel “Reset” shf <- buttonNewWithLabel “Shuffle” cht <- buttonNewWithLabel “Cheat”containerAdd win vbox boxPackStart vbox can PackGrow 0 boxPackStart vbox hbox PackNatural 5 boxPackStart hbox cls PackGrow 0 boxPackStart hbox rst PackGrow 0 boxPackStart hbox shf PackGrow 0 boxPackStart hbox cht PackGrow 0 widgetShowAll win
board <- newArray ((0, 0), (n-1, n-1)) 0 ans <- newArray ((0, 0), (n-1, n-1)) 0 cheat <- newIORef False on can exposeEvent $ updateCanvas can board ans m cheat on can buttonPressEvent $ updateBoard can board ans m cheat on cls buttonPressEvent $ liftIO mainQuit >> return True on rst buttonPressEvent $ liftIO (reset board ans) >> updateBoard can board ans m cheat on shf buttonPressEvent $ liftIO (shuffle board ans m) >> updateBoard can board ans m cheat on cht buttonPressEvent $ liftIO (modifyIORef cheat not) >> updateBoard can board ans m cheat mainGUI
main :: IO () main = do args <- getArgs if length args < 2 then run 2 5 else run (read $ args!!0) (read $ args!!1)
flipItSolver
fliptItSolver.h
#include “finiteGauss.h”int solve(int *x, int *b, int n, int q);
flipItSolver.c
#include “flipItSolver.h”int di[5] = {0, 1, 0, -1, 0}; int dj[5] = {0, 0, 1, 0, -1};
// Ax = b (mod q) を x について解く // ガウスの消去法を使用する // A は FlipIt の隣接行列 // 0 = 解無し, 1 = 解有り int solve(int *x, int *b, int n, int q) {
int i, j, k, a = (int)malloc(sizeof(int*) * n * n);
for (i = 0; i < n * n; ++i) { a[i] = (int*)malloc(sizeof(int) * n * n + 1); }
for (i = 0; i < n * n; ++i) for (j = 0; j < n * n + 1; ++j) a[i][j] = 0;
for (i = 0; i < n; ++i) for (j = 0; j < n; ++j) for (k = 0; k < 5; ++k) if (0 <= i + di[k] && i + di[k] < n && 0 <= j + dj[k] && j + dj[k] < n) { a[n * i + j][n * (i + di[k]) + (j + dj[k])] = 1; }
for (i = 0; i < n * n; ++i) a[i][n * n] = b[i];
return gauss(a, x, n * n, n * n + 1, q); }
finiteGauss
finiteGauss.h
#include <stdio.h> #include <stdlib.h>int gauss(int **a, int *x, int m, int n, int q);
finiteGauss.c
#include “finiteGauss.h”// input : a, b // output : x, y s.t. ax + by = (符号付き)gcd(a, b) int extGcd(int a, int b, int *x, int *y) { if (b == 0) { *x = 1; *y = 0; return a; } int g = extGcd(b, a % b, y, x); (*y) -= (a / b) * (*x); return g; }
// xn = 1 (mod p) int invMod(int n, int p) { int x, y, g = extGcd (n, p, &x, &y); if (g == 1) return x; else if (g == -1) return -x; else return 0; // gcd(n, p) != 1,解なし }
// 有限体上の線型方程式系 Ax = b (mod q)を解く // a = [A | b]: m × n の係数行列 // x: 解を記録するベクトル // 計算量: O(min(m, n) * m * n) int gauss(int **a, int *x, int m, int n, int q) {
int rank = 0, i, j, k, l, pivot = (int)malloc(sizeof(int) * n);
// 前進消去 for (i = 0, j = 0; i < m && j < n-1; ++j) {
int p = -1, tmp = 0; // ピボットを探す for (k = i; p < 0 && k < m; ++k) { if (a[k][j] != 0) p = k; // 有限体上なので非零で十分 } // ランク落ち対策 if (p == -1) continue; // 第i行と第p行を入れ替える for (k = j; k < n; ++k) tmp = a[i][k], a[i][k] = a[p][k], a[p][k] = tmp; // 第i行を使って掃き出す for (k = i+1; k < m; ++k) { tmp = - a[k][j] * invMod(a[i][j], q) % q; for (l = j; l < n; ++l) a[k][l] = (a[k][l] + tmp * a[i][l]) % q; } // 第i行を正規化: a[i][j] = 1 にする tmp = invMod(a[i][j], q); for (k = j; k < n; ++k) a[i][k] = a[i][k] * tmp % q; pivot[i++] = j, rank++;
}
// 解の存在のチェック for (i = rank; i < m; ++i) if (a[i][n-1] != 0) { free(pivot); return 0; }
// 解をxに代入(後退代入) for (i = 0; i < rank; ++i) x[i] = a[i][n-1]; for (i = rank; i < n-1; ++i) x[i] = 0; for (i = rank-1; i >= 0; –i) { for (j = pivot[i] + 1; j < n-1; ++j) x[i] -= a[i][j] * x[j]; x[i] -= x[i] / q * q, x[i] = (x[i] + q) % q; // 0 <= x[i] < q に調整 }
free(pivot); return 1; }