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
FFI cook book - HaskellWiki
http://haskell.org/ghc/docs/latest/html/libraries/base-4.2.0.0/Foreign.html

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 を使いましょう．
http://haskell.org/ghc/docs/latest/html/libraries/base-4.2.0.0/Foreign-Marshal-Alloc.html

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

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

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

Foreign.Storable を使いましょう．
http://haskell.org/ghc/docs/latest/html/libraries/base-4.2.0.0/Foreign-Storable.html

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

ちなみに，
peek は チラ見，のぞき見
poke は 突っ込む
という意味らしい． 関数の動作とも一致する．

(4) 配列の場合

Ptr a が 配列の場合には便利なインターフェースが用意されている．
http://haskell.org/ghc/docs/latest/html/libraries/base-4.2.0.0/Foreign-Marshal-Array.html

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;
}