HaskellでGUI #2 FliptItの改良：FFIの利用
コンテンツ
(今回は 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 c_solve 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 ix
reset :: 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
c_solve 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 - 10*sw) (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]
win `onDestroy` 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;
}
作成者 Toru Mano
最終更新時刻 2023-01-01 (c70d5a1)