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