Last active
September 29, 2020 01:36
-
-
Save chiral/7295637 to your computer and use it in GitHub Desktop.
Quantum Shogi Program in Haskell
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
------------------------------------------------------------ | |
-- 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