add socket server

.gitignore

@@ -6,3 +6,4 @@
 *.hi
 *.o
 *.prof
+*.hp

AI/Rulebased.hs

@@ -4,12 +4,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module AI.Rulebased (
-    mkAIEnv
+    mkAIEnv, testds, simplify
 ) where
 
+import Control.Parallel.Strategies
+
 import Data.Ord
 import Data.Monoid ((<>))
 import Data.List
+import qualified Data.Set as S
 import Control.Monad.State
 import Control.Monad.Reader
 import qualified Data.Map.Strict as M
@@ -152,9 +155,17 @@ toPiles table (h1, h2, h3, skt) = Piles (cs1 ++ cs2 ++ cs3) table ss
           cs3 = map (putAt Hand3) h3
           ss  = map (putAt SkatP) skt
 
+compareGuess :: (Card, [Option]) -> (Card, [Option]) -> Ordering
+compareGuess (c1, ops1) (c2, ops2)
+    | length ops1 == 1 = LT
+    | length ops2 == 1 = GT
+    | c1 > c2 = LT
+    | c1 < c2 = GT
+
 distributions :: Guess -> (Int, Int, Int, Int) -> [Distribution]
 distributions guess nos =
-        helper (sortBy (comparing $ length . snd) $ M.toList guess) nos
+        helper (sortBy compareGuess $ M.toList guess) nos
+        `using` parList rdeepseq
     where helper []           _ = []
           helper ((c, hs):[]) ns = map fst (distr c hs ns)
           helper ((c, hs):gs) ns =
@@ -177,30 +188,33 @@ distributions guess nos =
                 in filterMap isOk (f card) hands
           cardsPerHand = (length guess - 2) `div` 3
 
-simplify :: Int -> [Distribution] -> [Distribution]
-simplify 10 ds = nubBy is789Variation ds
-simplify _ ds = ds
+type Abstract = (Int, Int, Int, Int)
 
-is789Variation :: Distribution -> Distribution -> Bool
-is789Variation (ha1, ha2, ha3, sa) (hb1, hb2, hb3, sb) =
-        f ha1 hb1 && f ha2 hb2 && f ha3 hb3 && f sa sb
-    where f cs1 cs2
-             | n789s cs1 /= n789s cs2 = False
-             | otherwise = and (zipCs (c789s cs1) (c789s cs2))
+abstract :: [Card] -> Abstract
+abstract cs = foldr f (0, 0, 0, 0) cs
+    where f c (clubs, spades, hearts, diamonds) =
+            let v = getID c in
+            case getColour c of
+                Diamonds -> (clubs, spades, hearts, diamonds + 1 + v*100)
+                Hearts -> (clubs, spades, hearts + 1 + v*100, diamonds)
+                Spades -> (clubs, spades + 1 + v*100, hearts, diamonds)
+                Clubs -> (clubs + 1 + v*100, spades, hearts, diamonds)
 
-zipCs :: [[Card]] -> [[Card]] -> [Bool]
-zipCs xs ys = zipWith g xs ys
+remove789s :: Hand
+           -> [Distribution]
+           -> M.Map (Abstract, Abstract) (Distribution, Int)
+remove789s hand ds = foldl' f M.empty ds
+    where f cleaned d =
+            let (c1, c2) = reduce hand d
+                a = (abstract c1, abstract c2) in
+            M.insertWith (\(oldD, n) _ -> (oldD, n+1)) a (d, 1) cleaned
+          reduce Hand1 (_, h2, h3, _) = (h2, h3)
+          reduce Hand2 (h1, _, h3, _) = (h1, h3)
+          reduce Hand3 (h1, h2, _, _) = (h1, h2)
 
-c789s :: [Card] -> [[Card]]
-c789s cs = groupBy (grouping getColour) $
-    sortBy (comparing getColour) $
-    filter ((==(0 :: Int)) . count) cs
-
-n789s :: [Card] -> [Card]
-n789s cs = filter ((/=(0 :: Int)) . count) cs
-
-g :: [a] -> [b] -> Bool
-g xs ys = length xs == length ys
+simplify :: Hand -> [Distribution] -> [(Distribution, Int)]
+simplify hand ds = M.elems cleaned
+    where cleaned = remove789s hand ds
 
 onPlayed :: MonadPlayer m => CardS Played -> AI m ()
 onPlayed c = do
@@ -235,9 +249,9 @@ chooseStatistic = do
                     2 -> 2
                     3 -> 3
                     -- simulate only partially
-                    4 -> 2
-                    5 -> 1
-                    6 -> 1
+                    4 -> 3
+                    5 -> 2
+                    6 -> 2
                     7 -> 1
                     8 -> 1
                     9 -> 1
@@ -255,13 +269,16 @@ chooseStatistic = do
                 0 -> (0,  0,  0, 0)
                 1 -> (-1, 0, -1, 0)
                 2 -> (0,  0, -1, 0)
-    let dis = distributions guess ns
-        disNo = length dis
-        piless = map (toPiles table) dis
+    let realDis = distributions guess ns
+        realDisNo = length realDis
+        reducedDis = simplify Hand3 realDis
+        reducedDisNo = length reducedDis
+        piless = map (\(d, n) -> (toPiles table d, n)) reducedDis
         limit = if depth == 1 && length table == 2
             then 1
-            else min 10000 $ disNo `div` 2
-    liftIO $ putStrLn $ "possible distrs " ++ show disNo
+            else min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
+    liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
     liftIO $ print vals
     return $ fst $ maximumBy (comparing snd) vals
@@ -280,10 +297,10 @@ foldWithLimit limit f start (x:xs) = do
         _ -> return start
 
 runOnPiles :: MonadPlayer m
-           => M.Map Card Int -> Piles -> AI m (M.Map Card Int)
-runOnPiles m ps = do
+           => M.Map Card Int -> (Piles, Int) -> AI m (M.Map Card Int)
+runOnPiles m (ps, n) = do
     c <- runWithPiles ps chooseOpen
-    return $ M.insertWith (+) c 1 m
+    return $ M.insertWith (+) c n m
 
 chooseOpen :: (MonadState AIEnv m, MonadPlayerOpen m) => m Card
 chooseOpen = do
@@ -396,10 +413,21 @@ aienv :: AIEnv
 aienv = AIEnv Single Hand3 [] [] [] newGuess 10
 
 testguess :: Guess
-testguess = isSkat (take 2 $ drop 10 allCards)
-        $ Hand3 `has` (take 10 allCards) $ m
-    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 allCards)
+testguess = isSkat (take 2 $ drop 10 cs)
+        $ Hand3 `has` (take 10 cs) $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) (take 32 cs)
           m = M.fromList l
+          cs = allCards
+
+testguess2 :: Guess
+testguess2 = isSkat (take 2 $ drop 6 cs)
+        $ Hand3 `has` [head cs, head $ drop 5 cs] $ m
+    where l = map (\c -> (c, [H Hand1, H Hand2, H Hand3, Skt])) cs
+          m = M.fromList l
+          cs = take 8 $ drop 8 allCards
 
 testds :: [Distribution]
 testds = distributions testguess (0, 0, 0, 0)
+
+testds2 :: [Distribution]
+testds2 = distributions testguess2 (0, 0, 0, 0)

AI/Server.hs

@@ -0,0 +1,105 @@
+module AI.Server where
+
+import qualified Network.Socket as Net
+import qualified System.IO as Sys
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad (forever)
+import Control.Monad.Reader
+import Data.List.Split
+
+data Buffering = NoBuffering
+               | LengthBuffering
+               | DelimiterBuffering String
+                 deriving (Show)
+
+data ServerEnv = ServerEnv
+    { buffering :: Buffering       -- ^ Buffermode
+    , socket :: Net.Socket         -- ^ the socket used to communicate
+    , global :: Chan String
+    , onReceive :: OnReceive
+    }
+
+instance Show ServerEnv where
+    show env = "A Server"
+
+type Server = ReaderT ServerEnv IO
+
+type OnReceive = Sys.Handle -> Net.SockAddr -> String -> Server ()
+
+broadcast :: String -> Server ()
+broadcast msg = do
+    bufmode <- asks buffering
+    chan <- asks global
+    case bufmode of
+        DelimiterBuffering delim -> liftIO $ writeChan chan $ msg ++ delim
+        _                        -> liftIO $ writeChan chan msg
+
+send :: Sys.Handle -> String -> Server ()
+send connhdl msg = do
+    bufmode <- asks buffering
+    case bufmode of
+        DelimiterBuffering delim -> liftIO $ Sys.hPutStr connhdl $ msg ++ delim
+        _                        -> liftIO $ Sys.hPutStr connhdl msg
+
+
+-- | Initialize a new server with the given port number and buffering mode
+initServer :: Net.PortNumber -> Buffering -> OnReceive -> IO ServerEnv
+initServer port buffermode handler = do
+    sock <- Net.socket Net.AF_INET Net.Stream 0
+    Net.setSocketOption sock Net.ReuseAddr 1
+    Net.bind sock (Net.SockAddrInet port Net.iNADDR_ANY)
+    Net.listen sock 5
+    chan <- newChan
+    forkIO $ forever $ do
+        msg <- readChan chan -- clearing the main channel
+        return ()
+    return (ServerEnv buffermode sock chan handler)
+
+close :: ServerEnv -> IO ()
+close = Net.close . socket
+
+-- | Looping over requests and establish connection
+procRequests :: Server ()
+procRequests = do
+    sock <- asks socket
+    (conn, clientaddr) <- liftIO $ Net.accept sock
+    env <- ask
+    liftIO $ forkIO $ runReaderT (procMessages conn clientaddr) env
+    procRequests
+
+-- | Handle one client
+procMessages :: Net.Socket -> Net.SockAddr -> Server ()
+procMessages conn clientaddr = do
+    connhdl <- liftIO $ Net.socketToHandle conn Sys.ReadWriteMode
+    liftIO $ Sys.hSetBuffering connhdl Sys.NoBuffering
+    globalChan <- asks global
+
+    commChan <- liftIO $ dupChan globalChan
+
+    reader <- liftIO $ forkIO $ forever $ do
+        msg <- readChan commChan
+        Sys.hPutStrLn connhdl msg
+
+    handler <- asks onReceive
+    messages <- liftIO $ Sys.hGetContents connhdl
+    buffermode <- asks buffering
+    case buffermode of
+        DelimiterBuffering delimiter ->
+            mapM_ (handler connhdl clientaddr) (splitOn delimiter messages)
+        LengthBuffering -> liftIO $ putStrLn (take 4 messages)
+        _ -> return ()
+
+    -- clean up
+    liftIO $ do killThread reader
+                Sys.hClose connhdl
+
+sampleHandler :: OnReceive
+sampleHandler connhdl addr query = do
+    liftIO $ putStrLn $ "new query " ++ query
+    send connhdl $ "> " ++ query
+
+main :: IO ()
+main = do
+    env <- initServer 4242 LengthBuffering sampleHandler
+    runReaderT procRequests env

AI/Socket.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module AI.Socket (
+    mkSocketEnv
+) where
+
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Concurrent
+import Control.Concurrent.Chan
+
+import Player
+import Pile
+import Card
+import Utils
+import Render
+import AI.Server
+
+data SocketEnv = SocketEnv { getTeam :: Team
+                           , getHand :: Hand
+                           , table :: [CardS Played]
+                           , myHand :: [Card]
+                           , socketThread :: Maybe ThreadId
+                           , socketServer :: Maybe ServerEnv }
+                  deriving Show
+
+setTable :: [CardS Played] -> SocketEnv -> SocketEnv
+setTable tab env = env { table = tab }
+
+setHand :: [Card] -> SocketEnv -> SocketEnv
+setHand hand env = env { myHand = hand }
+
+setSocket :: ThreadId -> SocketEnv -> SocketEnv
+setSocket n env = env { socketThread = Just n }
+
+clearSocket :: SocketEnv -> SocketEnv
+clearSocket env = env { socketThread = Nothing }
+
+setServer :: ServerEnv -> SocketEnv -> SocketEnv
+setServer s env = env { socketServer = Just s }
+
+type Socket m = StateT SocketEnv m
+
+instance MonadPlayer m => MonadPlayer (Socket m) where
+    trumpColour = lift $ trumpColour
+    turnColour = lift $ turnColour
+    showSkat = lift . showSkat
+
+instance Player SocketEnv where
+    team = getTeam
+    hand = getHand
+    chooseCard p table _ hand = runStateT (do
+        modify $ setTable table
+        modify $ setHand hand
+        choose) p
+
+choose :: MonadPlayer m => Socket m Card
+choose = do
+    initialize
+    trumpCol <- trumpColour
+    turnCol <- turnColour
+    hand <- gets myHand
+    (Just server) <- gets socketServer
+    liftIO $ writeChan (global server) "hi"
+    let possible = filter (isAllowed trumpCol turnCol hand) hand
+    case length hand of
+        1 -> liftIO (putStrLn "stopping server") >> stop
+        _ -> return ()
+    return $ head possible
+
+initialize :: MonadPlayer m => Socket m ()
+initialize = do
+    state <- gets socketThread
+    case state of
+        Just _ -> return ()
+        Nothing -> do
+            liftIO $ putStrLn "initializing server"
+            server <- liftIO $ initServer 4242 (DelimiterBuffering "\n") sampleHandler
+            n <- liftIO $ forkIO $ runReaderT procRequests server
+            modify $ setSocket n
+            modify $ setServer server
+
+stop :: MonadPlayer m => Socket m ()
+stop = do
+    state <- gets socketThread
+    case state of
+        Just n -> do liftIO $ putStrLn "killing thread"
+                     liftIO $ killThread n
+                     modify clearSocket
+                     Just server <- gets socketServer
+                     liftIO $ close server
+        Nothing -> return ()
+
+mkSocketEnv :: Team -> Hand -> SocketEnv
+mkSocketEnv tm h = SocketEnv tm h [] [] Nothing Nothing

AI/Test2.hs

@@ -0,0 +1,5 @@
+import AI.Rulebased
+import Pile
+
+main :: IO ()
+main = print $ length $ simplify Hand3 testds

Card.hs

@@ -6,6 +6,7 @@ module Card where
 import Data.List
 import System.Random (newStdGen)
 import Utils
+import Control.DeepSeq
 
 class Countable a b where
     count :: a -> b
@@ -40,12 +41,26 @@ data Card = Card Type Colour
 getColour :: Card -> Colour
 getColour (Card _ c) = c
 
+getID :: Card -> Int
+getID (Card t _) = case t of
+    Seven -> 0
+    Eight -> 0
+    Nine -> 0
+    Queen -> 2
+    King -> 4
+    Ten -> 8
+    Ace -> 16
+    Jack -> 32
+
 instance Countable Card Int where
     count (Card t _) = count t
 
 instance Countable [Card] Int where
     count = sum . map count
 
+instance NFData Card where
+    rnf (Card t c) = t `seq` c `seq` ()
+
 equals :: Colour -> Maybe Colour -> Bool
 equals col (Just x) = col == x
 equals col Nothing = True

Main.hs

@@ -9,11 +9,29 @@ import Player
 import Pile
 
 import AI.Stupid
-import AI.Human
+import AI.Socket
 import AI.Rulebased
 
 main :: IO ()
-main = putStrLn "Hello World"
+main = testAI 10
+
+testAI :: Int -> IO ()
+testAI n = do
+    let acs = repeat runAI
+    vals <- sequence (take n acs)
+    putStrLn $ "average won points " ++ show (fromIntegral (sum vals) / fromIntegral n)
+
+runAI :: IO Int
+runAI = do
+    env <- shuffledEnv
+    let ps = piles env
+        cs = handCards Hand3 ps
+        trs = filter (isTrump Spades) cs
+    if length trs >= 5 && any ((==32) . getID) cs
+        then do
+            pts <- fst <$> evalStateT (turn Hand1) env
+            if pts > 60 then return 1 else return 0
+        else runAI
 
 env :: SkatEnv
 env = SkatEnv piles Nothing Spades playersExamp
@@ -26,7 +44,7 @@ envStupid = SkatEnv piles Nothing Spades pls2
 playersExamp :: Players
 playersExamp = Players
     (PL $ Stupid Team Hand1)
-    (PL $ Stupid Team Hand2)
+    (PL $ mkSocketEnv Team Hand2)
     (PL $ mkAIEnv Single Hand3 10)
 
 pls2 :: Players
@@ -50,8 +68,3 @@ env2 = SkatEnv piles Nothing Spades playersExamp
           h3 = map (putAt Hand3) hand3
           piles = Piles (h1 ++ h2 ++ h3) [] []
 
-testAI :: Int -> IO ()
-testAI n = do
-    let acs = repeat (shuffledEnv >>= evalStateT (turnGeneric playOpen 10 Hand1) )
-    vals <- sequence (take n acs)
-    putStrLn $ "average won points " ++ show (fromIntegral (sum (map fst vals)) / fromIntegral n)

Pile.hs

@@ -14,7 +14,7 @@ data Team = Team | Single
 
 data CardS p = CardS { getCard :: Card
                      , getPile :: p }
-               deriving (Show, Eq)
+               deriving (Show, Eq, Ord)
 
 instance Countable (CardS p) Int where
     count = count . getCard
@@ -34,15 +34,15 @@ prev Hand3 = Hand2
 
 data Played = Table Hand
             | Won Hand Team
-              deriving (Show, Eq)
+              deriving (Show, Eq, Ord)
 
 data SkatP = SkatP
-             deriving (Show, Eq)
+             deriving (Show, Eq, Ord)
 
 data Piles = Piles { hands :: [CardS Hand]
                    , played :: [CardS Played]
                    , skat :: [CardS SkatP] }
-             deriving (Show, Eq)
+             deriving (Show, Eq, Ord)
 
 instance Countable Piles (Int, Int) where
     count ps = (sgl, tm)