├── .gitignore
├── TODO.md
├── modalagents.cabal
├── src
├── Modal
│ ├── Programs.hs
│ ├── Programming.hs
│ ├── Utilities.hs
│ ├── Display.hs
│ ├── Agents.hs
│ ├── Games.hs
│ ├── GameTools.hs
│ ├── Parser.hs
│ ├── Competition.hs
│ ├── Statement.hs
│ ├── Def.hs
│ ├── Formulas.hs
│ ├── Code.hs
│ ├── CompilerBase.hs
│ └── Combat.hs
├── ModalCombat.hs
├── WebInterface.hs
└── WebInterface.jsexe
│ └── index.html
├── LICENSE
├── agents
└── target.ua
└── README.md
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.o
3 | *.hi
4 | /dist
5 | /.cabal-sandbox
6 | /cabal.sandbox.config
7 |
--------------------------------------------------------------------------------
/TODO.md:
--------------------------------------------------------------------------------
1 | 1. Write a commented examples file that explains how things work.
2 | 2. Play with the API for loading up a file and fiddling with the objects
3 | manually. We probably don't want *all* the interaction to go through the
4 | new language compiler, as it's probably still buggy (and it's not as
5 | powerful as manipulating the formula maps manually).
6 | 3. Remove or upgrade all the "dying files" discussed in the README.
7 | 4. Grep around for TODOs
8 |
--------------------------------------------------------------------------------
/modalagents.cabal:
--------------------------------------------------------------------------------
1 | name: ModalCombat
2 | version: 0.0.1.0
3 | synopsis: Evaluates modal agents.
4 | license: MIT
5 | license-file: LICENSE
6 | author: Nate Soares
7 | maintainer: nate@intelligence.org
8 | build-type: Simple
9 | cabal-version: >=1.10
10 |
11 | executable modalcombat
12 | main-is: ModalCombat.hs
13 | hs-source-dirs: src
14 | default-language: Haskell2010
15 | default-extensions: OverloadedStrings
16 | build-depends:
17 | base >= 4.7,
18 | bytestring >= 0.10,
19 | containers >= 0.5,
20 | mtl >= 2.2.1,
21 | optparse-applicative >=0.10,
22 | parsec >= 3.1.7,
23 | text >= 1.1,
24 | transformers >= 0.4.1
25 |
--------------------------------------------------------------------------------
/src/Modal/Programs.hs:
--------------------------------------------------------------------------------
1 | module Modal.Programs where
2 | import Modal.Formulas
3 | import Modal.GameTools
4 | import Modal.Programming
5 | import Modal.Utilities
6 |
7 | generalUDT :: Eq a => [Int] -> [u] -> [a] -> a -> ModalProgram a (U1 u a)
8 | generalUDT levels uorder aorder dflt = completeProgram dflt mainLoop where
9 | mainLoop = mFor (zip levels uaPairs) (uncurry checkUApair)
10 | uaPairs = [(u, a) | u <- uorder, a <- aorder]
11 | checkUApair n (u, a) = mIf (boxk n (Var (U1A a) %> Var (U1 u))) (mReturn a)
12 |
13 | escalatingUDT :: (Eq a, Enum a, Enum u) => [Int] -> a -> ModalProgram a (U1 u a)
14 | escalatingUDT levels = generalUDT levels enumerate enumerate
15 |
16 | udtN :: (Eq a, Enum a, Enum u) => Int -> a -> ModalProgram a (U1 u a)
17 | udtN level = generalUDT (repeat level) enumerate enumerate
18 |
19 | udt' :: Eq a => [u] -> [a] -> a -> ModalProgram a (U1 u a)
20 | udt' = generalUDT (repeat 0)
21 |
22 | udt :: (Eq a, Enum a, Enum u) => a -> ModalProgram a (U1 u a)
23 | udt = udtN 0
24 |
--------------------------------------------------------------------------------
/src/ModalCombat.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | import Control.Monad (foldM)
3 | import Data.Monoid
4 | import Options.Applicative
5 | import System.Environment (getProgName)
6 | import Modal.Combat
7 | import Modal.Utilities
8 |
9 | programDescription :: String
10 | programDescription =
11 | "Modal combat checker. Figures out how modal agents will behave " <>
12 | "when pitted against each other."
13 |
14 | data Options = Options
15 | { optEnvs :: [FilePath]
16 | , optFile :: FilePath
17 | , optUtf8 :: Bool
18 | } deriving Show
19 |
20 | optionParser :: Parser Options
21 | optionParser = Options
22 | <$> many (option str
23 | ( long "env"
24 | <> short 'e'
25 | <> metavar "FILE"
26 | <> help "An environment file defining other agents." ))
27 | <*> argument str
28 | ( metavar "FILE" )
29 | <*> switch
30 | ( long "utf8"
31 | <> short 'u'
32 | <> help "Interpret input files in UTF-8." )
33 |
34 | options :: String -> ParserInfo Options
35 | options name = info (helper <*> optionParser)
36 | ( fullDesc
37 | <> progDesc programDescription
38 | <> header (name ++ " - MODAL COMBAT!" ) )
39 |
40 | main :: IO ()
41 | main = do
42 | name <- getProgName
43 | opts <- execParser $ options name
44 | let useUtf8 = optUtf8 opts
45 | file = optFile opts
46 | settings <- mapM (compileFile useUtf8) (optEnvs opts)
47 | case settings of
48 | [] -> playFile useUtf8 file
49 | (x:xs) -> foldM (run .: mergeSettingsR) x xs >>= playFile' useUtf8 file
50 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2015, Machine Intelligence Research Institute
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of the Machine Intelligence Research Institute, nor
17 | the names of other contributors may be used to endorse or promote
18 | products derived from this software without specific prior written
19 | permission.
20 |
21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 |
--------------------------------------------------------------------------------
/agents/target.ua:
--------------------------------------------------------------------------------
1 | --------------------------------------------------------------------------
2 | -- This is our standard modal version of UDT.
3 | -- (Parameterized by default action, staring proof level, and proof escalation
4 | -- amount.)
5 |
6 | theory UDT(action default, number level=0, number step=0)
7 | let &n = &level
8 | for outcome &o in outcomes
9 | for action &a in actions
10 | if [&n]⌜A()=&a → U()=&o⌝
11 | return &a
12 | let &n = &n + &step
13 | return &default
14 |
15 | --------------------------------------------------------------------------
16 | -- Here are some simple decision problems.
17 |
18 | problem FiveAndTen [$10, $5] [10, 5]
19 | if A()=5
20 | return $5
21 | return $10
22 |
23 | problem Newcomb(number level=0) [$1001000, $1000000, $1000, $0] [1, 2]
24 | if A()=2 and [&level]⌜A()=1⌝
25 | return $1001000
26 | if A()=1 and [&level]⌜A()=1⌝
27 | return $1000000
28 | if A()=2
29 | return $1000
30 | return $0
31 |
32 | problem map 5and10 [$10, $5] [5, 10]
33 | $5 ↔ A()=5
34 | $10 ↔ A()=10
35 |
36 | problem map PD [$DC, $CC, $DD, $CD] [C, D]
37 | $DC ↔ A1()=D and A2()=C
38 | $CC ↔ A1()=C and A2()=C
39 | $DD ↔ A1()=D and A2()=D
40 | $CD ↔ A1()=C and A2()=D
41 |
42 | bot CooperateBot = ⊤
43 |
44 | bot DefectBot = ⊥
45 |
46 | agent FairBot
47 | if □⌜Them(Me)=C⌝
48 | return C
49 | return D
50 |
51 | agent PrudentBot
52 | if [1]⌜Them(DefectBot)=D⌝ and □⌜Them(Me)=C⌝
53 | return C
54 | return D
55 |
56 | combat with frames! PrudentBot vs FairBot
57 |
58 | compete: PrudentBot vs FairBot
59 |
60 | play with map with frames: FiveAndTen, UDT(5).
61 | play: Newcomb, UDT(2, step=1).
62 | play: Newcomb(1), UDT(2, level=10, step=1).
63 | play: 5and10, UDT(5).
64 | play: 5and10, UDT(10).
65 | play: PD,
66 | UDT(D, step=1)[...][$DC, $CC, $DD, $CD],
67 | UDT(D, step=1)[...][$CD, $CC, $DD, $DC].
68 |
--------------------------------------------------------------------------------
/src/Modal/Programming.hs:
--------------------------------------------------------------------------------
1 | module Modal.Programming where
2 | import Prelude hiding ((.), id)
3 | import Control.Arrow
4 | import Control.Category
5 | import Data.Maybe
6 | import qualified Data.List as List
7 | import Modal.Display
8 | import Modal.Formulas
9 | import Modal.Parser
10 | import Text.Parsec (sepEndBy)
11 | import Text.Parsec.Text
12 |
13 | type ModalProgram a v = a -> ModalFormula v
14 |
15 | showProgram :: (Show a, Show v) => [a] -> ModalProgram a v -> String
16 | showProgram as p = renderTable $ tuplesToTable [(a, p a) | a <- as]
17 |
18 | programParser :: (Eq a, Read v) => Parser a -> Parser (ModalProgram a v)
19 | programParser p = makeProgram <$> (line `sepEndBy` w) where
20 | line = (,) <$> (p <* symbol ":") <*> parser
21 | makeProgram kvs = fromJust . flip List.lookup kvs
22 |
23 | -------------------------------------------------------------------------------
24 |
25 | -- The type of partial programs. You must tell them "what to do next" in order
26 | -- to generate the completed ModalProgram.
27 | type PartialProgram a v = ModalProgram a v -> ModalProgram a v
28 |
29 | -- Completes a program by adding a default action.
30 | completeProgram :: Eq a => a -> PartialProgram a v -> ModalProgram a v
31 | completeProgram dflt f = f $ Val . (dflt ==)
32 |
33 | -- Partial program that ignores the continuation and returns a.
34 | mReturn :: Eq a => a -> PartialProgram a v
35 | mReturn a _ = Val . (a ==)
36 |
37 | -- Partial program that either does t or e before the continuation.
38 | mIfElse :: ModalFormula v -> PartialProgram a v -> PartialProgram a v -> PartialProgram a v
39 | mIfElse cond t e next a = Or (cond %^ t next a) (Neg cond %^ e next a) where
40 | -- Alternatively: And (Imp cond (tnext a)) (Imp (Neg cond) (enext a))
41 |
42 | -- Partial program that may or may not do t.
43 | mIf :: ModalFormula v -> PartialProgram a v-> PartialProgram a v
44 | mIf cond t = mIfElse cond t id
45 |
46 | -- Partial program that iterates over the list of cs.
47 | mFor :: [c] -> (c -> PartialProgram a v) -> PartialProgram a v
48 | mFor [] _ = id
49 | mFor (c:cs) f = f c <<< mFor cs f
50 |
--------------------------------------------------------------------------------
/src/WebInterface.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types, DeriveDataTypeable #-}
2 | module Main (
3 | main
4 | ) where
5 |
6 | import Prelude hiding ((!!))
7 | import Control.Applicative ((<$>))
8 | import Control.Monad.Trans (liftIO)
9 | import GHCJS.DOM
10 | import GHCJS.DOM.CSSStyleDeclaration
11 | import GHCJS.DOM.Document
12 | import GHCJS.DOM.HTMLElement
13 | import GHCJS.DOM.Element
14 | import GHCJS.DOM.HTMLTextAreaElement
15 | import GHCJS.DOM.Node
16 | import GHCJS.DOM.EventM
17 | import GHCJS.DOM.Types
18 | import Data.Text.Lazy (Text, unpack)
19 | import Text.Blaze.Html.Renderer.Text (renderHtml)
20 | import Text.Hamlet (shamlet)
21 | import Text.Blaze.Html (Html)
22 | import Text.Parsec hiding ((<|>), optional, many, State)
23 | import qualified Data.Text as T (unpack, pack)
24 |
25 | import Modal.Combat
26 | import Modal.Utilities
27 |
28 | runGame source = do
29 | game <- run $ parse gameParser "input" $ T.pack source
30 | playGame "game" $ game
31 |
32 | main = runWebGUI $ \ webView -> do
33 | enableInspector webView
34 | Just doc <- webViewGetDomDocument webView
35 | Just body <- documentGetBody doc
36 | Just div <- fmap castToHTMLDivElement <$> documentCreateElement doc "div"
37 | mbTerminal <- fmap castToHTMLDivElement <$> documentGetElementById doc "terminal"
38 | case mbTerminal of
39 | Just terminal -> do
40 | Just style <- elementGetStyle terminal
41 | cssStyleDeclarationSetProperty style "height" "200px" ""
42 | cssStyleDeclarationSetProperty style "position" "absolute" ""
43 | cssStyleDeclarationSetProperty style "bottom" "0" ""
44 | nodeInsertBefore body (Just div) (Just terminal)
45 | _ -> do
46 | nodeAppendChild body (Just div)
47 | Just input <- fmap castToHTMLTextAreaElement <$> documentGetElementById doc "input"
48 | Just btn <- fmap castToHTMLInputElement <$> documentGetElementById doc "btn"
49 | Just output <- fmap castToHTMLPreElement <$> documentGetElementById doc "output"
50 | elementOnclick btn $ liftIO $ do
51 | source <- htmlTextAreaElementGetValue input
52 | htmlElementSetInnerHTML output ""
53 | runGame $ unpack source
54 | return ()
55 |
--------------------------------------------------------------------------------
/src/Modal/Utilities.hs:
--------------------------------------------------------------------------------
1 | module Modal.Utilities
2 | ( (.:)
3 | , (.::)
4 | , (.:::)
5 | , ($>)
6 | , (<$$>)
7 | , Name
8 | , enumerate
9 | , alter
10 | , every
11 | , swap
12 | , firstDup
13 | , die
14 | , wrapError
15 | , force
16 | , run
17 | , runFile
18 | ) where
19 | import Prelude hiding (readFile)
20 | import Control.Monad.Except hiding (mapM, sequence)
21 | import qualified Data.ByteString as BS
22 | import Data.Text (Text)
23 | import Data.Text.Encoding (decodeUtf8)
24 | import Data.Text.IO (readFile)
25 | import System.IO (stderr, hPutStrLn)
26 | import System.Exit hiding (die)
27 | import Text.Printf (printf)
28 | import qualified Data.Set as Set
29 |
30 | (.:) :: (c -> x) -> (a -> b -> c) -> a -> b -> x
31 | (.:) = (.) . (.)
32 |
33 | (.::) :: (d -> x) -> (a -> b -> c -> d) -> a -> b -> c -> x
34 | (.::) = (.) . (.) . (.)
35 |
36 | (.:::) :: (e -> x) -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> x
37 | (.:::) = (.) . (.) . (.) . (.)
38 |
39 | infixl 4 $>, <$$>
40 |
41 | ($>) :: Applicative f => f a -> b -> f b
42 | x $> y = x *> pure y
43 |
44 | (<$$>) :: Functor f => f a -> (a -> b) -> f b
45 | (<$$>) = flip (<$>)
46 |
47 | type Name = String
48 |
49 | enumerate :: Enum a => [a]
50 | enumerate = enumFrom (toEnum 0)
51 |
52 | alter :: [a] -> Int -> (a -> a) -> [a]
53 | alter [] _ _ = error "empty list"
54 | alter (x:xs) 0 f = f x : xs
55 | alter (x:xs) n f = x : alter xs (pred n) f
56 |
57 | every :: Int -> [a] -> [a]
58 | every n (x : xs) = x : every n (drop (pred n) xs)
59 | every _ [] = []
60 |
61 | swap :: (a, b) -> (b, a)
62 | swap = uncurry $ flip (,)
63 |
64 | firstDup :: Ord a => [a] -> Maybe a
65 | firstDup = either Just (const Nothing) . foldM addToSet Set.empty where
66 | addToSet s x = if x `Set.member` s then Left x else Right (Set.insert x s)
67 |
68 | die :: Show a => a -> IO b
69 | die x = hPutStrLn stderr ("Failure: " ++ show x) >> exitFailure
70 |
71 | wrapError :: MonadError b m => (a -> b) -> Except a c -> m c
72 | wrapError wrap = either (throwError . wrap) return . runExcept
73 |
74 | force :: Show l => Either l r -> r
75 | force = either (error . printf "Forcing failed: %s" . show) id
76 |
77 | run :: Show x => Either x a -> IO a
78 | run = either die return
79 |
80 | readFileEnc :: Bool -> FilePath -> IO Text
81 | readFileEnc useUtf8 = if useUtf8 then readFileUtf8 else readFile
82 | where
83 | readFileUtf8 fn = decodeUtf8 <$> BS.readFile fn
84 |
85 | runFile :: Show x => (Text -> Either x a) -> Bool -> FilePath -> IO a
86 | runFile f useUtf8 path = run . f =<< readFileEnc useUtf8 path
87 |
--------------------------------------------------------------------------------
/src/Modal/Display.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Modal.Display where
3 | import Control.Arrow (first)
4 | import Data.List (transpose, intercalate)
5 | import Data.Map hiding (map, foldr)
6 | import Data.Monoid ((<>))
7 | import Data.Text (Text)
8 | import qualified Data.Text as Text
9 | import qualified Data.Text.IO as Text.IO
10 | import Modal.Utilities
11 | import Text.Printf (printf)
12 |
13 | type Table = [[String]]
14 |
15 | padr :: a -> Int -> [a] -> [a]
16 | padr x n xs = xs ++ replicate (n - length xs) x
17 |
18 | padl :: a -> Int -> [a] -> [a]
19 | padl x n xs = replicate (n - length xs) x ++ xs
20 |
21 | listmapToTable :: (Show k, Ord k) => [k] -> Map k [String] -> Table
22 | listmapToTable [] _ = []
23 | listmapToTable ks m = header : rows where
24 | header = "" : " │" : map (printf " %s" . show) ks
25 | unpaddedCols = map (m !) ks
26 | cols = map (padr "" $ maximum $ map length unpaddedCols) unpaddedCols
27 | rows = zipWith addNum [0 :: Int ..] (transpose cols)
28 | addNum n row = show n : " │" : map (printf " %s") row
29 |
30 | tuplesToTable :: (Show k, Show v) => [(k, v)] -> Table
31 | tuplesToTable kvs = [row k v | (k, v) <- kvs] where
32 | row k v = [padr ' ' maxwidth (show k), " : ", show v]
33 | maxwidth = foldr (\(k, _) n -> max (length $ show k) n) 0 kvs
34 |
35 | displayMap :: (Ord k, Show k, Show v) => Map k v -> IO ()
36 | displayMap = putStrLn . unlines . map concat . tuplesToTable . toAscList
37 |
38 | squareUp' :: String -> String -> Table -> [[String]]
39 | squareUp' l r rows = map normalizeRow paddedRows where
40 | paddedRows = map (padr "" $ maxlen rows) rows
41 | maxlen = foldr (max . length) 0
42 | normalizeRow = zipWith normalizeCell [0..] where
43 | normalizeCell i c = l ++ padr ' ' (colwidth i) c ++ r
44 | colwidth i = maximum [length $ row !! i | row <- paddedRows]
45 |
46 | squareUp :: Table -> [[String]]
47 | squareUp = squareUp' "" ""
48 |
49 | renderTable :: Table -> String
50 | renderTable table = unlines $ map concat (squareUp table)
51 |
52 | indentTable :: String -> Table -> Table
53 | indentTable indent = map (indent:)
54 |
55 | displayTable :: Table -> IO ()
56 | displayTable = putStrLn . renderTable
57 |
58 | class Blockable a where
59 | blockLines :: a -> [(Int, Text)]
60 |
61 | increaseIndent :: [(Int, Text)] -> [(Int, Text)]
62 | increaseIndent = map (first succ)
63 |
64 | renderBlock' :: Blockable a => Text -> a -> Text
65 | renderBlock' indent = Text.unlines . map (uncurry indented) . blockLines where
66 | indented n = (mconcat (replicate n indent) <>)
67 |
68 | renderBlock :: Blockable a => a -> Text
69 | renderBlock = renderBlock' " "
70 |
71 | displayBlock' :: Blockable a => Text -> a -> IO ()
72 | displayBlock' = Text.IO.putStrLn .: renderBlock'
73 |
74 | displayBlock :: Blockable a => a -> IO ()
75 | displayBlock = Text.IO.putStrLn . renderBlock
76 |
77 | -- TODO: Replace as many List.intercalates as you can with this.
78 | renderArgs :: (a -> String) -> [a] -> String
79 | renderArgs f = intercalate ", " . map f
80 |
--------------------------------------------------------------------------------
/src/WebInterface.jsexe/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
11 |
12 |
13 | Modal Kombat!
14 |
80 |
81 |
82 |
83 |
107 |
108 |
109 |
--------------------------------------------------------------------------------
/src/Modal/Agents.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | module Modal.Agents where
4 | import Control.Applicative
5 | import Data.Monoid
6 | import Modal.Code (Agent, ModalVar(..), Program, agent, ContextError, forceCompile)
7 | import Modal.Formulas
8 | import Modal.Environment
9 | import Modal.Parser
10 | import qualified Data.Text as Text
11 | import Text.Parsec (oneOf, ParseError)
12 | import Modal.Display
13 |
14 | data CorD = C | D deriving (Eq, Ord, Enum, Read, Show)
15 | instance Parsable CorD where parser = read . pure <$> oneOf "CD"
16 |
17 | instance Read (ModalVar CorD CorD) where
18 | readsPrec _ str = [(from name, rest) | not $ null name] where
19 | name = takeWhile (`elem` '_' : ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']) str
20 | rest = dropWhile (`elem` '_' : ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']) str
21 | from "a" = MeVsThemIs C
22 | from "b" = ThemVsMeIs C
23 | from n = ThemVsOtherIs (Text.pack n) C
24 |
25 | type AgentVar = ModalVar CorD CorD
26 |
27 | layeredBot :: Int -> ModalFormula AgentVar -> ModalFormula AgentVar
28 | layeredBot n base = foldl1 Or (map level [0..n]) where
29 | cond k = Neg (boxk k base) %^ diak k base
30 | level 0 = Box base
31 | level k = foldl1 And (map cond [0..pred k]) %^ boxk k base
32 |
33 | masqueBot :: Int -> ModalFormula AgentVar
34 | masqueBot n = dbLoop $ tbfLoop disjunct where
35 | dbLoop = loopBreakDBot (read "¬DB") (read "DB")
36 | tbfLoop = loopBreakDBot (read "TbF_2") (read "¬TbF_2")
37 | disjunct = foldl1 Or (map (\k -> boxk k $ read "b") [0..n])
38 | loopBreakDBot fbreak fdefect cont = breakOut n %^ cont where
39 | cond m = foldl1 And $ map (\k -> Neg (boxk k fbreak) %^ Neg (boxk k fdefect)) [0..m]
40 | breakOut 0 = Box fbreak
41 | breakOut m = breakOut (pred m) %| (cond (pred m) %^ boxk m fbreak)
42 |
43 | modalUDT :: (Agent CorD CorD)
44 | Right modalUDT = agent $
45 | "def UDT\n" <>
46 | " let $level = 0\n" <>
47 | " for outcome $o in ...\n" <>
48 | " for action $a in ...\n" <>
49 | " if [] $level [Me(Them)=$a -> Them(Me)=$o]\n" <>
50 | " return $a\n" <>
51 | " end\n" <>
52 | " let $level = $level + 1\n" <>
53 | " end\n" <>
54 | " end\n" <>
55 | " return\n"
56 |
57 | prg :: ModalFormula AgentVar -> Program CorD CorD
58 | prg f C = f
59 | prg f D = Neg f
60 |
61 | bot :: String -> Program CorD CorD
62 | bot = prg . read
63 |
64 | env :: Env CorD CorD
65 | Right env = nobody @<
66 | -- Rank 0 bots
67 | ("CB", bot "⊤") @+
68 | ("DB", bot "⊥") @+
69 | ("FB", bot "□ b") @+
70 | ("FB_1", bot "[1] b") @+
71 | ("FB_2", bot "[2] b") @+
72 | ("FB_3", bot "[3] b") @+
73 | ("FB_4", bot "[4] b") @+
74 | ("FB_5", bot "[5] b") @+
75 | ("TbF_1", prg $ layeredBot 1 $ read "b") @+
76 | ("TbF_2", prg $ layeredBot 2 $ read "b") @+
77 | ("TbF_3", prg $ layeredBot 3 $ read "b") @+
78 | ("FB_r", bot "¬□¬b ∧ □b") @+
79 | ("MB", bot "[1](□a → b)") @+
80 | ("WB", bot "¬□⊥ ∧ [1]b") @+
81 | ("WB_2", bot "¬□a ∧ (□¬a ∨ [1]b)") @+
82 | ("aMB", bot "¬[1](□¬a → b) ∧ [2](¬[1](□¬a → b) → b)") @+
83 | ("sMB", bot "□(◇a → b)") @+
84 | ("IB", bot "¬(□(a → ¬b))") @+
85 | -- Rank 1 bots
86 | ("PB", bot "□b ∧ [1]¬DB") @+
87 | ("PB_2", prg $ layeredBot 2 $ read "¬DB ∧ b") @+
88 | ("PB_3", prg $ layeredBot 3 $ read "¬DB ∧ b") @+
89 | ("NB", bot "□CB") @+
90 | ("JB", bot "□FB") @+
91 | ("TB", bot "□DB") @+
92 | ("QB_1", prg $ masqueBot 1) @+
93 | ("QB_2", prg $ masqueBot 2) @+
94 | ("QB_3", prg $ masqueBot 3)
95 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | Lightning overview:
2 |
3 | `Modal/Formulas.hs` is the starting point. That's where the modal formula data
4 | structure is defined, and that's where the fixed point solver lives.
5 |
6 | The other files are as follows: (Read in order to understand the code)
7 |
8 | `Modal/CompilerBase.hs`: Contains basic types used throughout the compiler,
9 | such as Ref, Relation, and all the error types.
10 |
11 | `Modal/Statement.hs`: Contains the definition and parser for "statements",
12 | which are like modal formulas but can refer to variables at the meta level.
13 | They can be turned into a formula given a context. (For example, "A()=&a
14 | → U()=&u" can be turned into a formula given a context containing both a and
15 | u.)
16 |
17 | `Modal/Code.hs`: Contains the definition and parser for "code", including if
18 | blocks, for blocks, etc. Can compile them down to a map of modal formulas: give
19 | it an action it gives you a formula saying true iff the code returns that
20 | action.
21 |
22 | `Modal/Def.hs`: Contains the definition and parser for "defs", which are the
23 | full agents including a name, parameters, code, etc. This file also contains
24 | the logic for applying the parameters from a call to create the code context,
25 | and then compiling the def into a map of modal formulas.
26 |
27 | `Modal/Competition.hs`: This basically takes a bunch of agent maps and combines
28 | them into the competition map evaluated by the fixpoint evaluator. It can
29 | currently either play two modalized agents againts each other, or it can play
30 | many modalized agents against a single unmodalized universe.
31 |
32 | `Modal/Combat.hs`: Contains the definition of and logic for handilng files such
33 | as `agents/test.mc` (which *totally exists* (TODO)), which consist of a series
34 | of agent definitions and execution commands used to play agents againt seach
35 | other or inspect their behavior.
36 |
37 | `ModalCombat.hs`: The file implementing the `modalcombat` executable, which
38 | runs on files such as the one found in `agents/test.mc`. (See that file for
39 | an example of what sort of syntax is supported.)
40 |
41 | Dying files
42 | -----------
43 |
44 | `Modal/Programming.hs`: This file provides some tools for making modal agents
45 | in Haskell (rather than in the still-rough-around-the-edges modal program
46 | language). Eventually the modal programming language may supersede the tools in
47 | this file, but we don't necessarily want to delete it altogether. (We might
48 | decide to add better tools for manipulating modal agents in ghci or something.)
49 |
50 | `Modal/GameTools.hs`: A file that makes it easier to evaluate agents in
51 | multi-player games. This file is slowly being deprecated by upgrades to
52 | `Combat.hs`, but it will be a little while before we're comfortable enough with
53 | multi-agent games in the language parser to justify removing this code.
54 |
55 | `Modal/Agents.hs`: A dead file that has a bunch of agents defined in it using
56 | an old format. They need to be evacuated to a file of their own, and then this
57 | file can be removed.
58 |
59 | `Modal/Games.hs`: Various haskell implementations of modal games
60 | (hand-specified), including the 5 and 10 problem, the Newcomb problem, and so
61 | on. This file is dying; the games need to be evacuated to a file of their own
62 | and then this file can be removed.
63 |
64 | Helpers
65 | -------
66 |
67 | `Modal/Utilities.hs`: contains some haskell convenience tools (such as
68 | functions which turn Either x a into IO a, etc).
69 |
70 | `Modal/Parser.hs`: contains some parsec convenience tools (such as a Parsable
71 | typeclass, etc).
72 |
73 | `Modal/Display.hs`: contains some display convenience tools (such as code for
74 | rendering maps, etc).
75 |
--------------------------------------------------------------------------------
/src/Modal/Games.hs:
--------------------------------------------------------------------------------
1 | module Modal.Games where
2 | import Data.Map hiding (map)
3 | import Modal.Display
4 | import Modal.Formulas
5 | import Modal.GameTools
6 | import Modal.Programming
7 | import Modal.Programs
8 |
9 | data FiveOrTen = Ten | Five deriving (Eq, Ord, Read, Enum)
10 | instance Show FiveOrTen where
11 | show Ten = "10"
12 | show Five = "5"
13 |
14 | fiveAndTen :: ModalProgram FiveOrTen FiveOrTen
15 | fiveAndTen Five = Var Five
16 | fiveAndTen Ten = Var Ten
17 |
18 |
19 | data OneOrTwo = OneBox | TwoBox deriving (Eq, Ord, Read, Enum)
20 | instance Show OneOrTwo where
21 | show OneBox = "1"
22 | show TwoBox = "2"
23 |
24 | data NewcombOutcome = MillionThousand | Million | Thousand | Naught
25 | deriving (Eq, Ord, Read, Enum)
26 | instance Show NewcombOutcome where
27 | show MillionThousand = "$1001000"
28 | show Million = "$1000000"
29 | show Thousand = "$1000"
30 | show Naught = "$0"
31 |
32 | oneboxes, twoboxes :: ModalFormula OneOrTwo
33 | oneboxes = Var OneBox
34 | twoboxes = Neg oneboxes
35 |
36 | newcomb :: Int -> ModalProgram NewcombOutcome OneOrTwo
37 | newcomb k MillionThousand = twoboxes %^ boxk k oneboxes
38 | newcomb k Million = oneboxes %^ boxk k oneboxes
39 | newcomb k Thousand = twoboxes %^ Neg (boxk k oneboxes)
40 | newcomb k Naught = oneboxes %^ Neg (boxk k oneboxes)
41 |
42 |
43 | data AorB = A| B deriving (Eq, Ord, Read, Enum)
44 | instance Show AorB where
45 | show A = "A"
46 | show B = "B"
47 | data GoodOrBad = Good | Bad deriving (Eq, Ord, Show, Read, Enum)
48 |
49 | doesA, doesB :: ModalFormula AorB
50 | doesA = Var A
51 | doesB = Neg doesA
52 |
53 | aGame :: Int -> ModalProgram GoodOrBad AorB
54 | aGame k Good = boxk k doesA
55 | aGame k Bad = Neg (boxk k doesA)
56 |
57 | bGame :: Int -> ModalProgram GoodOrBad AorB
58 | bGame k Good = boxk k doesB
59 | bGame k Bad = Neg (boxk k doesB)
60 |
61 | abAgent :: ModalProgram GoodOrBad AorB -> ModalProgram AorB AorB
62 | abAgent univ A = Box $ Var A %> univ Good
63 | abAgent univ B = Neg $ Box $ Var A %> univ Good
64 |
65 | data Strangeverse = Three | Two | One deriving (Eq, Ord, Read, Enum)
66 | instance Show Strangeverse where
67 | show Three = "3"
68 | show Two = "2"
69 | show One = "1"
70 | data Strangeact = Alpha | Beta deriving (Eq, Ord, Read, Enum)
71 | instance Show Strangeact where
72 | show Alpha = "α"
73 | show Beta = "β"
74 |
75 | doesAlpha, doesBeta :: ModalFormula Strangeact
76 | doesAlpha = Var Alpha
77 | doesBeta = Neg doesAlpha
78 |
79 | strangeverse :: Int -> ModalProgram Strangeverse Strangeact
80 | strangeverse k Three = doesAlpha %^ boxk k doesBeta
81 | strangeverse k Two = doesBeta
82 | strangeverse k One = doesAlpha %^ Neg (boxk k doesBeta)
83 |
84 |
85 | data PD = DC | CC | DD | CD deriving (Eq, Ord, Read, Enum)
86 | instance Show PD where
87 | show DC = "[D₁C₂]"
88 | show CC = "[C₁C₂]"
89 | show DD = "[D₁D₁]"
90 | show CD = "[C₁D₂]"
91 | data CorD = C | D deriving (Eq, Ord, Read, Enum)
92 | instance Show CorD where
93 | show C = "C"
94 | show D = "D"
95 |
96 | prisonersDilemma :: ModalProgram PD (Either CorD CorD)
97 | prisonersDilemma DC = And (Var $ Left D) (Var $ Right C)
98 | prisonersDilemma CC = And (Var $ Left C) (Var $ Right C)
99 | prisonersDilemma DD = And (Var $ Left D) (Var $ Right D)
100 | prisonersDilemma CD = And (Var $ Left C) (Var $ Right D)
101 |
102 | pdGameMap :: Map (U2 PD CorD CorD) (ModalFormula (U2 PD CorD CorD))
103 | pdGameMap = gameMap2 prisonersDilemma udtA udtB where
104 | udtA = udt' [DC, CC, DD, CD] [D, C] D
105 | udtB = udt' [CD, CC, DD, DC] [D, C] D
106 |
107 |
108 | main :: IO ()
109 | main = do
110 | putStrLn "In Newcomb's problem, if the predictor uses a box to predict"
111 | putStrLn "the agent's action, UDT takes whatever its default action was:"
112 | displayGame (newcomb 0) (udt OneBox)
113 | displayGame (newcomb 0) (udt TwoBox)
114 | putStrLn ""
115 | putStrLn "These are the modal formulas for UDT in the newcomb problem:"
116 | displayMap $ gameMap (newcomb 0) (udt TwoBox)
117 | putStrLn ""
118 | putStrLn "Time for the five and ten game!"
119 | displayGame fiveAndTen (udt Five)
120 | putStrLn ""
121 | putStrLn "These are the modal formulas for UDT in the 5-and-10 game:"
122 | displayMap $ gameMap fiveAndTen (udt Five)
123 |
--------------------------------------------------------------------------------
/src/Modal/GameTools.hs:
--------------------------------------------------------------------------------
1 | module Modal.GameTools where
2 | import Control.Applicative
3 | import Modal.Formulas
4 | import Data.Map hiding (map)
5 | import qualified Data.Map as Map
6 | import Modal.Competition
7 | import Modal.Programming
8 | import Modal.Utilities
9 | import Text.Printf (printf)
10 |
11 | data U1 u a = U1 u | U1A a | Q1 String deriving (Eq, Ord, Read)
12 | instance (Show a, Show u) => Show (U1 u a) where
13 | show (U1 u) = show u ++ "ₒ"
14 | show (U1A a) = show a ++ "ₐ"
15 | show (Q1 q) = q ++ "?"
16 | instance Functor (U1 u) where
17 | fmap f (U1A a) = U1A (f a)
18 | fmap _ (U1 u) = U1 u
19 | fmap _ (Q1 s) = Q1 s
20 |
21 | u1IsU :: U1 u a -> Bool
22 | u1IsU (U1 _) = True
23 | u1IsU _ = False
24 |
25 | u1IsA :: U1 u a -> Bool
26 | u1IsA (U1A _) = True
27 | u1IsA _ = False
28 |
29 | u1ExtractU :: Map (U1 u a) Bool -> u
30 | u1ExtractU m = let U1 u = extractPMEEkey u1IsU m in u
31 |
32 | u1ExtractA :: Map (U1 u a) Bool -> a
33 | u1ExtractA m = let U1A a = extractPMEEkey u1IsA m in a
34 |
35 | gameMap :: (Ord u, Enum u, Ord a, Enum a) =>
36 | ModalProgram u a ->
37 | ModalProgram a (U1 u a) ->
38 | Map (U1 u a) (ModalFormula (U1 u a))
39 | gameMap universe agent = Map.fromList $ us ++ as where
40 | us = [(U1 u, U1A <$> universe u) | u <- enumerate]
41 | as = [(U1A a, agent a) | a <- enumerate]
42 |
43 | resolveGame :: (Show a, Show u, Ord u, Enum u, Ord a, Enum a) =>
44 | Map (U1 u a) (ModalFormula (U1 u a)) ->
45 | (u, a)
46 | resolveGame game = (u1ExtractU fixpt, u1ExtractA fixpt) where
47 | fixpt = findGeneralGLFixpoint game
48 |
49 | playGame :: (Show a, Show u, Ord u, Enum u, Ord a, Enum a) =>
50 | ModalProgram u a ->
51 | ModalProgram a (U1 u a) ->
52 | (u, a)
53 | playGame universe agent = resolveGame $ gameMap universe agent
54 |
55 | showGame :: (Show u, Show a) => (u, a) -> IO ()
56 | showGame (u, a) =
57 | printf "U=%s, A=%s\n" (show u) (show a)
58 |
59 | displayGame :: (Ord u, Enum u, Show u, Ord a, Enum a, Show a) =>
60 | ModalProgram u a ->
61 | ModalProgram a (U1 u a) ->
62 | IO ()
63 | displayGame universe agent = showGame $ playGame universe agent
64 |
65 |
66 | data U2 u a1 a2 = U2 u | U2A1 a1 | U2A2 a2 | Q2 String deriving (Eq, Ord, Read)
67 | instance (Show u, Show a1, Show a2) => Show (U2 u a1 a2) where
68 | show (U2 u) = show u ++ "ₒ"
69 | show (U2A1 a) = show a ++ "₁"
70 | show (U2A2 a) = show a ++ "₂"
71 | show (Q2 q) = q ++ "?"
72 |
73 | u2IsU :: U2 u a1 a2 -> Bool
74 | u2IsU (U2 _) = True
75 | u2IsU _ = False
76 |
77 | u2IsA1 :: U2 u a1 a2 -> Bool
78 | u2IsA1 (U2A1 _) = True
79 | u2IsA1 _ = False
80 |
81 | u2IsA2 :: U2 u a1 a2 -> Bool
82 | u2IsA2 (U2A2 _) = True
83 | u2IsA2 _ = False
84 |
85 | u2ExtractU :: Map (U2 u a1 a2) Bool -> u
86 | u2ExtractU m = let U2 u = extractPMEEkey u2IsU m in u
87 |
88 | u2ExtractA1 :: Map (U2 u a1 a2) Bool -> a1
89 | u2ExtractA1 m = let U2A1 a = extractPMEEkey u2IsA1 m in a
90 |
91 | u2ExtractA2 :: Map (U2 u a1 a2) Bool -> a2
92 | u2ExtractA2 m = let U2A2 a = extractPMEEkey u2IsA2 m in a
93 |
94 | gameMap2 :: (Ord u, Enum u, Ord a1, Enum a1, Ord a2, Enum a2) =>
95 | ModalProgram u (Either a1 a2) ->
96 | ModalProgram a1 (U1 u a1) ->
97 | ModalProgram a2 (U1 u a2) ->
98 | Map (U2 u a1 a2) (ModalFormula (U2 u a1 a2))
99 | gameMap2 universe agent1 agent2 = Map.fromList $ us ++ a1s ++ a2s where
100 | us = [(U2 u, promoteToA <$> universe u) | u <- enumerate]
101 | a1s = [(U2A1 a1, promoteTo1 <$> agent1 a1) | a1 <- enumerate]
102 | a2s = [(U2A2 a2, promoteTo2 <$> agent2 a2) | a2 <- enumerate]
103 | promoteToA (Left a) = U2A1 a
104 | promoteToA (Right a) = U2A2 a
105 | promoteTo1 (U1A a) = U2A1 a
106 | promoteTo1 (U1 u) = U2 u
107 | promoteTo1 (Q1 s) = Q2 s
108 | promoteTo2 (U1A a) = U2A2 a
109 | promoteTo2 (U1 u) = U2 u
110 | promoteTo2 (Q1 s) = Q2 s
111 |
112 | resolveGame2 :: (Show u, Show a1, Show a2, Ord u, Enum u, Ord a1, Enum a1, Ord a2, Enum a2) =>
113 | Map (U2 u a1 a2) (ModalFormula (U2 u a1 a2)) ->
114 | (u, a1, a2)
115 | resolveGame2 game = (u2ExtractU fp, u2ExtractA1 fp, u2ExtractA2 fp) where
116 | fp = findGeneralGLFixpoint game
117 |
118 | playGame2 :: (Show u, Show a1, Show a2, Ord u, Enum u, Ord a1, Enum a1, Ord a2, Enum a2) =>
119 | ModalProgram u (Either a1 a2) ->
120 | ModalProgram a1 (U1 u a1) ->
121 | ModalProgram a2 (U1 u a2) ->
122 | (u, a1, a2)
123 | playGame2 u a1 a2 = resolveGame2 $ gameMap2 u a1 a2
124 |
125 | showGame2 :: (Show u, Show a1, Show a2) => (u, a1, a2) -> IO ()
126 | showGame2 (u, a1, a2) =
127 | printf "U=%s, A₁=%s, A₂=%s\n" (show u) (show a1) (show a2)
128 |
129 | displayGame2 ::
130 | (Ord u, Enum u, Show u,
131 | Ord a1, Enum a1, Show a1,
132 | Ord a2, Enum a2, Show a2) =>
133 | ModalProgram u (Either a1 a2) ->
134 | ModalProgram a1 (U1 u a1) ->
135 | ModalProgram a2 (U1 u a2) ->
136 | IO ()
137 | displayGame2 u a1 a2= showGame2 $ playGame2 u a1 a2
138 |
--------------------------------------------------------------------------------
/src/Modal/Parser.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Modal.Parser where
3 | import Control.Applicative
4 | import Control.Monad (void)
5 | import Data.Char
6 | import Data.Functor.Identity
7 | import Data.Set (Set)
8 | import Data.Text (Text)
9 | import Modal.Utilities
10 | import Text.Parsec hiding ((<|>), optional, many)
11 | import Text.Parsec.Text (Parser)
12 | import Text.Printf (printf)
13 | import qualified Data.Set as Set
14 | import qualified Data.Text as Text
15 |
16 | class Parsable a where
17 | parser :: Parser a
18 |
19 | instance Parsable Int where
20 | parser = read <$> many1 digit
21 | instance Parsable x => Parsable [x] where
22 | parser = listParser parser
23 | instance (Ord x, Parsable x) => Parsable (Set x) where
24 | parser = setParser parser
25 | instance Parsable a => Parsable (Identity a) where
26 | parser = Identity <$> parser
27 |
28 | listParser :: Parser x -> Parser [x]
29 | listParser p = brackets $ sepEndBy p comma
30 |
31 | setParser :: Ord x => Parser x -> Parser (Set x)
32 | setParser p = Set.fromList <$> braces (sepEndBy p comma)
33 |
34 | keyword :: String -> Parser ()
35 | keyword s = void $ try w *> try (string s) <* lookAhead ok <* w where
36 | ok = try eof <|> void (satisfy isOk)
37 | isOk c = not (isLetter c) && not (isNumber c) && c `notElem` ("-_" :: String)
38 |
39 | symbol :: String -> Parser ()
40 | symbol s = void $ w *> string s <* w
41 |
42 | eol :: Parser ()
43 | eol = try (void endOfLine) <|> try eof "a line ending"
44 |
45 | eols :: Parser ()
46 | eols = void $ many1 (w *> endOfLine)
47 |
48 | ignoredToken :: Parser ()
49 | ignoredToken
50 | = try _blockComment
51 | <|> try _lineComment
52 | <|> void (char ' ')
53 | "whitespace"
54 |
55 | _blockComment :: Parser ()
56 | _blockComment = void (o *> many innards *> c) "a block comment" where
57 | o = string "{-"
58 | c = string "-}"
59 | safeMark = char '-' *> notFollowedBy (char '}')
60 | innards = _blockComment <|> void (noneOf "-") <|> try safeMark
61 |
62 | _lineComment :: Parser ()
63 | _lineComment = void ((string "--" *> many (noneOf "\n")) "a line comment")
64 |
65 | ignoredLine :: Parser ()
66 | ignoredLine = many (void (char '\t') <|> ignoredToken) *> void endOfLine
67 |
68 | w :: Parser ()
69 | w = void $ many ignoredToken
70 |
71 | w1 :: Parser ()
72 | w1 = void $ many1 ignoredToken
73 |
74 | identifier :: Parser Char -> Parser Char -> Parser Name
75 | identifier h t = (:) <$> h <*> many t
76 |
77 | parens :: Parser a -> Parser a
78 | parens = between (symbol "(") (symbol ")")
79 |
80 | comma :: Parser ()
81 | comma = symbol ","
82 |
83 | powerComma :: Parser () -- can span newlines and eat tabs etc. Ugh.
84 | powerComma = void $ wN *> string "," <* wN where
85 | wN = void $ many (ignoredToken <|> void (char '\t') <|> void endOfLine)
86 |
87 | brackets :: Parser a -> Parser a
88 | brackets = between (symbol "[") (symbol "]")
89 |
90 | braces :: Parser a -> Parser a
91 | braces = between (symbol "{") (symbol "}")
92 |
93 | name :: Parser Name
94 | name = identifier (satisfy isNameFirstChar) (satisfy isNameChar)
95 |
96 | valueStr :: Parser String
97 | valueStr = many1 (satisfy isValueChar)
98 |
99 | isNameFirstChar, isNameChar, isValueChar :: Char -> Bool
100 | isNameFirstChar = (||) <$> isLetter <*> (`elem` ("-_'" :: String))
101 | isNameChar = (||) <$> isNameFirstChar <*> isNumber
102 | -- TODO: we may safely relax this, but it's not clear how far.
103 | isValueChar c = c `elem` ("$@" :: String) || isNameChar c
104 |
105 | anyComboOf :: Parser x -> Parser y -> Parser (Maybe x, Maybe y)
106 | anyComboOf x y = try xThenMaybeY <|> try yThenMaybeX <|> pure (Nothing, Nothing) where
107 | xThenMaybeY = (,) <$> (Just <$> x) <*> optional y
108 | yThenMaybeX = flip (,) <$> (Just <$> y) <*> optional x
109 |
110 | -------------------------------------------------------------------------------
111 | -- Testing
112 | verifyParseResult :: Show a => (a -> Maybe String) -> Parser a -> Text -> IO ()
113 | verifyParseResult check p input = either parseErr doCheck parsed where
114 | parsed = parse (p <* eof) "verifying parser" input
115 | doCheck result = maybe (putStr ".") checkErr (check result)
116 | parseErr = printf "\nError parsing \"%s\" in %s\n" (Text.unpack input) . show
117 | checkErr = printf "\nFailure parsing \"%s\"!\n%s\n" (Text.unpack input)
118 |
119 | verifyParser :: (Show a, Eq a) => Parser a -> Text -> a -> IO ()
120 | verifyParser p input target = verifyParseResult isTarget p input where
121 | isTarget result = if result == target
122 | then Nothing
123 | else Just $ printf "Expected %s, got %s" (show target) (show result)
124 |
125 | verifyParserFails :: Show a => Parser a -> Text -> IO ()
126 | verifyParserFails p input = either succeed err parsed where
127 | parsed = parse (p <* eof) "verifying parser failure" input
128 | succeed _ = putStr "."
129 | err result = printf "\nError! Expected a failure parsing \"%s\", but parsed %s.\n"
130 | (Text.unpack input) (show result)
131 |
132 | verifyParsable :: (Show a, Eq a, Parsable a) => Text -> a -> IO ()
133 | verifyParsable = verifyParser parser
134 |
135 | main :: IO ()
136 | main = do
137 | verifyParser w " {- IGNORE THIS COMMENT -} {- this one too. -}" ()
138 | verifyParser w " {- {- nested -} woo -} " ()
139 | verifyParser w " -- anything goes now! \t \t" ()
140 | verifyParserFails w " {- {- nested woo -} "
141 |
--------------------------------------------------------------------------------
/src/Modal/Competition.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Rank2Types #-}
2 | {-# LANGUAGE MultiParamTypeClasses #-}
3 | {-# LANGUAGE ConstraintKinds #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | module Modal.Competition where
6 | import Prelude hiding (mapM, sequence)
7 | import Control.Arrow ((***))
8 | import Control.Monad.Except hiding (mapM, sequence)
9 | import Data.Traversable (sequence)
10 | import Data.Map (Map)
11 | import Data.Maybe (fromMaybe)
12 | import Data.Set (Set)
13 | import Modal.CompilerBase
14 | import Modal.Formulas hiding (left)
15 | import Text.Printf (printf)
16 | import qualified Data.Map as Map
17 | import qualified Data.Set as Set
18 |
19 | extractPMEEkey :: (k -> Bool) -> Map k Bool -> k
20 | extractPMEEkey p = extract . Map.keys . Map.filterWithKey matchKey where
21 | matchKey k v = p k && v
22 | extract [ ] = error "No true formula! Map was not P.M.E.E."
23 | extract [x] = x
24 | extract _ = error "Multiple true formulas! Map was not P.M.E.E."
25 |
26 | --------------------------------------------------------------------------------
27 | -- The type of variables that actually makes it into the full competition map.
28 | -- This can be thought as the type of "canonicalized names" of various
29 | -- statements, such as "FairBot(PrudentBot)=C."
30 |
31 | data VsVar a o
32 | = Vs1 Call Call a
33 | | Vs2 Call Call o
34 | deriving (Eq, Ord)
35 |
36 | instance (Show a, Show o) => Show (VsVar a o) where
37 | show (Vs1 call1 call2 a) = printf "%s(%s)=%s" (show call1) (show call2) (show a)
38 | show (Vs2 call1 call2 o) = printf "%s(%s)=%s" (show call1) (show call2) (show o)
39 |
40 | is1 :: Call -> Call -> VsVar a o -> Bool
41 | is1 n m (Vs1 x y _) = x == n && y == m
42 | is1 _ _ _ = False
43 |
44 | is2 :: Call -> Call -> VsVar a o -> Bool
45 | is2 n m (Vs2 x y _) = x == n && y == m
46 | is2 _ _ _ = False
47 |
48 | class ModalCombatVar v where
49 | subagentsIn :: v a o -> Set Call
50 | makeModalVar :: (a-> x) -> (Maybe Call -> o-> x) -> v a o -> x
51 |
52 | subagents :: ModalCombatVar v => ModalAgent v a o -> Set Call
53 | subagents = Set.unions . map fSubagents . Map.elems where
54 | fSubagents = Set.unions . map subagentsIn . allVars
55 |
56 | --------------------------------------------------------------------------------
57 | -- Competitions, by default, allow agents with different action types to play
58 | -- against each other. This introduces a bit of extra complexity to the types;
59 | -- some helper functions (without 2s in their names) exist below to handle this
60 | -- simpler case.
61 |
62 | type ModalAgent v a o = Map a (ModalFormula (v a o))
63 | type Env m v a o = Call -> m (ModalAgent v a o)
64 | type Competition a o = Map (VsVar a o) (ModalFormula (VsVar a o))
65 | type IsCompetition v1 v2 a o =
66 | ( Ord a, Ord o, ModalCombatVar v1, ModalCombatVar v2 )
67 |
68 | -- Attempts to build a map of modal formulas describing the competition, given
69 | -- two environments and two names.
70 | modalCombatMap :: (IsCompetition v1 v2 a o, MonadError RuntimeError m) =>
71 | Env m v1 a o -> Env m v2 o a -> Call -> Call -> m (Competition a o)
72 | modalCombatMap env1 env2 call1 call2 = do
73 | agent1 <- env1 call1
74 | agent2 <- env2 call2
75 | let agent1map = Map.toList agent1
76 | let agent2map = Map.toList agent2
77 | let expand1 = fmap $ makeModalVar (Vs1 call1 call2) (Vs2 call2 . fromMaybe call1)
78 | let expand2 = fmap $ makeModalVar (Vs2 call2 call1) (Vs1 call1 . fromMaybe call2)
79 | let top1 = map (Vs1 call1 call2 *** expand1) agent1map
80 | let top2 = map (Vs2 call2 call1 *** expand2) agent2map
81 | let recurse = modalCombatMap env1 env2
82 | lefts <- sequence [recurse x call2 | x <- Set.toList $ subagents agent1]
83 | rights <- sequence [recurse call1 x | x <- Set.toList $ subagents agent2]
84 | return $ Map.unions $ Map.fromList top1 : Map.fromList top2 : lefts ++ rights
85 |
86 | -- TODO: Add error handling.
87 | -- (Right now, the fixpoint evaluator just errors when bad things happen.)
88 | modalCombatResolve :: (Show x, Show y, Ord x, Ord y) =>
89 | Call -> Call -> Competition x y -> (x, y)
90 | modalCombatResolve call1 call2 cmap = (result1, result2) where
91 | fixpt = findGeneralGLFixpoint cmap
92 | Vs1 _ _ result1 = extractPMEEkey (is1 call1 call2) fixpt
93 | Vs2 _ _ result2 = extractPMEEkey (is2 call2 call1) fixpt
94 |
95 | -- Attempts to figure out how the two named agents behave against each other.
96 | -- WARNING: This function may error if the modal formulas in the competition
97 | -- map are not P.M.E.E. (provably mutally exclusive and extensional).
98 | modalCombat :: (Show x, Show y, IsCompetition v1 v2 x y, MonadError RuntimeError m) =>
99 | Env m v1 x y -> Env m v2 y x -> Call -> Call -> m (x, y)
100 | modalCombat env1 env2 call1 call2 =
101 | modalCombatResolve call1 call2 <$> modalCombatMap env1 env2 call1 call2
102 |
103 | --------------------------------------------------------------------------------
104 | -- Simplified versions of the above functions for the scenario where both
105 | -- agents have the same action type.
106 |
107 | modalCombatMap1 :: (Ord a, ModalCombatVar v, MonadError RuntimeError m) =>
108 | Env m v a a -> Call -> Call -> m (Competition a a)
109 | modalCombatMap1 env = modalCombatMap env env
110 |
111 | modalCombat1 :: (Show a, Ord a, ModalCombatVar v, MonadError RuntimeError m) =>
112 | Env m v a a -> Call -> Call -> m (a, a)
113 | modalCombat1 env = modalCombat env env
114 |
115 | --------------------------------------------------------------------------------
116 | -- Competitions, by default, allow agents with different action types to play
117 | -- against each other. This introduces a bit of extra complexity to the types;
118 | -- some helper functions (without 2s in their names) exist below to handle this
119 | -- simpler case.
120 |
121 | type IsMultiCompetition vu va u a = (Ord u, Ord a, MultiVarU vu, MultiVarA va)
122 | type MultiCompetition u a = Map (MultiVsVar u a) (ModalFormula (MultiVsVar u a))
123 |
124 | class MultiVarA v where
125 | promoteA :: Int -> v a u -> MultiVsVar u a
126 |
127 | class MultiVarU v where
128 | promoteU :: v u a -> MultiVsVar u a
129 |
130 | data MultiVsVar u a = UniversePlays u | PlayerNPlays Int a deriving (Eq, Ord)
131 |
132 | instance (Show u, Show a) => Show (MultiVsVar u a) where
133 | show (UniversePlays x) = printf "U()=%s" (show x)
134 | show (PlayerNPlays i x) = printf "A%d()=%s" i (show x)
135 |
136 | isEntryFor :: Int -> MultiVsVar u a -> Bool
137 | isEntryFor 0 (UniversePlays _) = True
138 | isEntryFor _ (UniversePlays _) = False
139 | isEntryFor n (PlayerNPlays i _) = n == i
140 |
141 | multiCompetition :: IsMultiCompetition vu va u a =>
142 | Map u (ModalFormula (vu u a)) ->
143 | [Map a (ModalFormula (va a u))] ->
144 | MultiCompetition u a
145 | multiCompetition univ agents = Map.unions (uMap : pMaps) where
146 | uMap = Map.fromList $ map (uncurry createUEntry) $ Map.toList univ
147 | createUEntry outcome uFormula = (UniversePlays outcome, promoteU <$> uFormula)
148 | pMaps = zipWith createMap [1..] agents where
149 | createEntry n = PlayerNPlays n *** fmap (promoteA n)
150 | createMap n = Map.fromList . map (createEntry n) . Map.toList
151 |
152 | -- TODO: Add error handling.
153 | -- (Right now, the fixpoint evaluator just errors when bad things happen.)
154 | multiResolve :: (Show a, Show u, Ord a, Ord u) =>
155 | Int -> MultiCompetition u a -> (u, [a])
156 | multiResolve n cmap = (u, as) where
157 | fixpt = findGeneralGLFixpoint cmap
158 | UniversePlays u = extractPMEEkey (isEntryFor 0) fixpt
159 | as = [let PlayerNPlays _ a = extractPMEEkey (isEntryFor i) fixpt
160 | in a | i <- [1 .. n]]
161 |
162 | multiCompete :: (Show a, Show u, IsMultiCompetition vu va u a) =>
163 | Map u (ModalFormula (vu u a)) ->
164 | [Map a (ModalFormula (va a u))] ->
165 | (u, [a])
166 | multiCompete univ agents =
167 | multiResolve (length agents) (multiCompetition univ agents)
168 |
--------------------------------------------------------------------------------
/src/Modal/Statement.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ConstraintKinds #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE FlexibleInstances #-}
4 | {-# LANGUAGE OverloadedStrings #-}
5 | {-# LANGUAGE ScopedTypeVariables #-}
6 | {-# LANGUAGE TypeFamilies #-}
7 | module Modal.Statement where
8 | import Prelude hiding (readFile, sequence, mapM, foldr1, concat, concatMap)
9 | import Control.Applicative
10 | import Modal.CompilerBase hiding (main)
11 | import Modal.Formulas (ModalFormula)
12 | import Modal.Parser hiding (main)
13 | import Modal.Utilities
14 | import Text.Parsec hiding ((<|>), optional, many, State)
15 | import Text.Parsec.Expr
16 | import Text.Parsec.Text (Parser)
17 | import Text.Printf (printf)
18 | import qualified Data.Map as M
19 | import qualified Data.Text as T
20 | import qualified Modal.Formulas as F
21 |
22 | -------------------------------------------------------------------------------
23 |
24 | data Statement
25 | = Val Bool
26 | | Var ParsedClaim
27 | | Neg Statement
28 | | And Statement Statement
29 | | Or Statement Statement
30 | | Imp Statement Statement
31 | | Iff Statement Statement
32 | | Consistent (Ref Int)
33 | | Provable (Ref Int) Statement
34 | | Possible (Ref Int) Statement
35 | deriving Eq
36 |
37 | data ShowStatement = ShowStatement {
38 | topSymbol :: String,
39 | botSymbol :: String,
40 | notSymbol :: String,
41 | andSymbol :: String,
42 | orSymbol :: String,
43 | impSymbol :: String,
44 | iffSymbol :: String,
45 | conSign :: String -> String,
46 | boxSign :: String-> String,
47 | diaSign :: String -> String,
48 | quotes :: (String, String) }
49 |
50 | showsStatement :: ShowStatement -> Int -> Statement -> ShowS
51 | showsStatement sf p statement = result where
52 | result = case statement of
53 | Val l -> showString $ if l then topSymbol sf else botSymbol sf
54 | Var v -> showString $ show v
55 | Neg x -> showParen (p > 8) $ showString (notSymbol sf) . showsStatement sf 8 x
56 | And x y -> showParen (p > 7) $ showBinary (andSymbol sf) 7 x 8 y
57 | Or x y -> showParen (p > 6) $ showBinary (orSymbol sf) 6 x 7 y
58 | Imp x y -> showParen (p > 5) $ showBinary (impSymbol sf) 6 x 5 y
59 | Iff x y -> showParen (p > 4) $ showBinary (iffSymbol sf) 5 x 4 y
60 | Consistent v -> showString $ conSign sf (show v)
61 | Provable v x -> showParen (p > 8) $ showInner boxSign v 8 x
62 | Possible v x -> showParen (p > 8) $ showInner diaSign v 8 x
63 | padded o = showString " " . showString o . showString " "
64 | showBinary o l x r y = showsStatement sf l x . padded o . showsStatement sf r y
65 | showInner sig v i x = showString (sig sf $ show v) . quote (showsStatement sf i x)
66 | quote s = let (l, r) = quotes sf in showString l . s . showString r
67 |
68 | instance Show Statement where
69 | showsPrec = showsStatement (ShowStatement "⊤" "⊥" "¬" "∧" "∨" "→" "↔"
70 | (printf "Con(%s)")
71 | (\var -> if var == "0" then "□" else printf "[%s]" var)
72 | (\var -> if var == "0" then "◇" else printf "<%s>" var)
73 | ("⌜", "⌝"))
74 |
75 | instance Parsable Statement where
76 | parser = buildExpressionParser lTable term where
77 | lTable =
78 | [ [Prefix lNeg]
79 | , [ Infix lAnd AssocRight ]
80 | , [ Infix lOr AssocRight ]
81 | , [ Infix lImp AssocRight ]
82 | , [ Infix lIff AssocRight ] ]
83 | term
84 | = parens parser
85 | <|> try cConsistent
86 | <|> try (fProvable <*> quoted parser)
87 | <|> try (fPossible <*> quoted parser)
88 | <|> try (Var <$> parser)
89 | <|> try (Val <$> val)
90 | "a statement term"
91 | val = try sTop <|> try sBot "a boolean value" where
92 | sTop = sym $> True where
93 | sym = try (symbol "⊤")
94 | <|> try (keyword "top")
95 | <|> try (keyword "true")
96 | <|> try (keyword "True")
97 | "truth"
98 | sBot = sym $> False where
99 | sym = try (symbol "⊥")
100 | <|> try (keyword "bot")
101 | <|> try (keyword "bottom")
102 | <|> try (keyword "false")
103 | <|> try (keyword "False")
104 | "falsehood"
105 | lNeg = sym $> Neg where
106 | sym = try (symbol "¬")
107 | <|> try (symbol "~")
108 | <|> try (keyword "not")
109 | "a negation"
110 | lAnd = sym $> And where
111 | sym = try (symbol "∧")
112 | <|> try (symbol "/\\")
113 | <|> try (symbol "&")
114 | <|> try (symbol "&&")
115 | <|> try (keyword "and")
116 | "an and"
117 | lOr = sym $> Or where
118 | sym = try (symbol "∨")
119 | <|> try (symbol "\\/")
120 | <|> try (symbol "|")
121 | <|> try (symbol "||")
122 | <|> try (keyword "and")
123 | "an or"
124 | lImp = sym $> Imp where
125 | sym = try (symbol "→")
126 | <|> try (symbol "->")
127 | <|> try (keyword "implies")
128 | "an implication"
129 | lIff = sym $> Iff where
130 | sym = try (symbol "↔")
131 | <|> try (symbol "<->")
132 | <|> try (keyword "iff")
133 | "a biconditional"
134 | cConsistent = (symbol "Con" $> Consistent) <*> option (Lit 0) (parens parser)
135 | quoted x
136 | = try (between (symbol "⌜") (symbol "⌝") x)
137 | <|> try (between (symbol "[") (symbol "]") x)
138 | fProvable = try inSym <|> choice (map (try . afterSym) syms) "a box" where
139 | inSym = Provable <$> (char '[' *> option (Lit 0) parser <* char ']')
140 | afterSym s = Provable <$> (symbol s *> option (Lit 0) (parens parser))
141 | syms = ["□", "Provable", "Box"]
142 | fPossible = try inSym <|> choice (map (try . afterSym) syms) "a diamond" where
143 | inSym = Possible <$> (char '<' *> option (Lit 0) parser <* char '>')
144 | afterSym s = Possible <$> (symbol s *> option (Lit 0) (parens parser))
145 | syms = ["◇", "Possible", "Dia", "Diamond"]
146 |
147 | claimsParsed :: Statement -> [ParsedClaim]
148 | claimsParsed statement = case statement of
149 | Val _ -> []
150 | Var a -> [a]
151 | Neg s -> claimsParsed s
152 | And x y -> claimsParsed x ++ claimsParsed y
153 | Or x y -> claimsParsed x ++ claimsParsed y
154 | Imp x y -> claimsParsed x ++ claimsParsed y
155 | Iff x y -> claimsParsed x ++ claimsParsed y
156 | Consistent _ -> []
157 | Provable _ s -> claimsParsed s
158 | Possible _ s -> claimsParsed s
159 |
160 | type HandleVar v m = ParsedClaim -> m (ModalFormula v)
161 |
162 | compileStatement :: MonadCompile m => HandleVar v m -> Statement -> m (ModalFormula v)
163 | compileStatement handleVar stm = case stm of
164 | Val v -> return $ F.Val v
165 | Var v -> handleVar v
166 | Neg x -> F.Neg <$> rec x
167 | And x y -> F.And <$> rec x <*> rec y
168 | Or x y -> F.Or <$> rec x <*> rec y
169 | Imp x y -> F.Imp <$> rec x <*> rec y
170 | Iff x y -> F.Iff <$> rec x <*> rec y
171 | Consistent v -> F.incon <$> lookupN v
172 | Provable r x -> F.boxk <$> lookupN r <*> rec x
173 | Possible r x -> F.diak <$> lookupN r <*> rec x
174 | where rec = compileStatement handleVar
175 |
176 | -------------------------------------------------------------------------------
177 | -- Testing
178 |
179 | main :: IO ()
180 | main = do
181 | let fails = verifyParserFails (parser :: Parser Statement)
182 | let simpleClaim = ParsedClaim "A" Nothing (Equals $ Lit "a")
183 | verifyParsable "⊤" (Val True)
184 | verifyParsable "⊥" (Val False)
185 | fails "a"
186 | verifyParsable "A()=a" (Var simpleClaim)
187 | verifyParsable "¬A()=a" (Neg $ Var simpleClaim)
188 | verifyParsable "A()=a ∧ A()=a" (And (Var simpleClaim) (Var simpleClaim))
189 | verifyParsable "A()=a∨A()=a" (Or (Var simpleClaim) (Var simpleClaim))
190 | verifyParsable "A()=a → A()=a" (Imp (Var simpleClaim) (Var simpleClaim))
191 | verifyParsable "(⊤ ∨ ⊥) ∧ (⊤ ∨ ⊥)" (And
192 | (Or (Val True) (Val False)) (Or (Val True) (Val False)))
193 | verifyParsable "⊤ ∧ ⊤ ∨ ⊥ ∧ ⊥" (Or
194 | (And (Val True) (Val True)) (And (Val False) (Val False)))
195 | verifyParsable "⊤ → ⊥ ∧ ⊥" (Imp (Val True) (And (Val False) (Val False)))
196 | verifyParsable "⊤↔⊥" (Iff (Val True) (Val False))
197 | fails "x ∧ ∨ y"
198 | verifyParsable "Con(1)" (Consistent (Lit 1))
199 | verifyParsable "Con(&n)" (Consistent (Ref "n"))
200 | fails "Con 1"
201 | verifyParsable "□⌜⊤⌝" (Provable (Lit 0) (Val True))
202 | verifyParsable "[][top]" (Provable (Lit 0) (Val True))
203 | verifyParsable "[1][top]" (Provable (Lit 1) (Val True))
204 | verifyParsable "Provable[top]" (Provable (Lit 0) (Val True))
205 | verifyParsable "Provable(1)[top]" (Provable (Lit 1) (Val True))
206 | verifyParsable "◇⌜⊤⌝" (Possible (Lit 0) (Val True))
207 | verifyParsable "<>[top]" (Possible (Lit 0) (Val True))
208 | verifyParsable "<1>[top]" (Possible (Lit 1) (Val True))
209 | verifyParsable "Possible[top]" (Possible (Lit 0) (Val True))
210 | verifyParsable "Possible(1)[top]" (Possible (Lit 1) (Val True))
211 | verifyParsable "Con(1) implies ¬□⌜⊥⌝" (Imp
212 | (Consistent (Lit 1)) (Neg (Provable (Lit 0) (Val False))))
213 | verifyParsable "Con(1) implies ~[][bottom]" (Imp
214 | (Consistent (Lit 1)) (Neg (Provable (Lit 0) (Val False))))
215 | putStrLn ""
216 |
--------------------------------------------------------------------------------
/src/Modal/Def.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Rank2Types #-}
2 | {-# LANGUAGE ConstraintKinds #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE ScopedTypeVariables #-}
6 | {-# LANGUAGE UndecidableInstances #-}
7 | {-# LANGUAGE NoMonomorphismRestriction #-}
8 | module Modal.Def where
9 | import Prelude hiding (readFile, sequence, mapM, foldr1, concat)
10 | import Control.Applicative
11 | import Control.Monad.Except hiding (mapM, sequence)
12 | import Data.Either (partitionEithers)
13 | import Data.Map (Map)
14 | import Data.Set ((\\))
15 | import Data.Traversable
16 | import Modal.Code
17 | import Modal.CompilerBase
18 | import Modal.Formulas (ModalFormula)
19 | import Modal.Parser
20 | import Modal.Utilities
21 | import Text.Parsec hiding ((<|>), optional, many, State)
22 | import Text.Parsec.Text (Parser)
23 | import Text.Read (readMaybe)
24 | import qualified Data.Map as Map
25 | import qualified Data.Set as Set
26 |
27 | -------------------------------------------------------------------------------
28 |
29 | data DefConfig = DefConfig
30 | { defKw :: Name
31 | , defAllowsOrderings :: Bool
32 | , defActionKw :: Name
33 | , defActionsKw :: Name
34 | , defOutcomeKw :: Name
35 | , defOutcomesKw :: Name
36 | } deriving (Eq, Ord, Read, Show)
37 |
38 | makeCodeConfig :: DefConfig -> CodeConfig
39 | makeCodeConfig dconf = CodeConfig
40 | { actionKw = defActionKw dconf
41 | , actionsKw = defActionsKw dconf
42 | , outcomeKw = defOutcomeKw dconf
43 | , outcomesKw = defOutcomesKw dconf }
44 |
45 | -------------------------------------------------------------------------------
46 |
47 | data Def = Def
48 | { defArgs :: [(Name, VarType, Maybe VarVal)]
49 | , defName :: Name
50 | , defCode :: Code
51 | } deriving Eq
52 |
53 | instance Show Def where show = defName
54 |
55 | defHeadParser :: DefConfig -> Parser (Code -> Def)
56 | defHeadParser conf = makeDef where
57 | makeDef = flip Def <$> valueStr <*> option [] (try argsParser)
58 | argsParser = parens (arg `sepBy` comma) where
59 | arg = try num <|> try act <|> try out
60 | param kwd t p = (,,) <$>
61 | (keyword kwd *> name) <*>
62 | return t <*>
63 | optional (symbol "=" *> p)
64 | num = param "number" NumberT (Number <$> parser)
65 | act = param (defActionKw conf) (ClaimT ActionT) (Action <$> parser)
66 | out = param (defOutcomeKw conf) (ClaimT OutcomeT) (Outcome <$> parser)
67 |
68 | defParser :: DefConfig -> Parser Def
69 | defParser = fmap fst . defParserWithExtras (pure ())
70 |
71 | defParserWithExtras :: Parser x -> DefConfig -> Parser (Def, x)
72 | defParserWithExtras px conf = keyword (defKw conf) *> (try mapDef <|> codeDef) where
73 | mapDef = do
74 | keyword "map"
75 | h <- defHeadParser conf
76 | x <- px
77 | c <- codeMapParser
78 | return (h c, x)
79 | codeDef = do
80 | h <- defHeadParser conf
81 | x <- px
82 | c <- codeParser (makeCodeConfig conf)
83 | return (h c, x)
84 |
85 | -------------------------------------------------------------------------------
86 |
87 | -- Errors unless the left list is a subset of the right one.
88 | ensureEnumContains :: MonadError EnumError m => [Value] -> [Value] -> m ()
89 | ensureEnumContains xs enum =
90 | let missing = Set.fromList xs \\ Set.fromList enum
91 | in unless (Set.null missing) (throwError $ EnumExcludes enum missing)
92 |
93 | -- Checks that the first list and the second list are equivalent up to
94 | -- ordering, where an empty list is treated as missing (and ignored). Returns
95 | -- the non-missing list if any, preferring the ordering of the right list.
96 | matchEnumsR :: MonadError EnumError m => [Value] -> [Value] -> m [Value]
97 | matchEnumsR xs [] = return xs
98 | matchEnumsR [] ys = return ys
99 | matchEnumsR xs ys
100 | | Set.fromList xs == Set.fromList ys = return ys
101 | | otherwise = throwError $ EnumMismatch xs ys
102 |
103 | -------------------------------------------------------------------------------
104 |
105 | data CompileConfig a v = CompileConfig
106 | { availableActions :: [Value]
107 | , availableOutcomes :: [Value]
108 | , claimValues :: ParsedClaim -> [(ClaimType, Value)]
109 | , handleClaim :: forall m. MonadError DefError m => CompiledClaim -> m v
110 | , compileAction :: forall m. MonadError DefError m => Value -> m a
111 | , finalizeFormula :: forall m. MonadError DefError m => ModalFormula v -> m (ModalFormula v) }
112 |
113 | -- Finds all actions & outcomes mentioned in the code.
114 | codeAOs :: (ParsedClaim -> [(ClaimType, Value)]) -> Code -> ([Value], [Value])
115 | codeAOs valsIn code = (aMentions ++ asInClaims, oMentions ++ osInClaims) where
116 | aMentions = actionsMentioned code
117 | oMentions = outcomesMentioned code
118 | aLoR (t, v) = if t == ActionT then Left v else Right v
119 | aoList = concatMap valsIn (claimsMade code)
120 | (asInClaims, osInClaims) = partitionEithers (map aLoR aoList)
121 |
122 | -- Ensures that all actions (outcomes) mentioned in the code appear in the
123 | -- available action (outcome) list.
124 | reconfigureWithCode :: MonadError CompileError m =>
125 | Name -> Code -> CompileConfig a v -> m (CompileConfig a v)
126 | reconfigureWithCode defname code conf = do
127 | let (as, os) = codeAOs (claimValues conf) code
128 | let ensureA = ensureEnumContains as $ availableActions conf
129 | let ensureO = ensureEnumContains os $ availableOutcomes conf
130 | either (throwError . AListErr defname) return ensureA
131 | either (throwError . OListErr defname) return ensureO
132 | return conf
133 |
134 | -- Allows the call to reorder the available action (outcome) lists.
135 | reconfigureWithCall :: MonadError CompileError m =>
136 | Name -> Call -> CompileConfig a v -> m (CompileConfig a v)
137 | reconfigureWithCall defname call conf = do
138 | let (lAs, lOs) = (availableActions conf, availableOutcomes conf)
139 | let (rAs, rOs) = (callActions call, callOutcomes call)
140 | as <- wrapError (AListErr defname) (matchEnumsR lAs rAs)
141 | os <- wrapError (OListErr defname) (matchEnumsR lOs rOs)
142 | return conf{availableActions=as, availableOutcomes=os}
143 |
144 | effectiveAOs ::
145 | (ParsedClaim -> [(ClaimType, Value)]) -> Code -> Call -> ([Value], [Value])
146 | effectiveAOs valsIn code call = (preferR codeAs callAs, preferR codeOs callOs) where
147 | (callAs, callOs) = (callActions call, callOutcomes call)
148 | (codeAs, codeOs) = codeAOs valsIn code
149 | preferR xs ys = if null ys then xs else ys
150 |
151 | -------------------------------------------------------------------------------
152 |
153 | initialVariables :: MonadError CompileError m =>
154 | Name ->
155 | ([Value], [Value]) ->
156 | [(Name, VarType, Maybe VarVal)] ->
157 | [Value] ->
158 | Map Name Value ->
159 | m (Map Name VarVal)
160 | initialVariables defname (as, os) vars args kwargs = updateVars where
161 | updateVars = do
162 | when (length args > length vars)
163 | (throwError $ ArgErr defname $ TooManyArgs (length vars) (length args))
164 | unless (Set.null unknowns)
165 | (throwError $ ArgErr defname $ UnknownArgs unknowns)
166 | varsWithArgs <- zipWithM applyArg vars extendedArgs
167 | updatedVars <- mapM applyKwarg varsWithArgs
168 | return $ Map.fromList updatedVars
169 | fst3 (x, _, _) = x
170 | unknowns = Set.fromList (Map.keys kwargs) \\ Set.fromList (map fst3 vars)
171 | extendedArgs = map Just args ++ repeat Nothing
172 | applyArg (varname, t, mdflt) Nothing = return (varname, t, mdflt)
173 | applyArg (varname, t, _) (Just val) = (,,) varname t . Just <$> cast varname t val
174 | applyKwarg (varname, t, mval) = case (mval, Map.lookup varname kwargs) of
175 | (Nothing, Nothing) -> throwError $ ArgErr defname $ ArgMissing varname t
176 | (Just dflt, Nothing) -> return (varname, dflt)
177 | (_, Just val) -> (,) varname <$> cast varname t val
178 | cast vname NumberT v = maybe
179 | (throwError $ ArgErr defname $ ArgIsNotNum vname v)
180 | (return . Number)
181 | (readMaybe $ show v)
182 | cast vname (ClaimT ActionT) v = if v `notElem` as
183 | then throwError $ ArgErr defname $ ArgIsNotIn vname v as
184 | else return $ Action v
185 | cast vname (ClaimT OutcomeT) v = if v `notElem` os
186 | then throwError $ ArgErr defname $ ArgIsNotIn vname v os
187 | else return $ Outcome v
188 |
189 | makeContext :: MonadError CompileError m =>
190 | CompileConfig a v -> Call -> Def -> m CompileContext
191 | makeContext conf call def = do
192 | let n = defName def
193 | reconf <- reconfigureWithCall n call =<< reconfigureWithCode n (defCode def) conf
194 | let (as, os) = (availableActions reconf, availableOutcomes reconf)
195 | when (null as) (throwError $ AListErr n EnumMissing)
196 | when (null os) (throwError $ OListErr n EnumMissing)
197 | vars <- initialVariables n (as, os) (defArgs def) (callArgs call) (callKwargs call)
198 | return $ CompileContext vars as os n
199 |
200 | compile :: (MonadError CompileError m, Ord a) =>
201 | CompileConfig a v -> Call -> Def -> m (Map a (ModalFormula v))
202 | compile conf call def = do
203 | context <- makeContext conf call def
204 | program <- codeToProgram context (defCode def)
205 | let wrapDErr = wrapError $ DefErr $ defName def
206 | Map.fromList <$> mapM (wrapDErr . uncurry finalize) (Map.toList program)
207 | where finalize val formula = do
208 | action <- compileAction conf val
209 | varified <- traverse (handleClaim conf) formula
210 | finalized <- finalizeFormula conf varified
211 | return (action, finalized)
212 |
--------------------------------------------------------------------------------
/src/Modal/Formulas.hs:
--------------------------------------------------------------------------------
1 | module Modal.Formulas where
2 | import Control.Applicative hiding ((<|>))
3 | import Control.Arrow ((***))
4 | import Control.Monad (ap)
5 | import Data.List
6 | import Data.Monoid
7 | import Data.Maybe
8 | import Data.Map (Map)
9 | import qualified Data.Map as M
10 | import Data.Text (Text)
11 | import qualified Data.Text as T
12 | import Modal.Display
13 | import Modal.Parser hiding (parens, braces, identifier)
14 | import Text.Parsec
15 | import Text.Parsec.Expr
16 | import Text.Parsec.Language
17 | import Text.Parsec.Token
18 |
19 | -- Example usage:
20 | -- findGeneralGLFixpoint $ M.fromList [("a",read "~ [] b"), ("b", read "[] (a -> [] ~ b)")]
21 | -- Alternatively:
22 | -- findGeneralGLFixpoint $ makeEquivs [("a", "~ [] b"), ("b", "[] (a -> [] ~ b)")]
23 |
24 |
25 | -- Modal Logic Formula data structure
26 | data ModalFormula v = Val {value :: Bool}
27 | | Var {variable :: v}
28 | | Neg {contents :: ModalFormula v}
29 | | And {left, right :: ModalFormula v}
30 | | Or {left, right :: ModalFormula v}
31 | | Imp {left, right :: ModalFormula v}
32 | | Iff {left, right :: ModalFormula v}
33 | | Box {contents :: ModalFormula v}
34 | | Dia {contents :: ModalFormula v}
35 | deriving (Eq, Ord)
36 |
37 | instance Monad ModalFormula where
38 | return = Var
39 | m >>= f = modalEval ModalEvaluator{
40 | handleVal = Val, handleVar = f, handleNeg = Neg,
41 | handleAnd = And, handleOr = Or, handleImp = Imp, handleIff = Iff,
42 | handleBox = Box, handleDia = Dia } m
43 |
44 | instance Applicative ModalFormula where
45 | pure = return
46 | (<*>) = ap
47 |
48 | instance Functor ModalFormula where
49 | fmap f m = m >>= (Var . f)
50 |
51 | instance Foldable ModalFormula where
52 | foldMap acc = modalEval ModalEvaluator{
53 | handleVal = const mempty, handleVar = acc, handleNeg = id,
54 | handleAnd = (<>), handleOr = (<>), handleImp = (<>), handleIff = (<>),
55 | handleBox = id, handleDia = id }
56 |
57 | instance Traversable ModalFormula where
58 | traverse f = modalEval mevaler where
59 | mevaler = ModalEvaluator {
60 | handleVal = pure . Val, handleVar = fmap Var . f, handleNeg = fmap Neg,
61 | handleAnd = liftA2 And, handleOr = liftA2 Or,
62 | handleImp = liftA2 Imp, handleIff = liftA2 Iff,
63 | handleBox = fmap Box, handleDia = fmap Dia }
64 |
65 | -- Syntactic Conveniences:
66 | infixr 4 %=
67 | (%=) :: ModalFormula v -> ModalFormula v -> ModalFormula v
68 | (%=) = Iff
69 |
70 | infixr 5 %>
71 | (%>) :: ModalFormula v -> ModalFormula v -> ModalFormula v
72 | (%>) = Imp
73 |
74 | infixl 6 %|
75 | (%|) :: ModalFormula v -> ModalFormula v -> ModalFormula v
76 | (%|) = Or
77 |
78 | infixl 7 %^
79 | (%^) :: ModalFormula v -> ModalFormula v -> ModalFormula v
80 | (%^) = And
81 |
82 | ff :: ModalFormula v
83 | ff = Val False
84 |
85 | tt :: ModalFormula v
86 | tt = Val True
87 |
88 | incon :: Int -> ModalFormula v
89 | incon 0 = ff
90 | incon n = Box $ incon (n-1)
91 |
92 | holdsk :: Int -> ModalFormula v -> ModalFormula v
93 | holdsk 0 phi = phi
94 | holdsk k phi = Neg (incon k) `Imp` phi
95 |
96 | -- Operator like function that encodes "provable in S+Con^k(S)", where
97 | -- "S" is the original system.
98 | boxk :: Int -> ModalFormula v -> ModalFormula v
99 | boxk k phi = Box (holdsk k phi)
100 |
101 | diak :: Int -> ModalFormula v -> ModalFormula v
102 | diak k phi = Neg $ Box (holdsk k $ Neg phi)
103 |
104 | -- Data structure to be mapped across a formula.
105 | data ModalEvaluator v a = ModalEvaluator {
106 | handleVal :: Bool -> a,
107 | handleVar :: v -> a,
108 | handleNeg :: a -> a,
109 | handleAnd :: a -> a -> a,
110 | handleOr :: a -> a -> a,
111 | handleImp :: a -> a -> a,
112 | handleIff :: a -> a -> a,
113 | handleBox :: a -> a,
114 | handleDia :: a -> a}
115 |
116 | -- And how to use it to map:
117 | modalEval :: ModalEvaluator v a -> ModalFormula v -> a
118 | modalEval m = f where
119 | f (Val v) = handleVal m v
120 | f (Var v) = handleVar m v
121 | f (Neg x) = handleNeg m (f x)
122 | f (And x y) = handleAnd m (f x) (f y)
123 | f (Or x y) = handleOr m (f x) (f y)
124 | f (Imp x y) = handleImp m (f x) (f y)
125 | f (Iff x y) = handleIff m (f x) (f y)
126 | f (Box x) = handleBox m (f x)
127 | f (Dia x) = handleDia m (f x)
128 |
129 | allVars :: ModalFormula v -> [v]
130 | allVars = modalEval ModalEvaluator {
131 | handleVal = const [], handleVar = pure, handleNeg = id,
132 | handleAnd = (++), handleOr = (++), handleImp = (++), handleIff = (++),
133 | handleBox = id, handleDia = id }
134 |
135 | data ShowFormula = ShowFormula {
136 | topSymbol :: String,
137 | botSymbol :: String,
138 | negSymbol :: String,
139 | andSymbol :: String,
140 | orSymbol :: String,
141 | impSymbol :: String,
142 | iffSymbol :: String,
143 | boxSymbol :: String,
144 | diaSymbol :: String
145 | } deriving (Eq, Ord, Read, Show)
146 |
147 | showFormula :: Show v => ShowFormula -> Int -> ModalFormula v -> ShowS
148 | showFormula sf = showsFormula where
149 | showsFormula p f = case f of
150 | Val l -> showString $ if l then topSymbol sf else botSymbol sf
151 | Var v -> showString $ show v
152 | Neg x -> showParen (p > 8) $ showUnary (negSymbol sf) 8 x
153 | And x y -> showParen (p > 7) $ showBinary (andSymbol sf) 7 x 8 y
154 | Or x y -> showParen (p > 6) $ showBinary (orSymbol sf) 6 x 7 y
155 | Imp x y -> showParen (p > 5) $ showBinary (impSymbol sf) 6 x 5 y
156 | Iff x y -> showParen (p > 4) $ showBinary (iffSymbol sf) 5 x 4 y
157 | Box x -> showParen (p > 8) $ showUnary (boxSymbol sf) 8 x
158 | Dia x -> showParen (p > 8) $ showUnary (diaSymbol sf) 8 x
159 | padded o = showString " " . showString o . showString " "
160 | showUnary o i x = showString o . showsFormula i x
161 | showBinary o l x r y = showsFormula l x . padded o . showsFormula r y
162 |
163 | instance Show v => Show (ModalFormula v) where
164 | showsPrec = showFormula (ShowFormula "⊤" "⊥" "¬" "∧" "∨" "→" "↔" "□" "◇")
165 |
166 | --------------------------------------------------------------------------------
167 |
168 | instance Read v => Parsable (ModalFormula v) where parser = mformulaParser read
169 |
170 | mformulaParser :: (String -> v) -> Parsec Text s (ModalFormula v)
171 | mformulaParser reader = buildExpressionParser table term "ModalFormula" where
172 | table = [
173 | [ prefix $ choice
174 | [ m_reservedOp "¬" >> return Neg
175 | , m_reservedOp "~" >> return Neg
176 | , m_reservedOp "□" >> return Box
177 | , m_reservedOp "[]" >> return Box
178 | , m_reservedOp "[0]" >> return Box
179 | , m_reservedOp "[1]" >> return (boxk 1)
180 | , m_reservedOp "[2]" >> return (boxk 2)
181 | , m_reservedOp "[3]" >> return (boxk 3)
182 | , m_reservedOp "[4]" >> return (boxk 4)
183 | , m_reservedOp "[5]" >> return (boxk 5)
184 | , m_reservedOp "[6]" >> return (boxk 6)
185 | , m_reservedOp "[7]" >> return (boxk 7)
186 | , m_reservedOp "[8]" >> return (boxk 8)
187 | , m_reservedOp "[9]" >> return (boxk 9)
188 | , m_reservedOp "◇" >> return Dia
189 | , m_reservedOp "<>" >> return Dia
190 | , m_reservedOp "<0>" >> return Dia
191 | , m_reservedOp "<1>" >> return (diak 1)
192 | , m_reservedOp "<2>" >> return (diak 2)
193 | , m_reservedOp "<3>" >> return (diak 3)
194 | , m_reservedOp "<4>" >> return (diak 4)
195 | , m_reservedOp "<5>" >> return (diak 5)
196 | , m_reservedOp "<6>" >> return (diak 6)
197 | , m_reservedOp "<7>" >> return (diak 7)
198 | , m_reservedOp "<8>" >> return (diak 8)
199 | , m_reservedOp "<9>" >> return (diak 9) ] ]
200 | , [ Infix (m_reservedOp "∧" >> return And) AssocLeft
201 | , Infix (m_reservedOp "&&" >> return And) AssocLeft ]
202 | , [ Infix (m_reservedOp "∨" >> return Or) AssocLeft
203 | , Infix (m_reservedOp "||" >> return Or) AssocLeft ]
204 | , [ Infix (m_reservedOp "→" >> return Imp) AssocRight
205 | , Infix (m_reservedOp "->" >> return Imp) AssocRight ]
206 | , [ Infix (m_reservedOp "↔" >> return Iff) AssocRight
207 | , Infix (m_reservedOp "<->" >> return Iff) AssocRight ] ]
208 |
209 | term = m_parens (mformulaParser reader)
210 | <|> m_braces (mformulaParser reader)
211 | <|> (m_reserved "⊤" >> return (Val True))
212 | <|> (m_reserved "T" >> return (Val True))
213 | <|> (m_reserved "⊥" >> return (Val False))
214 | <|> (m_reserved "F" >> return (Val False))
215 | <|> fmap (Var . reader) m_identifier
216 |
217 | -- To work-around Parsec's limitation for prefix operators:
218 | prefix p = Prefix . chainl1 p $ return (.)
219 |
220 | TokenParser
221 | { parens = m_parens
222 | , braces = m_braces
223 | , identifier = m_identifier
224 | , reservedOp = m_reservedOp
225 | , reserved = m_reserved
226 | , semiSep1 = _
227 | , whiteSpace = _ } =
228 | makeTokenParser emptyDef
229 | { commentStart = "{-"
230 | , commentEnd = "-}"
231 | , identStart = satisfy isNameFirstChar
232 | , identLetter = satisfy isNameChar
233 | , opStart = oneOf "~-<[&|¬□◇→↔∨∧"
234 | , opLetter = oneOf "->]&|123456789"
235 | , reservedOpNames =
236 | [ "¬", "∧", "∨", "→", "↔", "□", "◇"
237 | , "~", "&&", "||", "->", "<->", "[]", "<>"
238 | , "[1]", "[2]", "[3]", "[4]", "[5]", "[6]", "[7]", "[8]", "[9]"
239 | , "<1>", "<2>", "<3>", "<4>", "<5>", "<6>", "<7>", "<8>", "<9>" ]
240 | , reservedNames = ["T", "F", "⊤", "⊥"]
241 | , caseSensitive = False }
242 |
243 | instance Read v => Read (ModalFormula v) where
244 | readsPrec _ s = case parse (parser <* eof) "reading formula" (T.pack s) of
245 | Right result -> [(result,"")]
246 | -- We could just return the remaining string, but Parsec gives
247 | -- much nicer errors. So we ask it to consume the whole input and
248 | -- fail if it fails.
249 | Left err -> error $ show err
250 |
251 | --------------------------------------------------------------------------------
252 |
253 | -- Note: Code not dead; just not yet used.
254 | isModalized :: ModalFormula v -> Bool
255 | isModalized = modalEval ModalEvaluator {
256 | handleVar = const False, handleVal = const True, handleNeg = id,
257 | handleAnd = (&&), handleOr = (&&), handleImp = (&&), handleIff = (&&),
258 | handleBox = const True, handleDia = const True }
259 |
260 | -- Nesting Depth of Modal Operators
261 | maxModalDepthHandler :: ModalEvaluator v Int
262 | maxModalDepthHandler = ModalEvaluator {
263 | handleVal = const 0, handleVar = const 0,
264 | handleNeg = id,
265 | handleAnd = max, handleOr = max, handleImp = max, handleIff = max,
266 | handleBox = (1+), handleDia = (1+)}
267 | maxModalDepth :: ModalFormula v -> Int
268 | maxModalDepth = modalEval maxModalDepthHandler
269 |
270 | -- How to simplify modal formulas:
271 | mapFormulaOutput :: (Bool -> Bool) -> ModalFormula v -> ModalFormula v
272 | mapFormulaOutput f formula = g (f False) (f True)
273 | where
274 | g True True = Val True
275 | g False False = Val False
276 | g False True = formula
277 | g True False = Neg formula
278 |
279 | simplifyBinaryOperator :: (ModalFormula v -> ModalFormula v -> ModalFormula v) ->
280 | (Bool -> Bool -> Bool) ->
281 | ModalFormula v -> ModalFormula v ->
282 | ModalFormula v
283 | simplifyBinaryOperator _ behavior (Val a) (Val b) = Val (behavior a b)
284 | simplifyBinaryOperator _ behavior (Val a) formula =
285 | mapFormulaOutput (behavior a) formula
286 | simplifyBinaryOperator _ behavior formula (Val b) =
287 | mapFormulaOutput (`behavior` b) formula
288 | simplifyBinaryOperator op _ f1 f2 = op f1 f2
289 |
290 | simplifyNeg :: ModalFormula v -> ModalFormula v
291 | simplifyNeg (Val v) = Val (not v)
292 | simplifyNeg (Neg x) = x
293 | simplifyNeg x = Neg x
294 |
295 | simplifyBox :: ModalFormula v -> ModalFormula v
296 | simplifyBox t@(Val True) = t
297 | simplifyBox x = Box x
298 |
299 | simplifyDia :: ModalFormula v -> ModalFormula v
300 | simplifyDia f@(Val False) = f
301 | simplifyDia x = Dia x
302 |
303 | simplifyHandler :: ModalEvaluator v (ModalFormula v)
304 | simplifyHandler = ModalEvaluator {
305 | handleVal = Val,
306 | handleVar = Var,
307 | handleNeg = simplifyNeg,
308 | handleAnd = simplifyBinaryOperator And (&&),
309 | handleOr = simplifyBinaryOperator Or (||),
310 | handleImp = simplifyBinaryOperator Imp (<=),
311 | handleIff = simplifyBinaryOperator Iff (==),
312 | handleBox = simplifyBox,
313 | handleDia = simplifyDia }
314 |
315 | simplify :: ModalFormula v -> ModalFormula v
316 | simplify = modalEval simplifyHandler
317 |
318 | -- GL Eval in standard model
319 | glEvalHandler :: ModalEvaluator v [Bool]
320 | glEvalHandler = ModalEvaluator {
321 | handleVal = repeat,
322 | handleVar = error "Variables are not supported in GLEval",
323 | handleNeg = fmap not,
324 | handleAnd = zipWith (&&),
325 | handleOr = zipWith (||),
326 | handleImp = zipWith (<=),
327 | handleIff = zipWith (==),
328 | handleBox = scanl (&&) True,
329 | handleDia = scanl (||) False }
330 |
331 | -- The reason we don't combine this with the above is because that would induce
332 | -- an Ord constraint on v unnecessarily.
333 | glEvalHandlerWithVars :: (Show v, Ord v) => Map v [Bool] -> ModalEvaluator v [Bool]
334 | glEvalHandlerWithVars m = glEvalHandler{
335 | handleVar = \var -> fromMaybe (unmapped var) (var `M.lookup` m)}
336 | where unmapped var = error $ "Unmapped variable in GLEval: " ++ show var
337 |
338 | glEvalWithVars :: (Show v, Ord v) => Map v [Bool] -> ModalFormula v -> [Bool]
339 | glEvalWithVars = modalEval . glEvalHandlerWithVars
340 |
341 | glEvalWithVarsStandard :: (Show v, Ord v) => Map v [Bool] -> ModalFormula v -> Bool
342 | glEvalWithVarsStandard m f = glEvalWithVars m f !! maxModalDepth f
343 |
344 | glEval :: ModalFormula v -> [Bool]
345 | glEval = modalEval glEvalHandler
346 |
347 | glEvalStandard :: ModalFormula v -> Bool
348 | glEvalStandard f = glEval f !! maxModalDepth f
349 |
350 | simplifiedMaxDepth :: ModalFormula v -> Int
351 | simplifiedMaxDepth formula =
352 | depth - length (head $ group $ reverse results) + 1 where
353 | results = take (depth+1) (glEval formula)
354 | depth = maxModalDepth formula
355 |
356 | fixpointGLEval :: (Show v, Eq v) => v -> ModalFormula v -> [Bool]
357 | fixpointGLEval var fi = result
358 | where
359 | unmapped = error . ("Non-fixpoint-variable used in fixpointGLEval: " ++) . show
360 | evalHandler = glEvalHandler{handleVar = \var' ->
361 | if var == var' then result else unmapped var'}
362 | result = modalEval evalHandler fi
363 |
364 | generalFixpointGLEval :: (Show v, Ord v) => Map v (ModalFormula v) -> Map v [Bool]
365 | generalFixpointGLEval formulaMap = evalMap
366 | where
367 | unmapped var = error $ "Unmapped variable in generalFixpointGLEval: " ++ show var
368 | evalHandler = glEvalHandler{handleVar = \var ->
369 | fromMaybe (unmapped var) (M.lookup var evalMap)}
370 | evalMap = M.map (modalEval evalHandler) formulaMap
371 |
372 | -- Finding the fixedpoints
373 |
374 | -- Check whether the length of a list is at least n without infinite looping.
375 | lengthAtLeast :: Int -> [a] -> Bool
376 | lengthAtLeast 0 _ = True
377 | lengthAtLeast _ [] = False
378 | lengthAtLeast n (_:xs) = lengthAtLeast (n-1) xs
379 |
380 | -- TODO: infinite loop
381 | fixpointDepth :: (Eq a) => Int -> [a] -> Int
382 | fixpointDepth n xs = 1 + countSkipped 0 (group xs) where
383 | countSkipped acc [] = acc
384 | countSkipped acc (g:gs)
385 | | lengthAtLeast n g = acc
386 | | otherwise = countSkipped (acc + length g) gs
387 |
388 | -- Find the fixpoint of a list, given a length of run after which we should conclude we found it.
389 | findFixpoint :: (Eq a) => Int -> [a] -> a
390 | findFixpoint n xs = (!!0) $ fromJust $ find (lengthAtLeast n) $ group xs
391 |
392 | -- Find the Fixpoint for a Modal formula
393 | findGLFixpoint :: (Show v, Eq v) => v -> ModalFormula v -> Bool
394 | findGLFixpoint var formula = findFixpoint
395 | (1 + maxModalDepth formula)
396 | (fixpointGLEval var formula)
397 |
398 | -- Find the Fixpoint for a collection of Modal formulas
399 | makeEquivs :: (Ord v, Read v) => [(String, String)] -> Map v (ModalFormula v)
400 | makeEquivs = M.fromList . map (read *** read)
401 |
402 | generalGLEvalSeq :: (Show v, Ord v) => Map v (ModalFormula v)-> [Map v Bool]
403 | generalGLEvalSeq formulaMap = map level [0..]
404 | where
405 | level n = M.map (!!n) result
406 | result = generalFixpointGLEval formulaMap
407 |
408 | findGeneralGLFixpoint :: (Eq v, Show v, Ord v) => Map v (ModalFormula v) -> Map v Bool
409 | findGeneralGLFixpoint formulaMap = findFixpoint (1 + maxFormulaDepth) results where
410 | results = generalGLEvalSeq formulaMap
411 | maxFormulaDepth = maximum $ map maxModalDepth $ M.elems formulaMap
412 |
413 | -- Display code to help visualize the kripke frames
414 | kripkeFrames :: (Eq v, Show v, Ord v) => Map v (ModalFormula v) -> Map v [Bool]
415 | kripkeFrames formulaMap = M.map (take (2 + fixPointer)) results where
416 | results = generalFixpointGLEval formulaMap
417 | mapList = generalGLEvalSeq formulaMap
418 | maxFormulaDepth = maximum $ map maxModalDepth $ M.elems formulaMap
419 | fixPointer = fixpointDepth (1 + maxFormulaDepth) mapList
420 |
421 | kripkeTable' :: (Show k, Ord k) => [k] -> Map k (ModalFormula k) -> Table
422 | kripkeTable' ks = toTable . kripkeFrames where
423 | toTable m = listmapToTable ks $ M.map (map boolify) m
424 | boolify = show . (Val :: Bool -> ModalFormula ())
425 |
426 | kripkeTable :: (Show k, Ord k) => Map k (ModalFormula k) -> Table
427 | kripkeTable m = kripkeTable' (M.keys m) m
428 |
429 | kripkeTableFiltered :: (Show k, Ord k) => (k -> Bool) -> Map k (ModalFormula k) -> Table
430 | kripkeTableFiltered f m = kripkeTable' (filter f $ M.keys m) m
431 |
432 | displayKripkeFrames :: (Show k, Ord k) => Map k (ModalFormula k) -> IO ()
433 | displayKripkeFrames = displayTable . kripkeTable
434 |
--------------------------------------------------------------------------------
/src/Modal/Code.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE ConstraintKinds #-}
3 | {-# LANGUAGE FlexibleContexts #-}
4 | module Modal.Code where
5 | import Prelude hiding (readFile, sequence, mapM, foldr1, concat, concatMap)
6 | import Control.Applicative
7 | import Control.Monad.Except hiding (mapM, sequence)
8 | import Control.Monad.State hiding (mapM, sequence, state)
9 | import Data.Map (Map)
10 | import Data.Maybe (mapMaybe, maybeToList)
11 | import Data.Monoid ((<>))
12 | import Data.Foldable
13 | import Data.Traversable
14 | import Modal.CompilerBase hiding (main)
15 | import Modal.Display
16 | import Modal.Formulas (ModalFormula, (%^), (%|))
17 | import Modal.Parser hiding (main)
18 | import Modal.Programming
19 | import Modal.Statement hiding (main)
20 | import Modal.Utilities
21 | import Text.Parsec hiding ((<|>), optional, many, State)
22 | import Text.Parsec.Expr
23 | import Text.Parsec.Text (Parser)
24 | import Text.Printf (printf)
25 | import qualified Data.List as List
26 | import qualified Data.Map as Map
27 | import qualified Data.Text as Text
28 | import qualified Modal.Formulas as F
29 |
30 | -------------------------------------------------------------------------------
31 |
32 | data CodeConfig = CodeConfig
33 | { actionKw :: String
34 | , actionsKw :: String
35 | , outcomeKw :: String
36 | , outcomesKw :: String
37 | } deriving (Eq, Ord, Read, Show)
38 |
39 | -------------------------------------------------------------------------------
40 |
41 | data SimpleExpr
42 | = Num (Ref Int)
43 | | Add SimpleExpr SimpleExpr
44 | | Sub SimpleExpr SimpleExpr
45 | | Mul SimpleExpr SimpleExpr
46 | | Exp SimpleExpr SimpleExpr
47 | deriving Eq
48 |
49 | instance Show SimpleExpr where
50 | show (Num v) = show v
51 | show (Add x y) = show x ++ "+" ++ show y
52 | show (Sub x y) = show x ++ "-" ++ show y
53 | show (Mul x y) = show x ++ "*" ++ show y
54 | show (Exp x y) = show x ++ "^" ++ show y
55 |
56 | instance Parsable SimpleExpr where
57 | parser = buildExpressionParser lTable term where
58 | lTable =
59 | [ [Infix (try $ symbol "+" $> Add) AssocRight]
60 | , [Infix (try $ symbol "-" $> Sub) AssocRight]
61 | , [Infix (try $ symbol "*" $> Mul) AssocRight]
62 | , [Infix (try $ symbol "^" $> Exp) AssocRight] ]
63 | term
64 | = parens parser
65 | <|> try (Num <$> (parser :: Parser (Ref Int)))
66 | "a math expression"
67 |
68 | compileExpr :: MonadCompile m => SimpleExpr -> m Int
69 | compileExpr (Num v) = lookupN v
70 | compileExpr (Add x y) = (+) <$> compileExpr x <*> compileExpr y
71 | compileExpr (Sub x y) = (-) <$> compileExpr x <*> compileExpr y
72 | compileExpr (Mul x y) = (*) <$> compileExpr x <*> compileExpr y
73 | compileExpr (Exp x y) = (^) <$> compileExpr x <*> compileExpr y
74 |
75 | -------------------------------------------------------------------------------
76 |
77 | data Range x
78 | = EnumRange (Ref x) (Maybe (Ref x)) (Maybe (Ref Int))
79 | | ListRange [Ref x]
80 | | TotalRange
81 | deriving Eq
82 |
83 | instance Show x => Show (Range x) where
84 | show (EnumRange sta msto mste) = printf "%s..%s%s" (show sta) x y where
85 | x = maybe ("" :: String) show msto
86 | y = maybe ("" :: String) (printf " by %s" . show) mste
87 | show (ListRange xs) = printf "[%s]" (List.intercalate ", " $ map show xs)
88 | show TotalRange = "[...]"
89 |
90 | instance Parsable x => Parsable (Range x) where
91 | parser = rangeParser "[...]" parser
92 |
93 | rangeParser :: String -> Parser x -> Parser (Range x)
94 | rangeParser allname x = try rEnum <|> try rList <|> try rAll "a range" where
95 | rEnum = EnumRange <$>
96 | (symbol "[" *> refParser x <* symbol "..") <*>
97 | (optional (refParser x) <* symbol "]") <*>
98 | optional (try $ keyword "by" *> parser)
99 | rList = ListRange <$> listParser (refParser x)
100 | rAll = keyword allname $> TotalRange
101 |
102 | _testRangeParser :: IO ()
103 | _testRangeParser = do
104 | let succeeds = verifyParser (parser :: Parser (Range Int))
105 | let fails = verifyParserFails (parser :: Parser (Range Int))
106 | succeeds "[1..]" (EnumRange (Lit 1) Nothing Nothing)
107 | succeeds "[ 1 ..]" (EnumRange (Lit 1) Nothing Nothing)
108 | succeeds "[ 1 .. 2 ]" (EnumRange (Lit 1) (Just (Lit 2)) Nothing)
109 | succeeds "[&n..]" (EnumRange (Ref "n") Nothing Nothing)
110 | succeeds "[&n..3]" (EnumRange (Ref "n") (Just (Lit 3)) Nothing)
111 | succeeds "[&n..3] by 2" (EnumRange (Ref "n") (Just (Lit 3)) (Just (Lit 2)))
112 | fails "[1..2..3]"
113 | succeeds "[1, 2, &three]" (ListRange [Lit 1, Lit 2, Ref "three"])
114 | succeeds "[...]" TotalRange
115 | succeeds "[ ]" (ListRange [])
116 | fails "[ "
117 |
118 | boundedRange :: Parsable x => Parser (Range x)
119 | boundedRange = try rBoundedEnum <|> try rList "a bounded range" where
120 | rBoundedEnum = EnumRange <$>
121 | (symbol "[" *> parser <* symbol "..") <*>
122 | (Just <$> parser <* symbol "]") <*>
123 | optional (try $ keyword "by" *> parser)
124 | rList = ListRange <$> parser
125 |
126 | _testBoundedRangeParser :: IO ()
127 | _testBoundedRangeParser = do
128 | let succeeds = verifyParser (boundedRange :: Parser (Range Int))
129 | let fails = verifyParserFails (boundedRange :: Parser (Range Int))
130 | fails "[1..]"
131 | succeeds "[1 .. 2]" (EnumRange (Lit 1) (Just (Lit 2)) Nothing)
132 | succeeds "[&n .. 2] by 10" (EnumRange (Ref "n") (Just (Lit 2)) (Just (Lit 10)))
133 | succeeds "[1, 2, &three]" (ListRange [Lit 1, Lit 2, Ref "three"])
134 | fails "[...]"
135 |
136 | rangeLitValues :: Range x -> [x]
137 | rangeLitValues (EnumRange sta sto _) =
138 | maybeToList (lit sta) ++ maybe [] (maybeToList . lit) sto
139 | rangeLitValues (ListRange refs) = mapMaybe lit refs
140 | rangeLitValues _ = []
141 |
142 | compileRange :: (Eq x, MonadCompile m) => m [x] -> (Ref x -> m x) -> Range x -> m [x]
143 | compileRange getXs _ TotalRange = getXs
144 | compileRange _ getX (ListRange xs) = mapM getX xs
145 | compileRange getXs getX (EnumRange sta msto mste) = renum msto mste where
146 | renum Nothing Nothing = dropWhile . (/=) <$> getX sta <*> getXs
147 | renum (Just sto) Nothing = takeWhile . (/=) <$> getX sto <*> renum Nothing Nothing
148 | renum _ (Just ste) = every <$> lookupN ste <*> renum msto Nothing
149 |
150 | -------------------------------------------------------------------------------
151 |
152 | data CodeFragment
153 | = For ClaimType Name (Range Value) [CodeFragment]
154 | | ForN Name (Range Int) [CodeFragment]
155 | | LetN Name SimpleExpr
156 | | If Statement [CodeFragment]
157 | | IfElse Statement [CodeFragment] [CodeFragment]
158 | | Return (Maybe (Ref Value))
159 | | Pass
160 | deriving Eq
161 |
162 | instance Blockable CodeFragment where
163 | blockLines (For t n r cs) =
164 | [(0, Text.pack $ printf "for %s %s in %s" (show t) n (show r))] <>
165 | increaseIndent (concatMap blockLines cs)
166 | blockLines (ForN n r cs) =
167 | [(0, Text.pack $ printf "for number %s in %s" n (show r))] <>
168 | increaseIndent (concatMap blockLines cs)
169 | blockLines (LetN n x) =
170 | [(0, Text.pack $ printf "let %s = %s" n (show x))]
171 | blockLines (If s xs) =
172 | [(0, Text.pack $ printf "if %s" $ show s)] <>
173 | increaseIndent (concatMap blockLines xs)
174 | blockLines (IfElse s xs ys) =
175 | [(0, Text.pack $ printf "if %s" $ show s)] <>
176 | increaseIndent (concatMap blockLines xs) <>
177 | [(0, "else")] <>
178 | increaseIndent (concatMap blockLines ys)
179 | blockLines (Return Nothing) = [(0, "return")]
180 | blockLines (Return (Just x)) = [(0, Text.pack $ printf "return %s" (show x))]
181 | blockLines (Pass) = [(0, "pass")]
182 |
183 | instance Show CodeFragment where
184 | show = Text.unpack . renderBlock
185 |
186 | data CodeFragConfig = CodeFragConfig
187 | { indentLevel :: Int
188 | , codeConfig :: CodeConfig
189 | } deriving (Eq, Ord, Read, Show)
190 |
191 | eatIndent :: CodeFragConfig -> Parser ()
192 | eatIndent conf = void (count (indentLevel conf) (char '\t'))
193 | printf "%d tabs" (indentLevel conf)
194 |
195 | codeFragmentParser :: CodeFragConfig -> Parser CodeFragment
196 | codeFragmentParser conf = try indent *> pFrag where
197 | indent = (many $ try ignoredLine) *> eatIndent conf
198 | pFrag = try pForA
199 | <|> try pForO
200 | <|> try pForN
201 | <|> try pLetN
202 | <|> try pIfElse
203 | <|> try pIf
204 | <|> try pReturn
205 | <|> try pPass
206 | pForA = pFor ActionT action actions
207 | pForO = pFor OutcomeT outcome outcomes
208 | pFor t x xs = For t
209 | <$> (keyword "for" *> keyword x *> varname)
210 | <*> (keyword "in" *> rangeParser xs parser <* w <* endOfLine)
211 | <*> pBlock
212 | pForN = ForN
213 | <$> (keyword "for" *> keyword "number" *> varname)
214 | <*> (keyword "in" *> boundedRange <* w <* endOfLine)
215 | <*> pBlock
216 | pLetN = LetN
217 | <$> (keyword "let" *> varname <* symbol "=")
218 | <*> parser <* eols
219 | pIf = If
220 | <$> (keyword "if" *> parser <* w <* endOfLine)
221 | <*> pBlock
222 | pIfElse = IfElse
223 | <$> (keyword "if" *> parser <* w <* endOfLine)
224 | <*> pBlock
225 | <*> (indent *> keyword "else" *> w *> endOfLine *> pBlock)
226 | pBlock = many1 $ try $ codeFragmentParser conf{indentLevel=succ $ indentLevel conf}
227 | pPass = symbol "pass" $> Pass <* w <* eol
228 | pReturn = try returnThing <|> returnNothing "a return statement"
229 | returnNothing :: Parser CodeFragment
230 | returnThing = symbol "return " *> (Return . Just <$> parser) <* w <* eol
231 | returnNothing = symbol "return" $> Return Nothing <* w <* eol
232 | action = actionKw $ codeConfig conf
233 | outcome = outcomeKw $ codeConfig conf
234 | actions = actionsKw $ codeConfig conf
235 | outcomes = outcomesKw $ codeConfig conf
236 | varname = char '&' *> name
237 |
238 | compileCodeFragment :: MonadCompile m =>
239 | CodeFragment -> m (PartialProgram Value CompiledClaim)
240 | compileCodeFragment code = case code of
241 | For ActionT n r x -> loop (withA n) x =<< compileRange (gets actionList) lookupA r
242 | For OutcomeT n r x -> loop (withO n) x =<< compileRange (gets outcomeList) lookupO r
243 | ForN n r x -> loop (withN n) x =<< compileRange (return [0..]) lookupN r
244 | LetN n x -> compileExpr x >>= modify . withN n >> return id
245 | If s block -> compileCodeFragment (IfElse s block [Pass])
246 | IfElse s tblock eblock -> do
247 | cond <- compileStatement compileClaim s
248 | thens <- mapM compileCodeFragment tblock
249 | elses <- mapM compileCodeFragment eblock
250 | let yes = foldr1 (.) thens
251 | let no = foldr1 (.) elses
252 | return (\continue act ->
253 | (cond %^ yes continue act) %| (F.Neg cond %^ no continue act))
254 | Return (Just v) -> (\a -> const $ F.Val . (a ==)) <$> lookupA v
255 | Return Nothing -> (\a -> const $ F.Val . (a ==)) <$> defaultAction
256 | Pass -> return id
257 | where loop update block xs
258 | | null xs = return id
259 | | otherwise = foldr1 (.) . concat <$> mapM doFragment xs
260 | where doFragment x = modify (update x) >> mapM compileCodeFragment block
261 |
262 | -------------------------------------------------------------------------------
263 |
264 | data Code
265 | = Code [CodeFragment]
266 | | ActionMap (Map Value Statement)
267 | deriving Eq
268 |
269 | instance Blockable Code where
270 | blockLines (Code frags) = concatMap blockLines frags
271 | blockLines (ActionMap a2s) = [
272 | (0, Text.pack $ printf "%s ↔ %s" (show a) (show s)) | (a, s) <- Map.toList a2s]
273 |
274 | instance Show Code where
275 | show = Text.unpack . renderBlock
276 |
277 | codeParser :: CodeConfig -> Parser Code
278 | codeParser conf = Code <$> many1 (codeFragmentParser $ CodeFragConfig 1 conf)
279 |
280 | _testCodeParser :: IO ()
281 | _testCodeParser = testAllSamples where
282 | sample1 = Text.unlines
283 | ["\tlet &step = 0"
284 | ,"\tfor action &a in actions"
285 | ,"\t\t-- This is a comment about the inner loop."
286 | ,"\t\tfor outcome &u in utilities"
287 | ,"\t\t\tif [&step][A()=&a -> U()=&u]"
288 | ,"\t\t\t\treturn &a"
289 | ,"\t\t\tlet &step = &step + 1"
290 | ,"\treturn"]
291 | sample2 = Text.unlines
292 | ["\tif {- IGNORE THIS COMMENT -} [][Them(Me)=C]"
293 | ,"\t\treturn C -- Ignore this one too."
294 | ,""
295 | ,"\telse"
296 | ,"\t\treturn D"]
297 | sample3 = Text.unlines
298 | [" -- Sample 3:"
299 | ,"\tfor number &n in [0, 1, 2, 3]"
300 | ,"\t\tif Possible(&n)[Them(Me)=C]"
301 | ,"\t\t\treturn C"
302 | ," \t "
303 | ,""
304 | ,"\treturn D"]
305 | sample4 = Text.unlines
306 | ["\tfor number &n in [...]"
307 | ,"\t\treturn &n"]
308 | sample5 = Text.unlines
309 | ["\tif ⊤"
310 | ,"\treturn 0"]
311 | sample6 = Text.unlines
312 | ["\tif ⊤"
313 | ,"\t return 0"]
314 | sample7 = Text.unlines
315 | ["\tif ⊤"
316 | ,"\t\t\treturn 0"]
317 | conf = CodeConfig "action" "actions" "outcome" "utilities"
318 | testAllSamples = do
319 | verifyParser (codeParser conf) sample1 (Code
320 | [ LetN "step" (Num (Lit 0))
321 | , For ActionT "a" TotalRange
322 | [ For OutcomeT "u" TotalRange
323 | [ If (Provable (Ref "step")
324 | (Imp
325 | (Var $ ParsedClaim "A" Nothing (Equals (Ref "a")))
326 | (Var $ ParsedClaim "U" Nothing (Equals (Ref "u")))))
327 | [ Return (Just (Ref "a")) ]
328 | , LetN "step" (Add (Num $ Ref "step") (Num $ Lit 1)) ] ]
329 | , Return Nothing ])
330 | verifyParser (codeParser conf) sample2 (Code
331 | [ IfElse (Provable (Lit 0)
332 | (Var $ ParsedClaim "Them"
333 | (Just $ Call "Me" [] Map.empty [] [])
334 | (Equals $ Lit "C")))
335 | [ Return (Just (Lit "C")) ]
336 | [ Return (Just (Lit "D")) ] ])
337 | verifyParser (codeParser conf) sample3 (Code
338 | [ ForN "n" (ListRange [Lit 0, Lit 1, Lit 2, Lit 3])
339 | [ If (Possible (Ref "n")
340 | (Var $ ParsedClaim "Them"
341 | (Just $ Call "Me" [] Map.empty [] [])
342 | (Equals $ Lit "C")))
343 | [ Return (Just (Lit "C")) ] ]
344 | , Return (Just (Lit "D")) ])
345 | verifyParserFails (codeParser conf) sample4
346 | verifyParserFails (codeParser conf) sample5
347 | verifyParserFails (codeParser conf) sample6
348 | verifyParserFails (codeParser conf) sample7
349 |
350 | codeMapParser :: Parser Code
351 | codeMapParser = ActionMap . Map.fromList <$> many1 assignment where
352 | indent = (many (w *> endOfLine)) *> char '\t'
353 | iffParsers = [symbol "↔", symbol "<->", keyword "iff"]
354 | pIff = void $ choice $ map try iffParsers
355 | assignment = (,) <$> (indent *> parser <* pIff) <*> (parser <* eols)
356 |
357 | _testCodeMapParser :: IO ()
358 | _testCodeMapParser = testAllSamples where
359 | sample1 = Text.unlines
360 | ["\tC ↔ [][Them(Me)=C]"
361 | ,"\tD ↔ ~[][Them(Me)=C]"]
362 | sample2 = Text.unlines
363 | ["\tCD iff A1()=C and A2()=D"
364 | ,"\tCC iff A1()=C and A2()=C"
365 | ,"\tDD iff A1()=D and A2()=D"
366 | ,"\tDC iff A1()=D and A2()=C"]
367 | sample3 = Text.unlines
368 | ["\tC ↔ [][Them(Me)=C]"
369 | ,"\t\tD ↔ ~[][Them(Me)=C]"]
370 | sample4 = Text.unlines
371 | ["\tC ↔ [][Them(Me)=C]"
372 | ," D ↔ ~[][Them(Me)=C]"]
373 | testAllSamples = do
374 | verifyParser codeMapParser sample1 (ActionMap $ Map.fromList
375 | [ ("C", Provable (Lit 0) (Var $ ParsedClaim "Them"
376 | (Just $ Call "Me" [] Map.empty [] [])
377 | (Equals $ Lit "C")))
378 | , ("D", Neg $ Provable (Lit 0) (Var $ ParsedClaim "Them"
379 | (Just $ Call "Me" [] Map.empty [] [])
380 | (Equals $ Lit "C"))) ])
381 | verifyParser codeMapParser sample2 (ActionMap $ Map.fromList
382 | [ ("CD", (And
383 | (Var $ ParsedClaim "A1" Nothing (Equals $ Lit "C"))
384 | (Var $ ParsedClaim "A2" Nothing (Equals $ Lit "D"))))
385 | , ("CC", (And
386 | (Var $ ParsedClaim "A1" Nothing (Equals $ Lit "C"))
387 | (Var $ ParsedClaim "A2" Nothing (Equals $ Lit "C"))))
388 | , ("DD", (And
389 | (Var $ ParsedClaim "A1" Nothing (Equals $ Lit "D"))
390 | (Var $ ParsedClaim "A2" Nothing (Equals $ Lit "D"))))
391 | , ("DC", (And
392 | (Var $ ParsedClaim "A1" Nothing (Equals $ Lit "D"))
393 | (Var $ ParsedClaim "A2" Nothing (Equals $ Lit "C")))) ])
394 | verifyParserFails codeMapParser sample3
395 | verifyParserFails codeMapParser sample4
396 |
397 | compileCode :: MonadCompile m => Code -> m (ModalProgram Value CompiledClaim)
398 | compileCode (Code frags) = do
399 | prog <- foldM (\f c -> (f .) <$> compileCodeFragment c) id frags
400 | dflt <- defaultAction
401 | return $ prog (F.Val . (dflt ==))
402 | compileCode (ActionMap a2smap) = do
403 | let a2slist = Map.toList a2smap
404 | formulas <- mapM (compileStatement compileClaim . snd) a2slist
405 | let a2flist = zip (map fst a2slist) formulas
406 | return $ \a -> let Just f = List.lookup a a2flist in f
407 |
408 | -- Note: Code not dead; just not yet used.
409 | actionsMentioned :: Code -> [Value]
410 | actionsMentioned (ActionMap m) = Map.keys m
411 | actionsMentioned (Code frags) = concatMap fragRets frags where
412 | fragRets (For ActionT _ range fs) = rangeLitValues range ++ concatMap fragRets fs
413 | fragRets (For OutcomeT _ _ fs) = concatMap fragRets fs
414 | fragRets (ForN _ _ fs) = concatMap fragRets fs
415 | fragRets (If _ fs) = concatMap fragRets fs
416 | fragRets (IfElse _ fs gs) = concatMap fragRets fs ++ concatMap fragRets gs
417 | fragRets (Return (Just v)) = maybeToList $ lit v
418 | fragRets (Return _) = []
419 | fragRets (LetN _ _) = []
420 | fragRets Pass = []
421 |
422 | -- Note: Code not dead; just not yet used.
423 | outcomesMentioned :: Code -> [Value]
424 | outcomesMentioned (ActionMap _) = []
425 | outcomesMentioned (Code frags) = concatMap fragRets frags where
426 | fragRets (For ActionT _ _ fs) = concatMap fragRets fs
427 | fragRets (For OutcomeT _ range fs) = rangeLitValues range ++ concatMap fragRets fs
428 | fragRets (ForN _ _ fs) = concatMap fragRets fs
429 | fragRets (If _ fs) = concatMap fragRets fs
430 | fragRets (IfElse _ fs gs) = concatMap fragRets fs ++ concatMap fragRets gs
431 | fragRets (Return _) = []
432 | fragRets (LetN _ _) = []
433 | fragRets Pass = []
434 |
435 | -- Note: Code not dead; just not yet used.
436 | claimsMade :: Code -> [ParsedClaim]
437 | claimsMade (ActionMap m) = concatMap claimsParsed $ Map.elems m
438 | claimsMade (Code frags) = concatMap fragClaims frags where
439 | fragClaims (For _ _ _ fs) = concatMap fragClaims fs
440 | fragClaims (ForN _ _ fs) = concatMap fragClaims fs
441 | fragClaims (If s fs) = claimsParsed s ++ concatMap fragClaims fs
442 | fragClaims (IfElse s fs gs) =
443 | claimsParsed s ++ concatMap fragClaims fs ++ concatMap fragClaims gs
444 | fragClaims (LetN _ _) = []
445 | fragClaims (Return _) = []
446 | fragClaims Pass = []
447 |
448 | -------------------------------------------------------------------------------
449 |
450 | type CompiledAgent = Map Value (ModalFormula CompiledClaim)
451 |
452 | codeToProgram :: MonadError CompileError m =>
453 | CompileContext -> Code -> m CompiledAgent
454 | codeToProgram context code = do
455 | (prog, state) <- runStateT (compileCode code) context
456 | return $ Map.fromList [(a, prog a) | a <- actionList state]
457 |
458 | -------------------------------------------------------------------------------
459 | -- Testing
460 |
461 | main :: IO ()
462 | main = do
463 | _testRangeParser
464 | _testBoundedRangeParser
465 | _testCodeParser
466 | _testCodeMapParser
467 | putStrLn ""
468 |
--------------------------------------------------------------------------------
/src/Modal/CompilerBase.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | {-# LANGUAGE FlexibleContexts #-}
4 | {-# LANGUAGE ConstraintKinds #-}
5 | module Modal.CompilerBase where
6 | import Prelude hiding (readFile, sequence, mapM, foldr1, concat, concatMap)
7 | import Control.Arrow (first)
8 | import Control.Applicative
9 | import Control.Monad.Except hiding (mapM, sequence)
10 | import Control.Monad.State hiding (mapM, sequence, state)
11 | import Data.Either (partitionEithers)
12 | import Data.Foldable
13 | import Data.Map (Map)
14 | import Data.Set (Set)
15 | import Data.String
16 | import Data.Traversable
17 | import Modal.Display (renderArgs)
18 | import Modal.Formulas (ModalFormula)
19 | import Modal.Parser hiding (main)
20 | import Modal.Utilities
21 | import Text.Parsec hiding ((<|>), optional, many, State)
22 | import Text.Parsec.Text (Parser)
23 | import Text.Printf (printf)
24 | import qualified Data.List as List
25 | import qualified Data.Map as Map
26 | import qualified Data.Set as Set
27 | import qualified Data.Text as Text
28 | import qualified Modal.Formulas as F
29 |
30 | -------------------------------------------------------------------------------
31 |
32 | newtype Value = V String deriving (Eq, Ord)
33 |
34 | instance Read Value where
35 | readsPrec _ s = case parse (parser <* eof) "reading value" (Text.pack s) of
36 | Right result -> [(result, "")]
37 | Left err -> []
38 |
39 | instance IsString Value where
40 | fromString = V
41 |
42 | instance Show Value where
43 | show (V val) = val
44 |
45 | instance Parsable Value where
46 | parser = V <$> valueStr
47 |
48 | -------------------------------------------------------------------------------
49 |
50 | data VarVal = Number Int | Action Value | Outcome Value deriving (Eq, Ord, Read)
51 |
52 | instance Show VarVal where
53 | show (Number n) = '#' : show n
54 | show (Action v) = '@' : show v
55 | show (Outcome v) = '$' : show v
56 |
57 | asN :: MonadCompile m => Name -> VarVal -> m Int
58 | asN _ (Number i) = return i
59 | asN n (Action _) = refError $ ExpectingNum n ActionT
60 | asN n (Outcome _) = refError $ ExpectingNum n OutcomeT
61 |
62 | asClaim :: MonadCompile m => Name -> VarVal -> m (ClaimType, Value)
63 | asClaim _ (Action v) = return (ActionT, v)
64 | asClaim _ (Outcome v) = return (OutcomeT, v)
65 | asClaim n _ = refError $ ExpectingClaim n
66 |
67 | -------------------------------------------------------------------------------
68 |
69 | data ClaimType = ActionT | OutcomeT deriving (Eq, Ord, Read, Enum)
70 |
71 | -- TODO: naming schema kinda sucks.
72 | -- This is especially evident when the universe has an universe-output
73 | -- enumeration that excludes values seen in the code, in which case the error
74 | -- message refers to this as an "action enumeration." (This is confusing
75 | -- because we think of the universe as outputing outcomes rather than actions,
76 | -- but vise versa for agents.)
77 | instance Show ClaimType where
78 | show ActionT = "action"
79 | show OutcomeT = "outcome"
80 |
81 | -------------------------------------------------------------------------------
82 |
83 | data VarType = NumberT | ClaimT ClaimType deriving (Eq, Read)
84 |
85 | instance Show VarType where
86 | show NumberT = "number"
87 | show (ClaimT t) = show t
88 |
89 | -------------------------------------------------------------------------------
90 |
91 | data DefType = AgentT | TheoryT | ProblemT deriving (Eq, Ord, Read, Enum)
92 |
93 | instance Show DefType where
94 | show AgentT = "agent"
95 | show TheoryT = "theory"
96 | show ProblemT = "problem"
97 |
98 | -------------------------------------------------------------------------------
99 |
100 | data Ref a = Ref Name | Lit a deriving (Eq, Ord, Read)
101 |
102 | instance Show a => Show (Ref a) where
103 | show (Ref n) = '&' : n
104 | show (Lit x) = show x
105 |
106 | instance Parsable a => Parsable (Ref a) where
107 | parser = refParser parser
108 |
109 | _testRefParser :: IO ()
110 | _testRefParser = do
111 | let succeeds = verifyParser (parser :: Parser (Ref Int))
112 | let fails = verifyParserFails (parser :: Parser (Ref Int))
113 | succeeds "&reference" (Ref "reference")
114 | fails "&123"
115 | succeeds "&_123" (Ref "_123")
116 | succeeds "3" (Lit 3)
117 | fails "hello"
118 | fails "3four5"
119 |
120 | lit :: Ref a -> Maybe a
121 | lit (Lit a) = Just a
122 | lit (Ref _) = Nothing
123 |
124 | refParser :: Parser x -> Parser (Ref x)
125 | refParser p = try (Lit <$> p)
126 | <|> try (Ref <$> (char '&' *> name))
127 | "a variable"
128 |
129 | -------------------------------------------------------------------------------
130 |
131 | data Relation a
132 | = Equals a
133 | | In [a]
134 | | NotEquals a
135 | | NotIn [a]
136 | deriving (Eq, Ord, Read, Functor)
137 |
138 | instance Show a => Show (Relation a) where
139 | show (Equals v) = printf "=%s" (show v)
140 | show (In vs) = printf "∈{%s}" (renderArgs show vs)
141 | show (NotEquals v) = printf "≠%s" (show v)
142 | show (NotIn vs) = printf "∉{%s}" (renderArgs show vs)
143 |
144 | instance Foldable Relation where
145 | foldMap addM (Equals a) = addM a
146 | foldMap addM (In as) = foldMap addM as
147 | foldMap addM (NotEquals a) = addM a
148 | foldMap addM (NotIn as) = foldMap addM as
149 |
150 | instance Traversable Relation where
151 | traverse f (Equals a) = Equals <$> f a
152 | traverse f (In as) = In <$> sequenceA (map f as)
153 | traverse f (NotEquals a) = NotEquals <$> f a
154 | traverse f (NotIn as) = NotIn <$> sequenceA (map f as)
155 |
156 | instance (Ord a, Parsable a) => Parsable (Relation a) where
157 | parser = relationParser parser
158 |
159 | _testRelationParser :: IO ()
160 | _testRelationParser = do
161 | let succeeds = verifyParser (parser :: Parser (Relation Int))
162 | let fails = verifyParserFails (parser :: Parser (Relation Int))
163 | succeeds "=3" (Equals 3)
164 | fails "=A"
165 | succeeds "≠0" (NotEquals 0)
166 | succeeds "in {1, 2, 3}" (In [1, 2, 3])
167 | fails "in {1,"
168 | succeeds "not in {1, 2, 3}" (NotIn [1, 2, 3])
169 | succeeds " ∈ {1,}" (In [1])
170 |
171 | relationParser :: Parser x -> Parser (Relation x)
172 | relationParser p = go where
173 | go = try (Equals <$> (sEquals *> p))
174 | <|> try (NotEquals <$> (sNotEquals *> p))
175 | <|> try (In <$> (sIn *> set))
176 | <|> NotIn <$> (sNotIn *> set)
177 | sEquals = void sym where
178 | sym = try (symbol "=")
179 | <|> try (symbol "==")
180 | <|> try (keyword "is")
181 | "an equality"
182 | sNotEquals = void sym where
183 | sym = try (symbol "≠")
184 | <|> try (symbol "!=")
185 | <|> try (symbol "/=")
186 | <|> try (keyword "isnt")
187 | "a disequality"
188 | sIn = void sym where
189 | sym = try (symbol "∈")
190 | <|> try (keyword "in")
191 | "a membership test"
192 | sNotIn = void sym where
193 | sym = try (symbol "∉")
194 | <|> try (keyword "not" *> keyword "in")
195 | "an absence test"
196 | set = braces $ sepEndBy p comma
197 |
198 | relToMentions :: Relation a -> [a]
199 | relToMentions (Equals a) = [a]
200 | relToMentions (In as) = as
201 | relToMentions (NotEquals a) = [a]
202 | relToMentions (NotIn as) = as
203 |
204 | -------------------------------------------------------------------------------
205 |
206 | data Call = Call
207 | { callName :: Name
208 | , callArgs :: [Value]
209 | , callKwargs :: Map Name Value
210 | , callActions :: [Value]
211 | , callOutcomes :: [Value]
212 | } deriving (Eq, Ord)
213 |
214 | instance Show Call where
215 | show (Call n args kwargs as os) = n ++ controlstr where
216 | controlstr = printf "%s%s%s" paramstr actsstr outsstr
217 | paramstr = if null args && Map.null kwargs then ("" :: String)
218 | else printf "(%s%s%s)" argstr mid kwargstr
219 | argstr = renderArgs show args
220 | mid = if List.null args || Map.null kwargs then "" else "," :: String
221 | kwargstr = renderArgs (\(k, v) -> printf "%s=%s" k (show v)) (Map.toAscList kwargs)
222 | actsstr = case (as, os) of
223 | ([], []) -> "" :: String
224 | ([], _) -> "[...]"
225 | (_, _) -> printf "[%s]" (renderArgs show as)
226 | outsstr = if null os then "" :: String else printf "[%s]" (renderArgs show os)
227 |
228 | instance Parsable Call where
229 | parser = do
230 | n <- valueStr
231 | (args, kwargs) <- option ([], Map.empty) (try argsParser)
232 | as <- option [] (try valuesParser)
233 | os <- option [] (try valuesParser)
234 | return $ Call n args kwargs as os
235 | where
236 | valuesParser = try (brackets (string "...") $> []) <|> listParser parser
237 | argsParser = parens argsAndKwargs where
238 | argOrKwarg = try (Right <$> kwarg) <|> (Left <$> parser)
239 | kwarg = (,) <$> name <*> (symbol "=" *> parser)
240 | argsAndKwargs = do
241 | (args, kwargs) <- partitionEithers <$> (argOrKwarg `sepEndBy` comma)
242 | return (args, Map.fromList kwargs)
243 |
244 | _testCallParser :: IO ()
245 | _testCallParser = do
246 | let succeeds = verifyParser (parser :: Parser Call)
247 | let fails = verifyParserFails (parser :: Parser Call)
248 | succeeds "Name" (Call "Name" [] Map.empty [] [])
249 | succeeds "A-B()" (Call "A-B" [] Map.empty [] [])
250 | fails "Name!#-"
251 | succeeds "A(x, y, z)" (Call "A" ["x", "y", "z"] Map.empty [] [])
252 | succeeds "A(arg, kwarg=1)" (Call "A" ["arg"] (Map.fromList [("kwarg", "1")]) [] [])
253 | succeeds "A(x=1, a, y=2, b,)" (Call "A" ["a", "b"] (Map.fromList
254 | [("x", "1"), ("y", "2")]) [] [])
255 | fails "A(a a a )"
256 | succeeds "A()[x, y]" (Call "A" [] Map.empty ["x", "y"] [])
257 | succeeds "A()[x, y][a, b]" (Call "A" [] Map.empty ["x", "y"] ["a", "b"])
258 | succeeds "A()[][a, b]" (Call "A" [] Map.empty [] ["a", "b"])
259 | succeeds "A()[...][a, b]" (Call "A" [] Map.empty [] ["a", "b"])
260 | succeeds "A()[...][...]" (Call "A" [] Map.empty [] [])
261 | succeeds "A()[x, y][...]" (Call "A" [] Map.empty ["x", "y"] [])
262 | fails "A()[][][]"
263 |
264 | instance Read Call where
265 | readsPrec _ s = case parse (parser <* eof) "reading call" (Text.pack s) of
266 | Right result -> [(result,"")]
267 | Left err -> error $ show err
268 |
269 | simpleCall :: Name -> Call
270 | simpleCall n = Call n [] Map.empty [] []
271 |
272 | -------------------------------------------------------------------------------
273 |
274 | data ParsedClaim = ParsedClaim Name (Maybe Call) (Relation (Ref Value))
275 | deriving (Eq, Ord, Read)
276 |
277 | instance Show ParsedClaim where
278 | show (ParsedClaim n o r) = printf "%s(%s)%s" n (maybe "" show o) (show r)
279 |
280 | instance Parsable ParsedClaim where
281 | parser = try pclaim "a claim about an agent" where
282 | pclaim = ParsedClaim <$>
283 | name <*>
284 | maybeCall <*>
285 | relationParser (refParser parser)
286 | maybeCall = try (symbol "()" $> Nothing)
287 | <|> try (Just <$> parens parser)
288 | <|> pure Nothing
289 |
290 | _testParsedClaimParser :: IO ()
291 | _testParsedClaimParser = do
292 | let succeeds = verifyParser (parser :: Parser ParsedClaim)
293 | let fails = verifyParserFails (parser :: Parser ParsedClaim)
294 | succeeds "A=val" (ParsedClaim "A" Nothing (Equals $ Lit $ "val"))
295 | fails "X=y=z"
296 | succeeds "A=&a" (ParsedClaim "A" Nothing (Equals $ Ref "a"))
297 | succeeds "A()=&a" (ParsedClaim "A" Nothing (Equals $ Ref "a"))
298 | succeeds "A(B(a))=&a" (ParsedClaim "A"
299 | (Just (Call "B" ["a"] Map.empty [] [])) (Equals $ Ref "a"))
300 | succeeds "Xxx(B(a)[...][x]) in {&a, b, &c}" (ParsedClaim "Xxx"
301 | (Just (Call "B" ["a"] Map.empty [] ["x"])) (In [Ref "a", Lit $ "b", Ref "c"]))
302 | fails "X(f(g(h(x))))=value"
303 |
304 | -------------------------------------------------------------------------------
305 |
306 | data CompiledClaim = CompiledClaim
307 | { claimNameIs :: Name
308 | , claimPlayedVs :: Maybe Call
309 | , claimType :: Maybe ClaimType
310 | , claimAgentPlays :: Value
311 | } deriving (Eq, Ord, Read)
312 |
313 | instance Show CompiledClaim where
314 | show (CompiledClaim n o t v) = printf "%s(%s)=%s%s" n showo showt (show v) where
315 | showo = maybe "" show o
316 | showt = maybe ("" :: String) (printf "%c" . tSymbol) t
317 | tSymbol ActionT = '@'
318 | tSymbol OutcomeT = '$'
319 |
320 | compileClaim :: MonadCompile m => ParsedClaim -> m (ModalFormula CompiledClaim)
321 | compileClaim (ParsedClaim n o rel) = mapM makeClaim (toF rel) where
322 | makeClaim :: MonadCompile m => Ref Value -> m CompiledClaim
323 | makeClaim ref = uncurry (CompiledClaim n o) <$> lookupClaim ref
324 | toF (Equals a) = F.Var a
325 | toF (In []) = F.Val False
326 | toF (In as) = foldr1 F.Or $ map F.Var as
327 | toF (NotEquals a) = F.Neg $ toF (Equals a)
328 | toF (NotIn []) = F.Val True
329 | toF (NotIn as) = F.Neg $ toF (In as)
330 |
331 | -------------------------------------------------------------------------------
332 |
333 | data CompileContext = CompileContext
334 | { variables :: Map Name VarVal
335 | , actionList :: [Value]
336 | , outcomeList :: [Value]
337 | , agentName :: Name
338 | } deriving (Eq, Show)
339 |
340 | withN :: Name -> Int -> CompileContext -> CompileContext
341 | withN n i c = c{variables=Map.insert n (Number i) $ variables c}
342 |
343 | withA :: Name -> Value -> CompileContext -> CompileContext
344 | withA n a c = c{variables=Map.insert n (Action a) $ variables c}
345 |
346 | withO :: Name -> Value -> CompileContext -> CompileContext
347 | withO n o c = c{variables=Map.insert n (Outcome o) $ variables c}
348 |
349 | lookupN :: MonadCompile m => Ref Int -> m Int
350 | lookupN (Ref n) = gets variables >>= toN where
351 | toN = maybe unknown (asN n) . Map.lookup n
352 | unknown = refError $ UnknownNumVar n
353 | lookupN (Lit i) = return i
354 |
355 | lookupClaim :: MonadCompile m => Ref Value -> m (Maybe ClaimType, Value)
356 | lookupClaim (Ref n) = gets variables >>= toClaim where
357 | toClaim = maybe unknown (fmap (first Just) . asClaim n) . Map.lookup n
358 | unknown = refError $ UnknownClaimVar n
359 | lookupClaim (Lit v) = return (Nothing, v)
360 |
361 | lookupA :: MonadCompile m => Ref Value -> m Value
362 | lookupA ref = lookupClaim ref >>= forceA where
363 | forceA (Just OutcomeT, _) = let Ref n = ref in refError $ ExpectingA n
364 | forceA (_, v) = return v
365 |
366 | lookupO :: MonadCompile m => Ref Value -> m Value
367 | lookupO ref = lookupClaim ref >>= forceO where
368 | forceO (Just ActionT, _) = let Ref n = ref in refError $ ExpectingO n
369 | forceO (_, v) = return v
370 |
371 | defaultAction :: MonadCompile m => m Value
372 | defaultAction = gets actionList >>= getFirst where
373 | getFirst [] = actionListError EnumMissing
374 | getFirst (a:_) = return a
375 |
376 | argumentError :: MonadCompile m => ArgumentError -> m a
377 | argumentError err = gets agentName >>= throwError . flip ArgErr err
378 |
379 | actionListError :: MonadCompile m => EnumError -> m a
380 | actionListError err = gets agentName >>= throwError . flip AListErr err
381 |
382 | outcomeListError :: MonadCompile m => EnumError -> m a
383 | outcomeListError err = gets agentName >>= throwError . flip OListErr err
384 |
385 | refError :: MonadCompile m => RefError -> m a
386 | refError err = gets agentName >>= throwError . flip RefErr err
387 |
388 | defError :: MonadCompile m => DefError -> m a
389 | defError err = gets agentName >>= throwError . flip DefErr err
390 |
391 | type MonadCompile m = (MonadError CompileError m, MonadState CompileContext m)
392 |
393 | -------------------------------------------------------------------------------
394 |
395 | data ArgumentError
396 | = UnknownArgs (Set Name)
397 | | TooManyArgs Int Int
398 | | ArgMissing Name VarType
399 | | ArgIsNotNum Name Value
400 | | ArgIsNotIn Name Value [Value]
401 | deriving (Eq, Read)
402 |
403 | instance Show ArgumentError where
404 | show (UnknownArgs ns) =
405 | printf "unknown keyword arguments: {%s}" (renderArgs id $ Set.toList ns)
406 | show (TooManyArgs x y) =
407 | printf "too many arguments: expected %d, got %d" x y
408 | show (ArgMissing n t) =
409 | printf "%s argument %s not given" (show t) n
410 | show (ArgIsNotNum n v) =
411 | printf "argument type mismatch for %s: expected a number, got %s" n (show v)
412 | show (ArgIsNotIn n v vs) =
413 | printf "argument type mismatch for %s: expected one of {%s}, got %s"
414 | n (renderArgs show vs) (show v)
415 |
416 | data EnumError
417 | = EnumMissing
418 | | EnumExcludes [Value] (Set Value)
419 | | EnumMismatch [Value] [Value]
420 | deriving (Eq, Ord, Read)
421 |
422 | instance Show EnumError where
423 | show EnumMissing = "enumeration missing."
424 | show (EnumExcludes xs vs) =
425 | printf "enumeration {%s} excludes {%s}, used in the code"
426 | (renderArgs show xs)
427 | (renderArgs show $ Set.toList vs)
428 | show (EnumMismatch vs ws) =
429 | printf "enumeration mismatch: [%s] / [%s]" (renderArgs show vs) (renderArgs show ws)
430 |
431 | data RefError
432 | = UnknownNumVar Name
433 | | UnknownClaimVar Name
434 | | ExpectingNum Name ClaimType
435 | | ExpectingClaim Name
436 | | ExpectingA Name
437 | | ExpectingO Name
438 | deriving (Eq, Read)
439 |
440 | instance Show RefError where
441 | show (UnknownNumVar n) = printf "unknown number var %s" n
442 | show (UnknownClaimVar n) = printf "unknown var %s used in action claim" n
443 | show (ExpectingNum n t) = printf "%s variable %s used as a number" (show t) n
444 | show (ExpectingClaim n) = printf "number variable %s used in an action claim" n
445 | show (ExpectingA n) = printf "outcome variable %s used as an action" n
446 | show (ExpectingO n) = printf "action variable %s used as an outcome" n
447 |
448 | data DefError
449 | = IsUnmodalized (ModalFormula String)
450 | | InvalidValue ClaimType Value [Value]
451 | | InvalidClaim CompiledClaim String
452 | deriving (Eq, Read)
453 |
454 | instance Show DefError where
455 | show (IsUnmodalized s) = printf "unmodalized statement: %s" (show s)
456 | show (InvalidValue t v vs) = printf "invalid %s %s: expected one of [%s]"
457 | (show t) (show v) (renderArgs show vs)
458 | show (InvalidClaim c s) = printf "invalid claim: %s (%s)" (show c) s
459 |
460 | data CompileError
461 | = ArgErr Name ArgumentError
462 | | AListErr Name EnumError
463 | | OListErr Name EnumError
464 | | RefErr Name RefError
465 | | DefErr Name DefError
466 | deriving (Eq, Read)
467 |
468 | instance Show CompileError where
469 | show (ArgErr n e) = printf "error while compiling %s: %s" n (show e)
470 | show (AListErr n e) = printf "error while compiling %s: action %s" n (show e)
471 | show (OListErr n e) = printf "error while compiling %s: outcome %s" n (show e)
472 | show (RefErr n e) = printf "error while compiling %s: %s" n (show e)
473 | show (DefErr n e) = printf "error while compiling %s: %s" n (show e)
474 |
475 | -- TODO: Not yet in use.
476 | data ExecutionError
477 | = FixpointError String
478 | deriving (Eq, Read)
479 |
480 | instance Show ExecutionError where
481 | show (FixpointError v) = printf "unknown variable when finding fixpoint: %s" v
482 |
483 | data FileError
484 | = UnknownDef DefType Name
485 | | NameCollision DefType Name
486 | deriving (Eq, Read)
487 |
488 | instance Show FileError where
489 | show (UnknownDef t n) = printf "unknown %s: %s" (show t) n
490 | show (NameCollision t n) = printf "name collision: %s %s is already defined" (show t) n
491 |
492 | data RuntimeError
493 | = FileErr FilePath FileError
494 | | ExecErr FilePath String ExecutionError
495 | | CompileErr FilePath CompileError
496 | deriving (Eq, Read)
497 |
498 | instance Show RuntimeError where
499 | show (FileErr f g) = printf "error in %s: %s" f (show g)
500 | show (ExecErr f x r) = printf "error running %s in %s: %s" x f (show r)
501 | show (CompileErr f c) = printf "error running %s: %s" f (show c)
502 |
503 | -------------------------------------------------------------------------------
504 | -- Testing
505 |
506 | main :: IO ()
507 | main = do
508 | _testRefParser
509 | _testRelationParser
510 | _testCallParser
511 | _testParsedClaimParser
512 | putStrLn ""
513 |
--------------------------------------------------------------------------------
/src/Modal/Combat.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ConstraintKinds #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE OverloadedStrings #-}
4 | {-# LANGUAGE TupleSections #-}
5 | {-# LANGUAGE TypeFamilies #-}
6 | module Modal.Combat where
7 | import Prelude hiding (mapM, sequence, foldr)
8 | import Control.Applicative
9 | import Control.Monad.Except hiding (mapM, mapM_, sequence)
10 | import Data.Maybe
11 | import Data.Map (Map)
12 | import Data.Traversable
13 | import Modal.CompilerBase
14 | import Modal.Code
15 | import Modal.Def
16 | import Modal.Competition
17 | import Modal.Display
18 | import Modal.Formulas
19 | import Modal.Parser (Parsable, parser)
20 | import Modal.Utilities
21 | import Text.Parsec hiding ((<|>), optional, many, State)
22 | import Text.Parsec.Text
23 | import Text.Printf (printf)
24 | import Text.Read (readMaybe)
25 | import qualified Data.List as List
26 | import qualified Data.Map as Map
27 | import qualified Data.Set as Set
28 | import qualified Data.Text as Text
29 | import qualified Modal.Parser as P
30 | import qualified Modal.Statement as S
31 |
32 | -------------------------------------------------------------------------------
33 |
34 | data CorD = C | D deriving (Eq, Ord, Enum, Read, Show)
35 |
36 | -------------------------------------------------------------------------------
37 |
38 | data CombatVar m t = MeVsThemIs m | ThemVsIs (Maybe Call) t deriving (Eq, Ord)
39 |
40 | instance (Show a, Show o) => Show (CombatVar a o) where
41 | show (MeVsThemIs m) = printf "Me(Them)=%s" (show m)
42 | show (ThemVsIs Nothing t) = printf "Them(Me)=%s" (show t)
43 | show (ThemVsIs (Just o) t) = printf "Them(%s)%s" (show o) (show t)
44 |
45 | instance (Parsable m, Parsable t) => Parsable (CombatVar m t) where
46 | parser = try mvt <|> try tvm <|> try tvo "a variable" where
47 | mvt = MeVsThemIs . snd <$> vs (string "Me") (nilOr "Them") parser
48 | tvm = ThemVsIs Nothing . snd <$> vs (string "Them") (nilOr "Me") parser
49 | tvo = uncurry (ThemVsIs . Just) <$> vs (string "Them") parser parser
50 | vs x y z = (,) <$> (x *> P.parens y) <*> z
51 | nilOr = option () . void . string
52 |
53 | instance (Parsable u, Parsable a) => Read (CombatVar u a) where
54 | readsPrec _ s = case parse (parser <* eof) "reading CombatVar" (Text.pack s) of
55 | Right result -> [(result,"")]
56 | Left err -> error $ show err
57 |
58 | instance ModalCombatVar CombatVar where
59 | subagentsIn (ThemVsIs (Just x) _) = Set.singleton x
60 | subagentsIn _ = Set.empty
61 |
62 | makeModalVar v1 _ (MeVsThemIs m) = v1 m
63 | makeModalVar _ v2 (ThemVsIs o t) = v2 o t
64 |
65 | -------------------------------------------------------------------------------
66 |
67 | data AVar a u = AMe a | AThem u deriving (Eq, Ord)
68 |
69 | instance (Show a, Show u) => Show (AVar a u) where
70 | show (AMe a) = printf "A()%s" (show a)
71 | show (AThem u) = printf "U()%s" (show u)
72 |
73 | instance MultiVarA AVar where
74 | promoteA i (AMe a) = PlayerNPlays i a
75 | promoteA _ (AThem u) = UniversePlays u
76 |
77 | -------------------------------------------------------------------------------
78 |
79 | data UVar u a = UMe u | UThem Int a deriving (Eq, Ord)
80 |
81 | instance (Show a, Show u) => Show (UVar a u) where
82 | show (UMe u) = printf "U()%s" (show u)
83 | show (UThem n a) = printf "A%d()%s" n (show a)
84 |
85 | instance MultiVarU UVar where
86 | promoteU (UMe u) = UniversePlays u
87 | promoteU (UThem n a) = PlayerNPlays n a
88 |
89 | -------------------------------------------------------------------------------
90 |
91 | data Controls = Controls
92 | { ctrlShowFrames :: Bool
93 | , ctrlShowMap :: Bool
94 | , ctrlHidden :: Bool
95 | } deriving (Eq, Ord, Read)
96 |
97 | instance Show Controls where
98 | show (Controls f m h) = "<" ++
99 | (if f then "F" else "") ++
100 | (if m then "M" else "") ++
101 | (if h then "H" else "") ++ ">"
102 |
103 | instance Parsable Controls where
104 | parser = do
105 | let pWith kw = P.keyword "with" *> P.keyword kw
106 | (f, m) <- P.anyComboOf (pWith "frames") (pWith "map")
107 | h <- optional (P.keyword "hidden")
108 | return $ Controls (isJust f) (isJust m) (isJust h)
109 |
110 | -------------------------------------------------------------------------------
111 |
112 | data GameObject
113 | = Agent Def
114 | | Theory Def
115 | | Problem Def [Value] [[Value]]
116 | | Execute Action
117 | deriving Show
118 |
119 | instance Parsable GameObject where
120 | parser
121 | = pProblem
122 | <|> (Theory <$> defParser theoryDConf)
123 | <|> (Agent <$> defParser agentDConf)
124 | <|> (Agent <$> pOldschoolBot)
125 | <|> (Execute <$> parser)
126 | where
127 | problemDConf = DefConfig "problem" True "outcome" "outcomes" "action" "actions"
128 | theoryDConf = DefConfig "theory" False "action" "actions" "outcome" "outcomes"
129 | agentDConf = DefConfig "agent" False "action" "actions" "response" "responses"
130 | pProblem = (\(d, (v, vs)) -> Problem d v vs) <$>
131 | defParserWithExtras pValues problemDConf
132 | pValues = (,) <$> valuesParser <*> many1 valuesParser
133 | valuesParser = try vals <|> try dunno where
134 | vals = P.brackets (parser `sepEndBy` P.comma)
135 | dunno = P.brackets (string "...") $> []
136 | pOldschoolBot = do
137 | P.keyword "bot"
138 | name <- P.valueStr
139 | P.symbol "="
140 | rawStatement <- parser
141 | let actTable = [("C", rawStatement), ("D", S.Neg rawStatement)]
142 | return $ Def [] name (ActionMap $ Map.fromList actTable)
143 |
144 | -------------------------------------------------------------------------------
145 |
146 | data Action
147 | = Combat Controls Call Call
148 | | Compete Controls Call Call
149 | | Play Controls Call [Call]
150 | deriving Show
151 |
152 | instance Parsable Action where
153 | parser = combatParser <|> competeParser <|> playParser where
154 | combatParser = Combat
155 | <$> (P.keyword "combat" *> parser <* P.symbol "!")
156 | <*> (parser <* P.keyword "vs")
157 | <*> parser
158 | competeParser = Compete
159 | <$> (P.keyword "compete" *> parser <* P.symbol ":")
160 | <*> (parser <* P.keyword "vs")
161 | <*> parser
162 | playParser = Play
163 | <$> (P.keyword "play" *> parser <* P.symbol ":")
164 | <*> (parser <* P.powerComma)
165 | <*> ((parser `sepEndBy` P.powerComma) <* P.symbol ".")
166 |
167 | -------------------------------------------------------------------------------
168 |
169 | data Setting = Setting
170 | { settingName :: Name
171 | , agents :: Map Name Def
172 | , theories :: Map Name Def
173 | , problems :: Map Name (Def, [Value], [[Value]])
174 | } deriving Show
175 |
176 | instance Blockable Setting where
177 | blockLines setting =
178 | [ (0, Text.pack $ printf "%s:" $ settingName setting)
179 | , (1, Text.pack $ line "Agents" agents)
180 | , (1, Text.pack $ line "Theories" theories)
181 | , (1, Text.pack $ line "Problems" problems) ]
182 | where line :: String -> (Setting -> Map Name x) -> String
183 | line x m = printf "%s: %s" x $ renderArgs id $ Map.keys $ m setting
184 |
185 | mergeSettingsR :: MonadError FileError m => Setting -> Setting -> m Setting
186 | mergeSettingsR x y = do
187 | as <- mergeMap (NameCollision AgentT) (agents x) (agents y)
188 | ts <- mergeMap (NameCollision TheoryT) (theories x) (theories y)
189 | ps <- mergeMap (NameCollision ProblemT) (problems x) (problems y)
190 | return $ Setting (settingName y) as ts ps
191 | where mergeMap err a b = case firstDup (Map.keys a ++ Map.keys b) of
192 | Nothing -> return $ a `Map.union` b
193 | Just dup -> throwError (err dup)
194 |
195 | -------------------------------------------------------------------------------
196 |
197 | lookupDef :: MonadError FileError m => DefType -> Map Name x -> Name -> m x
198 | lookupDef t defs name = maybe errUnknown return (Map.lookup name defs) where
199 | errUnknown = throwError $ UnknownDef t name
200 |
201 | lookupVal :: MonadError DefError m => ClaimType -> [(Value, x)] -> Value -> m x
202 | lookupVal t table val = maybe errInvalid return (List.lookup val table) where
203 | errInvalid = throwError $ InvalidValue t val (map fst table)
204 |
205 | lookupAndCompile :: (Ord a, MonadError RuntimeError m) =>
206 | Setting -> CompileConfig a (v a o) -> Call -> m (ModalAgent v a o)
207 | lookupAndCompile setting conf call = do
208 | let compileErr = CompileErr $ settingName setting
209 | let fileErr = FileErr $ settingName setting
210 | def <- wrapError fileErr (lookupDef AgentT (agents setting) (callName call))
211 | wrapError compileErr (compile conf call def)
212 |
213 | -------------------------------------------------------------------------------
214 |
215 | printVsHeader :: Controls -> Call -> Call -> IO ()
216 | printVsHeader ctrls call1 call2 =
217 | (unless $ ctrlHidden ctrls)
218 | (printf "%s vs %s:\n" (show call1) (show call2))
219 |
220 | printMultiHeader :: Controls -> Call -> [Call] -> IO ()
221 | printMultiHeader ctrls call0 calls = unless (ctrlHidden ctrls) doDisplay where
222 | doDisplay =
223 | (printf "%s as U vs\n %s:\n" (show call0)
224 | (List.intercalate ",\n " $ zipWith addAliases calls [1..]))
225 | addAliases :: Call -> Int -> String
226 | addAliases c d = printf "%s as A%s" (show c) (anum d)
227 | anum d = if length calls == 1 then "" else show d
228 |
229 | printCompetitionTable :: Show v => Controls -> Map v (ModalFormula v) -> IO ()
230 | printCompetitionTable ctrls cmap =
231 | (when $ ctrlShowMap ctrls && not (ctrlHidden ctrls))
232 | (putStrLn "\n Full combat map:" >>
233 | (displayTable $ indentTable " " $ tuplesToTable $ Map.toAscList cmap))
234 |
235 | printKripkeTable :: (Ord v, Show v)
236 | => Controls -> (v -> Bool) -> Map v (ModalFormula v) -> IO ()
237 | printKripkeTable ctrls varFilter cmap = do
238 | when (ctrlShowFrames ctrls && not (ctrlHidden ctrls)) $ do
239 | putStrLn "\n Kripke frames:"
240 | displayTable $ indentTable " " $ kripkeTableFiltered varFilter cmap
241 |
242 | printVsResults :: (Show a, Show b) => Controls -> Call -> a -> Call -> b -> IO ()
243 | printVsResults ctrls call1 r1 call2 r2 =
244 | (unless $ ctrlHidden ctrls)
245 | (printf " Result: %s=%s, %s=%s\n\n"
246 | (show call1) (show r1)
247 | (show call2) (show r2))
248 |
249 | printMultiResults :: (Show a, Show b) =>
250 | Controls -> Call -> a -> [Call] -> [b] -> IO ()
251 | printMultiResults ctrls call0 r0 calls rs = unless (ctrlHidden ctrls) doDisplay where
252 | doDisplay =
253 | (printf " Result: U()=%s, %s\n\n" (show r0)
254 | (renderArgs id $ zipWith showAresult rs [1..]))
255 | showAresult :: Show b => b -> Int -> String
256 | showAresult r d = if length rs == 1
257 | then printf "A()=%s" (show r)
258 | else printf "A%d()=%s" d (show r)
259 |
260 | -------------------------------------------------------------------------------
261 |
262 | modalClaimValues :: ParsedClaim -> [(ClaimType, Value)]
263 | modalClaimValues (ParsedClaim name _ rel) = case name of
264 | "Me" -> map (ActionT,) (mapMaybe lit $ relToMentions rel)
265 | "Them" -> map (OutcomeT,) (mapMaybe lit $ relToMentions rel)
266 | _ -> []
267 |
268 | handleModalClaim :: MonadError DefError m =>
269 | [(Value, a)] -> [(Value, o)] -> CompiledClaim -> m (CombatVar a o)
270 | handleModalClaim as os claim@(CompiledClaim name mcall mtype val) = handler where
271 | err = throwError . InvalidClaim claim
272 | mcall' = if mcall == Just (simpleCall "Me") then Nothing else mcall
273 | getAVal = lookupVal ActionT as val
274 | getOVal = lookupVal OutcomeT os val
275 | handler = do
276 | when (name `notElem` ["Me", "Them"])
277 | (err "claim must be about 'Me' or 'Them'")
278 | when (name == "Me" && mtype == Just OutcomeT)
279 | (err "'Me' returns actions, not responses")
280 | when (name == "Me" && isJust mcall && mcall /= Just (simpleCall "Them"))
281 | (err "cannot reason about what 'Me' would do against another")
282 | when (name == "Them" && mtype == Just ActionT)
283 | (err "'Them' returns responses, not actions")
284 | if name == "Me" then MeVsThemIs <$> getAVal else ThemVsIs mcall' <$> getOVal
285 |
286 | modalCombatCConf :: (Show a, Show o) =>
287 | [(Value, a)] -> [(Value, o)] -> CompileConfig a (CombatVar a o)
288 | modalCombatCConf aTable oTable = CompileConfig
289 | { availableActions = map fst aTable
290 | , availableOutcomes = map fst oTable
291 | , compileAction = lookupVal ActionT aTable
292 | , claimValues = modalClaimValues
293 | , handleClaim = handleModalClaim aTable oTable
294 | , finalizeFormula = \f -> do
295 | unless (isModalized f) (throwError $ IsUnmodalized $ show <$> f)
296 | return $ simplify f }
297 |
298 | -------------------------------------------------------------------------------
299 |
300 | problemClaimValues :: ParsedClaim -> [(ClaimType, Value)]
301 | problemClaimValues (ParsedClaim name _ rel) = case name of
302 | "U" -> map (ActionT,) (mapMaybe lit $ relToMentions rel)
303 | _ -> map (OutcomeT,) (mapMaybe lit $ relToMentions rel)
304 |
305 | handleProblemClaim :: MonadError DefError m =>
306 | [(Value, u)] -> [(Value, a)] -> CompiledClaim -> m (UVar u a)
307 | handleProblemClaim us as claim@(CompiledClaim name mcall mtype val) = handler where
308 | err :: MonadError DefError m => String -> m a
309 | err = throwError . InvalidClaim claim
310 | getUVal = lookupVal ActionT us val
311 | getAVal = lookupVal OutcomeT as val
312 | notAnAgent = err "not a valid agent (use A1, A2, ...)"
313 | getPNum = case name of
314 | "U" -> return (0 :: Int)
315 | "A" -> return 1
316 | ('A':num) -> maybe notAnAgent return (readMaybe num)
317 | _ -> notAnAgent
318 | handler = do
319 | pnum <- getPNum
320 | when (name /= "U" && pnum < 1) (err "player numbers must be at least 1")
321 | when (name == "U" && isJust mcall)
322 | (err "cannot reason about self vs other agents")
323 | when (name /= "U" && isJust mcall)
324 | (err "universe cannot reason about agents vs other universes")
325 | -- This is correct. Don't be confused: problem "outcomes" are ActionT,
326 | -- and vice versa. (theory "outcomes" are OutcomeT. Someone has to be
327 | -- reversed. Or we could find better names for ActionT/OutcomeT.)
328 | when (name == "U" && mtype == Just OutcomeT)
329 | (err "'U' returns outcomes, not actions")
330 | when (name /= "U" && mtype == Just ActionT)
331 | (err "players returns actions, not outcomes")
332 | if pnum == 0 then UMe <$> getUVal else UThem pnum <$> getAVal
333 |
334 | problemCConf :: [(Value, u)] -> [(Value, a)] -> CompileConfig u (UVar u a)
335 | problemCConf uTable aTable = CompileConfig
336 | { availableActions = map fst uTable
337 | , availableOutcomes = map fst aTable
338 | , compileAction = lookupVal ActionT uTable
339 | , claimValues = problemClaimValues
340 | , handleClaim = handleProblemClaim uTable aTable
341 | , finalizeFormula = return . simplify }
342 |
343 | -------------------------------------------------------------------------------
344 |
345 | theoryClaimValues :: ParsedClaim -> [(ClaimType, Value)]
346 | theoryClaimValues (ParsedClaim name _ rel) = case name of
347 | "A" -> map (ActionT,) (mapMaybe lit $ relToMentions rel)
348 | "U" -> map (OutcomeT,) (mapMaybe lit $ relToMentions rel)
349 | _ -> []
350 |
351 | handleTheoryClaim :: MonadError DefError m =>
352 | [(Value, a)] -> [(Value, u)] -> CompiledClaim -> m (AVar a u)
353 | handleTheoryClaim as us claim@(CompiledClaim name mcall mtype val) = handler where
354 | err = throwError . InvalidClaim claim
355 | getAVal = lookupVal ActionT as val
356 | getUVal = lookupVal OutcomeT us val
357 | handler = do
358 | when (name `notElem` ["A", "U"]) (err "invalid player (use A or U)")
359 | when (name == "A" && isJust mcall)
360 | (err "cannot reason about self in other universes")
361 | when (name == "U" && isJust mcall)
362 | (err "cannot reason about universe vs other agents")
363 | when (name == "A" && mtype == Just OutcomeT)
364 | (err "'A' returns actions, not outcomes")
365 | when (name == "U" && mtype == Just ActionT)
366 | (err "'U' returns outcomes, not actions")
367 | if name == "A" then AMe <$> getAVal else AThem <$> getUVal
368 |
369 | theoryCConf :: (Show a, Show u) =>
370 | [(Value, a)] -> [(Value, u)] -> CompileConfig a (AVar a u)
371 | theoryCConf aTable uTable = CompileConfig
372 | { availableActions = map fst aTable
373 | , availableOutcomes = map fst uTable
374 | , compileAction = lookupVal ActionT aTable
375 | , claimValues = theoryClaimValues
376 | , handleClaim = handleTheoryClaim aTable uTable
377 | , finalizeFormula = \f -> do
378 | unless (isModalized f) (throwError $ IsUnmodalized $ show <$> f)
379 | return $ simplify f }
380 |
381 | -------------------------------------------------------------------------------
382 |
383 | runModalCombat :: (Eq x, Eq y, Ord x, Ord y, Show x, Show y) =>
384 | Controls -> Call -> Call -> (VsVar x y -> Bool) -> Competition x y -> IO ()
385 | runModalCombat ctrls call1 call2 varFilter cmap = do
386 | let (r1, r2) = modalCombatResolve call1 call2 cmap
387 | printCompetitionTable ctrls cmap
388 | printKripkeTable ctrls varFilter cmap
389 | printVsResults ctrls call1 r1 call2 r2
390 |
391 | executeAction :: Setting -> Action -> IO ()
392 | executeAction setting = execute where
393 | -- Prisoner's dilemma competition
394 | execute (Combat ctrls call1 call2) = do
395 | printVsHeader ctrls call1 call2
396 | cmap <- run $ modalCombatMap1 (lookupAndCompile setting pdconf) call1 call2
397 | runModalCombat ctrls call1 call2 varIsC cmap
398 | -- Modal agents referring to each other
399 | execute (Compete ctrls call1 call2) = do
400 | printVsHeader ctrls call1 call2
401 | def1 <- run $ findDef AgentT (agents setting) call1
402 | def2 <- run $ findDef AgentT (agents setting) call2
403 | let (as1, os1) = effectiveAOs modalClaimValues (defCode def1) call1
404 | let (as2, os2) = effectiveAOs modalClaimValues (defCode def2) call2
405 | let conf1 = modalCombatCConf (makeTable as1) (makeTable $ List.nub $ as2 ++ os1)
406 | let conf2 = modalCombatCConf (makeTable as2) (makeTable $ List.nub $ as1 ++ os2)
407 | let env1 = lookupAndCompile setting conf1
408 | let env2 = lookupAndCompile setting conf2
409 | cmap <- run $ modalCombatMap env1 env2 call1 call2
410 | runModalCombat ctrls call1 call2 (const True) cmap
411 | -- Unmodalized universe vs modalized agents
412 | execute (Play ctrls pCall tCalls) = do
413 | printMultiHeader ctrls pCall tCalls
414 | (pDef, oList, aLists) <- run $ findDef ProblemT (problems setting) pCall
415 | tDefs <- run $ mapM (findDef TheoryT (theories setting)) tCalls
416 | let (pAms, pOms) = effectiveAOs problemClaimValues (defCode pDef) pCall
417 | let pATable = makeTable $ if null oList then pAms else oList
418 | let pOTable = makeTable $ if all null aLists then pOms else concat aLists
419 | let pConf = problemCConf pATable pOTable
420 | let makeTableR xs ys = makeTable (if null xs then ys else xs)
421 | let { makeTConf def call aList =
422 | let (tAms, tOms) = effectiveAOs theoryClaimValues (defCode def) call
423 | in theoryCConf (makeTableR tAms aList) (makeTableR tOms oList) }
424 | let aLists' = if length aLists == 1 then repeat (head aLists) else aLists
425 | let tConfs = zipWith3 makeTConf tDefs tCalls aLists'
426 | let tCompile (conf, call, def) = wrapCErr $ compile conf call def
427 | p <- run $ wrapCErr $ compile pConf pCall pDef
428 | ts <- run $ mapM tCompile (zip3 tConfs tCalls tDefs)
429 | let cmap = multiCompetition p ts
430 | printCompetitionTable ctrls cmap
431 | printKripkeTable ctrls (const True) cmap
432 | let (pResult, tResults) = multiCompete p ts
433 | printMultiResults ctrls pCall pResult tCalls tResults
434 | -- Error wrappers
435 | wrapFErr :: MonadError RuntimeError m => Except FileError a -> m a
436 | wrapFErr = wrapError (FileErr $ settingName setting)
437 | wrapCErr :: MonadError RuntimeError m => Except CompileError a -> m a
438 | wrapCErr = wrapError (CompileErr $ settingName setting)
439 | -- Generic helper functions
440 | makeTable = map (\v -> (v, v))
441 | findDef t defs = wrapFErr . lookupDef t defs . callName
442 | -- Helpers specific to the prisoner's dilemma
443 | cdTable = [("C", C), ("D", D)]
444 | pdconf = modalCombatCConf cdTable cdTable
445 | varIsC (Vs1 _ _ C) = True
446 | varIsC (Vs2 _ _ C) = True
447 | varIsC _ = False
448 |
449 | -------------------------------------------------------------------------------
450 |
451 | actions :: [GameObject] -> [Action]
452 | actions objects = [x | Execute x <- objects]
453 |
454 | gameToSetting :: MonadError FileError m => Name -> [GameObject] -> m Setting
455 | gameToSetting name = foldM addToSetting emptySetting where
456 | emptySetting = Setting name Map.empty Map.empty Map.empty
457 | addToSetting setting (Agent a) =
458 | (\x -> setting{agents=x}) <$> addToMap AgentT (defName a) a (agents setting)
459 | addToSetting setting (Theory t) =
460 | (\x -> setting{theories=x}) <$> addToMap TheoryT (defName t) t (theories setting)
461 | addToSetting setting (Problem p v vs) =
462 | (\x -> setting{problems=x}) <$>
463 | addToMap ProblemT (defName p) (p, v, vs) (problems setting)
464 | addToSetting setting (Execute _) = return setting
465 | addToMap :: MonadError FileError m =>
466 | DefType -> Name -> x -> Map Name x -> m (Map Name x)
467 | addToMap t n val m = do
468 | when (Map.member n m) (throwError $ NameCollision t n)
469 | return $ Map.insert n val m
470 |
471 | gameParser :: Parser [GameObject]
472 | gameParser = many P.ignoredLine *> (parser `sepEndBy` many P.ignoredLine) <* end where
473 | end = many (void (char '\t') <|> P.ignoredToken) *> eof -- Ugh.
474 |
475 | -------------------------------------------------------------------------------
476 |
477 | parseFile :: Bool -> FilePath -> IO [GameObject]
478 | parseFile useUtf8 path = runFile (parse gameParser path) useUtf8 path
479 |
480 | compileFile :: Bool -> FilePath -> IO Setting
481 | compileFile useUtf8 path = run . gameToSetting path =<< parseFile useUtf8 path
482 |
483 | playGame :: Name -> [GameObject] -> IO ()
484 | playGame name game = do
485 | setting <- run $ gameToSetting name game
486 | putStrLn "Setting:"
487 | displayBlock' (Text.pack " ") setting
488 | putStrLn "Loaded. Executing..."
489 | putStrLn ""
490 | mapM_ (executeAction setting) (actions game)
491 |
492 | playFile :: Bool -> FilePath -> IO ()
493 | playFile useUtf8 path = parseFile useUtf8 path >>= playGame path
494 |
495 | playGame' :: Name -> Setting -> [GameObject] -> IO ()
496 | playGame' name base game = do
497 | putStrLn "Setting loaded from other files:"
498 | displayBlock' (Text.pack " ") base
499 | local <- run $ gameToSetting name game
500 | putStrLn "Setting from this file:"
501 | displayBlock' (Text.pack " ") local
502 | setting <- run $ mergeSettingsR base local
503 | putStrLn "Merged. Executing..."
504 | putStrLn ""
505 | mapM_ (executeAction setting) (actions game)
506 |
507 | playFile' :: Bool -> FilePath -> Setting -> IO ()
508 | playFile' useUtf8 path setting = parseFile useUtf8 path >>= playGame' path setting
509 |
--------------------------------------------------------------------------------