クラスメソッドには、あらゆる型変数(定義しようとしているものを除く)の上の 制約を付加することができます。たとえば、
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'
{-# 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 -}
ひとまずこれで動きはしますが、ということでした。
7.6.?Class and instances declarations
うーん。
えーと、なんだっけ、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
うーん、長いな。
文字列を haskell の式として評価する関数はないのでしょうか > System.Eval.Haskell っていうのがそうか。
$ 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
のソースを使ったら動いた。仕組みも使い方もさっぱりだけど。
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マスごとに全数字を試す。反省点
わかった
Num クラスに属する型は数値リテラルを使える。
instance Num MyType where ... fromLiteral :: MyType = 1 -- OK
だからといって、例えば Int から勝手に型を変換してくれるわけではない。Haskell には暗黙の型変換はない。
i :: Int = 1 fromFunction :: MyType = i -- NG
nobsun に教えてもらいました。助かります。
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]
Memoise の 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 はいらないと思うんだけど、ないとエラーになる。暗黙の型変換を理解してない。
記事を読んだ。
その場合無条件に変換なしとしても最小距離は変わらない、と思ったんだけど、違うのかな。いや違くないよな。
lookup が O(n) から O(log n) になる。普通の配列でやれば O(1) だけど、と最後に言ってる
なるほどーうまいねー
前回の連載「記憶する関数」は理解されないこと前提だったのですか
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 a の a の演算を繋げて 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 って使えないの？
Control.Monad 以下の色々がないのは、mtl というパッケージを入れてないから。
$ ghc-pkg list
でインストール済みパッケージを一覧できる。GHC: Download version 6.6 にある ghc-6.6-src-extralibs.tar.bz2 を展開した中の mtl ディレクトリで
$ runghc Setup.hs configure $ runghc Setup.hs build $ runghc Setup.hs install
でインストールできる。
というのを 第6回 局所的な「状態」を利用するためのStateモナド - 本物のプログラマはHaskellを使う：ITpro で学んだ。
length to の型は Int です。mdistance の型は Memo ListTable (String,String) Int
すなわち (String,String) -> State (ListTable (String,String) Int ですので、
return なしでは型があいません。