(今回は 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

FFI cook book – HaskellWiki

404 Not Found

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 を使いましょう．

404 Not Found

malloc と free があるのでそれを使う．C と同じ感覚だと思う．

malloc :: Storable a => IO (Ptr a)
free :: Ptr a => IO ()

(2)(3) Ptr a の読み書き

Foreign.Storable を使いましょう．

404 Not Found

peek :: Ptr  a -> IO  a
poke :: Ptr a -> a -> IO ()

ちなみに，

peek は チラ見，のぞき見

poke は 突っ込む

という意味らしい． 関数の動作とも一致する．

(4) 配列の場合

Ptr a が 配列の場合には便利なインターフェースが用意されている．

404 Not Found

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 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
  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]
  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 &lt; 0 && k &lt; m; ++k) {
  if (a[k][j] != 0) p = k;  // 有限体上なので非零で十分
}


// ランク落ち対策
if (p == -1) continue;


// 第i行と第p行を入れ替える
for (k = j; k &lt; n; ++k)
  tmp = a[i][k], a[i][k] = a[p][k], a[p][k] = tmp;


// 第i行を使って掃き出す
for (k = i+1; k &lt; m; ++k) {
  tmp = - a[k][j] * invMod(a[i][j], q) % q;
  for (l = j; l &lt; 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 &lt; 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;
}