generalize skat online ai to use a general communicator type

.gitignore

@@ -2,6 +2,7 @@
 
 !*.*
 !*/
+!LICENSE
 
 *.hi
 *.o

LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Operations.hs

@@ -1,88 +0,0 @@
-module Operations where
-
-import Control.Monad.State
-import System.Random (newStdGen, randoms)
-import Data.List
-import Data.Ord
-
-import Card
-import Skat
-import Pile
-import Player (chooseCard, Players(..), Player(..), PL(..),
-    updatePlayer, playersToList, player)
-import Utils (shuffle)
-
-compareRender :: Card -> Card -> Ordering
-compareRender (Card t1 c1) (Card t2 c2) = case compare c1 c2 of
-    EQ -> compare t1 t2
-    v  -> v
-
-sortRender :: [Card] -> [Card]
-sortRender = sortBy compareRender
-
-turnGeneric :: (PL -> Skat Card)
-            -> Int
-            -> Hand
-            -> Skat (Int, Int)
-turnGeneric playFunc depth n = do
-    table <- getp tableCards
-    ps <- gets players
-    let p = player ps n
-    hand <- getp $ handCards n
-    trCol <- gets trumpColour
-    case length table of
-        0 -> playFunc p >> turnGeneric playFunc depth (next n)
-        1 -> do
-            modify $ setTurnColour
-                (Just $ effectiveColour trCol $ head table)
-            playFunc p
-            turnGeneric playFunc depth (next n)
-        2 -> playFunc p >> turnGeneric playFunc depth (next n)
-        3 -> do
-            w <- evaluateTable
-            if depth <= 1 || length hand == 0
-                then countGame
-                else turnGeneric playFunc (depth - 1) w
-
-turn :: Hand -> Skat (Int, Int)
-turn n = turnGeneric play 10 n
-
-evaluateTable :: Skat Hand
-evaluateTable = do
-    trumpCol <- gets trumpColour
-    turnCol <- gets turnColour
-    table <- getp tableCards
-    ps <- gets players
-    let winningCard = highestCard trumpCol turnCol table
-    Just winnerHand <- getp $ originOfCard winningCard
-    let winner = player ps winnerHand
-    modifyp $ cleanTable (team winner)
-    modify $ setTurnColour Nothing
-    return $ hand winner
-
-countGame :: Skat (Int, Int)
-countGame = getp count
-
-play :: (Show p, Player p) => p -> Skat Card
-play p = do
-    liftIO $ putStrLn "playing"
-    table <- getp tableCardsS
-    turnCol <- gets turnColour
-    trump <- gets trumpColour
-    hand <- getp $ handCards (hand p)
-    fallen <- getp played
-    (card, p') <- chooseCard p table fallen hand
-    modifyPlayers $ updatePlayer p'
-    modifyp $ playCard card
-    ps <- fmap playersToList $ gets players
-    table' <- getp tableCardsS
-    ps' <- mapM (\p -> onCardPlayed p (head table')) ps
-    mapM_ (modifyPlayers . updatePlayer) ps'
-    return card
-
-playOpen :: (Show p, Player p) => p -> Skat Card
-playOpen p = do
-    --liftIO $ putStrLn $ show (hand p) ++ " playing open"
-    card <- chooseCardOpen p
-    modifyp $ playCard card
-    return card

README.md

@@ -1 +1,4 @@
-# skat
+# Skat
+
+This is a Haskell implementation of the famous german card game Skat. It provides
+a library implementing all the game mechanics and a simple AI.

app/Main.hs

@@ -35,7 +35,8 @@ runAI = do
     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
+            -- if pts > 60 then return 1 else return 0
+            return pts
         else runAI
 
 env :: SkatEnv

package.yaml

@@ -1,10 +1,10 @@
 name:                skat
-version:             0.1.0.0
+version:             0.1.0.1
 github:              "githubuser/skat"
 license:             BSD3
-author:              "Author name here"
+author:              "flavis"
-maintainer:          "example@example.com"
+maintainer:          "christian@flavigny.de"
-copyright:           "2019 Author name here"
+copyright:           "2019"
 
 extra-source-files:
 - README.md
@@ -17,7 +17,7 @@ extra-source-files:
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+description:         Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 
 dependencies:
 - base >= 4.7 && < 5

skat.cabal

@@ -4,16 +4,16 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e2db48733c92b94d7f2d8f4991dd2f7cec26d59666cd3c618710a8a3c22616d0
+-- hash: 0d6eafec0c3ba6bb4c0150a39f4dbab784c7a519ec911d0f0344edd1c5d916da
 
 name:           skat
-version:        0.1.0.0
+version:        0.1.0.1
-description:    Please see the README on GitHub at <https://github.com/githubuser/skat#readme>
+description:    Please see the README on Gitea at <https://git.flavigny.de/christian/skat>
 homepage:       https://github.com/githubuser/skat#readme
 bug-reports:    https://github.com/githubuser/skat/issues
-author:         Author name here
+author:         flavis
-maintainer:     example@example.com
+maintainer:     christian@flavigny.de
-copyright:      2019 Author name here
+copyright:      2019
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
@@ -34,6 +34,7 @@ library
       Skat.AI.Server
       Skat.AI.Stupid
       Skat.Card
+      Skat.Matches
       Skat.Operations
       Skat.Pile
       Skat.Player

src/Skat/AI/Online.hs

@@ -5,7 +5,6 @@
 module Skat.AI.Online where
 
 import Control.Monad.Reader
-import Network.WebSockets (Connection, sendTextData, receiveData)
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as BS
 
@@ -15,41 +14,45 @@ import Skat.Pile
 import Skat.Card
 import Skat.Render
 
+class Communicator a where
+    send :: a -> String -> IO ()
+    receive :: a -> IO String
+
 class Monad m => MonadClient m where
     query :: String -> m ()
     response :: m String
 
-data OnlineEnv = OnlineEnv { getTeam :: Team
+data OnlineEnv c = OnlineEnv { getTeam :: Team
-                           , getHand :: Hand
+                             , getHand :: Hand
-                           , connection :: Connection }
+                             , connection :: c }
-                 deriving Show
 
-instance Show Connection where
+instance Show (OnlineEnv c) where
-    show _ = "A connection"
+    show _ = "An online env"
 
-instance Player OnlineEnv where
+instance Communicator c => Player (OnlineEnv c) where
     team = getTeam
     hand = getHand
     chooseCard p table _ hand = runReaderT (choose table hand) p >>= \c -> return (c, p)
     onCardPlayed p c = runReaderT (cardPlayed c) p >> return p
     onGameResults p res = runReaderT (onResults res) p
+    onGameStart p singlePlayer = runReaderT (onStart singlePlayer) p
 
-type Online m = ReaderT OnlineEnv m
+type Online a m = ReaderT (OnlineEnv a) m
 
-instance MonadIO m => MonadClient (Online m) where
+instance (Communicator c, MonadIO m) => MonadClient (Online c m) where
     query s = do
         conn <- asks connection
-        liftIO $ sendTextData conn (BS.pack s)
+        liftIO $ send conn s
     response = do
         conn <- asks connection
-        liftIO $ BS.unpack <$> receiveData conn
+        liftIO $ receive conn
 
-instance MonadPlayer m => MonadPlayer (Online m) where
+instance MonadPlayer m => MonadPlayer (Online a m) where
     trumpColour = lift $ trumpColour
     turnColour = lift $ turnColour
     showSkat = lift . showSkat
 
-choose :: MonadPlayer m => [CardS Played] -> [Card] -> Online m Card
+choose :: (Communicator c, MonadPlayer m) => [CardS Played] -> [Card] -> Online c m Card
 choose table hand = do
     query (BS.unpack $ encode $ ChooseQuery hand table)
     r <- response
@@ -59,29 +62,36 @@ choose table hand = do
             if card `elem` hand && allowed then return card else choose table hand
         Nothing -> choose table hand
 
-cardPlayed :: MonadPlayer m => CardS Played -> Online m ()
+cardPlayed :: (Communicator c, MonadPlayer m) => CardS Played -> Online c m ()
 cardPlayed card = query (BS.unpack $ encode $ CardPlayedQuery card)
 
-onResults :: MonadIO m => (Int, Int) -> Online m ()
+onResults :: (Communicator c, MonadIO m) => (Int, Int) -> Online c m ()
 onResults (sgl, tm) = query (BS.unpack $ encode $ GameResultsQuery sgl tm)
 
-data ChooseQuery = ChooseQuery [Card] [CardS Played]
+onStart :: (Communicator c, MonadPlayer m) => Hand -> Online c m ()
-data CardPlayedQuery = CardPlayedQuery (CardS Played)
+onStart singlePlayer = do
-data GameResultsQuery = GameResultsQuery Int Int
+    trCol <- trumpColour
-data ChosenResponse = ChosenResponse Card
+    ownHand <- asks getHand
+    query (BS.unpack $ encode $ GameStartQuery trCol ownHand singlePlayer)
     
-instance ToJSON ChooseQuery where
+data Query = ChooseQuery [Card] [CardS Played]
+           | CardPlayedQuery (CardS Played)
+           | GameResultsQuery Int Int
+           | GameStartQuery Colour Hand Hand
+
+data Response = ChosenResponse Card
+     
+instance ToJSON Query where
     toJSON (ChooseQuery hand table) =
         object ["query" .= ("choose_card" :: String), "hand" .= hand, "table" .= table]
-
-instance ToJSON CardPlayedQuery where
     toJSON (CardPlayedQuery card) =
         object ["query" .= ("card_played" :: String), "card" .= card]
-
-instance ToJSON GameResultsQuery where
     toJSON (GameResultsQuery sgl tm) =
         object ["query" .= ("results" :: String), "single" .= sgl, "team" .= tm]
+    toJSON (GameStartQuery trumps handNo sglPlayer) =
+        object ["query" .= ("start_game" :: String), "trumps" .= show trumps,
+                "hand" .= toInt handNo, "single" .= toInt sglPlayer]
 
-instance FromJSON ChosenResponse where
+instance FromJSON Response where
     parseJSON = withObject "ChosenResponse" $ \v -> ChosenResponse
         <$> v .: "card"

src/Skat/AI/Rulebased.hs

@@ -250,7 +250,7 @@ chooseStatistic = do
                     3 -> 3
                     -- simulate only partially
                     4 -> 3
-                    5 -> 2
+                    5 -> 3
                     6 -> 2
                     7 -> 1
                     8 -> 1
@@ -277,6 +277,7 @@ chooseStatistic = do
         limit = if depth == 1 && length table == 2
             then 1
             else min 10000 $ realDisNo `div` 2
+    liftIO $ putStrLn $ "players hand" ++ show handCards
     liftIO $ putStrLn $ "possible distrs without simp " ++ show realDisNo
     liftIO $ putStrLn $ "possible distrs " ++ show reducedDisNo
     vals <- M.toList <$> foldWithLimit limit runOnPiles M.empty piless
@@ -307,6 +308,7 @@ chooseOpen = do
     piles <- showPiles
     hand <- gets getHand
     let myCards = handCards hand piles
+    liftIO $ putStrLn $ show hand ++ " chooses from " ++ show myCards
     possible <- filterM (P.isAllowed myCards) myCards
     case length myCards of
         0 -> do
@@ -329,6 +331,7 @@ chooseSimulating = do
             results <- mapM simulate cs
             let both = zip results cs
                 best = maximumBy (comparing fst) both
+            liftIO $ putStrLn $ "results " ++ show both
             return $ snd best
 
 simulate :: (MonadState AIEnv m, MonadPlayerOpen m)
@@ -341,6 +344,7 @@ simulate card = do
     myTeam <- gets getTeam
     myHand <- gets getHand
     depth <- gets simulationDepth
+    liftIO $ putStrLn $ "simulate: " ++ show myHand ++ " plays " ++ show card
     let newDepth = depth - 1
         -- create a virtual env with 3 ai players
         ps = Players
@@ -364,7 +368,8 @@ predictValue (own, others) = do
     piles <- showPiles
     let cs = handCards hand piles
     pot <- potential cs
-    return $ own + pot
+    --return $ own + pot
+    return (own-others)
 
 potential :: (MonadState AIEnv m, MonadPlayerOpen m)
           => [Card] -> m Int
@@ -383,7 +388,7 @@ position card = do
     let effCol = effectiveColour tr card
         l = M.toList guess
         cs = filterMap ((==effCol) . effectiveColour tr . fst) fst l
-        csInd = zip [0..] cs
+        csInd = zip [0..] (reverse cs)
         Just (pos, _) = find ((== card) . snd) csInd
     return pos
 
@@ -401,8 +406,11 @@ chooseLead :: (MonadState AIEnv m, MonadPlayer m) => m Card
 chooseLead = do
     cards <- gets myHand
     possible <- filterM (P.isAllowed cards) cards
+    liftIO $ putStrLn $ "choosing lead from " ++ show possible
     pots <- mapM leadPotential possible
-    return $ snd $ maximumBy (comparing fst) (zip pots possible)
+    let ps = zip pots possible
+    liftIO $ putStrLn $ "lead potential of cards " ++ show ps
+    return $ snd $ maximumBy (comparing fst) ps
 
 mkAIEnv :: Team -> Hand -> Int -> AIEnv
 mkAIEnv tm h depth = AIEnv tm h [] [] [] newGuess depth

src/Skat/Card.hs

@@ -6,7 +6,7 @@ module Skat.Card where
 
 import Data.List
 import Data.Aeson
-import System.Random (newStdGen)
+import System.Random (newStdGen, StdGen)
 import Control.DeepSeq
 
 import Skat.Utils
@@ -123,6 +123,9 @@ shuffleCards = do
     gen <- newStdGen
     return $ shuffle gen allCards
 
+shuffleCardsWithGen :: StdGen -> [Card]
+shuffleCardsWithGen gen = shuffle gen allCards
+
 -- TESTING VARS
 
 c1 :: Card

src/Skat/Matches.hs

@@ -0,0 +1,44 @@
+module Skat.Matches (
+    singleVsBots
+) where
+
+import Control.Monad.State
+import System.Random (mkStdGen)
+
+import Skat
+import Skat.Operations
+import Skat.Player
+import Skat.Pile
+import Skat.Card
+
+import Skat.AI.Rulebased
+import Skat.AI.Online
+import Skat.AI.Stupid
+
+-- | predefined card distribution for testing purposes
+cardDistr :: Piles
+cardDistr = Piles hands [] (map (putAt SkatP) skt)
+    where hand3 = [Card Ace Spades, Card Jack Diamonds, Card Jack Clubs, Card King Spades,
+                   Card Nine Spades, Card Ace Diamonds, Card Queen Diamonds, Card Ten Clubs,
+                   Card Eight Clubs, Card King Clubs]
+          hand1 = [Card Jack Spades, Card Jack Hearts, Card Ten Spades, Card Ace Hearts, Card Ten Hearts,
+                   Card Nine Hearts, Card Seven Clubs, Card Ace Clubs, Card King Diamonds,
+                   Card Ten Diamonds]
+          hand2 = [Card Eight Spades, Card Queen Spades, Card Seven Spades, Card Seven Diamonds,
+                   Card Seven Hearts, Card Eight Hearts, Card Queen Hearts, Card King Hearts,
+                   Card Nine Diamonds, Card Eight Diamonds]
+          hands = map (putAt Hand1) hand1
+            ++ map (putAt Hand2) hand2
+            ++ map (putAt Hand3) hand3
+          skt = [Card Nine Clubs, Card Queen Clubs]
+
+singleVsBots :: Communicator c => c -> IO ()
+singleVsBots comm = do
+    --let gen = mkStdGen 123
+    --    cards = shuffleCardsWithGen gen
+    let ps = Players
+                (PL $ OnlineEnv Team Hand1 comm)
+                (PL $ Stupid Team Hand2)
+                (PL $ mkAIEnv Single Hand3 10)
+        env = SkatEnv cardDistr Nothing Spades ps
+    liftIO $ evalStateT (publishGameStart Hand3 >> turn Hand1 >>= publishGameResults) env

src/Skat/Operations.hs

@@ -1,4 +1,7 @@
-module Skat.Operations where
+module Skat.Operations (
+    turn, turnGeneric, play, playOpen, publishGameResults,
+    publishGameStart
+) where
 
 import Control.Monad.State
 import System.Random (newStdGen, randoms)
@@ -86,3 +89,13 @@ playOpen p = do
     card <- chooseCardOpen p
     modifyp $ playCard card
     return card
+
+publishGameResults :: (Int, Int) -> Skat ()
+publishGameResults res = do
+    pls <- gets players
+    mapM_ (\p -> onGameResults p res) (playersToList pls)
+
+publishGameStart :: Hand -> Skat ()
+publishGameStart sglPlayer = do
+    pls <- gets players
+    mapM_ (\p -> onGameStart p sglPlayer) (playersToList pls)

src/Skat/Pile.hs

@@ -28,6 +28,11 @@ instance ToJSON p => ToJSON (CardS p) where
 data Hand = Hand1 | Hand2 | Hand3
             deriving (Show, Eq, Ord)
 
+toInt :: Hand -> Int
+toInt Hand1 = 1
+toInt Hand2 = 2
+toInt Hand3 = 3
+
 next :: Hand -> Hand
 next Hand1 = Hand2
 next Hand2 = Hand3

src/Skat/Player.hs

@@ -43,6 +43,11 @@ class Player p where
                   -> (Int, Int)
                   -> m ()
     onGameResults _ _ = return ()
+    onGameStart :: MonadPlayer m
+                => p
+                -> Hand
+                -> m ()
+    onGameStart _ _ = return ()
 
 data PL = forall p. (Show p, Player p) => PL p
 
@@ -60,6 +65,7 @@ instance Player PL where
         return $ PL v
     chooseCardOpen (PL p) = chooseCardOpen p
     onGameResults (PL p) res = onGameResults p res
+    onGameStart (PL p) singlePlayer = onGameStart p singlePlayer
 
 data Players = Players PL PL PL
                deriving Show