Hatena::Grouphaskell

wanparkの日記

2008-01-09

教えてどこかのもみの木さん

クラスメソッドには、あらゆる型変数(定義しようとしているものを除く)の上の 制約を付加することができます。たとえば、

class C a where
  m                     :: Show b => a -> b

このようなクラスでは、メソッド m は型 b が Show クラスに属していることを要求します。

A Gentle Introduction to Haskell: Classes

とあるのですが、これのインスタンスを作ろうとするとエラーになります。どうすればよいのでしょうか。

class C a where
    m :: Show b => a -> b

instance C Int where
    m i = i
test.hs:5:10:
    Couldn't match expected type `b' (a rigid variable)
           against inferred type `Int'
      `b' is bound by the type signature for `m' at test.hs:2:12
    In the expression: i
    In the definition of `m': m i = i
    In the definition for method `m'

maoeくんにきいた

{-# OPTIONS -fglasgow-exts #-}
import Data.Char

class Show b => C a b | b -> a where
  m :: a -> b

instance C Int Int where
  m i = i

instance C Int Char where
  m i = chr i

instance C Int String where
  m i = show i

test = do
  print (m 1 :: Int)
  print (m 1 :: Char)
  print (m 1 :: String)

{- ちゃんとerrorになる
data Hoge

instance C Int Hoge where
  m = undefined
-}

ひとまずこれで動きはしますが、ということでした。

404 Not Found

うーん。

2007-12-05

Haskellプログラミング(9)

えーと、なんだっけ、n目並べを作るんだっけ。あれだよね、評価関数を作ってmin-maxとかalpha-betaとかやるんだよね。本かwebかで見たことある。

思考はおいといて、とりあえずプログラムの骨組み部分。

import System
import List
import Char
import Text.Regex

main = do args <- getArgs
          let [w, h] = map read args
           in play [Human black, AI white stupid] w h


play :: [Player] -> Int -> Int -> IO ()
play players w h = play' (cycle players) (createBoard w h)
    where play' ps board = do putStr (showBoard board)
                              let p   = head ps
                                  tok = token p
                              pos <- next p board
                              let board' = update pos tok board
                              if maxNarabe pos tok board' >= nmoku
                                then win p board'
                                else play' (tail ps) (board')

win :: Player -> Board -> IO ()
win p board = do putStr (showBoard board)
                 putStrLn (showToken (token p) ++ " win!")


------------------------------------------------------------------------
-- Board とかの構造
------------------------------------------------------------------------

nmoku :: Int  -- n 目並べ
nmoku = 4


type Position = (Int, Int)


type Token = Int

blank :: Token
blank = 0
black :: Token
black = 1
white :: Token
white = 2


type Board = [[Token]]

cell :: Position -> Board -> Token
cell (x, y) board = board !! y !! x

rows :: Board -> [[Token]]
rows = id


------------------------------------------------------------------------
-- Board handling
------------------------------------------------------------------------

-- Show のインスタンスにしたかったんだけど
-- -flasgow-exts -fallow-overlapping-instances をつけてもだめだった
showToken :: Token -> String
showToken token | token == black = "#"
                | token == white = "O"
                | otherwise      = "."

showBoard :: Board -> String
showBoard board = unlines $ sandwitch id [header] (zipWith formatRow [1..] (rows board))
    where sandwitch f s t = s ++ t ++ f s
          header = "    " ++ (unwords $ map (:[]) $ take (width board) ['a'..])
          formatRow n row = unwords $ sandwitch reverse [show n, "|"] $ map showToken row


width :: Board -> Int
width = length . head . rows

height :: Board -> Int
height = length . rows

createBoard :: Int -> Int -> Board
createBoard w h = take h $ repeat $ take w $ repeat blank

inBounds :: Position -> Board -> Bool
inBounds (x, y) board = inBounds' x (0, width board) &&
                        inBounds' y (0, height board)
    where inBounds' t (s, e) = t >= s && t < e

canPlace :: Position -> Board -> Bool
canPlace pos@(x, y) board = inBounds pos board && cell (x, y) board == blank

update :: Position -> Token -> Board -> Board
update (x, y) tok = replace y (replace x (const tok))

replace :: Int -> (a -> a) -> [a] -> [a]
replace pos f xs = take pos xs ++ [f (xs !! pos)] ++ drop (pos + 1) xs


-- pos に tok をおいた場合に並ぶ数
maxNarabe :: Position -> Token -> Board -> Int
maxNarabe (x, y) tok board = maximum $ map narabe [(1, 0), (0, 1), (1, 1)]
    where narabe dir     = 1 + count dir + count (negate dir)
          negate (x, y)  = (-x, -y)
          count (dx, dy) = length $ takeWhile (\pos -> inBounds pos board && cell pos board == tok) $ map (\n -> (x + dx * n, y + dy * n)) [1..]


------------------------------------------------------------------------
-- Player
------------------------------------------------------------------------

data Player = Human Token
            | AI Token Eval

-- 評価関数
type Eval = Token -> Board -> Score
type Score = Int

token :: Player -> Token
token (Human tok) = tok
token (AI tok _)  = tok

next :: Player -> Board -> IO Position
next (Human tok)   board = getNext tok board
next (AI tok eval) board = do let pos = thinkNext tok eval board
                              putStrLn $ "next " ++ showToken tok ++ " : " ++ showPosition pos
                              return pos

-- ユーザーに次の手を聞く
getNext :: Token -> Board -> IO Position
getNext tok board = do putStr $ "next " ++ showToken tok ++ " : "
                       input <- getLine
                       case readPosition input of
                         Just pos -> if canPlace pos board
                                     then return pos
                                     else getNext tok board
                         Nothing  -> getNext tok board

readPosition :: String -> Maybe Position
readPosition str = case matchRegex (mkRegx "^([a-z])([0-9])") str of
                     Just [x, y] -> return (ord (head x) - ord 'a', digitToInt (head y) - 1)
                     otherwise   -> Nothing

showPosition :: Position -> String
showPosition (x, y) = [chr (ord 'a' + x), intToDigit (y + 1)]

-- 次の手を考える
thinkNext :: Token -> Eval -> Board -> Position
thinkNext tok eval board = maximumFst $ map pairWithScore $ candidate board
    where maximumFst        = snd . head . sortBy (\a b -> fst b `compare` fst a)
          pairWithScore pos = (eval tok (update pos tok board), pos)

candidate :: Board -> [Position]
candidate board = filter (flip canPlace board) [(x, y) | x <- [0 .. width board - 1], y <- [0 .. height board - 1]]


------------------------------------------------------------------------
-- 評価関数
------------------------------------------------------------------------

stupid :: Eval
stupid tok board = 0

うーん、長いな。

2007-11-30

eval

文字列を haskell の式として評価する関数はないのでしょうか > System.Eval.Haskell っていうのがそうか。

Error 403 - Access Forbidden

$ ghci
Prelude> :m System.Eval.Haskell
Prelude System.Eval.Haskell> eval "1 + 2 :: Int" [] :: IO (Maybe Int)
Nothing

うぐぐ、インストール苦労したのに

できた

darcs get --set-scripts-executable http://www.cse.unsw.edu.au/~dons/code/hs-plugins

のソースを使ったら動いた。仕組みも使い方もさっぱりだけど。

2007-11-28

Haskellプログラミング(8) ペンシルパズルを解く

http://www.ipsj.or.jp/07editj/promenade/4611.pdf

二コリをよく買っていた時期があったけど、数独とカックロはなんか面倒でいつもとばしてたなー。

import List
import Char

main = do input <- getContents
          case solve $ readSudoku input of
            Just s  -> print s
            Nothing -> putStrLn "No solutions."


------------------------------------------------------------------------
-- データ構造
------------------------------------------------------------------------

type Token    = Int
type Position = (Int, Int)
data Sudoku   = Sudoku { cells :: [[Maybe Token]] }

instance Show Sudoku where
    show = unlines . map ((join '\t') . (map showCell)) . cells
        where showCell Nothing = ""
              showCell (Just tok) = show tok

readSudoku :: String -> Sudoku
readSudoku str = Sudoku $ map readRow (adjustLength size "" rows)
    where (info:rows)  = lines str
          size         = read info
          readRow      = map readMaybeInt . adjustLength size "" . split '\t'

size:: Sudoku -> Int
size = length . cells

cell :: Position -> Sudoku -> Maybe Token
cell (x, y) (Sudoku cells) = cells  !! y !! x

tokens :: Sudoku -> [Token]
tokens sudoku = [1 .. size sudoku]


------------------------------------------------------------------------
-- Sudoku handling
------------------------------------------------------------------------

update :: Position -> Token -> Sudoku -> Sudoku
update (x, y) tok = Sudoku . replace y (replace x (const $ Just tok)) . cells

valid :: Position -> Sudoku -> Bool
valid (x, y) sudoku = all uniq [row, line, box]
    where s  = size sudoku
          ms = floor $ sqrt $ fromIntegral s
          mx = x `div` ms * ms
          my = y `div` ms * ms
          row  = [(i, y) | i <- [0 .. (s - 1)]]
          line = [(x, i) | i <- [0 .. (s - 1)]]
          box  = [(i, j) | i <- [mx .. (mx + ms - 1)], j <- [my .. (my + ms - 1)]]
          uniq positions = let toks = removeNothing $ map (flip cell sudoku) positions
                           in length toks == length (nub toks)


------------------------------------------------------------------------
-- solve
------------------------------------------------------------------------

solve :: Sudoku -> Maybe Sudoku
solve sudoku = case nextSpace sudoku of
                 Nothing  -> Just sudoku
                 Just pos -> (find (not . isNothing) $ map (flip (assume pos) sudoku) (tokens sudoku)) >>= id

assume :: Position -> Token -> Sudoku -> Maybe Sudoku
assume pos tok sudoku = let updated = update pos tok sudoku
                        in  if valid pos updated
                            then solve updated
                            else Nothing

nextSpace :: Sudoku -> Maybe Position
nextSpace (Sudoku cells) = do let indexes = map (findIndex isNothing) cells
                              y <- findIndex (not . isNothing) indexes
                              x <- indexes !! y
                              return (x, y)


------------------------------------------------------------------------
-- basic functions
------------------------------------------------------------------------

join :: a -> [[a]] -> [a]
join sep = foldl1 (\ x y -> x ++ (sep:y))

split :: Eq a => a -> [a] -> [[a]]
split _   [] = []
split sep xs = group : split sep rest
    where (group, rest') = break (==sep) xs
          rest = if null rest' then [] else tail rest'

readMaybeInt :: String -> Maybe Int
readMaybeInt str = case filter (not . isSpace) str of
                     "" -> Nothing
                     s  -> Just $ read s

adjustLength :: Int -> a -> [a] -> [a]
adjustLength size fill xs = take size xs ++ take (max 0 (size - (length xs))) (repeat fill)

replace :: Int -> (a -> a) -> [a] -> [a]
replace pos f xs = take pos xs ++ [f (xs !! pos)] ++ drop (pos + 1) xs

isNothing :: Maybe a -> Bool
isNothing Nothing = True
isNothing _ = False

removeNothing :: [Maybe a] -> [a]
removeNothing = foldr f []
    where f (Just x) xs = x:xs
          f _        xs = xs
$ cat data.txt
9
8				3	4		5
		2						1
	1		9
		8			9			6
5				1				8
6			4			7
					1		7
2						1
	9		5	6				2
$ runghc sudoku.hs < data.txt
8	6	7	1	3	4	2	5	9
9	5	2	6	7	8	3	4	1
4	1	3	9	5	2	6	8	7
7	4	8	3	2	9	5	1	6
5	3	9	7	1	6	4	2	8
6	2	1	4	8	5	7	9	3
3	8	6	2	4	1	9	7	5
2	7	5	8	9	3	1	6	4
1	9	4	5	6	7	8	3	2

1マスごとに全数字を試す。反省点

  • 遅い。9x9でぎりぎり
    • 全マスに置ける数字を計算しておく -> 1つの数字しか置けないマスは確定 -> ... とやるとだいぶましになる
  • 引数の最後に Sudoku を渡すパターンは State で書くとよいと思う
  • Maybe を無理やり目に使ってみたけど、ぎこちない
  • Sudoku のデータ構造を外に漏らすな。traverse とか書けばいいんだけど。Traversable っていうのを実装するのが標準的?
  • print デバッグができなくて大変だ。いやテストを書けと

本文読んだ

わかった


数値リテラルと型変換は違う

Num クラスに属する型は数値リテラルを使える。

instance Num MyType where ...

fromLiteral :: MyType = 1      -- OK

だからといって、例えば Int から勝手に型を変換してくれるわけではない。Haskell には暗黙の型変換はない。

i :: Int = 1
fromFunction :: MyType = i     -- NG

nobsun に教えてもらいました。助かります。


Haskellプログラミング(6) 文字列間の距離-モナドを使って-

http://www.ipsj.or.jp/07editj/promenade/4609.pdf

レーベンシュタイン距離を計算する。

data Operator = Insert Char
              | Delete
              | Substitute Char
              | Ident
                deriving Eq

align :: String -> String -> [Operator]
align [] []     = []
align (x:xs) [] = Delete   : align xs []
align [] (x:xs) = Insert x : align [] xs
align xxs@(x:xs) yys@(y:ys) = if x == y
                              then Ident : align xs ys
                              else shortest [Delete       : align xs yys,
                                             Insert y     : align xxs ys,
                                             Substitute y : align xs ys]
shortest = snd . foldl1 (\ a b -> if fst a > fst b then b else a) . map (\a -> (length $ filter (/= Ident) a, a))


showAlignment :: String -> String -> String
showAlignment from to = unlines ["Levenshtein distance: " ++ show (distance operators),
                                 showSkipWord isInsert from operators,
                                 showHomology operators,
                                 showSkipWord (== Delete) to operators]
    where
      operators = align from to
      distance = length . filter (/= Ident)
      isInsert (Insert _) = True
      isInsert _ = False
      showSkipWord :: (Operator -> Bool) -> String -> [Operator] -> String
      showSkipWord _ []  _ = ""
      showSkipWord _ cs [] = cs
      showSkipWord skip ccs@(c:cs) (op:ops) = if skip op
                                              then ' ' : showSkipWord skip ccs ops
                                              else c   : showSkipWord skip cs  ops
      showHomology = map (\op -> if op == Ident then '|' else ' ')
*Main> putStr $ showAlignment "kitten" "sitting"
Levenshtein distance: 3
kitten
 ||| |
sitting

DNA の alignment っぽく表示してみました。単に距離を求めるだけなら

distance :: String -> String -> Int
distance [] xs = length xs
distance xs [] = length xs
distance xxs@(x:xs) yys@(y:ys) = if x == y
                                 then distance xs ys
                                 else 1 + minimum [distance xs ys,
                                                   distance xxs ys,
                                                   distance xs yys]

Page not found · GitHub Pages の Memo モジュールを使ってメモ化する。ghc6.6 の場合、-fglasgow-exts オプションをつけないといけないみたいです。

import Memo
import Monad

data Ord a => ListTable a b  = ListTable [(a, b)]

instance Table ListTable where
    emptyTable = ListTable []
    lookupTable key (ListTable []) = Nothing
    lookupTable key tbl@(ListTable ((k, v):rest)) | key >  k  = Nothing
                                                  | key == k  = Just v
                                                  | otherwise = lookupTable key (ListTable rest)
    insertTable k v (ListTable list) = case break ((k >) . fst) list of
                                         (xs, ys) -> ListTable (xs ++ (k, v):ys)


mdistance :: Memo ListTable (String, String) Int
mdistance ([],   to) = return $ length to
mdistance (from, []) = return $ length from
mdistance (from, to) = memoise (\ (xxs@(x:xs), yys@(y:ys)) ->
                                    if x == y
                                    then mdistance (xs, ys)
                                    else 1 + liftM minimum (sequence [mdistance (xs,  ys),
                                                                      mdistance (xxs, ys),
                                                                      mdistance (xs,  yys)])) (from, to)

evalMdistance ::String -> String -> Int
evalMdistance from to = evalMemo mdistance (from, to)

"mdistance ([], to) = return $ length to" の return はいらないと思うんだけど、ないとエラーになる。暗黙の型変換を理解してない。

記事を読んだ。

先頭の文字が一致している時の挙動

その場合無条件に変換なしとしても最小距離は変わらない、と思ったんだけど、違うのかな。いや違くないよな。

Data.Map

lookup が O(n) から O(log n) になる。普通の配列でやれば O(1) だけど、と最後に言ってる

表示のやり方

なるほどーうまいねー

結局

前回の連載「記憶する関数」は理解されないこと前提だったのですか

nobsunnobsun2007/11/28 23:48Haskell には暗黙の型変換はありません。
length to の型は Int です。mdistance の型は Memo ListTable (String,String) Int
すなわち (String,String) -> State (ListTable (String,String) Int ですので、
return なしでは型があいません。

wanparkwanpark2007/11/29 03:19ありがとうございます。暗黙の型変換はそもそもないんですか。数値リテラルと型変換を混同していたようです。

2007-11-27

Stateによるメモ化を理解すべくがんばる

http://www.sampou.org/cgi-bin/haskell.cgi?Memoise

フィボナッチ数

fib :: Integer -> Integer
fib 0 = 0
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

これをメモ化

type Table = [(Integer,Integer)]

fib :: Integer -> Integer
fib = fst . flip memofib []

memofib :: Integer -> Table -> (Integer,Table)
memofib 0 mt = (0, (0,0):mt)
memofib 1 mt = (1, (1,1):mt)
memofib n mt = case prev of
                 Just r    -> (r , mt)
                 Nothing   -> (r1+r2, (n,r1+r2):tb2)
                where
                  prev = lookup n mt
                  (r1,tb1) = memofib (n-1) mt
                  (r2,tb2) = memofib (n-2) tb1

ここまではいいんだけど、memoise とか言い出すところからついていけない。まず State モナドを返すように memofib を変える。

import Control.Monad.State

type Table = [(Integer,Integer)]

fib :: Integer -> Integer
fib n = evalState (memofib n) []

memofib :: Integer -> State Table Integer
memofib 0 = return 0
memofib 1 = return 1
memofib n = State (\mt -> let prev = lookup n mt
                              (r1,tb1) = runState (memofib (n-1)) mt
                              (r2,tb2) = runState (memofib (n-2)) tb1
                          in case prev of
                               Just r    -> (r , mt)
                               Nothing   -> (r1+r2, (n,r1+r2):tb2))

あんまり変わってない。次に memoise を理解できる形で書いてみる。

memoise :: (Integer -> State Table Integer) -> Integer -> State Table Integer
memoise f n = State (\mt -> case lookup n mt of
                              Just r  -> (r, mt)
                              Nothing -> let (r, tb) = runState (f n) mt
                                         in  (r, (n, r):tb))

テーブルの検索、結果の挿入を抜き出しているわけですね。memoise を使って memofib を書き直す。

fib :: Integer -> Integer
fib n = evalState (memofib n) []

memofib :: Integer -> State Table Integer
memofib 0 = return 0
memofib 1 = return 1
memofib n = memoise memofib' n

memofib' :: Integer -> State Table Integer
memofib' n = State (\mt -> let (r1,tb1) = runState (memofib (n-1)) mt
                               (r2,tb2) = runState (memofib (n-2)) tb1
                           in  (r1 + r2, tb2))

やってることはわかった。これをモナドっぽく書き直すのに使うのはこのへん。

instance Monad (State s) where
        return a = State $ \s -> (a, s)
        m >>= k  = State $ \s -> let
                (a, s') = runState m s
                in runState (k a) s'

instance MonadState s (State s) where
        get   = State $ \s -> (s, s)
        put s = State $ \_ -> ((), s)

>>= は、State s aa の演算を繋げて s を後ろで受け渡す。get は s にある状態を a に持ってきて操作できるように、put は逆に s に持っていく。

つかんだね、これは。連載の両替何通り問題でやってみる。

type Amount = Integer
type Coin   = Integer
type Count  = Integer

cc :: Amount -> [Coin] -> Count
cc 0 _  = 1
cc _ [] = 0
cc a ccs@(c:cs)
       | a < 0     = 0
       | otherwise = cc (a - c) ccs
                   + cc a       cs

メモ化する

import Control.Monad.State

memoise f x = find x                  >>= \ prev ->
              case prev of
                Just r  -> return r
                Nothing -> f x        >>= \ r ->
                           ins (x, r) >>  return r
ins item = get >>=  put . (item:)
find n = get >>= return . lookup n


type Amount = Integer
type Coin   = Integer
type Count  = Integer

cc :: Amount -> [Coin] -> Count
cc a cs = evalState (memocc (a, cs)) []

memocc :: (Amount, [Coin]) -> State [((Amount, [Coin]), Count)] Count
memocc (0, _ ) = return 1
memocc (_, []) = return 0
memocc (ammount, coins)
    | ammount < 0 = return 0
    | otherwise   = memoise (\ (a, ccs@(c:cs)) ->
                                 if a < 0
                                 then return 0
                                 else liftM2 (+) (memocc ((a - c), ccs)) (memocc (a, cs)))
                            (ammount, coins)

載ってるのそのままだけど。

こないだの、指定leaf数の木を列挙するやつ

trees :: Int -> [Tree]
trees = flip evalState [] . mtrees

mtrees :: Int -> State [(Int, [Tree])] [Tree]
mtrees 1 = return [Leaf]
mtrees n = memoise (\n' -> let treesL i = do ts1 <- mtrees i
                                             ts2 <- mtrees (n' - i)
                                             return [Node t1 t2 | t1 <- ts1, t2 <- ts2]
                               concatMapM f xs = liftM concat (mapM f xs)
                           in  concatMapM treesL [1..(n'-1)]) n

無名関数の中で where って使えないの?

mtl - A monad transformer library

Control.Monad 以下の色々がないのは、mtl というパッケージを入れてないから。

$ ghc-pkg list

でインストール済みパッケージを一覧できる。GHC 6.6 download ? The Glasgow Haskell Compiler にある ghc-6.6-src-extralibs.tar.bz2 を展開した中の mtl ディレクトリで

$ runghc Setup.hs configure
$ runghc Setup.hs build
$ runghc Setup.hs install

でインストールできる。

というのを 本物のプログラマはHaskellを使う - 第6回 局所的な「状態」を利用するためのStateモナド:ITpro で学んだ。