Skip to content

Instantly share code, notes, and snippets.

@chiral
Last active September 29, 2020 01:36
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save chiral/7295637 to your computer and use it in GitHub Desktop.
Save chiral/7295637 to your computer and use it in GitHub Desktop.
Quantum Shogi Program in Haskell
------------------------------------------------------------
-- Quantum Shogi Program in Haskell
------------------------------------------------------------
module Main where
import System.Environment
import Data.Maybe
import Data.List
import Data.Char
import Control.Monad
import Control.Monad.Error
import Data.IntMap (IntMap,(!))
import qualified Data.IntMap as IM
import Data.BitSet.Word (BitSet,(\\))
import qualified Data.BitSet.Word as BS
data Color = Black | White deriving (Eq, Enum, Show)
which :: Color -> (a,a) -> a
which Black = fst
which White = snd
whichUpdate :: Color -> (a->a) -> (a,a) -> (a,a)
whichUpdate Black f (x,y) = (f x,y)
whichUpdate White f (x,y) = (x,f y)
opp Black = White
opp White = Black
type Pos = (Int,Int)
toX = fst
toY = snd
isOB (x,y) = x<1 || x>9 || y<1 || y>9
data PieceType = Pawn | Lance | Knight | Silver | Gold |
Bishop | Rook | King deriving (Eq, Enum, Show)
type PieceQuantum = BitSet PieceType
allPT = enumFromTo Pawn King
allPQ = BS.fromList allPT
type Promoted = Bool
type Owner = Color
type PieceIndex = Int -- [0..39]
type Piece = (PieceQuantum,Promoted,Owner,PieceIndex)
origin :: PieceIndex -> Color
origin pi = if (pi<20) then Black else White
type Square = (Pos, Maybe Piece)
type Board = IntMap Piece
-- board key: [0..39] -> piece in hands
-- [40..120] -> piece on squares
toKey :: Pos -> Int
toKey (x,y) = x*9+y+30 -- eqivalent to (x-1)*9+(y-1)+40
infixl 9 `at`
at :: Board -> Pos -> Square
at board pos = (pos, IM.lookup (toKey pos) board)
setAt :: Pos -> Piece -> Board -> Board
setAt pos = IM.insert (toKey pos)
delAt :: Pos -> Board -> Board
delAt pos = IM.delete (toKey pos)
setHand :: PieceIndex -> Piece -> Board -> Board
setHand = IM.insert
delHand :: PieceIndex -> Board -> Board
delHand = IM.delete
type Direction = Int
type Dir = Direction
type DirSet = BitSet Dir
type ShortDirs = DirSet
type LongDirs = DirSet
type PieceDirs = (ShortDirs,LongDirs)
type Distance = Int
whichDS :: Distance -> PieceDirs -> DirSet
whichDS distance = case distance of 1->fst; otherwise->snd
-- direction specification
-- +-+-+-+
-- |9|/|8|
-- +-+-+-+
-- |5|0|4|
-- +-+-+-+
-- |3|*|2| <-- center sq is on *
-- +-+-+-+
-- |7|1|6|
-- +-+-+-+
piece_dirs :: [PieceDirs]
piece_dirs = let bs=BS.fromList;e=BS.empty in [
(bs[0],e),
(bs[0],bs[0]),
(bs[8,9],e),
(bs[0,4,5,6,7],e),
(bs[0,1,2,3,4,5],e),
(bs[4,5,6,7],bs[4,5,6,7]),
(bs[0,1,2,3],bs[0,1,2,3]),
(bs[0,1,2,3,4,5,6,7],e),
(bs[0,1,2,3,4,5],e),
(bs[0,1,2,3,4,5],e),
(bs[0,1,2,3,4,5],e),
(bs[0,1,2,3,4,5],e),
(e,e),
(bs[0,1,2,3,4,5,6,7],bs[4,5,6,7]),
(bs[0,1,2,3,4,5,6,7],bs[0,1,2,3])
]
accByIndices :: (Int -> a -> b -> b) -> b -> [a] -> [Int] -> b
accByIndices acc init list indices = loop 0 indices list init
where
loop _ _ [] done = done;
loop _ [] _ done = done;
loop i (x:xs) (y:ys) done
| i==x = loop (i+1) xs ys (acc i y done)
| otherwise = loop (i+1) (x:xs) ys done
infixl 9 `proj` -- ex) [a,b,c,d,e] `proj` [0,2,3] == [(0,a),(2,c),(3,d)]
proj :: [a] -> [Int] -> [(Int,a)]
proj = accByIndices (\i x xs -> (i,x):xs) []
ptIndex :: Promoted -> PieceType -> Int
ptIndex True = (+8).fromEnum
ptIndex False = fromEnum
pieceDirs :: PieceQuantum -> Promoted -> PieceDirs
pieceDirs pq pr = accByIndices merge (e,e) piece_dirs indices
where
u = BS.union; e = BS.empty
merge _ (a,b) (c,d) = (u a c, u b d)
indices = map (ptIndex pr) $ BS.toList pq
type Diff = Pos
step :: Pos -> Diff -> Pos
step (x,y) (dx,dy) = (x+dx,y+dy)
skip :: Distance -> Pos -> Diff -> Pos
skip distance (x,y) (dx,dy) = (x+dx*distance,y+dy*distance)
blackDiffs = [(0,-1),(0,1),(-1,0),(1,0),(-1,-1),(1,-1),(-1,1),(1,1),(-1,-2),(1,-2)]
whiteDiffs = let rot (x,y)=(-x,-y) in map rot blackDiffs
getDiffs :: Owner -> [Dir] -> [(Dir,Diff)]
getDiffs owner = (which owner (blackDiffs,whiteDiffs) `proj`)
type Effect = ((Dir, Distance), Square)
shortEffect :: Board -> Owner -> Pos -> [Dir] -> [Effect]
shortEffect board owner from dirs = do
(dir,diff) <- getDiffs owner dirs
let to = step from diff
guard $ not.isOB $ to
return ((dir,1), board `at` to)
takeUntil_then_drop1 :: (a -> Bool) -> [a] -> [a]
takeUntil_then_drop1 p list = loop 0 p list []
where
loop _ _ [] done = done
loop 0 p (x:xs) []
| p x = []
| otherwise = loop 1 p xs []
loop i p (x:xs) done
| p x = x:done
| otherwise = loop (i+1) p xs (x:done)
longEffect :: Board -> Owner -> Pos -> [Dir] -> [Effect]
longEffect board owner from dirs = do
(dir,diff) <- getDiffs owner dirs
takeUntil_then_drop1 (isJust.snd.snd) $ do
distance <- [1..8]
let to = skip distance from diff
guard $ not.isOB $ to
return ((dir,distance), board `at` to)
effect :: Board -> Pos -> Piece -> [Effect]
effect board pos (pq,pr,owner,_) = le ++ se
where
tl = BS.toList
(sd,ld) = pieceDirs pq pr
se = shortEffect board owner pos $ tl sd
le = longEffect board owner pos $ tl ld
initPos :: Color -> [(PieceIndex,Pos)]
initPos White = zip [0..19] [(x,y)|y<-[1..3],x<-[1..9],y/=2 || x==2 || x==8]
initPos Black = zip [20..39] [(x,y)|y<-[7..9],x<-[1..9],y/=8 || x==2 || x==8]
initBoard = IM.fromList $ do
col <- [Black,White]; (pi,pos) <- initPos col
return (toKey pos, (allPQ,False,col,pi))
type Promote = Bool
data Move = Move Piece Pos Effect Promote | Drop Piece Pos deriving (Show)
type Moves = [Move]
type Turn = Color
type Game = (Board,Turn,Moves)
initGame = (initBoard,Black,[])
applyMove :: Move -> Board -> Board
applyMove (Move piece from (dd,(to,cap)) pr) = converge . f
where f = qs_move piece from to dd pr . qs_capture cap
applyMove (Drop piece to) = converge . qs_drop piece to
qs_capture :: Maybe Piece -> Board -> Board
qs_capture Nothing = id
qs_capture (Just (pq,pr,owner,pi)) = setHand pi (BS.delete King pq,False,opp owner,pi)
qs_move :: Piece -> Pos -> Pos -> (Dir,Distance) -> Promote -> Board -> Board
qs_move (pq,pr1,owner,pi) from to dd pr2 = setAt to (pq1,pr1or2,owner,pi) . delAt from
where
pr1or2 = pr1 || pr2
invalid pt = invalid1 dd pr1 pt || invalid2 owner to pr1or2 pt
pq1 = BS.filter (not.invalid) pq
invalid1 :: (Dir,Distance) -> Promoted -> PieceType -> Bool
invalid1 (dir,distance) pr pt = not $ BS.member dir ds
where ds = whichDS distance $ piece_dirs!!(ptIndex pr pt)
invalid2 :: Color -> Pos -> Promoted -> PieceType -> Bool
invalid2 col pos pr pt = i<3 && y_margin<[1,1,2]!!i
where i=ptIndex pr pt; y=toY pos; y_margin = which col (y-1,9-y)
qs_drop :: Piece -> Pos -> Board -> Board
qs_drop (pq,_,owner,pi) to = setAt to (pq1,False,owner,pi) . delHand pi
where pq1 = BS.filter (not.invalid2 owner to False) pq
ptNum :: PieceType -> Int
ptNum pt = [9,2,2,2,2,1,1,1] !! fromEnum pt
checkSingleton :: Color -> Board -> PieceType -> Bool
checkSingleton col b pt = ptNum pt <= IM.foldl f 0 b
where
f n (pq,_,_,pi) = if (origin pi==col && pq==BS.singleton pt) then n+1 else n
converge :: Board -> Board
converge = converge1 White allPT . converge1 Black allPT
converge1 :: Color -> [PieceType] -> Board -> Board
converge1 col pts b = if (cv==[]) then b else rec
where (cv,not_cv) = partition (checkSingleton col b) pts
mapB = IM.map $ adjustPQ col $ BS.fromList cv
rec = converge1 col not_cv $ mapB b
adjustPQ :: Color -> PieceQuantum -> Piece -> Piece
adjustPQ col pq0 pc@(pq,pr,o,pi) = if (origin pi==col) then (pq1,pr,o,pi) else pc
where
pq1 = if (BS.size pq>1) then (BS.difference pq $ BS.intersection pq pq0) else pq
toMove :: Pos -> Pos -> Promote -> Board -> Maybe Move
toMove from to pr b = do
pc <- IM.lookup (toKey from) b
ef <- listToMaybe $ filter ((to==).fst.snd) $ effect b from pc
return $ Move pc from ef pr
toDrop :: PieceIndex -> Pos -> Board -> Maybe Move
toDrop pi to b = do
guard $ pi<40
pc <- IM.lookup pi b
return $ Drop pc to
------------------------------------------------------------
-- test
------------------------------------------------------------
printBoard :: Board -> IO ()
printBoard b = do
print "board"
mapM_ print $ filter (isJust.snd) $ map (at b) [(x,y)|y<-[1..9],x<-[1..9]]
print "hand"
mapM_ print $ filter ((40>).fst) $ IM.toList b
test = do
let (b,t,mvs) = initGame
let test = flip $ foldl (\bb t-> applyMove (fromJust $ t bb) bb)
let b1 = test [ toMove (5,7) (5,3) False
,toMove (4,1) (5,3) False
,toMove (5,9) (5,3) True
,toDrop 24 (5,9)
,toMove (4,9) (5,9) False
] b
printBoard b1
let b2 = test [ toMove (7,7) (6,8) False
,toMove (7,3) (7,4) False
,toMove (6,8) (7,8) False
,toMove (7,4) (7,8) True
] b
printBoard b2
------------------------------------------------------------
-- check
------------------------------------------------------------
data MoveError = NoTurn | NoEffect | NoPiece |
CantPromote | CantCapt | CantDrop |
Invalid Int MoveError |
Other String deriving (Show,Eq)
instance Error MoveError where
noMsg = Other "unknown"
strMsg s = Other s
type MoveCheck = Either MoveError
maybeError :: MoveError -> Maybe a -> MoveCheck a
maybeError e = maybe (Left e) Right
check :: MoveError -> Bool -> MoveCheck ()
check e False = Left e
check _ True = return ()
checkPromote :: Turn -> Pos -> Pos -> Piece -> Bool
checkPromote t (_,fy) (_,ty) (_,pr,_,_) = not $
pr || (t==Black && (fy>3 && ty>3) || t==White && (fy<7 && ty<7))
toD :: Char -> Int
toD c = ord c - ord '0'
pieceOwner :: Piece -> Owner
pieceOwner (_,_,o,_) = o
checkCapture :: Color -> Maybe Piece -> MoveCheck ()
checkCapture _ Nothing = return ()
checkCapture c (Just pc) = check CantCapt $ pieceOwner pc==opp c
toValidMove :: String -> Turn -> Board -> MoveCheck Move
toValidMove [x1,y1,x2,y2,p] t b = do
let from = (toD x1,toD y1)
pc <- maybeError NoPiece $ IM.lookup (toKey from) b
check NoPiece $ pieceOwner pc==t
let to = (toD x2,toD y2)
efl = filter ((to==).fst.snd) $ effect b from pc
ef <- maybeError NoEffect $ listToMaybe efl
checkCapture t $ snd $ snd ef
let pr = (p=='p')
check CantPromote $ (not pr) || checkPromote t from to pc
return $ Move pc from ef pr
toValidMove [i,j,x,y] t b = do
let pi = (toD i)*10+(toD j)
pc <- maybeError NoPiece $ IM.lookup pi b
check NoPiece $ pieceOwner pc==t
let to = (toD x,toD y)
check CantDrop $ isNothing $ IM.lookup (toKey to) b
return $ Drop pc to
toValidMove s _ _ = Left $ Other s
checkBoard :: Board -> MoveCheck Board
checkBoard = return
proceed :: Game -> [String] -> MoveCheck Game
proceed (b,t,ms) (s:ss) = do
let annotate a = case a of
(Left e)->(Left $ Invalid (length ms) e)
otherwise->a
m <- annotate $ toValidMove s t b
b1 <- annotate $ checkBoard $ applyMove m b
proceed (b1,opp t,m:ms) ss
proceed g [] = return g
------------------------------------------------------------
-- main
------------------------------------------------------------
showSq :: Square -> String
showSq ((x,y),Just pc) = (showP pc)++","++(show [x,y])
showSq _ = []
showP :: Piece -> String
showP (pq,p,o,pi) = a++","++b++","++c++","++d
where
a=show pi
b=show $ fromEnum o
c=if p then "1" else "0"
d=show $ map fromEnum $ BS.toList pq
printB :: Board -> IO ()
printB b = do
mapM_ putStrLn $ map showSq $ filter (isJust.snd) $ map (at b) [(x,y)|y<-[1..9],x<-[1..9]]
mapM_ putStrLn $ map showP $ map snd $ filter ((40>).fst) $ IM.toList b
cmd :: String -> Game -> IO ()
cmd "check" = \(b,_,_) -> printB b
cmd "think" = think
cmd _ = const $ return ()
main = do
(a1:args) <- getArgs
either print (cmd a1) $ proceed initGame args
------------------------------------------------------------
-- think
------------------------------------------------------------
think :: Game -> IO ()
think = const $ return ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment