-
-
Save nna774/3987001 to your computer and use it in GitHub Desktop.
subset of shougi?
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- https://twitpic.com/aynpyj これ | |
-- これ自体の詳細は不明 | |
-- http://ideone.com/25TF8 ここで軽く動かしてる | |
{-# OPTIONS | |
-XMultiParamTypeClasses | |
-XFunctionalDependencies | |
-XFlexibleInstances | |
#-} | |
import Monad | |
import Data.List | |
import Data.Maybe | |
import Control.Monad | |
import Control.Applicative | |
--import Control.Monad.State | |
---------- | |
newtype State s a = State { runState :: s -> (a, s) } | |
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' | |
class (Monad m) => MonadState s m | m -> s where | |
get :: m s | |
put :: s -> m () | |
instance MonadState s (State s) where | |
get = State $ \s -> (s, s) | |
put s = State $ \_ -> ((), s) | |
evalState :: State s a -- The state to evaluate | |
-> s -- An initial value | |
-> a -- The return value of the state application | |
evalState m s = fst (runState m s) | |
execState :: State s a -- The state to evaluate | |
-> s -- An initial value | |
-> s -- The new state | |
execState m s = snd (runState m s) | |
gets :: (MonadState s m) => (s -> a) -> m a | |
gets f = do | |
s <- get | |
return (f s) | |
modify :: (MonadState s m) => (s -> s) -> m () | |
modify f = do | |
s <- get | |
put (f s) | |
------------------------- | |
(<.>) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) | |
(<.>) f g = (f.).g | |
{- | |
comb :: (a -> b) -> (c -> d -> a) -> c -> d -> b | |
comb f g x y = f $ g x y | |
-} | |
fst3 :: (a,b,c) -> a | |
fst3 (x,_,_) = x | |
snd3 :: (a,b,c) -> b | |
snd3 (_,y,_) = y | |
thd3 :: (a,b,c) -> c | |
thd3 (_,_,z) = z | |
data KomaType = Hei | Hi | Hime | Ki | KiDo | King | YKing deriving (Show,Eq,Read,Ord,Enum) | |
data Player = P1 | P2 deriving (Show,Eq,Read,Ord,Enum) | |
type Point = (Int,Int) -- (x,y) Zero-origin | |
type Koma = (Player,KomaType,Point) | |
type Board = [ Koma ] | |
type Hand = (Point,Point) -- (OldPoint,NewPoint) | |
data MoveType = Zero | One | Inf deriving (Show,Eq,Read,Ord,Enum) | |
data MoveDir = Dir { dir1,dir2,dir3,dir4,dir6,dir7,dir8,dir9 :: MoveType } deriving (Show,Eq,Read) | |
type Turn = (Player,Hand) | |
moveTypeP1 :: KomaType -> MoveDir | |
moveTypeP1 Hei = Dir { dir1=Zero,dir2=Zero,dir3=Zero,dir4=Zero,dir6=Zero,dir7=One,dir8=One,dir9=One } | |
moveTypeP1 Hi = Dir { dir1=Zero,dir2=Inf,dir3=Zero,dir4=Inf,dir6=Inf,dir7=Zero,dir8=Inf,dir9=Zero } | |
moveTypeP1 Hime = Dir { dir1=Zero,dir2=One,dir3=Zero,dir4=One,dir6=One,dir7=One,dir8=One,dir9=One } | |
moveTypeP1 Ki = Dir { dir1=One,dir2=One,dir3=One,dir4=One,dir6=One,dir7=One,dir8=One,dir9=One } | |
moveTypeP1 KiDo = Dir { dir1=Inf,dir2=Inf,dir3=Inf,dir4=Inf,dir6=Inf,dir7=Inf,dir8=Inf,dir9=Inf } | |
moveTypeP1 King = Dir { dir1=One,dir2=One,dir3=One,dir4=One,dir6=One,dir7=One,dir8=One,dir9=One } | |
moveTypeP1 YKing = Dir { dir1=Zero,dir2=One,dir3=Zero,dir4=Zero,dir6=Zero,dir7=Zero,dir8=One,dir9=Zero } | |
moveTypeP1 _ = error "unknown arg on calling 'moveType'" | |
moveTypeP2 :: KomaType -> MoveDir | |
moveTypeP2 Hei = Dir { dir1=One,dir2=One,dir3=One,dir4=Zero,dir6=Zero,dir7=Zero,dir8=Zero,dir9=Zero } | |
moveTypeP2 Hi = Dir { dir1=Zero,dir2=Inf,dir3=Zero,dir4=Inf,dir6=Inf,dir7=Zero,dir8=Inf,dir9=Zero } | |
moveTypeP2 Hime = Dir { dir1=One,dir2=One,dir3=One,dir4=One,dir6=One,dir7=Zero,dir8=One,dir9=Zero } | |
moveTypeP2 Ki = Dir { dir1=One,dir2=One,dir3=One,dir4=One,dir6=One,dir7=One,dir8=One,dir9=One } | |
moveTypeP2 KiDo = Dir { dir1=Inf,dir2=Inf,dir3=Inf,dir4=Inf,dir6=Inf,dir7=Inf,dir8=Inf,dir9=Inf } | |
moveTypeP2 King = Dir { dir1=One,dir2=One,dir3=One,dir4=One,dir6=One,dir7=One,dir8=One,dir9=One } | |
moveTypeP2 YKing = Dir { dir1=Zero,dir2=One,dir3=Zero,dir4=Zero,dir6=Zero,dir7=Zero,dir8=One,dir9=Zero } | |
moveTypeP2 _ = error "unknown arg on calling 'moveTypeP2'" | |
moveType :: Player -> KomaType -> MoveDir | |
moveType P1 t = moveTypeP1 t | |
moveType P2 t = moveTypeP2 t | |
anotherPlayer :: Player -> Player | |
anotherPlayer P1 = P2 | |
anotherPlayer P2 = P1 | |
isInBoard :: Point -> Bool | |
isInBoard (x,y) = and [ x >= 0 , 3 >= x , y >= 0 , 7 >= y ] | |
newBoard :: Board | |
newBoard = | |
[ | |
(P2,Hi,(0,0)) , (P2,King,(1,0)) , (P2,Ki,(2,0)) , (P2,Hime,(3,0)) , | |
(P2,Hei,(0,1)) , (P2,Hei,(1,1)) , (P2,Hei,(2,1)) , (P2,Hei,(3,1)) , | |
(P1,Hei,(0,6)) , (P1,Hei,(1,6)) , (P1,Hei,(2,6)) , (P1,Hei,(3,6)) , | |
(P1,Hi,(0,7)) , (P1,King,(1,7)) , (P1,Ki,(2,7)) , (P1,Hime,(3,7)) | |
] | |
nextPossibleBoard :: Board -> [ Board ] | |
nextPossibleBoard = undefined | |
showBoard :: Board -> String | |
--showBoard = unlines . map show | |
showBoard board = unlines $ map f [0..7] | |
where | |
f y = intercalate "," $ map (g y) [0..3] | |
g y x = maybe "void" (\(p,t) -> show p ++ show t) $ koma (x,y) | |
koma p = lookup p $ map (\(player,t,point) -> (point,(player,t))) board | |
impKoma :: Board -> Point -> [Koma] | |
impKoma board point = filter ((==point).thd3) board | |
exiKoma :: Board -> Point -> Bool | |
exiKoma = ([] /=) <.> impKoma | |
getKoma :: Board -> Point -> Koma -- pointが空で無いことを仮定 | |
getKoma = head <.> impKoma | |
getKomaM :: Board -> Point -> Maybe Koma | |
getKomaM = listToMaybe <.> impKoma | |
elimKoma :: Board -> Point -> Board | |
elimKoma board point = filter ((/=point).thd3) board | |
putKoma :: Board -> Koma -> Board | |
putKoma board koma@(_,_,point) = koma : elimKoma board point | |
move :: Board -> Hand -> Board -- 駒の種類に関わらず問答無用に駒を動かす また、oldの位置に何も無かった場合死ぬ | |
move board (old,new) = putKoma afterBoard $ (\(p,t,_) -> (p,t,new)) $ getKoma board old | |
where afterBoard = elimKoma board old | |
safeMove :: Board -> Hand -> Maybe Board -- 駒の種類的に動けない場合Nothing 何も無いところから動かそうとしてもNothing | |
safeMove board hand@(old,_) = getKomaM board old >> f board hand | |
where f board hand = guard (isPossibleHand board hand) >> return (move board hand) | |
isPossibleHand :: Board -> Hand -> Bool | |
isPossibleHand board (old,new) = koma /= Nothing && isInBoard new && (f diff $ moveType player komaType) | |
where | |
koma = getKomaM board old | |
(player,komaType,_) = fromJust koma | |
diff = (fst new - fst old,-(snd new - snd old)) | |
f (1,1) dir = dir9 dir > Zero | |
f (0,1) dir = dir8 dir > Zero | |
f (-1,1) dir = dir7 dir > Zero | |
f (1,0) dir = dir6 dir > Zero | |
f (0,0) _ = False | |
f (-1,0) dir = dir4 dir > Zero | |
f (1,-1) dir = dir3 dir > Zero | |
f (0,-1) dir = dir2 dir > Zero | |
f (-1,-1) dir = dir1 dir > Zero | |
f (n,0) dir = if n>0 then dir6 dir == Inf else dir4 dir == Inf | |
f (0,n) dir = if n>0 then dir8 dir == Inf else dir2 dir == Inf | |
f (n,m) dir | n == m = if n>0 then dir9 dir == Inf else dir1 dir == Inf | |
| n == -m = if n>0 then dir3 dir == Inf else dir7 dir == Inf | |
| otherwise = False | |
f d komaMove = error "never come" | |
isOwnKoma :: Player -> Board -> Point -> Bool | |
isOwnKoma player = maybe False ((==player) .fst3) <.> getKomaM | |
safeMoves :: Board -> [Hand] -> Maybe Board | |
safeMoves = foldM safeMove | |
readM :: (Read a) => String -> IO (Maybe a) | |
readM s = catch (readIO s >>= (return . Just)) (const $ return Nothing) | |
getHandIOM :: IO (Maybe Hand) | |
getHandIOM = getLine >>= readM | |
getHandIO :: IO Hand | |
getHandIO = h | |
where h = getHandIOM >>= maybe (putStrLn "Invalid Input" >> h) return | |
isPossibleTurn :: Board -> Turn -> Bool | |
isPossibleTurn board (player,hand@(old,_)) = isOwnKoma player board old && isPossibleHand board hand | |
turnM :: Board -> Turn -> Maybe Board | |
turnM board (player,hand) = guard (isOwnKoma player board $ fst hand) >> safeMove board hand | |
turnIO :: Board -> Player -> IO Board | |
turnIO board player = putStr (show player)>> putStrLn "! Input Your Hand">> h | |
where h = fmap (curry (turnM board) player) getHandIO >>= maybe (putStrLn "Impossible Move" >> h) return | |
turnIOs :: Board -> Player -> IO () | |
turnIOs board player = do | |
b <- turnIO board player | |
putStrLn . showBoard $ b | |
maybe (putStr "Next " >> turnIOs b (anotherPlayer player) ) (putStr . (\x -> show x ++ " won!!") ) (existWinner b) | |
existWinner :: Board -> Maybe Player | |
existWinner board = if haveKing (playerKomas P1) then if haveKing (playerKomas P2) then Nothing else Just P1 else Just P2 | |
where | |
playerKomas player = map snd3 $ filter ((==player).fst3) board | |
haveKing :: [KomaType] -> Bool | |
haveKing [] = False | |
haveKing (x:xs) = x == King || x == YKing || haveKing xs | |
--turns :: Board -> [ ] -> Board | |
--turns = foldl turn | |
{- | |
game :: Board -> IO () | |
game board = showBoard . fromJust <$> nextBoard >>= putStr >> nextBoard >>= game . fromJust | |
where nextBoard = safeMove board <$> getHandIO | |
-} | |
--main = print $ getKoma newBoard (3,0) | |
--main = print $ moveS ((3,0),(3,3)) newBoard | |
--main = putStr $ showBoard $ flip move ((3,5),(2,4)) $ move newBoard ((3,0),(3,5)) | |
--main = mapM putStrLn $ map (show.moveTypeP1) [Hei .. YKing] | |
--main = print $ map (\new -> isPossibleHand newBoard ((0,1),new) ) [(0,0),(1,1),(0,2),(1,2),(2,2)] | |
--main = print $ getKomaM newBoard (0,6) | |
--main = print $ moveType P1 Hei | |
--main = print $ dir9 $ moveType P1 Hei | |
--main = print $ (\(old,new) -> (fst new - fst old,snd new - snd old) ) ((0,6),(0,5)) | |
--main = turnIO newBoard P1>>= putStr . showBoard | |
main = turnIOs newBoard P1 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
良い感じに書き直せるところあれば, ぜひお教え下さいです.