hategod.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2
   3 import Data.Array.IArray
   4 import Data.Maybe
   5 import Data.List
   6 import Data.Char
   7
   8 import Control.Monad.State
   9
  10 --import Database.HDBC
  11 --import Database.HDBC.PostgreSQL
  12 import Database.HaskellDB.HDBC.PostgreSQL
  13 import Database.HaskellDB hiding ((!))
  14
  15 import Network
  16 import System.Posix.Process
  17 import System.Posix.Files
  18 import System.IO
  19 import System.Directory
  20 import Control.Concurrent
  21
  22 import Data.Digest.SHA512
  23
  24 data Color = Black | White deriving Eq
  25 type Board = Array (Int, Int) (Maybe Color)
  26 type Form = [(Int, Int)]
  27 data Move = Move Int Int Color | Pass deriving Eq
  28 type Game = [Move]
  29
  30 data Status = Connected | LoggedOn | Playing | Counting deriving (Eq, Ord)
  31
  32 data ServerState = ServerState {
  33         username :: Maybe String,
  34         status :: Status
  35         -- salt
  36 }
  37
  38 newtype Server a = S {
  39         runS :: StateT ServerState IO a
  40 } deriving (Monad, MonadState ServerState, MonadIO)
  41
  42 evalServer :: Server a -> IO a
  43 evalServer x = evalStateT (runS x) $ ServerState Nothing Connected
  44
  45
  46 protocolVersion = "0"
  47
  48
  49 say :: String -> Server ()
  50 say = liftIO . hPutStrLn stderr
  51
  52
  53 readMove :: Color -> String -> Maybe Move
  54 readMove c a = case words a of
  55         [x, y] -> Just $ Move (read x) (read y) c
  56         ["pass"] -> Just Pass
  57         _ -> Nothing
  58
  59 instance Show Color where
  60         show Black = "B"
  61         show White = "W"
  62
  63 readColor 'B' = Black
  64 readColor 'W' = White
  65
  66 other Black = White
  67 other White = Black
  68
  69 {-
  70  - unlines $ (zipWith (\x y -> "f " ++ show x ++ " = Just '" ++ [y] ++ "'") [0..18] "ABCDEFGHJKLMNOPQRST") ++ ["f _ = Nothing"]
  71  -
  72 showX :: Int -> String
  73 showX x =
  74 -}
  75 instance Show Move where
  76         show (Move x y c) = unwords [show c, show x, show y]
  77         show Pass = "pass"
  78
  79
  80 main = do
  81         --installHandler sigPIPE Ignore Nothing
  82         --stdin <- getContents
  83         {-
  84         dbconn <- postgresqlConnect [
  85                 ("host", "localhost"),
  86                 ("dbname", "hategod"),
  87                 ("sslmode", "disable")] return
  88         -}
  89         pid <- getProcessID
  90         hPutStrLn stderr "hello"
  91         evalServer $ server
  92         return ()
  93         -- TODO clean db
  94         --commit dbconn
  95         --disconnect dbconn
  96
  97 server :: Server ()
  98 server = do
  99         sequence_ $ repeat (interpreter =<< (liftIO getLine))
 100         --(mapM_ interpreter) =<< (liftIO $ sequence $ repeat getLine)
 101         liftIO . maybe (return ()) (removeFile . ("hategod-player." ++)) . username =<< get
 102
 103 interpreter :: String -> Server ()
 104 interpreter x = do
 105         s <- get
 106         case words x of
 107                 ("username":username:[]) -> if not (isGoodUsername username) then
 108                         say "error: bad username" else do
 109                 -- TODO auth
 110                         put $ s { username = Just username, status = LoggedOn }
 111                         say $ "user " ++ username
 112                         say "logged on"
 113                 ("version":[]) -> say protocolVersion
 114                 ("who":[]) -> liftIO who
 115                 ("play":username:x:y:[]) -> if status s /= LoggedOn then
 116                         say "error: wrong status" else if not $ isGoodUsername username then
 117                         say "error: bad username" else do
 118                         put $ s { status = Playing }
 119                         say "playing"
 120                         startGame username (read x) (read y)
 121                 ("listen":[]) -> if status s /= LoggedOn then
 122                         say "error: wrong status" else do
 123                         put $ s { status = Playing }
 124                         acceptGame
 125                 _ -> say "error: parse failed"
 126
 127 isGoodUsername = and . map isAlphaNum
 128
 129 who :: IO ()
 130 who = sequence_ . map (hPutStrLn stderr) . catMaybes . map (stripPrefix "hategod-player.") =<< getDirectoryContents =<< getCurrentDirectory
 131
 132 acceptGame :: Server ()
 133 acceptGame = do
 134         s <- get
 135         let fn = "hategod-player." ++ (fromJust $ username s)
 136         (rival, _, _) <- liftIO $ accept =<< (listenOn $ UnixSocket fn)
 137         x <- liftIO $ hGetLine rival
 138         y <- liftIO $ hGetLine rival
 139         g <- play rival (emptyBoard (read x) (read y)) False
 140         liftIO $ seq g (hClose rival)
 141
 142 startGame :: String -> Int -> Int -> Server ()
 143 startGame user x y = do
 144         -- connect
 145         rival <- liftIO $ connectTo "" $ UnixSocket $ "hategod-player." ++ user
 146         g <- play rival (emptyBoard x y) True
 147         liftIO $ seq g (hClose rival)
 148 --      countScore g
 149 --      pushToDB
 150         return ()
 151
 152 play :: Handle -> Board -> Bool -> Server Game
 153 play r b amifirst = let mc = if amifirst then Black else White
 154                         tc = other mc
 155                         mm = myMove r b mc
 156                         tm = getTheirsMove r in
 157         sequence $ (if amifirst then [mm] else []) ++ cycle [tm, mm]
 158
 159
 160 {-
 161 pushToDB :: Game -> Server ()
 162 pushToDB = return ()    -- TODO
 163 -}
 164
 165 myMove :: Handle -> Board -> Color -> Server Move
 166 myMove r b c = do
 167         say "iwannayourmove"
 168         m <- (return . head . filter (isGood b) . repeat) =<< (getMyMove c)
 169         liftIO $ hPutStrLn r $ show m
 170         return m
 171
 172
 173 getMyMove :: Color -> Server Move
 174 getMyMove c = liftIO $ (return . fromJust . readMove c) =<< getLine
 175
 176 -- theirs move is always a good one
 177 getTheirsMove :: Handle -> Server Move
 178 getTheirsMove rival = do
 179         say "igetthm"
 180         c <- liftIO $ (return . readColor) =<< hGetChar rival
 181         m <- liftIO $ (return . fromJust . readMove c) =<< getLine
 182         say $ show m
 183         return m
 184
 185 gameToBoard :: Game -> Board -> Maybe Board
 186 gameToBoard g b = foldM doMove b g
 187
 188 doMove :: Board -> Move -> Maybe Board
 189 doMove b Pass = Just b
 190 doMove b m@(Move x y c) | isGood b m = Just $ flip doKill c $ doMove_ b m
 191                         | otherwise = Nothing
 192
 193 doMove_ :: Board -> Move -> Board
 194 doMove_ b (Move x y c) = b // [((x, y), Just c)]
 195
 196 isGood :: Board -> Move -> Bool
 197 isGood b m = and $ (\a b c -> zipWith uncurry a (repeat (b, c))) goodSigns b m
 198 -- TODO
 199
 200 goodSigns :: [Board -> Move -> Bool]
 201 goodSigns = [(\z (Move x y _) -> not $ isOccupied z (x, y)),
 202              curry $ not . uncurry isSuicide]
 203
 204 isOccupied :: Board -> (Int, Int) -> Bool
 205 isOccupied b i = maybe False (const True) $ b ! i
 206
 207 isSuicide b m@(Move x y c) = if isKilling b m then False else countDameF b (fromJust $ findForm (doMove_ b m) (x, y)) == 0
 208
 209
 210 isKilling b m@(Move x y c) = b /= (flip doKill (other c) $ doMove_ b m)
 211
 212 doKill :: Board -> Color -> Board
 213 doKill board color = remove board $ concat $ filter (\f -> countDameF board f == 0) $ nub $ mapMaybe (\i -> findForm board i) $ indices board
 214
 215 countDameF :: Board -> Form -> Int -- STUPID!
 216 countDameF b f = sum $ map (countDame b) f
 217
 218 countDame :: Board -> (Int, Int) -> Int
 219 countDame b i = sum $ map (b2i . not . isOccupied b) $ findNeighbours b i
 220
 221 remove :: Board -> Form -> Board
 222 remove b f = b // (map (\i -> (i, Nothing))) f
 223
 224 b2i True = 1
 225 b2i False = 0
 226
 227 findForm :: Board -> (Int, Int) -> Maybe Form
 228 findForm b i = liftM (findForm_ b [i]) (b ! i)
 229
 230 findForm_ :: Board -> Form -> Color -> Form
 231 findForm_ b i c = let f = nub $ sort $ concatMap (flip (friendlyNeighbours b) c) i in
 232         if i == f then f else findForm_ b f c
 233
 234 friendlyNeighbours :: Board -> (Int, Int) -> Color -> [(Int, Int)]
 235 friendlyNeighbours b i c = map fst $ filter (\x -> Just c == snd x) $ map (\i -> (i, b ! i)) $ findNeighbours b i
 236
 237 findNeighbours :: Board -> (Int, Int) -> [(Int, Int)]
 238 findNeighbours b (x, y) = filter (inRange $ bounds b) [(x + 1, y + 1), (x - 1, y + 1), (x + 1, y - 1), (x - 1, y - 1)]
 239
 240 emptyBoard :: Int -> Int -> Board
 241 emptyBoard x y = array ((1, 1), (x, y)) [((a, b), Nothing) | a <- [1..x], b <- [1..y]]
 242