subset of shougi?

s.hs

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

良い感じに書き直せるところあれば, ぜひお教え下さいです.