Haskell implementation
This commit is contained in:
parent
ef9ba1aafe
commit
6c61765624
4 changed files with 328 additions and 0 deletions
30
LICENSE
Normal file
30
LICENSE
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2013, Barak Michener
|
||||
|
||||
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 Barak Michener 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.
|
||||
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
274
Tim.hs
Normal file
274
Tim.hs
Normal file
|
|
@ -0,0 +1,274 @@
|
|||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
|
||||
import qualified Numeric.Probability.Distribution as Dist
|
||||
import Numeric.Probability.Distribution as Probs
|
||||
--import Control.Monad (liftM2, replicateM, ap)
|
||||
--import Control.Monad (ap)
|
||||
import Control.Monad.Parallel (replicateM)
|
||||
import Control.Monad (replicateM, ap)
|
||||
import Data.List (permutations, isPrefixOf)
|
||||
import Data.List.Split (splitOn)
|
||||
import qualified Numeric.Probability.Random as Rnd
|
||||
import Numeric.Probability.Trace (Trace)
|
||||
|
||||
type Prob = Double
|
||||
type Dist a = Dist.T Prob a
|
||||
|
||||
data Side = Good | Evil
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
otherSide Good = Evil
|
||||
otherSide Evil = Good
|
||||
|
||||
data Role = Role { roleName :: String
|
||||
, roleSide :: Side }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type Deal = [Role]
|
||||
|
||||
good1 = Role "G1" Good
|
||||
good2 = Role "G2" Good
|
||||
good3 = Role "G3" Good
|
||||
good4 = Role "G4" Good
|
||||
good5 = Role "G5" Good
|
||||
good6 = Role "G6" Good
|
||||
bad1 = Role "E1" Evil
|
||||
bad2 = Role "E2" Evil
|
||||
bad3 = Role "E3" Evil
|
||||
bad4 = Role "E4" Evil
|
||||
|
||||
defaultGame :: Deal
|
||||
defaultGame = [good1, good2, good3, bad1, bad2,
|
||||
good4, bad3, good5, good6, bad4 ]
|
||||
|
||||
gameSize n = take n defaultGame
|
||||
|
||||
allDecks n = permutations $ take n defaultGame
|
||||
|
||||
|
||||
bernoulli :: Double -> Dist Bool
|
||||
bernoulli x = fromFreqs [(True, x), (False, (1 - x))]
|
||||
|
||||
deals :: Int -> Dist Deal
|
||||
deals = Dist.uniform . allDecks
|
||||
|
||||
stateSpace :: Int -> Dist Game
|
||||
stateSpace nPlayers = return Game `ap`
|
||||
deals nPlayers `ap` -- trueRoles
|
||||
bernoulli 0.5 `ap`
|
||||
makeVoteDucks `ap`
|
||||
makeProposalIgnorance `ap`
|
||||
makeProposalDucks `ap`
|
||||
makeDecay
|
||||
|
||||
--`ap` -- ladyWillLie
|
||||
--playerBeliefVar (1 / 3.0) nPlayers
|
||||
|
||||
data Game = Game { trueRoles :: Deal
|
||||
, ladyWillLie :: Bool
|
||||
, willDuckOnRound :: [Bool]
|
||||
, proposalIgnorant :: Double
|
||||
, proposalDucks :: Double
|
||||
, decay :: Double
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
|
||||
|
||||
beliefVar :: Double -> Dist Double
|
||||
beliefVar precision = Dist.uniform [0.0, precision..1.0]
|
||||
|
||||
playerBeliefVar :: Double -> Int -> Dist [Double]
|
||||
playerBeliefVar precision n_players = constraint ?=<< var
|
||||
where var = Control.Monad.replicateM n_players $ beliefVar precision
|
||||
constraint in_var =
|
||||
sum in_var == (sum $ Prelude.map (\x -> if roleSide x == Good then 1.0 else 0.0) $ gameSize n_players)
|
||||
|
||||
makeVoteDucks = mapM bernoulli [0.8, 0.6, 0.4]
|
||||
makeProposalIgnorance = certainly 0.8
|
||||
makeProposalDucks = certainly 0.8
|
||||
makeDecay = certainly 0.8
|
||||
|
||||
isGood :: Int -> Game -> Bool
|
||||
isGood player game = roleSide (trueRoles game !! player) == Good
|
||||
isEvil player game = roleSide (trueRoles game !! player) == Evil
|
||||
|
||||
playerNisRole :: Int -> String -> Dist.Event Game
|
||||
playerNisRole n name game = roleName (trueRoles game !! n) == name
|
||||
|
||||
seePlayerN n role dist = playerNisRole n role ?=<< dist
|
||||
|
||||
playerNisSide :: Int -> Side -> Dist.Event Game
|
||||
playerNisSide n side game = getSide n game == side
|
||||
|
||||
-- trustLevel n game = tableTrust game !! n
|
||||
|
||||
playerSeesPlayerAndClaims :: Int -> Int -> Side -> Dist.Event Game
|
||||
playerSeesPlayerAndClaims p1 p2 claim game =
|
||||
if isGood p1 game
|
||||
then playerNisSide p2 claim game
|
||||
else if not (ladyWillLie game) then playerNisSide p2 claim game
|
||||
else playerNisSide p2 (otherSide claim) game
|
||||
|
||||
getSide x game = roleSide (trueRoles game !! x)
|
||||
|
||||
getRoundIgnorance round game = proposalIgnorant game * (decay game ** (round - 1)) > 0.5
|
||||
|
||||
getProposalDucks round game = proposalDucks game * (decay game ** (round - 1)) > 0.5
|
||||
|
||||
|
||||
teamIsGood [] game = True
|
||||
teamIsGood (x:xs) game = getSide x game == Good && (teamIsGood xs game)
|
||||
|
||||
doProposal team votes round game =
|
||||
foldl (||) False $ Prelude.map (proposalConstraints game) $ zip [0,1..] votes
|
||||
where
|
||||
proposalConstraints game (player, vote) =
|
||||
if vote == 1 then
|
||||
if getSide player game == Good then
|
||||
if teamIsGood team game then True
|
||||
else if getRoundIgnorance round game then True
|
||||
else False
|
||||
else
|
||||
if not (teamIsGood team game) then True
|
||||
else if getProposalDucks round game then True
|
||||
else False
|
||||
else
|
||||
if getSide player game == Good then
|
||||
if not (teamIsGood team game) then True
|
||||
else if getRoundIgnorance round game then True
|
||||
else False
|
||||
else
|
||||
if teamIsGood team game then True
|
||||
else if getProposalDucks round game then True
|
||||
else False
|
||||
|
||||
|
||||
|
||||
-- doVote :: [Int] -> Int -> Dist.Event Game
|
||||
doVote team successes round game =
|
||||
foldl (||) False $ Prelude.map (makeConstraints game) $ [(successes, x) | x <- permutations team]
|
||||
where
|
||||
makeConstraints game (0, []) = True
|
||||
makeConstraints game (0, (x:xs)) = getSide x game == Evil && (makeConstraints game (0,xs))
|
||||
makeConstraints game (n, (x:xs)) = (getSide x game == Good || (ducks round game && (getSide x game == Evil))) && (makeConstraints game ((n - 1), xs))
|
||||
ducks round game = if round > 2 then False else ((willDuckOnRound game) !! round)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
assertOnGame x game = x ?=<< game
|
||||
|
||||
assertions = [(doVote [0, 2] 1 1), (playerSeesPlayerAndClaims 0 1 Evil)]
|
||||
|
||||
applyAssertions = foldl (\x y -> (assertOnGame y x))
|
||||
|
||||
|
||||
dropNth i list = (take i list) ++ (drop (i+1) (list))
|
||||
{-seePlayerN n role dist = do-}
|
||||
{-val <- dist-}
|
||||
{-Dist.filter (playerNisRole n role) val-}
|
||||
{-return val-}
|
||||
|
||||
--main = putStrLn $ show (seePlayerN 0 good1 deals)
|
||||
|
||||
playerReport n dist =
|
||||
"Player " ++ show n ++ ":\n" ++
|
||||
" Is Good: " ++ show (playerNisSide n Good ?? dist) ++ "\n" ++
|
||||
" Is Evil: " ++ show (playerNisSide n Evil ?? dist) ++ "\n"
|
||||
|
||||
ladyLoop nPlayers stateSpace assertions command ls =
|
||||
let continueLoop = mainLoop nPlayers stateSpace assertions ls in
|
||||
let args = splitOn " " command in
|
||||
if length args < 4 then do
|
||||
putStrLn $ show args
|
||||
continueLoop
|
||||
else do
|
||||
putStrLn "Got it"
|
||||
let arg1 = read (args !! 1) :: Int
|
||||
let arg2 = read (args !! 2) :: Int
|
||||
let arg3 = if (read (args !! 3) :: Int) == 1 then Good else Evil
|
||||
mainLoop nPlayers stateSpace (assertions ++ [(playerSeesPlayerAndClaims arg1 arg2 arg3)]) (ls ++ [command])
|
||||
|
||||
assertLoop nPlayers stateSpace assertions command ls =
|
||||
let continueLoop = mainLoop nPlayers stateSpace assertions ls in
|
||||
let args = splitOn " " command in
|
||||
if length args < 3 then do
|
||||
putStrLn $ show args
|
||||
continueLoop
|
||||
else do
|
||||
putStrLn "Got it"
|
||||
let arg1 = read (args !! 1) :: Int
|
||||
let arg2 = read (args !! 2) :: Int
|
||||
let side = if arg2 == 0 then Evil else Good in
|
||||
mainLoop nPlayers stateSpace (assertions ++ [(playerNisSide arg1 side)]) (ls ++ [command])
|
||||
|
||||
propLoop nPlayers stateSpace assertions command ls =
|
||||
let continueLoop = mainLoop nPlayers stateSpace assertions ls in
|
||||
let args = splitOn " " command in
|
||||
if length args < 4 then do
|
||||
putStrLn $ show args
|
||||
continueLoop
|
||||
else do
|
||||
putStrLn "Got it"
|
||||
let arg1 = Prelude.map (\x -> (read x :: Int)) $ drop 1 $ splitOn "" (args !! 1)
|
||||
let arg2 = Prelude.map (\x -> (read x :: Int)) $ drop 1 $ splitOn "" (args !! 2)
|
||||
let arg3 = read (args !! 3) :: Double
|
||||
putStrLn $ show arg1
|
||||
putStrLn $ show arg2
|
||||
mainLoop nPlayers stateSpace (assertions ++ [(doProposal arg1 arg2 (arg3 - 1))]) (ls ++ [command])
|
||||
|
||||
voteLoop nPlayers stateSpace assertions command ls =
|
||||
let continueLoop = mainLoop nPlayers stateSpace assertions ls in
|
||||
let args = splitOn " " command in
|
||||
if length args < 4 then do
|
||||
putStrLn $ show args
|
||||
continueLoop
|
||||
else do
|
||||
putStrLn "Got it"
|
||||
let arg1 = Prelude.map (\x -> (read x :: Int)) $ drop 1 $ splitOn "" (args !! 1)
|
||||
let arg2 = read (args !! 2) :: Int
|
||||
let arg3 = read (args !! 3) :: Int
|
||||
putStrLn $ show arg1
|
||||
putStrLn $ show arg2
|
||||
mainLoop nPlayers stateSpace (assertions ++ [(doVote arg1 arg2 (arg3 - 1))]) (ls ++ [command])
|
||||
|
||||
mainLoop nPlayers stateSpace assertions ls = do
|
||||
let continueLoop = mainLoop nPlayers stateSpace assertions ls
|
||||
putStrLn $ "Tim " ++ show nPlayers ++ "> "
|
||||
command <- getLine
|
||||
if command == "quit"
|
||||
then return ()
|
||||
else if isPrefixOf "lol" command then
|
||||
ladyLoop nPlayers stateSpace assertions command ls
|
||||
else if isPrefixOf "ass" command then
|
||||
assertLoop nPlayers stateSpace assertions command ls
|
||||
else if isPrefixOf "ls" command then do
|
||||
putStrLn $ foldl (\x y -> x ++ (show $ fst y) ++ ": " ++ (snd y) ++ "\n") "" $ zip [0,1..] ls
|
||||
continueLoop
|
||||
else if isPrefixOf "deass" command then do
|
||||
let args = splitOn " " command
|
||||
let arg1 = read (args !! 1) :: Int
|
||||
mainLoop nPlayers stateSpace (dropNth arg1 assertions) (dropNth arg1 ls)
|
||||
else if isPrefixOf "vot" command then
|
||||
voteLoop nPlayers stateSpace assertions command ls
|
||||
else if isPrefixOf "pro" command then
|
||||
propLoop nPlayers stateSpace assertions command ls
|
||||
else if command == "eval" then do
|
||||
trace <- Control.Monad.Parallel.replicateM 100 (Rnd.run $ Rnd.pick $ applyAssertions stateSpace assertions)
|
||||
let traceDist = Dist.uniform trace
|
||||
putStrLn $ foldl (++) "" $ Prelude.map (flip playerReport traceDist) [0..(nPlayers - 1)]
|
||||
continueLoop
|
||||
else do
|
||||
putStrLn "Unknown"
|
||||
continueLoop
|
||||
|
||||
main = do
|
||||
putStrLn "N players? "
|
||||
players <- getLine
|
||||
let nplayers = read players :: Int
|
||||
mainLoop nplayers (stateSpace nplayers) [] []
|
||||
|
||||
22
tim-the-enchanter.cabal
Normal file
22
tim-the-enchanter.cabal
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
-- Initial tim-the-enchanter.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: tim-the-enchanter
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Barak Michener
|
||||
maintainer: me@barakmich.com
|
||||
-- copyright:
|
||||
category: Game
|
||||
build-type: Simple
|
||||
cabal-version: >=1.8
|
||||
|
||||
executable tim-the-enchanter
|
||||
-- main-is:
|
||||
Main-is: Tim.hs
|
||||
ghc-options: -O3 -threaded -rtsopts
|
||||
-- other-modules:
|
||||
build-depends: base ==4.6.*, probability, monad-parallel, split
|
||||
Loading…
Add table
Add a link
Reference in a new issue