├── .github └── workflows │ └── main.yml ├── .gitignore ├── ACT.md ├── Architecture.md ├── LICENSE ├── README.md ├── Tutorial ├── Auction.png ├── Bimatrix.png ├── GameSimple.png ├── Sequential.png └── TUTORIAL.md ├── act ├── Act.hs ├── Act │ ├── Execution.hs │ ├── Prelude.hs │ ├── TH.hs │ ├── TH │ │ ├── Extractor.hs │ │ └── State.hs │ └── Utils.hs ├── EVM │ └── TH.hs ├── Examples │ ├── AmmGenerated.hs │ ├── EVM.hs │ └── Player.hs └── Main.hs ├── amm.act ├── app └── Main.hs ├── bench └── Main.hs ├── graphics └── Main.hs ├── open-games-hs.cabal ├── opengames └── Main.hs ├── package.yaml ├── simple.act ├── solitidy ├── AMM.sol ├── ERC20.sol ├── UniswapExchange.sol └── UniswapFactory.sol ├── src ├── Data │ └── Utils.hs ├── Examples │ ├── Auctions │ │ ├── AuctionSupportFunctions.hs │ │ ├── ChooseReservePrice.hs │ │ ├── DutchAuction.hs │ │ ├── SequentialAuction.hs │ │ ├── SimultaneousBidAuction.hs │ │ └── output.svg │ ├── Bayesian.hs │ ├── Decision.hs │ ├── Markov │ │ ├── NStageMarkov.hs │ │ ├── RepeatedPD.hs │ │ ├── RepeatedPDNonState.hs │ │ ├── TestSimpleMonteCarlo.hs │ │ ├── TestSimpleMonteCarlo │ │ │ └── Continuation.hs │ │ └── TwoStageMarkov.hs │ ├── SequentialMoves.hs │ ├── SimultaneousMoves.hs │ ├── Staking │ │ ├── AndGateMarkov.hs │ │ └── AndGateMarkovMC.hs │ └── Token │ │ └── Concrete.hs ├── Graphics.hs ├── OpenGames.hs └── OpenGames │ ├── Engine │ ├── AtomicGames.hs │ ├── BayesianGames.hs │ ├── BayesianGamesNonState.hs │ ├── Diagnostics.hs │ ├── Engine.hs │ ├── IOGames.hs │ ├── Nat.hs │ ├── OpenGames.hs │ ├── OpticClass.hs │ ├── TLL.hs │ └── Vec.hs │ ├── Preprocessor.hs │ └── Preprocessor │ ├── BlockSyntax.hs │ ├── Codegen.hs │ ├── CompileBlock.hs │ ├── CompileSyntax.hs │ ├── Parser.hs │ └── RuntimeAST.hs ├── stack.yaml ├── stack.yaml.lock └── tests └── ArrowTest.hs /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI 4 | 5 | # Controls when the action will run. 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the master branch 8 | push: 9 | branches: [ master, act-amm ] 10 | pull_request: 11 | branches: [ master ] 12 | 13 | # Allows you to run this workflow manually from the Actions tab 14 | workflow_dispatch: 15 | 16 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 17 | jobs: 18 | runhaskell: 19 | name: run tests 20 | runs-on: ubuntu-latest # or macOS-latest, or windows-latest 21 | steps: 22 | - uses: actions/checkout@v2 23 | - uses: cachix/install-nix-action@v20 24 | with: 25 | nix_path: nixpkgs=channel:nixos-unstable 26 | - uses: haskell-actions/run-ormolu@v11 27 | - uses: haskell/actions/setup@v1 28 | with: 29 | ghc-version: '8.10.4' # Exact version of ghc to use 30 | # cabal-version: 'latest'. Omitted, but defaults to 'latest' 31 | enable-stack: true 32 | stack-version: 'latest' 33 | - run: stack test 34 | - run: stack run act-exec 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Core latex/pdflatex auxiliary files: 2 | *.aux 3 | *.lof 4 | *.log 5 | *.lot 6 | *.fls 7 | *.out 8 | *.toc 9 | *.fmt 10 | 11 | ## Intermediate documents: 12 | *.dvi 13 | *-converted-to.* 14 | # these rules might exclude image files for figures etc. 15 | # *.ps 16 | # *.eps 17 | *.pdf 18 | 19 | ## Bibliography auxiliary files (bibtex/biblatex/biber): 20 | *.bbl 21 | *.bcf 22 | *.blg 23 | *-blx.aux 24 | *-blx.bib 25 | *.brf 26 | *.run.xml 27 | 28 | ## Build tool auxiliary files: 29 | *.fdb_latexmk 30 | *.synctex 31 | *.synctex.gz 32 | *.synctex.gz(busy) 33 | *.pdfsync 34 | 35 | ## Auxiliary and intermediate files from other packages: 36 | # algorithms 37 | *.alg 38 | *.loa 39 | 40 | # achemso 41 | acs-*.bib 42 | 43 | # amsthm 44 | *.thm 45 | 46 | # beamer 47 | *.nav 48 | *.snm 49 | *.vrb 50 | 51 | # cprotect 52 | *.cpt 53 | 54 | #(e)ledmac/(e)ledpar 55 | *.end 56 | *.[1-9] 57 | *.[1-9][0-9] 58 | *.[1-9][0-9][0-9] 59 | *.[1-9]R 60 | *.[1-9][0-9]R 61 | *.[1-9][0-9][0-9]R 62 | *.eledsec[1-9] 63 | *.eledsec[1-9]R 64 | *.eledsec[1-9][0-9] 65 | *.eledsec[1-9][0-9]R 66 | *.eledsec[1-9][0-9][0-9] 67 | *.eledsec[1-9][0-9][0-9]R 68 | 69 | # glossaries 70 | *.acn 71 | *.acr 72 | *.glg 73 | *.glo 74 | *.gls 75 | 76 | # gnuplottex 77 | *-gnuplottex-* 78 | 79 | # hyperref 80 | *.brf 81 | 82 | # knitr 83 | *-concordance.tex 84 | *.tikz 85 | *-tikzDictionary 86 | 87 | # listings 88 | *.lol 89 | 90 | # makeidx 91 | *.idx 92 | *.ilg 93 | *.ind 94 | *.ist 95 | 96 | # minitoc 97 | *.maf 98 | *.mtc 99 | *.mtc[0-9] 100 | *.mtc[1-9][0-9] 101 | 102 | # minted 103 | _minted* 104 | *.pyg 105 | 106 | # morewrites 107 | *.mw 108 | 109 | # mylatexformat 110 | *.fmt 111 | 112 | # nomencl 113 | *.nlo 114 | 115 | # sagetex 116 | *.sagetex.sage 117 | *.sagetex.py 118 | *.sagetex.scmd 119 | 120 | # sympy 121 | *.sout 122 | *.sympy 123 | sympy-plots-for-*.tex/ 124 | 125 | # pdfcomment 126 | *.upa 127 | *.upb 128 | 129 | #pythontex 130 | *.pytxcode 131 | pythontex-files-*/ 132 | 133 | # Texpad 134 | .texpadtmp 135 | 136 | # TikZ & PGF 137 | *.dpth 138 | *.md5 139 | *.auxlock 140 | 141 | # todonotes 142 | *.tdo 143 | 144 | # xindy 145 | *.xdy 146 | 147 | # xypic precompiled matrices 148 | *.xyc 149 | 150 | # WinEdt 151 | *.bak 152 | *.sav 153 | 154 | # endfloat 155 | *.ttt 156 | *.fff 157 | 158 | # Latexian 159 | TSWLatexianTemp* 160 | 161 | # DS Store 162 | .DS_Store 163 | .stack-work/ 164 | dist-newstyle/ 165 | -------------------------------------------------------------------------------- /ACT.md: -------------------------------------------------------------------------------- 1 | # Act integration with Open games 2 | 3 | Act integration with open games can be used with the `act` target of the project. 4 | 5 | In its current state it will run `act/Main.hs` which will import `Examples.AmmGenerated` 6 | and `Examples.player`. The generated version is automatically derived from an ACT 7 | file, the `Player` uses the generated code to setup a game with transactions and players 8 | sending those transactions. 9 | 10 | ## How to use 11 | 12 | We split our example into 3 files: 13 | 14 | - `Examples.AmmGenerated` for template-haskell code 15 | - `Examples.Player` for strategic analysis 16 | - `Main` for running the analysis 17 | 18 | ### `AmmGenerated` 19 | 20 | `Examples.AmmGenerated` shows an example of how to import an ACT program into an 21 | open game for analysis. 22 | 23 | ```haskell 24 | import Act.TH 25 | import Act.Prelude 26 | import Act.Execution 27 | 28 | -- This generates the `ammContract` 29 | $(act2OG "amm.act") 30 | 31 | -- This combines two contracts with non-shared state 32 | twoAmms = combine (unionContracts ("amm1", ammContract) ("amm2", ammContract)) 33 | ``` 34 | 35 | The first three imports are essential to import the `act2OG` splice which will generate 36 | all the top-level declarations necessary to interact with the contract. In particular it 37 | will generate a definition for a _type_ that represents the state of the contract. In 38 | our amm example the type is called "AmmState". The name will always be the name of the 39 | contract followed by "State". 40 | We also generate a top-level function that takes a `Transaction` and a _State_ and 41 | returns a new state. This function re-creates the operations defined in the original ACT 42 | specification. It can then be re-used within an open game as a non-strategic player since 43 | it is now a plain haskell function. Finally the `combine` function comes from `Act.Execution` 44 | which provides some utilities to interact with contract-functions generated. 45 | 46 | ### `Player` 47 | 48 | Our contract-function is then instanciated as an open game where the state of the game is 49 | threaded to the function. You can see this in the function `playerAutomatic` which takes 50 | two amm states, and runs a series of transactions on both 51 | 52 | ### `Main` 53 | 54 | The main file is useful in order to start playing around with this setup, it is not necessary 55 | to use it at all. It is enough to import `ACT.TH`, `ACT.Prelude` and possibly `ACT.Execution` 56 | in order to start using the ACT translation layer. 57 | -------------------------------------------------------------------------------- /Architecture.md: -------------------------------------------------------------------------------- 1 | 2 | # Open games architecture around Act contracts 3 | 4 | An act contract is a program that represents some contract on the Ethereum blockchain. 5 | 6 | They are used to find vulnerabilities in contract implementations. 7 | 8 | Open games are a compositional tool for game theory. The tool we developped 9 | translates act contracts into open games to allow for game-theoretic analysis. 10 | 11 | Act finds implementation bugs. Open games find economical bugs. 12 | 13 | ## Act contracts in open games 14 | 15 | - we translate each contract into a single function 16 | - we combine each contracts together into a "blochain execution" function 17 | - we lift our blockchain execution into an open game 18 | - You can now submit transactions to it and see the result. Analysing for 19 | equilibrium. 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2022 Jules Hedges, André Videla, Philipp Zahn & other contributors 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Getting started with open games 2 | 3 | This tutorial is about how to install the tools to use open games and how to master the language 4 | of open games to write powerful games and analyze them. 5 | 6 | This repo is a refactored and simplified implementation on the basis of [this](https://github.com/jules-hedges/open-game-engine) version by Jules Hedges. 7 | 8 | If you have questions, drop me (Philipp) a [mail](mailto:philipp.zahn@unisg.ch)! 9 | 10 | This repo is work in progress. Expect changes at any time! 11 | 12 | # What are open games? 13 | 14 | _Open games_ are a mathematical structure allowing you to describe game-theoretical games. _Open-games-hs_ 15 | is a framework to write those games in a programmatic way and analyze those games. The framework is 16 | written in Haskell and this allows Open Games to inherit a lot of features from the haskell ecosystem such 17 | as datatypes, functions and the large set of haskell libraries. 18 | 19 | _Open-games-hs_ is a framework implementing the theory of _Open games_ with which you can write a program that 20 | describes a game and its players. You can supply strategies for the game and test the game for equilibrium. 21 | If the game does not reach equilibrium, the list of deviations 22 | is printed and the reason why the player want to deviate is recorded. The biggest strength of open games 23 | is the ability to build your game from smaller modular components that you can 24 | swap out or parameterize. 25 | 26 | # Modelling in open games 27 | 28 | This [tutorial](https://github.com/philipp-zahn/open-games-hs/blob/master/Tutorial/TUTORIAL.md) shows how to use the software for modelling. 29 | 30 | 31 | # How to install and run open-games-hs 32 | 33 | Open-games-hs requires stack and a text editor, for the text editor, it is very likely 34 | that your existing one already supports haskell. If you do not have one I recommend starting with [VSCode][VSCODE]. 35 | 36 | You can install stack following the instructions here: (https://docs.haskellstack.org/en/stable/install_and_upgrade/)[https://docs.haskellstack.org/en/stable/install_and_upgrade/] 37 | 38 | Stack will be responsible for installing haskell, the Open-games-hs framework and its dependencies. 39 | 40 | Once stack is installed you can run the demo project by running `stack run`. That will execute the project, and 41 | print the result of executing an equilibrium check on a very simple game. The rest of the tutorial will go into how 42 | to use the open-games framework in order to design and analyse games interactively using `ghci`. To invoke it, use 43 | `stack ghci` and that will start a new interactive session. 44 | 45 | # Designing and analyzing games interactively 46 | 47 | During an interactive session you can: 48 | 49 | - execute programs 50 | - recompile the project with `:r` 51 | - obtain documentation about a function with `:i` 52 | - query the type of an expression with `:t` 53 | 54 | Most of the programs you will execute will print the result of analyzing a game. In the demo project, the main function 55 | perform an analysis of two simple games, the first one is in equilibrium and the second one exhibits profitable deviations. To 56 | run the program from the interactive sessions type `main`. 57 | 58 | # Graph dependency visualiser 59 | 60 | There is a rudimentary dependency visualizer for debugging (and inspecting larger games). 61 | 62 | If you run `stack run graphics`, a `dotfile` is created. This is a graphviz file that can be interpreted with graphviz with the following command: 63 | 64 | dot -Tsvg dotfile > output.svg 65 | 66 | This will create an SVG that you can open with any SVG viewer (like a web browser). The graph is generated from the `parseTree` of a game. Files of this form need to be located in `graphics/Main.hs` where the main function simply prints the dot file from the game passed in argument. If you want to use a different game, you can pass it a new parsetree using the `parseTree` quasiquote. 67 | -------------------------------------------------------------------------------- /Tutorial/Auction.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CyberCat-Institute/open-game-engine/d3e933e0f1a39432e78f1eaea89799741268e85d/Tutorial/Auction.png -------------------------------------------------------------------------------- /Tutorial/Bimatrix.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CyberCat-Institute/open-game-engine/d3e933e0f1a39432e78f1eaea89799741268e85d/Tutorial/Bimatrix.png -------------------------------------------------------------------------------- /Tutorial/GameSimple.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CyberCat-Institute/open-game-engine/d3e933e0f1a39432e78f1eaea89799741268e85d/Tutorial/GameSimple.png -------------------------------------------------------------------------------- /Tutorial/Sequential.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CyberCat-Institute/open-game-engine/d3e933e0f1a39432e78f1eaea89799741268e85d/Tutorial/Sequential.png -------------------------------------------------------------------------------- /act/Act.hs: -------------------------------------------------------------------------------- 1 | module Act (module Act.Prelude, module Act.Execution, module Act.TH) where 2 | 3 | import Act.Execution 4 | import Act.Prelude 5 | import Act.TH 6 | -------------------------------------------------------------------------------- /act/Act/Execution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedRecordDot #-} 3 | {-# LANGUAGE NoFieldSelectors #-} 4 | 5 | module Act.Execution where 6 | 7 | import Act.Prelude 8 | 9 | -- An ACT contract is a pair of a _name_ and a function that updates 10 | -- a state `s` given a transaction 11 | type ActContract s = (String, s -> Transaction -> s) 12 | 13 | unionContracts :: 14 | ActContract s1 -> 15 | ActContract s2 -> 16 | [ActContract (s1, s2)] 17 | unionContracts (n1, f1) (n2, f2) = 18 | [(n1, focus fst (\(x, y) x' -> (x', y)) f1), (n2, focus snd (\(x, y) y' -> (x, y')) f2)] 19 | where 20 | focus :: (t -> s) -> (t -> s -> t) -> (s -> Transaction -> s) -> (t -> Transaction -> t) 21 | focus view update fn st trans = update st (fn (view st) trans) 22 | 23 | -- Given an arbitrary number of contracts we can generate a state-updating function that 24 | -- performs a list of transaction on the given set of contracts. 25 | combine :: [ActContract s] -> [Transaction] -> s -> s 26 | combine contracts [transaction] globalState = 27 | let Just trans = Prelude.lookup (transaction.contract) contracts 28 | in trans globalState transaction 29 | combine contracts (t : ts) globalState = 30 | case Prelude.lookup (t.contract) contracts of 31 | Just trans -> let newState = trans globalState t in combine contracts ts newState 32 | Nothing -> error ("got illegal transaction " ++ show t) 33 | combine _ [] st = error "we were not given any transactions" 34 | -------------------------------------------------------------------------------- /act/Act/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedRecordDot #-} 3 | {-# LANGUAGE NoFieldSelectors #-} 4 | 5 | module Act.Prelude (Word256, EthTransaction (..), Transaction (..), AbiType (..), AbiValue (..)) where 6 | 7 | import Data.DoubleWord (Word256) 8 | import Data.Text 9 | import EVM.ABI (AbiType (..), AbiValue (..)) 10 | import EVM.Types (Addr, W256) 11 | 12 | data Transaction = Transaction 13 | { contract :: String, 14 | method :: String, 15 | arguments :: [AbiValue] 16 | } 17 | deriving (Eq, Show, Ord) 18 | 19 | data EthTransaction = EthTransaction 20 | { contract :: Addr, 21 | method :: Text, 22 | arguments :: [AbiValue], 23 | ethAmt :: W256, 24 | gas :: W256 25 | } 26 | deriving (Eq, Show, Ord) 27 | -------------------------------------------------------------------------------- /act/Act/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TupleSections #-} 6 | 7 | module Act.TH (act2OG, module Act.Prelude) where 8 | 9 | import Act.Prelude 10 | import Act.TH.Extractor 11 | import Act.TH.State 12 | import Act.Utils 13 | import CLI 14 | import Data.List 15 | import Data.Validation 16 | import Error 17 | import GHC.IO.Unsafe 18 | import Language.Haskell.TH.Syntax as TH 19 | import Syntax.Annotated 20 | 21 | -- Convert from a an act filepath to a list of top-level declaration 22 | -- state is converted into a record 23 | -- invariants are converted into if-statements 24 | -- We make one data declaration with one constructor for each method 25 | -- which we then use for dispatching the correct functionality in the 26 | -- contract. 27 | -- a single top-level function is created taking in argument 28 | -- the method dispatcher 29 | act2OG :: String -> Q [Dec] 30 | act2OG filename = do 31 | let file :: String = unsafePerformIO $ readFile filename 32 | let compiled :: Error String Act = compile file 33 | case compiled of 34 | Failure err -> 35 | reportError (extractError err) 36 | >> pure [] 37 | -- A parsed Act file is a list of claims 38 | Success (Act store contracts) -> do 39 | methods <- traverse generateContractFunction contracts 40 | let stateTypes = stateDec4Interface store 41 | pure (stateTypes ++ concat methods) 42 | where 43 | extractError :: NonEmpty (Pn, String) -> String 44 | extractError err = "" 45 | 46 | arr x y = AppT (AppT ArrowT x) y 47 | 48 | -- generate a top-level function that will define the contract 49 | -- it's type will always be the same: 50 | -- (ContractState, ContractMethod) -> ContractState 51 | -- This is then going to be instanciated as an open game using `fromFunctions` 52 | generateContractFunction :: Contract -> Q [Dec] 53 | generateContractFunction (Contract constr behav) = do 54 | let contractName = uncapitalise (_cname constr) 55 | let interface = _cinterface constr 56 | extractMethods <- generateExtractMethods [(_name b, _interface b) | b <- behav] 57 | methodClauses <- traverse mapMethod2TH behav 58 | generateContractDecl contractName methodClauses extractMethods 59 | 60 | contractState :: TH.Name 61 | contractState = mkName "contractState" 62 | 63 | contractArgs :: TH.Name 64 | contractArgs = mkName "args" 65 | 66 | -- This builds the function signature for the contract, each contract generates one function 67 | -- that recieves transactions, each contract function has it's own internal "method dispatcher" 68 | -- that matches on the method of the transaction, extracts the arguments and calls the body with 69 | -- the arguments in scope 70 | -- Each contract has this shape: 71 | -- 72 | -- ``` 73 | -- contractName :: ContractState -> Transaction -> ContractState 74 | -- contractName st transaction = case method transaction of 75 | -- "m1" -> let (arg1, arg2) <- extractm1 (args transaction) in b1 76 | -- "m2" -> let (arg1, arg2, arg3) <- extractm2 (args transaction) in b2 77 | -- "m3" -> let (arg1) <- extractm3 (args transaction) in b3 78 | -- ``` 79 | generateContractDecl :: String -> [(String, TH.Exp)] -> [Dec] -> Q [Dec] 80 | generateContractDecl contractName clauses extractMethods = do 81 | let method = mkName "method" 82 | crashMessage <- [|error ("unexpected method, got '" ++ $(return (VarE method)) ++ "'\\nexpected one of : " ++ $(return clauseLit))|] 83 | transactionPattern <- [p|Act.Prelude.Transaction _ $(return (VarP method)) $(return (VarP contractArgs))|] 84 | pure 85 | [ signatureForContract, 86 | FunD 87 | fnName 88 | [ Clause 89 | [VarP contractState, transactionPattern] 90 | ( NormalB 91 | ( CaseE 92 | (VarE method) 93 | (matchClauses ++ [matchE WildP crashMessage]) 94 | ) 95 | ) 96 | extractMethods 97 | ] 98 | ] 99 | where 100 | -- The name of the function is the name of the contract 101 | fnName :: Name 102 | fnName = mkName (contractName ++ "Contract") 103 | 104 | -- The name of the type that represents the storage for the contract is given 105 | -- by the function `storeTypeName`. It capitalises and appends "state" to its argument 106 | contractStateTypeName :: Type 107 | contractStateTypeName = (ConT (storeTypeName contractName)) 108 | 109 | -- The signature for a contract named "c" is given by the type 110 | -- c :: CState -> Transaction -> CState 111 | signatureForContract :: Dec 112 | signatureForContract = 113 | SigD 114 | fnName 115 | (contractStateTypeName `arr` (ConT (mkName "Transaction") `arr` contractStateTypeName)) 116 | 117 | -- A string of all the methods, comma-separated. Used for printing errors. 118 | clauseLit :: TH.Exp 119 | clauseLit = LitE (StringL (intercalate ", " (fmap fst clauses))) 120 | 121 | -- This is the list of pattern to dispatch the transaction to the correct function body for the contract 122 | -- ``` 123 | -- case (method transaction) of 124 | -- "call1" -> body1 \ 125 | -- "call2" -> body2 |-> This bit 126 | -- "call3" -> body3 / 127 | -- ``` 128 | matchClauses :: [Match] 129 | matchClauses = fmap (\(pat, exp) -> matchE (LitP (StringL pat)) exp) clauses 130 | matchE p b = Match p (NormalB b) [] 131 | 132 | undefinedE = VarE (mkName "undefined") 133 | 134 | -- Return the pattern for bringing the arguments into scope from the argument extractor 135 | -- functions 136 | -- If the method has no argument, the pattern is a unit 137 | -- If the method has one argument the pattern is just a variable name 138 | -- If the method has multiple arguments, the pattern is a tuple, one per argument 139 | bindVariables :: [Decl] -> TH.Pat 140 | bindVariables [] = VarP '() 141 | bindVariables [Decl _ name] = VarP (mkName name) 142 | bindVariables xs = TupP (fmap (VarP . mkName . getDeclId) xs) 143 | 144 | -- A series of rewrites of the state is translated as the composition of the rewrites applied to the state 145 | -- each rewrite is written as a single `State -> State` update function as per the implementation of `rewriteOne` 146 | -- each constant is also written as a single `State -> State` update function 147 | mapMethod2TH :: Behaviour -> Q (String, TH.Exp) 148 | mapMethod2TH (Behaviour methodName _ (Interface _ args) _ _ _ actExp _) = do 149 | body <- RecUpdE (VarE contractState) <$> traverse rewriteOne actExp 150 | let extractor = AppE (VarE (argumentExtractorName methodName)) (VarE contractArgs) 151 | pure $ (methodName, LetE [ValD (bindVariables args) (NormalB extractor) []] body) 152 | where 153 | rewriteOne :: Rewrite -> Q (Name, TH.Exp) 154 | rewriteOne (Constant loc) = pure (mkName "unimplemented", VarE (mkName "undefined")) 155 | rewriteOne (Rewrite (Update ty (Item _ _ (SVar _ _ varName)) newValue)) = 156 | (mkName varName,) <$> mapExp newValue 157 | rewriteOne _ = error "unsupported method" 158 | 159 | -- The rest of this file is for debugging purposes 160 | 161 | -- display :: String 162 | -- display = case compiled of 163 | -- Success s -> unlines (fmap ((++ "\n") . printClaim) s) 164 | 165 | printBehaviour :: Behaviour -> String 166 | printBehaviour b = 167 | "name: " 168 | ++ _name b 169 | ++ "\n" 170 | ++ "contract: " 171 | ++ show (_contract b) 172 | ++ "\n" 173 | ++ "interface: " 174 | ++ show (_interface b) 175 | ++ "\n" 176 | ++ "preconditions:\n" 177 | ++ unlines (fmap ((" - " ++) . show) (_preconditions b)) 178 | ++ "postConditions:\n" 179 | ++ unlines (fmap ((" - " ++) . show) (_postconditions b)) 180 | ++ "\nstate updates:\n" 181 | ++ unlines (fmap ((" - " ++) . show) (_stateUpdates b)) 182 | 183 | printConstructor :: Constructor -> String 184 | printConstructor 185 | ( Constructor 186 | name 187 | mode 188 | interface 189 | preconditions 190 | postconditions 191 | initialStorage 192 | stateupdates 193 | ) = 194 | "constructor: " ++ name 195 | -------------------------------------------------------------------------------- /act/Act/TH/Extractor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Act.TH.Extractor (argumentExtractorName, generateExtractMethods) where 6 | 7 | import Act.Prelude 8 | import Act.Utils 9 | import Data.Data 10 | import Data.List 11 | import Language.Haskell.TH.Syntax as TH 12 | import Syntax.Annotated 13 | 14 | deriving instance Data AbiType 15 | 16 | -- Given each method in the contract we need to know how to extract the arguments from the 17 | -- arguments' array. for this we create a partial top-level function which matches 18 | -- on the argument array and return the correct number of argument in its expected type 19 | -- as a tuple. The function is then called with the expected tuple match in order to 20 | -- retrieve all the argument in the order expected by the body of the function 21 | -- if a method has interface m1(a int, b uint) 22 | -- then the extract function will look like so: 23 | -- ``` 24 | -- extractM1 :: [AbiType] -> (Int, UInt) 25 | -- extractM1 [AbiInt i, AbiUInt j] = (i, j) 26 | -- extractM1 x = error ("expected arguments of type (Int, UInt) but got " ++ show x) 27 | -- ``` 28 | generateExtractMethods :: [(String, Interface)] -> Q [TH.Dec] 29 | generateExtractMethods = fmap concat . traverse generateExtract 30 | 31 | argumentExtractorName :: String -> TH.Name 32 | argumentExtractorName methodName = mkName ("extract" ++ capitalise methodName) 33 | 34 | transactionSignature :: Interface -> String 35 | transactionSignature (Interface _ types) = 36 | let constructors = fmap (\(Decl ty _) -> show ty) types 37 | in concat $ intersperse ", " constructors 38 | 39 | parens :: String -> String 40 | parens x = "(" ++ x ++ ")" 41 | 42 | -- Given a name and an interface, generate a function definition which extracts the arguments 43 | -- expected from the given interface 44 | generateExtract :: (String, Interface) -> Q [TH.Dec] 45 | generateExtract (name, signature) = do 46 | let fnName = argumentExtractorName name 47 | sig <- extractorTypeForSignature signature 48 | let signatureStr = transactionSignature signature 49 | let asStringSplice = pure (LitE (StringL (parens signatureStr))) 50 | incorrectPatternError <- [|error ("unexpected arguments, got: " ++ show x ++ "\nexpected: " ++ $asStringSplice)|] 51 | valuePatterns <- valuePatterns4Interface signature 52 | pure 53 | [ SigD 54 | fnName 55 | sig, 56 | FunD 57 | fnName 58 | [ Clause 59 | [valuePatterns] 60 | (NormalB (expression4Interface signature)) 61 | [], 62 | Clause [VarP (mkName "x")] (NormalB (incorrectPatternError)) [] 63 | ] 64 | ] 65 | 66 | constructorNameForType :: String -> AbiType -> Pat 67 | constructorNameForType name (AbiUIntType _) = ConP (mkName "AbiUInt") [] [WildP, VarP (mkName name)] 68 | constructorNameForType name (AbiIntType _) = ConP (mkName "AbiInt") [] [WildP, VarP (mkName name)] 69 | constructorNameForType name (AbiAddressType) = ConP (mkName "AbiAddress") [] [VarP (mkName name)] 70 | constructorNameForType name (AbiBoolType) = ConP (mkName "AbiBool") [] [VarP (mkName name)] 71 | constructorNameForType name (AbiBytesType _) = ConP (mkName "AbiBytes") [] [WildP, VarP (mkName name)] 72 | constructorNameForType name (AbiBytesDynamicType) = ConP (mkName "AbiBytesDynamic") [] [VarP (mkName name)] 73 | constructorNameForType name (AbiStringType) = ConP (mkName "AbiString") [] [VarP (mkName name)] 74 | constructorNameForType name (AbiArrayDynamicType ty) = ConP (mkName "AbiArrayDynamic") [] [WildP, VarP (mkName name)] 75 | constructorNameForType name (AbiArrayType size ty) = ConP (mkName "AbiArray") [] [WildP, WildP, VarP (mkName name)] 76 | constructorNameForType name (AbiTupleType types) = ConP (mkName "AbiTuple") [] [VarP (mkName name)] 77 | constructorNameForType name (AbiFunctionType) = error "functions unsupported" 78 | 79 | -- Generate a pattern for a given declaration, the declaration tells us the type of the ACT 80 | -- variable and therefore the constructor to use for out `AbiType` the name will be used as 81 | -- binding variable and used in the body to return the value of that type 82 | patternForDecl :: Decl -> Q TH.Pat 83 | patternForDecl (Decl ty name) = pure (constructorNameForType name ty) 84 | 85 | templateCons :: Q TH.Pat -> Q TH.Pat -> Q TH.Pat 86 | templateCons a b = [p|$a : $b|] 87 | 88 | -- Generate the pattern for matching on the list of arguments of a transaction, the `Interface` 89 | -- describes the argument tuple as a list of values and we convert it into a list-pattern 90 | -- for each value. The type is used to create a constructor-pattern for `AbiType` 91 | valuePatterns4Interface :: Interface -> Q TH.Pat 92 | valuePatterns4Interface (Interface _ types) = foldr templateCons [p|[]|] $ fmap patternForDecl types 93 | 94 | -- Convert an ACT Interface into the tuple of values extracted from the list of arguments 95 | -- This implement the extractor function which signature is given by `extractorTypeForSignature` 96 | -- if the method takes no argument we return a unit value 97 | -- if the method takes one argument, we extract that single value from the list 98 | -- If the method takes multiple arguments we bundle each 99 | expression4Interface :: Interface -> TH.Exp 100 | expression4Interface (Interface _ []) = ConE '() 101 | expression4Interface (Interface _ [Decl _ name]) = VarE (mkName name) 102 | expression4Interface (Interface _ decls) = TupE (fmap (Just . VarE . mkName . getDeclId) decls) 103 | 104 | -- Convert a list of declarations name-type into a single tuple. If there 105 | -- is only one declaration then the result is the type of that declaration 106 | -- If there are no declarations the argument is a unit 107 | convertDecls :: [Decl] -> TH.Type 108 | convertDecls [] = ConT ''() 109 | convertDecls [Decl ty _] = mapAbiTypes ty 110 | convertDecls (Decl ty _ : decls) = 111 | foldl (\x y -> AppT x y) (TupleT (length decls + 1) `AppT` mapAbiTypes ty) (fmap (mapAbiTypes . getDeclType) decls) 112 | 113 | -- Convert an ACT interface into a haskell type 114 | -- This is purely for extractors so the type will always be of the shape 115 | -- 116 | -- ``` 117 | -- [AbiType] -> *argument tuple* 118 | -- ``` 119 | -- 120 | -- The argument tuple is defined by `convertDecls` the implementation of the 121 | -- function is handled by `expression4Interface` 122 | extractorTypeForSignature :: Interface -> Q Type 123 | extractorTypeForSignature (Interface _ decls) = [t|[AbiValue] -> $(pure (convertDecls decls))|] 124 | -------------------------------------------------------------------------------- /act/Act/TH/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Act.TH.State where 4 | 5 | import Act.Utils 6 | import qualified Data.Map as M 7 | import Language.Haskell.TH.Syntax 8 | import Syntax.Annotated (Id, SlotType, Store) 9 | 10 | -- Generate a type for the global state of the contract 11 | stateDec4Interface :: Store -> [Dec] 12 | stateDec4Interface = fmap createDataDeclaration . M.toList 13 | 14 | createDataDeclaration :: (Id, M.Map Id SlotType) -> Dec 15 | createDataDeclaration (storeName, types) = 16 | DataD 17 | [] -- no constraints 18 | (storeTypeName storeName) -- the name is the name from the store 19 | [] -- no type variables 20 | Nothing -- no kind signature, not a GADT 21 | [RecC (storeTypeName storeName) (fmap (\(nm, ty) -> (mkName nm, defaultBang, mapEVMTypes ty)) (M.toList types))] 22 | [DerivClause Nothing [ConT ''Show, ConT ''Eq]] 23 | -------------------------------------------------------------------------------- /act/Act/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Act.Utils where 5 | 6 | import Data.Char (toLower, toUpper) 7 | import Data.DoubleWord (Word256) 8 | import Data.Vector (Vector) 9 | import EVM.ABI 10 | import EVM.Types (Addr) 11 | import Language.Haskell.TH.Syntax as TH 12 | import Syntax.Annotated as ACT 13 | 14 | storeTypeName :: String -> Name 15 | storeTypeName storeName = mkName (capitalise (storeName ++ "State")) 16 | 17 | getDeclId :: Decl -> String 18 | getDeclId (Decl _ name) = name 19 | 20 | getDeclType :: Decl -> AbiType 21 | getDeclType (Decl ty _) = ty 22 | 23 | mapEVMTypes :: SlotType -> Type 24 | mapEVMTypes (StorageMapping _ _) = undefined 25 | mapEVMTypes (StorageValue (ContractType contractRef)) = undefined -- fill up to get the storage of a contract reference 26 | mapEVMTypes (StorageValue (PrimitiveType (AbiUIntType n))) = ConT ''Word256 27 | mapEVMTypes (StorageValue (PrimitiveType (AbiIntType n))) = ConT ''Int 28 | mapEVMTypes (StorageValue (PrimitiveType AbiAddressType)) = undefined 29 | mapEVMTypes (StorageValue (PrimitiveType AbiBoolType)) = ConT ''Bool 30 | mapEVMTypes (StorageValue (PrimitiveType (AbiBytesType n))) = undefined 31 | mapEVMTypes (StorageValue (PrimitiveType AbiBytesDynamicType)) = undefined 32 | mapEVMTypes (StorageValue (PrimitiveType AbiStringType)) = undefined 33 | mapEVMTypes (StorageValue (PrimitiveType (AbiArrayDynamicType ty))) = undefined 34 | mapEVMTypes (StorageValue (PrimitiveType (AbiArrayType n ty))) = undefined 35 | mapEVMTypes (StorageValue (PrimitiveType (AbiTupleType _))) = undefined 36 | mapEVMTypes (StorageValue (PrimitiveType AbiFunctionType)) = undefined 37 | 38 | mapAbiTypes :: AbiType -> Type 39 | mapAbiTypes (AbiUIntType n) = ConT ''Word256 40 | mapAbiTypes (AbiIntType n) = ConT ''Int 41 | mapAbiTypes AbiAddressType = ConT ''Addr 42 | mapAbiTypes AbiBoolType = ConT ''Bool 43 | mapAbiTypes (AbiBytesType n) = ConT ''ByteString 44 | mapAbiTypes AbiBytesDynamicType = ConT ''ByteString 45 | mapAbiTypes AbiStringType = ConT ''ByteString 46 | mapAbiTypes (AbiArrayDynamicType ty) = ConT ''Vector `AppT` ConT ''AbiType 47 | mapAbiTypes (AbiArrayType n ty) = ConT ''Vector `AppT` ConT ''AbiType 48 | mapAbiTypes (AbiTupleType vty) = ConT ''Vector `AppT` ConT ''AbiType 49 | mapAbiTypes (AbiFunctionType) = error "function types not supported" 50 | 51 | capitalise :: String -> String 52 | capitalise [] = [] 53 | capitalise (x : xs) = toUpper x : xs 54 | 55 | uncapitalise :: String -> String 56 | uncapitalise [] = [] 57 | uncapitalise (x : xs) = toLower x : xs 58 | 59 | defaultBang :: Bang 60 | defaultBang = Bang NoSourceUnpackedness NoSourceStrictness 61 | 62 | -- todo: Complete this function 63 | accessStorage :: ACT.StorageRef -> TH.Exp 64 | accessStorage (SVar _ _ varName) = VarE $ mkName varName 65 | accessStorage (SMapping _ _ _) = error "contract storage access unimplemented" 66 | accessStorage (SField _ _ _ _) = error "contract storage field access unimplemented" 67 | 68 | mapExp :: ACT.Exp t -> Q TH.Exp 69 | -- mapExp _ = VarE (mkName "undefined") 70 | mapExp (And _ x y) = [|$(mapExp x) && $(mapExp y)|] 71 | mapExp (Or _ x y) = [|$(mapExp x) || $(mapExp y)|] 72 | mapExp (Impl _ x y) = [|not $(mapExp x) || $(mapExp y)|] 73 | mapExp (Neg _ x) = [|not $(mapExp x)|] 74 | mapExp (ACT.LT _ x y) = [|$(mapExp x) < $(mapExp y)|] 75 | mapExp (LEQ _ x y) = [|$(mapExp x) <= $(mapExp y)|] 76 | mapExp (GEQ _ x y) = [|$(mapExp x) >= $(mapExp y)|] 77 | mapExp (ACT.GT _ x y) = [|$(mapExp x) > $(mapExp y)|] 78 | mapExp (LitBool _ x) = [|x|] 79 | -- integers, double check all this! 80 | mapExp (Add _ x y) = [|$(mapExp x) + $(mapExp y)|] 81 | mapExp (Sub _ x y) = [|$(mapExp x) - $(mapExp y)|] 82 | mapExp (Mul _ x y) = [|$(mapExp x) * $(mapExp y)|] 83 | mapExp (Div _ x y) = [|$(mapExp x) `div` $(mapExp y)|] 84 | mapExp (Mod _ x y) = [|$(mapExp x) `mod` $(mapExp y)|] 85 | mapExp (Exp _ x y) = [|$(mapExp x) ** $(mapExp y)|] 86 | mapExp (LitInt _ x) = [|x|] 87 | mapExp (IntEnv _ x) = error "unimplemented" 88 | -- bounds 89 | mapExp (IntMin _ x) = error "unimplemented" 90 | mapExp (IntMax _ x) = error "unimplemented" 91 | mapExp (UIntMin _ x) = error "unimplemented" 92 | mapExp (UIntMax _ x) = error "unimplemented" 93 | -- bytestrings 94 | mapExp (Cat _ x y) = error "unimplemented" 95 | mapExp (Slice _ a x y) = error "unimplemented" 96 | mapExp (ByStr _ str) = error "unimplemented" 97 | mapExp (ByLit _ byt) = error "unimplemented" 98 | mapExp (ByEnv _ eth) = error "unimplemented" 99 | -- polymorphic 100 | mapExp (Eq _ _ x y) = [|$(mapExp x) == $(mapExp y)|] 101 | mapExp (NEq _ _ x y) = [|$(mapExp x) /= $(mapExp y)|] 102 | mapExp (ITE _ condition _then _else) = [|if $(mapExp condition) then $(mapExp _then) else $(mapExp _else)|] 103 | mapExp (Var _ _ id) = pure (VarE $ mkName id) 104 | mapExp (TEntry _ _ (Item _ _ storage)) = pure (AppE (accessStorage storage) (VarE (mkName "contractState"))) 105 | mapExp (Create _ _ _ _) = error "create unimplemented" 106 | -------------------------------------------------------------------------------- /act/EVM/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedLabels #-} 3 | {-# LANGUAGE OverloadedRecordDot #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TupleSections #-} 7 | 8 | module EVM.TH where 9 | 10 | import Act.Prelude (EthTransaction (..)) 11 | import Control.Monad.Trans.State.Strict (State, put) 12 | import Data.ByteString (ByteString) 13 | import Data.Map as Map 14 | import Data.Text (Text, unpack) 15 | import Data.Text.IO (readFile) 16 | import qualified Data.Tree.Zipper as Zipper 17 | import Data.Vector as Vector (fromList) 18 | import EVM (blankState, initialContract) 19 | import EVM.ABI 20 | import EVM.FeeSchedule 21 | import EVM.Solidity (solcRuntime) 22 | import EVM.Types 23 | import GHC.IO.Unsafe 24 | import Language.Haskell.TH.Syntax as TH 25 | import Prelude hiding (FilePath, readFile) 26 | 27 | -- put this in sttate.callData 28 | -- run it to execute the transaction 29 | -- put more for subsequent calls 30 | -- run more for more results 31 | makeCallData :: EthTransaction -> ByteString 32 | makeCallData (EthTransaction _ method args _ _) = 33 | abiMethod method (AbiTuple (Vector.fromList args)) 34 | 35 | emptyVM :: [(Addr, ByteString)] -> VM 36 | emptyVM contracts = 37 | VM 38 | { result = Nothing, 39 | state = blankState, 40 | frames = [], 41 | env = envForContracts contracts, 42 | block = emptyBlock, 43 | tx = emptyTransaction, 44 | logs = [], 45 | traces = Zipper.fromForest mempty, 46 | cache = Cache mempty mempty mempty, 47 | burned = 0, 48 | iterations = mempty, 49 | constraints = [], 50 | keccakEqs = [], 51 | allowFFI = True, 52 | overrideCaller = Nothing 53 | } 54 | where 55 | -- question: Is that a reasonable empty first block? 56 | emptyBlock :: Block 57 | emptyBlock = 58 | Block 59 | { coinbase = 0, 60 | timestamp = Lit 0, 61 | number = 0, 62 | prevRandao = 0, 63 | maxCodeSize = 0, 64 | gaslimit = 0, 65 | baseFee = 0, 66 | schedule = berlin -- specifically this, what is it suppsoed to be? 67 | } 68 | emptyTransaction :: TxState 69 | emptyTransaction = 70 | TxState 71 | { gasprice = 0, 72 | gaslimit = 0, 73 | priorityFee = 0, 74 | origin = 0, 75 | toAddr = 0, 76 | value = Lit 0, 77 | substate = emptySubState, 78 | isCreate = True, 79 | txReversion = mempty 80 | } 81 | emptySubState :: SubState 82 | emptySubState = 83 | SubState 84 | { selfdestructs = [], 85 | touchedAccounts = [], 86 | accessedAddresses = mempty, 87 | accessedStorageKeys = mempty, 88 | refunds = [] 89 | } 90 | 91 | envForContracts :: [(Addr, ByteString)] -> Env 92 | envForContracts contracts = 93 | Env 94 | { contracts = Map.fromList (fmap (fmap bytecodeToContract) contracts), 95 | chainId = 0, 96 | storage = EmptyStore, 97 | origStorage = mempty, 98 | sha3Crack = mempty 99 | } 100 | 101 | bytecodeToContract :: ByteString -> Contract 102 | bytecodeToContract = initialContract . RuntimeCode . ConcreteRuntimeCode 103 | 104 | -- setup a new VM state from the list of contracts we are using 105 | loadIntoVM :: [(Addr, ByteString)] -> State VM () 106 | loadIntoVM contracts = put (emptyVM contracts) 107 | 108 | -- import a list of contracts as an open game 109 | -- - first we read off all the files and translate them into solidity bytecode 110 | -- - Then we associate each contract to a contract name which 111 | loadEVM :: [(Text, Text)] -> IO (State VM ()) 112 | loadEVM contracts = do 113 | files :: [(Text, Text)] <- traverse (\(name, filename) -> (name,) <$> readFile (unpack filename)) (contracts) 114 | contracts :: [ByteString] <- 115 | traverse 116 | ( \(nm, body) -> do 117 | Just bytecode <- solcRuntime nm body 118 | pure bytecode 119 | ) 120 | files 121 | let bytecodeMap :: [(Addr, ByteString)] = zip [0 ..] contracts 122 | let newVM = loadIntoVM bytecodeMap 123 | pure newVM 124 | 125 | loadContracts :: [(Text, Text)] -> State VM () 126 | loadContracts arg = unsafePerformIO $ loadEVM arg 127 | 128 | compileTimeLoad :: [(Text, Text)] -> Q [Dec] 129 | compileTimeLoad = undefined 130 | -------------------------------------------------------------------------------- /act/Examples/AmmGenerated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Examples.AmmGenerated where 7 | 8 | import Act.TH 9 | 10 | -- This generates the `ammContract` 11 | $(act2OG "amm.act") 12 | 13 | -- $(hevm2OG "contract") --- do something??? 14 | -------------------------------------------------------------------------------- /act/Examples/EVM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Examples.EVM where 4 | 5 | import EVM.TH 6 | 7 | -- todo: 8 | -- - Lending platform, look for aave. aave.sol ?? 9 | -- - Implement state into the open game 10 | -- - Obtain amm.sol and erc20.sol 11 | -- - test arbitrage strategy 12 | blockchainState = 13 | loadContracts 14 | [ ("token1", "ERC20.sol"), 15 | ("token2", "ERC20.sol"), 16 | ("amm", "AMM.sol") 17 | ] 18 | -------------------------------------------------------------------------------- /act/Examples/Player.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Examples.Player where 7 | 8 | import Act 9 | import Data.List 10 | import Examples.AmmGenerated 11 | import OpenGames.Engine.Engine 12 | import OpenGames.Preprocessor 13 | 14 | -- This combines two contracts with non-shared state 15 | twoAmms = combine (unionContracts ("amm1", ammContract) ("amm2", ammContract)) 16 | 17 | swapStrategy :: Word256 -> [Word256] 18 | swapStrategy n = [0, 1 .. n] 19 | 20 | bigPayoff finalUSD initialUSD swappedUSD = 21 | finalUSD + initialUSD - swappedUSD 22 | 23 | swap0 :: Word256 -> Transaction 24 | swap0 d = Transaction "" "swap0" [AbiUInt 64 d] 25 | 26 | swap1 :: Word256 -> Transaction 27 | swap1 d = Transaction "" "swap1" [AbiUInt 64 d] 28 | 29 | diffEur :: AmmState -> AmmState -> Word256 30 | diffEur (AmmState old _) (AmmState new _) = new - old 31 | 32 | diffUsd :: AmmState -> AmmState -> Word256 33 | diffUsd (AmmState old _) (AmmState new _) = new - old 34 | 35 | playerAutomatic usd = 36 | [opengame| 37 | inputs : ammSt1, ammSt2 ; 38 | feedback : ; 39 | :-------: 40 | 41 | operation : dependentDecision "Marx" (const (swapStrategy usd)) ; 42 | outputs : d ; 43 | returns : fromIntegral (diffUsd ammSt2 st''); 44 | 45 | inputs : ammSt1, swap0 d; 46 | feedback : ; 47 | operation : forwardFunction (uncurry ammContract) ; 48 | outputs : st' ; 49 | returns : ; 50 | 51 | inputs : ammSt2, swap1 (diffEur ammSt1 st') ; 52 | feedback : ; 53 | operation : forwardFunction (uncurry ammContract) ; 54 | outputs : st'' ; 55 | returns : ; 56 | 57 | :-------: 58 | outputs: ; 59 | returns : ; 60 | |] 61 | 62 | contracts = (combine [("amm2", ammContract), ("amm1", ammContract)]) 63 | 64 | allTransactionSwap = 65 | [ Transaction "amm1" "swap1" [AbiUInt 64 5], 66 | Transaction "amm2" "swap0" [AbiUInt 64 10] 67 | ] 68 | 69 | allTransaction x = 70 | [ Transaction "amm2" "swap0" [AbiUInt 64 x] | x <- [1 .. x] 71 | ] 72 | 73 | transactionOrders :: [[Transaction]] 74 | transactionOrders = permutations allTransactionSwap 75 | 76 | twoTokensPayoff :: AmmState -> AmmState -> Word256 77 | twoTokensPayoff (AmmState t1old t2old) (AmmState t1new t2new) = 78 | (t1new - t1old) + (t2new - t2old) 79 | 80 | swapSequence = 81 | [opengame| 82 | inputs : ammSt1 ; 83 | feedback : ; 84 | 85 | :-------: 86 | 87 | operation : dependentDecision "Marx" (const transactionOrders) ; 88 | outputs : transactions ; 89 | returns : fromIntegral (twoTokensPayoff ammSt1 finalState) ; 90 | 91 | inputs : transactions, ammSt1; 92 | feedback : ; 93 | operation : forwardFunction (uncurry contracts ) ; 94 | outputs : finalState; 95 | returns : ; 96 | 97 | :-------: 98 | outputs : ; 99 | returns : ; 100 | |] 101 | 102 | -- test out 2 erc contracts 103 | -- test out multi-contract calls 104 | -- 105 | -------------------------------------------------------------------------------- /act/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Main where 7 | 8 | import Examples.AmmGenerated 9 | import Examples.Player 10 | import OpenGames.Engine.Engine 11 | 12 | -- questions: 13 | -- - What do we improve in this model next? 14 | -- - sandwich? (different example) 15 | -- - another "from act" example 16 | -- - betting contract from act? 17 | -- - betting on the exchange rate of an AMM 18 | -- - clockwork finance example 19 | -- - move on to token swap 20 | -- - What do we automate from Act ? 21 | -- - extract name state fields 22 | -- - what about rollback? 23 | -- - strategy stealing? 24 | -- - failing transactions added to the global state? 25 | -- - generate players ? 26 | -- - gas fees + mem pool + Bribable coordinator 27 | -- 28 | -- To do in general: 29 | -- - Work on the common infrastructure around modelling situations 30 | -- - coordinator 31 | -- - calling subcontract 32 | -- - bribes 33 | -- 34 | -- Next week: 35 | -- - Work on another act example, maybe draw from clockwork finance 36 | -- - Create an act program for a full AMM with setup 37 | -- - Create an act program for betting 38 | -- 39 | -- ## 10.03 40 | -- - We have a game with multiple AMM and a way to dispatch transactions 41 | -- todo: 42 | -- - send multiple transactions and check they are executed correctly 43 | -- - game to find which transaction order would optimise the payoff 44 | -- - run this for 1 amm 45 | -- - Work toward having common state between AMMs 46 | -- - same operations but now find how to 47 | 48 | ctx = 49 | StochasticStatefulContext @() 50 | (pure ((), (AmmState 8 10, AmmState 10 8))) 51 | (\_ _ -> return ()) 52 | 53 | ev = evaluate (playerAutomatic 10) ((pureAction 1) :- Nil) ctx 54 | 55 | ctx1 = 56 | StochasticStatefulContext @() 57 | (pure ((), (AmmState 10 10))) 58 | (\_ _ -> return ()) 59 | 60 | ev1 = evaluate (swapSequence) ((pureAction (reverse (allTransactionSwap))) :- Nil) ctx1 61 | 62 | main :: IO () 63 | main = putStrLn "hello Act" 64 | -------------------------------------------------------------------------------- /amm.act: -------------------------------------------------------------------------------- 1 | constructor of Amm 2 | interface constructor() 3 | 4 | creates 5 | 6 | uint256 reserve0 := 1000 7 | uint256 reserve1 := 1000 8 | 9 | invariants 10 | 11 | 1000 * 1000 <= reserve0 * reserve1 12 | 13 | behaviour swap0 of Amm 14 | interface swap0(uint256 amt) 15 | 16 | iff in range uint256 17 | 18 | reserve0 + amt 19 | 20 | storage 21 | 22 | reserve0 => reserve0 + amt 23 | reserve1 => (reserve0 * reserve1) / (reserve0 + amt) + 1 24 | 25 | behaviour swap1 of Amm 26 | interface swap1(uint256 amt) 27 | 28 | iff in range uint256 29 | 30 | reserve1 + amt 31 | 32 | storage 33 | 34 | reserve0 => (reserve0 * reserve1) / (reserve1 + amt) + 1 35 | reserve1 => reserve1 + amt 36 | 37 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Examples.Decision 4 | import Examples.SequentialMoves 5 | import Examples.SimultaneousMoves 6 | 7 | main = do 8 | putStrLn "Single decision -->" 9 | isOptimalSingleDecisionVerbose (pureIdentity 4) 10 | putStrLn "\n Single decision -->" 11 | isOptimalSingleDecisionVerbose (pureIdentity 5) 12 | putStrLn "\n Single decision with stochastic environment -->" 13 | isOptimalSingleDecisionStoch peak 14 | putStrLn "\n Prisoner's dilemma both cooperate -->" 15 | isEquilibriumPrisonersDilemma strategTupleCooperate 16 | putStrLn "\n Prisoner's dilemma both defect -->" 17 | isEquilibriumPrisonersDilemma strategTupleDefect 18 | putStrLn "\n Matching Pennies - mixed with equal prob -->" 19 | isEquilibriumMatchingPennies strategyTupleMixed 20 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE EmptyCase #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 12 | 13 | module Main where 14 | 15 | import Criterion 16 | import Criterion.Main 17 | import Data.Maybe 18 | import qualified Examples.Markov.RepeatedPD as RPD 19 | import qualified Examples.Markov.TestSimpleMonteCarlo as MC 20 | import Examples.SimultaneousMoves (ActionPD (..), prisonersDilemmaMatrix) 21 | import System.Environment 22 | import Text.Read 23 | 24 | main = do 25 | iters <- fmap (fromMaybe [5, 6, 7] . (>>= readMaybe)) (lookupEnv "ITERS") 26 | defaultMain 27 | [ bgroup 28 | "Old version" 29 | [ bench 30 | ("iters/" ++ show i) 31 | (nfIO (do RPD.eqOutput i RPD.strategyTupleTest (Cooperate, Cooperate))) 32 | | i <- iters 33 | ], 34 | bgroup 35 | "Monte Carlo version" 36 | [ bench 37 | ("iters/" ++ show i) 38 | (nfIO (do MC.eqOutput 1000 i MC.strategyTupleTest (Cooperate, Cooperate))) 39 | | i <- iters 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /graphics/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Main where 7 | 8 | import Data.GraphViz 9 | import Data.GraphViz.Attributes.Complete 10 | import Data.GraphViz.Commands.IO 11 | import Graphics as Gfx 12 | import OpenGames.Preprocessor 13 | 14 | customParams :: GraphvizParams n String Gfx.ArrowType () String 15 | customParams = 16 | let rec = quickParams :: GraphvizParams n String Gfx.ArrowType () String 17 | in rec 18 | { fmtNode = \x -> Shape BoxShape : (fmtNode rec x), 19 | fmtEdge = \case 20 | (_, _, (Contravariant lbl)) -> [Label $ toLabelValue lbl, Style [SItem Dotted []]] 21 | (_, _, Covariant lbl) -> [Label $ toLabelValue lbl, Style [SItem Solid []]] 22 | (_, _, Gfx.Both lbl) -> [Label $ toLabelValue lbl, Style [SItem Dotted [], SItem Solid []]] 23 | } 24 | 25 | bidding = 26 | [parseTree| 27 | 28 | inputs : ; 29 | feedback : ; 30 | 31 | :-----------------: 32 | 33 | label : AliceDraw ; 34 | inputs : ; 35 | feedback : ; 36 | operation : natureDrawsTypeStage "Alice" ; 37 | outputs : aliceValue ; 38 | returns : ; 39 | 40 | label : BobDraw ; 41 | inputs : ; 42 | feedback : ; 43 | operation : natureDrawsTypeStage "Bob" ; 44 | outputs : bobValue ; 45 | returns : ; 46 | 47 | label : CarolDraw ; 48 | inputs : ; 49 | feedback : ; 50 | operation : natureDrawsTypeStage "Carol" ; 51 | outputs : carolValue ; 52 | returns : ; 53 | 54 | label : AliceBid ; 55 | inputs : aliceValue ; 56 | feedback : ; 57 | operation : biddingStage "Alice" ; 58 | outputs : aliceDec ; 59 | returns : payments ; 60 | 61 | label : BobBid ; 62 | inputs : bobValue ; 63 | feedback : ; 64 | operation : biddingStage "Bob" ; 65 | outputs : bobDec ; 66 | returns : payments ; 67 | 68 | label : CarolBid ; 69 | inputs : carolValue ; 70 | feedback : ; 71 | operation : biddingStage "Carol" ; 72 | outputs : carolDec ; 73 | returns : payments ; 74 | 75 | label : Auction ; 76 | inputs : [("Alice",aliceDec),("Bob",bobDec),("Carol",carolDec)] ; 77 | feedback : ; 78 | operation : transformPayments kPrice kSlots noLotteries paymentFunction ; 79 | outputs : payments ; 80 | returns : ; 81 | :-----------------: 82 | 83 | outputs : ; 84 | returns : ; 85 | |] 86 | 87 | main :: IO () 88 | main = writeDotFile "dotfile" (graphToDot customParams (convertBlock bidding)) 89 | -------------------------------------------------------------------------------- /open-games-hs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: open-games-hs 8 | version: 0.1.0.0 9 | synopsis: Haskell implementation of open games 10 | category: Math 11 | author: Jules Hedges, André Videla, Philipp Zahn & other contributors 12 | maintainer: philipp.zahn@protonmail 13 | copyright: Jules Hedges, André Videla, Philipp Zahn & other contributors 14 | license: AGPL 15 | license-file: LICENSE 16 | build-type: Simple 17 | extra-source-files: 18 | README.md 19 | 20 | library 21 | exposed-modules: 22 | OpenGames 23 | OpenGames.Engine.BayesianGames 24 | OpenGames.Engine.Diagnostics 25 | OpenGames.Engine.Engine 26 | OpenGames.Engine.OpenGames 27 | OpenGames.Engine.OpticClass 28 | OpenGames.Engine.TLL 29 | OpenGames.Preprocessor 30 | OpenGames.Preprocessor.BlockSyntax 31 | OpenGames.Preprocessor.Codegen 32 | OpenGames.Preprocessor.CompileBlock 33 | OpenGames.Preprocessor.CompileSyntax 34 | OpenGames.Preprocessor.Parser 35 | OpenGames.Preprocessor.RuntimeAST 36 | Examples.SimultaneousMoves 37 | Examples.Bayesian 38 | Examples.Decision 39 | Examples.SequentialMoves 40 | Examples.Auctions.AuctionSupportFunctions 41 | Examples.Auctions.ChooseReservePrice 42 | Examples.Auctions.DutchAuction 43 | Examples.Auctions.SequentialAuction 44 | Examples.Auctions.SimultaneousBidAuction 45 | Examples.Markov.RepeatedPD 46 | Examples.Markov.RepeatedPDNonState 47 | Examples.Markov.TwoStageMarkov 48 | Examples.Markov.TestSimpleMonteCarlo 49 | Examples.Markov.TestSimpleMonteCarlo.Continuation 50 | Graphics 51 | other-modules: 52 | Data.Utils 53 | Examples.Markov.NStageMarkov 54 | Examples.Staking.AndGateMarkov 55 | Examples.Staking.AndGateMarkovMC 56 | Examples.Token.Concrete 57 | OpenGames.Engine.AtomicGames 58 | OpenGames.Engine.BayesianGamesNonState 59 | OpenGames.Engine.IOGames 60 | OpenGames.Engine.Nat 61 | OpenGames.Engine.Vec 62 | Paths_open_games_hs 63 | hs-source-dirs: 64 | src 65 | build-depends: 66 | QuickCheck 67 | , act 68 | , ad 69 | , base >=4.7 && <5 70 | , comonad 71 | , criterion 72 | , extra 73 | , fgl 74 | , ghc 75 | , graphviz 76 | , hashable 77 | , hashmap 78 | , haskeline 79 | , lens 80 | , monad-bayes 81 | , mtl 82 | , mwc-random 83 | , parsec 84 | , poly 85 | , probability 86 | , profunctors 87 | , random 88 | , template-haskell 89 | , transformers 90 | , typed-process 91 | , vector 92 | default-language: Haskell2010 93 | 94 | executable act-exec 95 | main-is: Main.hs 96 | other-modules: 97 | Act 98 | Act.Execution 99 | Act.Prelude 100 | Act.TH 101 | Act.TH.Extractor 102 | Act.TH.State 103 | Act.Utils 104 | EVM.TH 105 | Examples.AmmGenerated 106 | Examples.EVM 107 | Examples.Player 108 | Paths_open_games_hs 109 | hs-source-dirs: 110 | act 111 | ghc-options: -fwarn-unused-imports -Wno-partial-type-signatures 112 | build-depends: 113 | QuickCheck 114 | , act 115 | , ad 116 | , base >=4.7 && <5 117 | , bytestring 118 | , comonad 119 | , containers 120 | , criterion 121 | , data-dword 122 | , extra 123 | , fgl 124 | , file-embed 125 | , ghc 126 | , graphviz 127 | , hashable 128 | , hashmap 129 | , haskeline 130 | , hevm >=0.51.0 131 | , lens 132 | , monad-bayes 133 | , mtl 134 | , mwc-random 135 | , open-games-hs 136 | , optics-core 137 | , optics-extra 138 | , parsec 139 | , poly 140 | , probability 141 | , profunctors 142 | , random 143 | , rosezipper 144 | , template-haskell 145 | , text 146 | , transformers 147 | , typed-process 148 | , validation 149 | , vector 150 | default-language: Haskell2010 151 | 152 | executable graphics 153 | main-is: Main.hs 154 | other-modules: 155 | Paths_open_games_hs 156 | hs-source-dirs: 157 | graphics 158 | build-depends: 159 | QuickCheck 160 | , act 161 | , ad 162 | , base >=4.7 && <5 163 | , comonad 164 | , criterion 165 | , extra 166 | , fgl 167 | , ghc 168 | , graphviz 169 | , hashable 170 | , hashmap 171 | , haskeline 172 | , lens 173 | , monad-bayes 174 | , mtl 175 | , mwc-random 176 | , open-games-hs 177 | , parsec 178 | , poly 179 | , probability 180 | , profunctors 181 | , random 182 | , template-haskell 183 | , transformers 184 | , typed-process 185 | , vector 186 | default-language: Haskell2010 187 | 188 | executable open-games-exe 189 | main-is: Main.hs 190 | other-modules: 191 | Paths_open_games_hs 192 | hs-source-dirs: 193 | app 194 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 195 | build-depends: 196 | QuickCheck 197 | , act 198 | , ad 199 | , base >=4.7 && <5 200 | , comonad 201 | , criterion 202 | , extra 203 | , fgl 204 | , ghc 205 | , graphviz 206 | , hashable 207 | , hashmap 208 | , haskeline 209 | , lens 210 | , monad-bayes 211 | , mtl 212 | , mwc-random 213 | , open-games-hs 214 | , parsec 215 | , poly 216 | , probability 217 | , profunctors 218 | , random 219 | , template-haskell 220 | , transformers 221 | , typed-process 222 | , vector 223 | default-language: Haskell2010 224 | -------------------------------------------------------------------------------- /opengames/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import OpenGames.Engine.KleisliOptics 7 | import Opengames.Compiler 8 | import Opengames.Preprocessor 9 | 10 | matchingPennies = 11 | [opengame| 12 | 13 | label : player1 ; 14 | operation : reindex const (decision "player1" [Heads, Tails]) ; 15 | outputs : x ; 16 | returns : matchingPenniesMatrix1 x $ y ; 17 | 18 | label : player2 ; 19 | operation : reindex const (decision "player2" [Heads, Tails]) ; 20 | outputs : y ; 21 | returns : matchingPenniesMatrix2 x y ; 22 | |] 23 | 24 | main :: IO () 25 | main = undefined 26 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: open-games-hs 2 | version: '0.1.0.0' 3 | synopsis: Haskell implementation of open games 4 | category: Math 5 | author: Jules Hedges, André Videla, Philipp Zahn & other contributors 6 | maintainer: philipp.zahn@protonmail 7 | copyright: Jules Hedges, André Videla, Philipp Zahn & other contributors 8 | license: AGPL 9 | extra-source-files: 10 | - README.md 11 | 12 | 13 | library: 14 | source-dirs: src 15 | exposed-modules: 16 | # - OpenGames.Engine.AtomicGames 17 | - OpenGames 18 | - OpenGames.Engine.BayesianGames 19 | - OpenGames.Engine.Diagnostics 20 | - OpenGames.Engine.Engine 21 | - OpenGames.Engine.OpenGames 22 | - OpenGames.Engine.OpticClass 23 | - OpenGames.Engine.TLL 24 | - OpenGames.Preprocessor 25 | - OpenGames.Preprocessor.BlockSyntax 26 | - OpenGames.Preprocessor.Codegen 27 | - OpenGames.Preprocessor.CompileBlock 28 | - OpenGames.Preprocessor.CompileSyntax 29 | - OpenGames.Preprocessor.Parser 30 | - OpenGames.Preprocessor.RuntimeAST 31 | - Examples.SimultaneousMoves 32 | - Examples.Bayesian 33 | - Examples.Decision 34 | - Examples.SequentialMoves 35 | - Examples.Auctions.AuctionSupportFunctions 36 | - Examples.Auctions.ChooseReservePrice 37 | - Examples.Auctions.DutchAuction 38 | - Examples.Auctions.SequentialAuction 39 | - Examples.Auctions.SimultaneousBidAuction 40 | - Examples.Markov.RepeatedPD 41 | - Examples.Markov.RepeatedPDNonState 42 | - Examples.Markov.TwoStageMarkov 43 | - Examples.Markov.TestSimpleMonteCarlo 44 | - Examples.Markov.TestSimpleMonteCarlo.Continuation 45 | - Graphics 46 | 47 | dependencies: 48 | - base >=4.7 && <5 49 | - act 50 | - mtl 51 | - ghc 52 | - transformers 53 | - probability 54 | - ad 55 | - poly 56 | - profunctors 57 | - template-haskell 58 | - parsec 59 | - QuickCheck 60 | - comonad 61 | - haskeline 62 | - hashmap 63 | - hashable 64 | - extra 65 | - fgl 66 | - graphviz 67 | - lens 68 | - typed-process 69 | - mwc-random 70 | - random 71 | - vector 72 | - monad-bayes 73 | - criterion 74 | 75 | 76 | executables: 77 | open-games-exe: 78 | main: Main.hs 79 | source-dirs: app 80 | ghc-options: 81 | - -threaded 82 | - -rtsopts 83 | - -with-rtsopts=-N 84 | dependencies: 85 | - open-games-hs 86 | 87 | act-exec: 88 | main: Main.hs 89 | source-dirs: act 90 | ghc-options: 91 | - -fwarn-unused-imports 92 | - -Wno-partial-type-signatures 93 | dependencies: 94 | - act 95 | - data-dword 96 | - open-games-hs 97 | - optics-core 98 | - optics-extra 99 | - rosezipper 100 | - file-embed 101 | - bytestring 102 | - validation 103 | - hevm >= 0.51.0 104 | - containers 105 | - text 106 | graphics: 107 | main: Main.hs 108 | source-dirs: graphics 109 | dependencies: 110 | - open-games-hs 111 | - graphviz 112 | - template-haskell 113 | - criterion 114 | -------------------------------------------------------------------------------- /simple.act: -------------------------------------------------------------------------------- 1 | 2 | constructor of A 3 | interface constructor() 4 | 5 | creates 6 | 7 | mapping (uint=>uint) x := [] 8 | 9 | behaviour f of A 10 | interface f() 11 | 12 | storage 13 | 14 | x[0] => 1 15 | 16 | returns 17 | 18 | 1 19 | -------------------------------------------------------------------------------- /solitidy/AMM.sol: -------------------------------------------------------------------------------- 1 | // SPDX-License-Identifier: AGPL-3.0-only 2 | pragma solidity ^0.7.5; 3 | 4 | import {ERC20} from "./ERC20.sol"; 5 | 6 | contract AMM is ERC20 { 7 | ERC20 token0; 8 | ERC20 token1; 9 | 10 | constructor(address _token0, address _token1) { 11 | token0 = ERC20(_token0); 12 | token1 = ERC20(_token1); 13 | } 14 | 15 | // join allows the caller to exchange amt0 and amt1 tokens for some amount 16 | // of pool shares. The exact amount of pool shares minted depends on the 17 | // state of the pool at the time of the call. 18 | function join(uint amt0, uint amt1) external { 19 | require(amt0 > 0 && amt1 > 0, "insufficient input amounts"); 20 | 21 | uint bal0 = token0.balanceOf(address(this)); 22 | uint bal1 = token1.balanceOf(address(this)); 23 | 24 | uint shares = totalSupply == 0 25 | ? min(amt0, amt1) 26 | : min(mul(totalSupply, amt0) / bal0, 27 | mul(totalSupply, amt1) / bal1); 28 | 29 | balanceOf[msg.sender] = add(balanceOf[msg.sender], shares); 30 | totalSupply = add(totalSupply, shares); 31 | 32 | token0.transferFrom(msg.sender, address(this), amt0); 33 | token1.transferFrom(msg.sender, address(this), amt1); 34 | } 35 | 36 | // exit allows the caller to exchange shares pool shares for the 37 | // proportional amount of the underlying tokens. 38 | function exit(uint shares) external { 39 | uint amt0 = mul(token0.balanceOf(address(this)), shares) / totalSupply; 40 | uint amt1 = mul(token1.balanceOf(address(this)), shares) / totalSupply; 41 | 42 | balanceOf[msg.sender] = sub(balanceOf[msg.sender], shares); 43 | totalSupply = sub(totalSupply, shares); 44 | 45 | token0.transfer(msg.sender, amt0); 46 | token1.transfer(msg.sender, amt1); 47 | } 48 | 49 | // swap allows the caller to exchange amt of src for dst at a price given 50 | // by the constant product formula: x * y == k. 51 | function swap(address src, address dst, uint amt) external { 52 | require(src != dst, "no self swap"); 53 | require(src == address(token0) || src == address(token1), "src not in pair"); 54 | require(dst == address(token0) || dst == address(token1), "dst not in pair"); 55 | 56 | uint K = mul(token0.balanceOf(address(this)), token1.balanceOf(address(this))); 57 | 58 | ERC20(src).transferFrom(msg.sender, address(this), amt); 59 | 60 | uint out = sub( 61 | ERC20(dst).balanceOf(address(this)), 62 | K / ERC20(src).balanceOf(address(this)) + 1 // rounding 63 | ); 64 | 65 | ERC20(dst).transfer(msg.sender, out); 66 | 67 | uint KPost = mul(token0.balanceOf(address(this)), token1.balanceOf(address(this))); 68 | assert(KPost >= K); 69 | } 70 | 71 | } 72 | -------------------------------------------------------------------------------- /solitidy/ERC20.sol: -------------------------------------------------------------------------------- 1 | // SPDX-License-Identifier: AGPL-3.0-only 2 | pragma solidity ^0.7.5; 3 | 4 | import {DSMath} from "ds-math/math.sol"; 5 | 6 | contract ERC20 is DSMath { 7 | string public constant name = "Token"; 8 | string public constant symbol = "TKN"; 9 | uint8 public decimals = 18; 10 | uint256 public totalSupply; 11 | 12 | mapping (address => uint) public balanceOf; 13 | mapping (address => mapping (address => uint)) public allowance; 14 | 15 | event Approval(address indexed src, address indexed guy, uint amt); 16 | event Transfer(address indexed src, address indexed dst, uint amt); 17 | 18 | function transfer(address dst, uint amt) public returns (bool) { 19 | return transferFrom(msg.sender, dst, amt); 20 | } 21 | function transferFrom(address src, address dst, uint amt) public returns (bool) { 22 | require(balanceOf[src] >= amt, "insufficient-balance"); 23 | 24 | if (src != msg.sender && allowance[src][msg.sender] != uint(-1)) { 25 | require(allowance[src][msg.sender] >= amt, "insufficient-allowance"); 26 | allowance[src][msg.sender] = sub(allowance[src][msg.sender], amt); 27 | emit Approval(src, msg.sender, allowance[src][msg.sender]); 28 | } 29 | 30 | balanceOf[src] = sub(balanceOf[src], amt); 31 | balanceOf[dst] = add(balanceOf[dst], amt); 32 | emit Transfer(src, dst, amt); 33 | return true; 34 | } 35 | function approve(address usr, uint amt) public returns (bool) { 36 | allowance[msg.sender][usr] = amt; 37 | emit Approval(msg.sender, usr, amt); 38 | return true; 39 | } 40 | } 41 | 42 | contract MintableERC20 is ERC20 { 43 | // --- Auth --- 44 | address public owner; 45 | modifier auth() { require(msg.sender == owner, "unauthorized"); _; } 46 | 47 | // --- Init --- 48 | constructor() { 49 | owner = msg.sender; 50 | } 51 | 52 | // --- Mint/Burn --- 53 | function mint(address usr, uint amt) public auth { 54 | balanceOf[usr] = add(balanceOf[usr], amt); 55 | totalSupply = add(totalSupply, amt); 56 | emit Transfer(address(0), usr, amt); 57 | } 58 | function burn(address usr, uint amt) public auth { 59 | balanceOf[usr] = sub(balanceOf[usr], amt); 60 | totalSupply = sub(totalSupply, amt); 61 | emit Transfer(usr, address(0), amt); 62 | } 63 | } 64 | 65 | -------------------------------------------------------------------------------- /solitidy/UniswapFactory.sol: -------------------------------------------------------------------------------- 1 | pragma solidity ^0.4.20; 2 | import "./UniswapExchange.sol"; 3 | 4 | 5 | contract FactoryInterface { 6 | address[] public tokenList; 7 | mapping(address => address) tokenToExchange; 8 | mapping(address => address) exchangeToToken; 9 | function launchExchange(address _token) public returns (address exchange); 10 | function getExchangeCount() public view returns (uint exchangeCount); 11 | function tokenToExchangeLookup(address _token) public view returns (address exchange); 12 | function exchangeToTokenLookup(address _exchange) public view returns (address token); 13 | event ExchangeLaunch(address indexed exchange, address indexed token); 14 | } 15 | 16 | 17 | contract UniswapFactory is FactoryInterface { 18 | event ExchangeLaunch(address indexed exchange, address indexed token); 19 | 20 | // index of tokens with registered exchanges 21 | address[] public tokenList; 22 | mapping(address => address) tokenToExchange; 23 | mapping(address => address) exchangeToToken; 24 | 25 | function launchExchange(address _token) public returns (address exchange) { 26 | require(tokenToExchange[_token] == address(0)); //There can only be one exchange per token 27 | require(_token != address(0) && _token != address(this)); 28 | UniswapExchange newExchange = new UniswapExchange(_token); 29 | tokenList.push(_token); 30 | tokenToExchange[_token] = newExchange; 31 | exchangeToToken[newExchange] = _token; 32 | ExchangeLaunch(newExchange, _token); 33 | return newExchange; 34 | } 35 | 36 | function getExchangeCount() public view returns (uint exchangeCount) { 37 | return tokenList.length; 38 | } 39 | 40 | function tokenToExchangeLookup(address _token) public view returns (address exchange) { 41 | return tokenToExchange[_token]; 42 | } 43 | 44 | function exchangeToTokenLookup(address _exchange) public view returns (address token) { 45 | return exchangeToToken[_exchange]; 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /src/Data/Utils.hs: -------------------------------------------------------------------------------- 1 | module Data.Utils where 2 | 3 | import Data.HashMap 4 | import Data.Hashable 5 | import Prelude hiding (map) 6 | 7 | adjustOrAdd :: (Hashable k, Ord k) => (v -> v) -> v -> k -> Map k v -> Map k v 8 | adjustOrAdd f def = alter (Just . maybe def f) 9 | 10 | average :: (Hashable k, Fractional a) => Int -> Map k a -> Map k a 11 | average sampleSize = map (\x -> x / (fromIntegral sampleSize)) 12 | -------------------------------------------------------------------------------- /src/Examples/Auctions/AuctionSupportFunctions.hs: -------------------------------------------------------------------------------- 1 | module Examples.Auctions.AuctionSupportFunctions where 2 | 3 | import Data.List 4 | import OpenGames.Engine.Engine (Stochastic, uniformDist) 5 | 6 | ---------------------- 7 | -- 0. Types 8 | 9 | ---------------------- 10 | -- 1. Auction rules 11 | 12 | -- Order bids from large to small 13 | orderAllocation :: (Ord v) => [(n, v)] -> [(n, v)] 14 | orderAllocation = sortBy (flip (\(_, v1) (_, v2) -> compare v1 v2)) 15 | 16 | -- Determine k-max bid 17 | kMaxBid :: (Ord v) => Int -> [(n, v)] -> v 18 | kMaxBid k ls = snd $ orderAllocation ls !! (k - 1) 19 | 20 | -- Determine k-max bid 21 | kMaxBidReservePrice :: (Ord v) => v -> Int -> [(n, v)] -> v 22 | kMaxBidReservePrice resPrice k ls = snd $ orderAllocation (resPriceLs ls) !! (k - 1) 23 | where 24 | resPriceLs [] = [] 25 | resPriceLs ((n, v) : xs) = 26 | if v > resPrice 27 | then (n, v) : resPriceLs xs 28 | else (n, resPrice) : resPriceLs xs 29 | 30 | -- k- price auction rule, i.e. the sequence for winning bidders is ignored, winners always pay k-highest price 31 | noLotteryPayment :: (Num v) => v -> v -> Int -> Int -> Int -> [(n, v, Bool)] -> [(n, v)] 32 | noLotteryPayment _ _ _ _ _ [] = [] 33 | noLotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ((name, bid, winner) : ls) = 34 | if winner 35 | then (name, kmax) : noLotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ls 36 | else (name, 0) : noLotteryPayment resPrice kmax noLottery (counterWinner + 1) lotteriesGiven ls 37 | 38 | -- k- price auction rule, i.e. the sequence for winning bidders is ignored, winners always pay k-highest price 39 | noLotteryPaymentReservePrice :: (Num v, Ord v) => v -> v -> Int -> Int -> Int -> [(n, v, Bool)] -> [(n, v)] 40 | noLotteryPaymentReservePrice _ _ _ _ _ [] = [] 41 | noLotteryPaymentReservePrice resPrice kmax noLottery counterWinner lotteriesGiven ((name, bid, winner) : ls) 42 | | winner && bid >= resPrice = (name, bid) : noLotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ls 43 | | winner && bid < resPrice = (name, resPrice) : noLotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ls 44 | | otherwise = (name, 0) : noLotteryPayment resPrice kmax noLottery (counterWinner + 1) lotteriesGiven ls 45 | 46 | -- Determine payments for winners; for lottery winners, and for those who do not get a good set it to 0 47 | lotteryPayment :: (Num v) => v -> v -> Int -> Int -> Int -> [(String, v, Bool)] -> [(String, v)] 48 | lotteryPayment _ _ _ _ _ [] = [] 49 | lotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ((name, bid, winner) : ls) = 50 | if winner 51 | then 52 | if counterWinner < noLottery 53 | then (name, resPrice) : lotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ls 54 | else (name, kmax) : lotteryPayment resPrice kmax noLottery counterWinner lotteriesGiven ls 55 | else 56 | if noLottery > lotteriesGiven 57 | then (name, resPrice) : lotteryPayment resPrice kmax noLottery (counterWinner + 1) (lotteriesGiven + 1) ls 58 | else (name, 0) : lotteryPayment resPrice kmax noLottery (counterWinner + 1) lotteriesGiven ls 59 | 60 | -- Determine payments for winners; for lottery winners, and for those who do not get a good set it to 0 61 | -- Use a different payment rule; kmax is reduced by factor depending on number of lottery slots, pricing rule, and reserve price 62 | lotteryPayment2 :: (Fractional v) => v -> v -> Int -> Int -> Int -> [(String, v, Bool)] -> [(String, v)] 63 | lotteryPayment2 _ _ _ _ _ [] = [] 64 | lotteryPayment2 resPrice kmax noLottery counterWinner lotteriesGiven ((name, bid, winner) : ls) = 65 | if winner 66 | then 67 | if counterWinner < noLottery 68 | then (name, resPrice) : lotteryPayment2 resPrice kmax noLottery counterWinner lotteriesGiven ls 69 | else (name, pay) : lotteryPayment2 resPrice kmax noLottery counterWinner lotteriesGiven ls 70 | else 71 | if noLottery > lotteriesGiven 72 | then (name, resPrice) : lotteryPayment2 resPrice kmax noLottery (counterWinner + 1) (lotteriesGiven + 1) ls 73 | else (name, 0) : lotteryPayment2 resPrice kmax noLottery (counterWinner + 1) lotteriesGiven ls 74 | where 75 | pay = kmax - (fromIntegral noLottery) / 2 * (kmax - resPrice) 76 | 77 | -- Mark the auctionWinners 78 | auctionWinner :: (Ord v) => v -> [(n, v)] -> [(n, v, Bool)] 79 | auctionWinner _ [] = [] 80 | auctionWinner kmax ((name, b) : bs) = 81 | if b < kmax 82 | then (name, b, False) : auctionWinner kmax bs 83 | else (name, b, True) : auctionWinner kmax bs 84 | 85 | -- Mark the auctionWinners 86 | auctionWinnerReservePrice :: (Ord v) => v -> v -> [(n, v)] -> [(n, v, Bool)] 87 | auctionWinnerReservePrice _ _ [] = [] 88 | auctionWinnerReservePrice reservePrice kmax ((name, b) : bs) = 89 | if b < kmax || b < reservePrice 90 | then (name, b, False) : auctionWinner kmax bs 91 | else (name, b, True) : auctionWinner kmax bs 92 | 93 | -- Select the payment for a player given the list of payments 94 | selectPayoffs :: (Eq n, Num v) => n -> [(n, v)] -> v 95 | selectPayoffs name [] = 0 96 | selectPayoffs name ((n, p) : ls) = if name == n then p else selectPayoffs name ls 97 | 98 | -- Determines the payoff for each player 99 | setPayoff :: (Eq n, Num v, Eq v) => (n, v) -> [(n, v)] -> v 100 | setPayoff (name, value) payments = 101 | if pay == 0 then 0 else value - pay 102 | where 103 | pay = selectPayoffs name payments 104 | 105 | -- Determine the payments given k-highest price (1,2..) and no of winnerSlots being allocated through auction; and _noLotteries_ slots through lottery 106 | -- NOTE the restriction of k-highest price and number of slots 107 | auctionPayment :: 108 | (Ord v) => 109 | -- | Payment function 110 | (v -> v -> Int -> Int -> Int -> [(n, v, Bool)] -> [(n, v)]) -> 111 | -- | Reserve Price 112 | v -> 113 | Int -> 114 | Int -> 115 | Int -> 116 | -- | Parameters 117 | [(n, v)] -> 118 | [(n, v)] 119 | auctionPayment paymentFunction reservePrice kPrice winnerSlots noLotteries ls = 120 | if kMax > kThreshold 121 | then paymentFunction reservePrice kThreshold noLotteries 0 0 (auctionWinner kThreshold ls) 122 | else paymentFunction reservePrice kMax noLotteries 0 0 (auctionWinner kThreshold ls) 123 | where 124 | kMax = kMaxBid kPrice ls 125 | kThreshold = kMaxBid winnerSlots ls 126 | 127 | auctionPaymentResPrice :: 128 | (Ord v) => 129 | -- | Payment function 130 | (v -> v -> Int -> Int -> Int -> [(n, v, Bool)] -> [(n, v)]) -> 131 | Int -> 132 | Int -> 133 | Int -> 134 | -- | Parameters 135 | ([(n, v)], v) -> 136 | [(n, v)] 137 | auctionPaymentResPrice paymentFunction kPrice winnerSlots noLotteries (ls, reservePrice) = 138 | if kMax > kThreshold 139 | then paymentFunction reservePrice kThreshold noLotteries 0 0 (auctionWinnerReservePrice reservePrice kThreshold ls) 140 | else paymentFunction reservePrice kMax noLotteries 0 0 (auctionWinnerReservePrice reservePrice kThreshold ls) 141 | where 142 | kMax = kMaxBidReservePrice reservePrice kPrice ls 143 | kThreshold = kMaxBidReservePrice reservePrice winnerSlots ls 144 | 145 | -- Random shuffle of bids 146 | shuffleBids :: [(n, v)] -> Stochastic [(n, v)] 147 | shuffleBids ls = uniformDist $ permutations ls 148 | -------------------------------------------------------------------------------- /src/Examples/Auctions/ChooseReservePrice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | 11 | module Examples.Auctions.ChooseReservePrice where 12 | 13 | import Examples.Auctions.SimultaneousBidAuction 14 | import OpenGames 15 | import OpenGames.Preprocessor 16 | 17 | ---------- 18 | -- A Model 19 | ---------- 20 | -- 0. Auxiliary function 21 | 22 | revenueAuctioneer :: (Num v) => [(n, v)] -> v 23 | revenueAuctioneer ls = sum $ fmap snd ls 24 | 25 | --------------------- 26 | -- 1 The actual games 27 | 28 | -- Draws a value and creates a pair of _value_ _name_ 29 | setReservePrice kPrice kSlots = 30 | [opengame| 31 | 32 | inputs : ; 33 | feedback : ; 34 | 35 | :-----: 36 | inputs : ; 37 | feedback : ; 38 | operation : dependentDecision "auctioneer" (const [0,20..100]) ; 39 | outputs : reservePrice ; 40 | returns : revenueAuctioneer payments ; 41 | 42 | inputs : reservePrice ; 43 | feedback : ; 44 | operation : bidding2ReservePrice kPrice kSlots; 45 | outputs : payments ; 46 | returns : ; 47 | :-----: 48 | 49 | outputs : ; 50 | returns : ; 51 | |] 52 | 53 | -- B Analysis 54 | ---------------- 55 | -- 0. Strategies 56 | stratAuctioneer x = pureAction x 57 | 58 | stratTuple x = stratAuctioneer x :- truthfulStrat 59 | 60 | --------------- 61 | -- 1 Equilibria 62 | -- 1.0 Eq. game with 3 players 63 | equilibriumSetReservePrice kPrice kSlots strat = evaluate (setReservePrice kPrice kSlots) strat void 64 | 65 | ------------------------ 66 | -- 2 Interactive session 67 | 68 | -- One object being auctioned off Once we exclude slots via lottery, and just auction off one slot, truthful bidding becomes an equilibrium 69 | testReservePrice p = generateIsEq $ equilibriumSetReservePrice 2 1 (stratTuple p) 70 | -------------------------------------------------------------------------------- /src/Examples/Auctions/SequentialAuction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | 11 | module Examples.Auctions.SequentialAuction where 12 | 13 | import Examples.Auctions.AuctionSupportFunctions 14 | import OpenGames 15 | import OpenGames.Preprocessor 16 | 17 | -- TODO Generalize to population of players 18 | 19 | ---------- 20 | -- A Model 21 | ---------- 22 | 23 | --------------- 24 | -- 0 Parameters 25 | 26 | type Values = Double 27 | 28 | values = [20, 30, 60] 29 | 30 | reservePrice :: Double 31 | reservePrice = 1 32 | 33 | --------------------- 34 | -- 1 The actual games 35 | 36 | -- Draws a value and creates a pair of _value_ _name_ 37 | natureDrawsTypeStage name = 38 | [opengame| 39 | 40 | inputs : ; 41 | feedback : ; 42 | 43 | :-----: 44 | inputs : ; 45 | feedback : ; 46 | operation : nature (uniformDist values) ; 47 | outputs : value ; 48 | returns : ; 49 | :-----: 50 | 51 | outputs : (name,value) ; 52 | returns : ; 53 | |] 54 | 55 | -- Individual bidding stage 56 | biddingStage name = 57 | [opengame| 58 | 59 | inputs : nameValuePair ; 60 | feedback : ; 61 | 62 | :---------------------------: 63 | inputs : nameValuePair ; 64 | feedback : ; 65 | operation : dependentDecision name (const [0,20..60]) ; 66 | outputs : dec ; 67 | returns : setPayoff nameValuePair payments ; 68 | :---------------------------: 69 | 70 | outputs : dec ; 71 | returns : payments ; 72 | |] 73 | 74 | -- Transforms the payments into a random reshuffling 75 | transformPayments kPrice kSlots noLotteries paymentFunction = 76 | [opengame| 77 | 78 | inputs : bids ; 79 | feedback : ; 80 | 81 | :-----------------: 82 | inputs : bids ; 83 | feedback : ; 84 | operation : liftStochasticForward shuffleBids ; 85 | outputs : shuffledBids ; 86 | returns : ; 87 | 88 | inputs : shuffledBids ; 89 | feedback : ; 90 | operation : forwardFunction (auctionPayment paymentFunction reservePrice kPrice kSlots noLotteries) ; 91 | outputs : payments ; 92 | returns : ; 93 | :-----------------: 94 | 95 | outputs : payments ; 96 | returns : ; 97 | |] 98 | 99 | -- Instantiates a simplified version with three players 100 | bidding kPrice kSlots noLotteries paymentFunction = 101 | [opengame| 102 | 103 | inputs : ; 104 | feedback : ; 105 | 106 | :-----------------: 107 | inputs : ; 108 | feedback : ; 109 | operation : natureDrawsTypeStage "Alice" ; 110 | outputs : aliceValue ; 111 | returns : ; 112 | 113 | inputs : ; 114 | feedback : ; 115 | operation : natureDrawsTypeStage "Bob" ; 116 | outputs : bobValue ; 117 | returns : ; 118 | 119 | inputs : ; 120 | feedback : ; 121 | operation : natureDrawsTypeStage "Carol" ; 122 | outputs : carolValue ; 123 | returns : ; 124 | 125 | inputs : aliceValue ; 126 | feedback : ; 127 | operation : biddingStage "Alice" ; 128 | outputs : aliceDec ; 129 | returns : payments ; 130 | 131 | inputs : bobValue ; 132 | feedback : ; 133 | operation : biddingStage "Bob" ; 134 | outputs : bobDec ; 135 | returns : payments ; 136 | 137 | inputs : carolValue ; 138 | feedback : ; 139 | operation : biddingStage "Carol" ; 140 | outputs : carolDec ; 141 | returns : payments ; 142 | 143 | inputs : [("Alice",aliceDec),("Bob",bobDec),("Carol",carolDec)] ; 144 | feedback : ; 145 | operation : transformPayments kPrice kSlots noLotteries paymentFunction ; 146 | outputs : payments ; 147 | returns : ; 148 | :-----------------: 149 | 150 | outputs : ; 151 | returns : ; 152 | |] 153 | 154 | -- B Analysis 155 | ------------- 156 | 157 | --------------- 158 | -- 0 Strategies 159 | 160 | -- Truthful bidding 161 | stratBidderTruth :: Kleisli Stochastic (String, Values) Values 162 | stratBidderTruth = Kleisli (\(_, x) -> playDeterministically x) 163 | 164 | -- Bidding strategy with threshold 50 and value 10 165 | stratBidderThreshold :: Kleisli Stochastic (String, Values) Values 166 | stratBidderThreshold = Kleisli (\(_, x) -> if x >= 50 then playDeterministically 20 else playDeterministically 10) 167 | 168 | -- Bidding with different threshold 169 | stratBidderThreshold' :: Kleisli Stochastic (String, Values) Values 170 | stratBidderThreshold' = 171 | Kleisli 172 | ( \(_, x) -> case () of 173 | _ 174 | | x < 30 -> playDeterministically 0 175 | | x == 30 -> playDeterministically 10 176 | | otherwise -> playDeterministically 20 177 | ) 178 | 179 | -- Complete strategy for truthful bidding for 3 players 180 | truthfulStrat :: 181 | List 182 | '[ Kleisli Stochastic (String, Values) Values, 183 | Kleisli Stochastic (String, Values) Values, 184 | Kleisli Stochastic (String, Values) Values 185 | ] 186 | truthfulStrat = 187 | stratBidderTruth 188 | :- stratBidderTruth 189 | :- stratBidderTruth 190 | :- Nil 191 | 192 | -- Complete strategy for threshold bidding 3 players 193 | thresholdStrat :: 194 | List 195 | '[ Kleisli Stochastic (String, Values) Values, 196 | Kleisli Stochastic (String, Values) Values, 197 | Kleisli Stochastic (String, Values) Values 198 | ] 199 | thresholdStrat = 200 | stratBidderThreshold 201 | :- stratBidderThreshold 202 | :- stratBidderThreshold 203 | :- Nil 204 | 205 | -- Complete strategy for threshold' bidding 3 players 206 | thresholdStrat' :: 207 | List 208 | '[ Kleisli Stochastic (String, Values) Values, 209 | Kleisli Stochastic (String, Values) Values, 210 | Kleisli Stochastic (String, Values) Values 211 | ] 212 | thresholdStrat' = 213 | stratBidderThreshold' 214 | :- stratBidderThreshold' 215 | :- stratBidderThreshold' 216 | :- Nil 217 | 218 | --------------- 219 | -- 1 Equilibria 220 | -- 1.0 Eq. game with 3 players 221 | equilibriumGame kPrice kSlots noLotteries paymentFunction strat = evaluate (bidding kPrice kSlots noLotteries paymentFunction) strat void 222 | 223 | ------------------------ 224 | -- 2 Interactive session 225 | 226 | -- 3 players with 1 auction slot, 2nd highest price, and 1 lottery slot - truthful bidding - not an eq 227 | -- generateIsEq $ equilibriumGame 2 1 1 lotteryPayment truthfulStrat 228 | 229 | -- 3 players with 1 auction slot, 2nd highest price, and 1 lottery slot with modified payment - truthful bidding - eq 230 | -- generateIsEq $ equilibriumGame 2 1 1 lotteryPayment2 truthfulStrat 231 | 232 | -- 3 players with 1 auction slot, 2nd highest price is paid, and 1 lottery slot - threshold bidding - is an eq 233 | -- generateIsEq $ equilibriumGame 2 1 1 lotteryPayment thresholdStrat 234 | 235 | -- 3 players with 1 auction slot and 1 lottery slot AND 2nd price rule - strategies before not an equilibrium 236 | -- generateIsEq $ equilibriumGame 2 1 1 noLotteryPayment thresholdStrat 237 | 238 | -- Truthful bidding is also not an equilibrium 239 | -- generateIsEq $ equilibriumGame 2 1 1 noLotteryPayment truthfulStrat 240 | 241 | -- But the alternative threshold strategy is an equilibrium 242 | -- generateIsEq $ equilibriumGame 2 1 1 noLotteryPayment thresholdStrat' 243 | 244 | -- Also note: Once we exclude slots via lottery, and just auction off one slot, truthful bidding becomes an equilibrium 245 | -- generateIsEq $ equilibriumGame 2 1 0 noLotteryPayment truthfulStrat 246 | -------------------------------------------------------------------------------- /src/Examples/Auctions/SimultaneousBidAuction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | 11 | module Examples.Auctions.SimultaneousBidAuction where 12 | 13 | import Examples.Auctions.AuctionSupportFunctions 14 | import OpenGames 15 | import OpenGames.Preprocessor 16 | 17 | ---------- 18 | -- A Model 19 | ---------- 20 | 21 | --------------- 22 | -- 0 Parameters 23 | 24 | type Values = Double 25 | 26 | values = [0, 20 .. 100] 27 | 28 | reservePriceParameter :: Double 29 | reservePriceParameter = 1 30 | 31 | --------------------- 32 | -- 1 The actual games 33 | 34 | -- Draws a value and creates a pair of _value_ _name_ 35 | natureDrawsTypeStage name = 36 | [opengame| 37 | 38 | inputs : ; 39 | feedback : ; 40 | 41 | :-----: 42 | inputs : ; 43 | feedback : ; 44 | operation : nature (uniformDist values) ; 45 | outputs : value ; 46 | returns : ; 47 | :-----: 48 | 49 | outputs : (name,value) ; 50 | returns : ; 51 | |] 52 | 53 | -- Individual bidding stage 54 | biddingStage name = 55 | [opengame| 56 | 57 | inputs : nameValuePair ; 58 | feedback : ; 59 | 60 | :---------------------------: 61 | inputs : nameValuePair ; 62 | feedback : ; 63 | operation : dependentDecision name (const [0,20..100]) ; 64 | outputs : bid ; 65 | returns : setPayoff nameValuePair payments ; 66 | :---------------------------: 67 | 68 | outputs : bid ; 69 | returns : payments ; 70 | |] 71 | 72 | -- Transforms the payments into a random reshuffling 73 | transformPaymentsReservePrice kPrice kSlots = 74 | [opengame| 75 | 76 | inputs : (bids,reservePrice) ; 77 | feedback : ; 78 | 79 | :-----------------: 80 | inputs : (bids,reservePrice) ; 81 | feedback : ; 82 | operation : forwardFunction (auctionPaymentResPrice noLotteryPayment kPrice kSlots 0) ; 83 | outputs : payments ; 84 | returns : ; 85 | :-----------------: 86 | 87 | outputs : payments ; 88 | returns : ; 89 | |] 90 | 91 | bidding2ReservePrice kPrice kSlots = 92 | [opengame| 93 | 94 | inputs : reservePrice ; 95 | feedback : ; 96 | 97 | :-----------------: 98 | inputs : ; 99 | feedback : ; 100 | operation : natureDrawsTypeStage "Alice" ; 101 | outputs : aliceValue ; 102 | returns : ; 103 | 104 | inputs : ; 105 | feedback : ; 106 | operation : natureDrawsTypeStage "Bob" ; 107 | outputs : bobValue ; 108 | returns : ; 109 | 110 | inputs : aliceValue ; 111 | feedback : ; 112 | operation : biddingStage "Alice" ; 113 | outputs : aliceDec ; 114 | returns : payments ; 115 | 116 | inputs : bobValue ; 117 | feedback : ; 118 | operation : biddingStage "Bob" ; 119 | outputs : bobDec ; 120 | returns : payments ; 121 | 122 | inputs : ([("Alice",aliceDec),("Bob",bobDec)],reservePrice) ; 123 | feedback : ; 124 | operation : transformPaymentsReservePrice kPrice kSlots ; 125 | outputs : payments ; 126 | returns : ; 127 | :-----------------: 128 | 129 | outputs : payments ; 130 | returns : ; 131 | |] 132 | 133 | ---- Without reserve price 134 | -- Transforms the payments into a random reshuffling 135 | transformPayments kPrice kSlots reservePrice = 136 | [opengame| 137 | 138 | inputs : bids ; 139 | feedback : ; 140 | 141 | :-----------------: 142 | inputs : bids ; 143 | feedback : ; 144 | operation : forwardFunction (auctionPayment noLotteryPayment reservePrice kPrice kSlots 0) ; 145 | outputs : payments ; 146 | returns : ; 147 | :-----------------: 148 | 149 | outputs : payments ; 150 | returns : ; 151 | |] 152 | 153 | -- Instantiates a simplified version with two players 154 | bidding2 kPrice kSlots reservePrice = 155 | [opengame| 156 | 157 | inputs : ; 158 | feedback : ; 159 | 160 | :-----------------: 161 | inputs : ; 162 | feedback : ; 163 | operation : natureDrawsTypeStage "Alice" ; 164 | outputs : aliceValue ; 165 | returns : ; 166 | 167 | inputs : ; 168 | feedback : ; 169 | operation : natureDrawsTypeStage "Bob" ; 170 | outputs : bobValue ; 171 | returns : ; 172 | 173 | inputs : aliceValue ; 174 | feedback : ; 175 | operation : biddingStage "Alice" ; 176 | outputs : aliceDec ; 177 | returns : payments ; 178 | 179 | inputs : bobValue ; 180 | feedback : ; 181 | operation : biddingStage "Bob" ; 182 | outputs : bobDec ; 183 | returns : payments ; 184 | 185 | inputs : [("Alice",aliceDec),("Bob",bobDec)] ; 186 | feedback : ; 187 | operation : transformPayments kPrice kSlots reservePrice ; 188 | outputs : payments ; 189 | returns : ; 190 | :-----------------: 191 | 192 | outputs : ; 193 | returns : ; 194 | |] 195 | 196 | -- B Analysis 197 | ------------- 198 | 199 | --------------- 200 | -- 0 Strategies 201 | 202 | -- Truthful bidding 203 | stratBidderTruth :: Kleisli Stochastic (String, Values) Values 204 | stratBidderTruth = Kleisli (\(_, x) -> playDeterministically x) 205 | 206 | -- Constant bidding 207 | constBidding :: Values -> Kleisli Stochastic (String, Values) Values 208 | constBidding x = Kleisli (\(_, _) -> playDeterministically x) 209 | 210 | -- Complete strategy for truthful bidding for 2 players 211 | truthfulStrat :: 212 | List 213 | '[ Kleisli Stochastic (String, Values) Values, 214 | Kleisli Stochastic (String, Values) Values 215 | ] 216 | truthfulStrat = 217 | stratBidderTruth 218 | :- stratBidderTruth 219 | :- Nil 220 | 221 | -- Complete strategy for const bidding for 2 players 222 | constBiddingStrat x y = 223 | constBidding x 224 | :- constBidding y 225 | :- Nil 226 | 227 | --------------- 228 | -- 1 Equilibria 229 | -- 1.0 Eq. game with 3 players 230 | equilibriumGame kPrice kSlots reservePrice strat = evaluate (bidding2 kPrice kSlots reservePrice) strat void 231 | 232 | ------------------------ 233 | -- 2 Interactive session 234 | 235 | -- One object being auctioned off Once we exclude slots via lottery, and just auction off one slot, truthful bidding becomes an equilibrium 236 | -- generateIsEq $ equilibriumGame 2 1 reservePriceParameter truthfulStrat 237 | 238 | -- Not an equilibrium 239 | -- generateIsEq $ equilibriumGame 2 1 reservePriceParameter (constBiddingStrat 30 30) 240 | -------------------------------------------------------------------------------- /src/Examples/Auctions/output.svg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CyberCat-Institute/open-game-engine/d3e933e0f1a39432e78f1eaea89799741268e85d/src/Examples/Auctions/output.svg -------------------------------------------------------------------------------- /src/Examples/Bayesian.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Examples.Bayesian where 7 | 8 | import OpenGames 9 | import OpenGames.Preprocessor 10 | 11 | -------------- 12 | -- 0. Overview 13 | -- This file contains two examples. First, a single player making a decision updating information given a signal structure. This games illustrates the Bayesian updating inherent in the players' optimization. Second, a Bayesian prisoner's dilemma, taken from Mas-Colell, Whinston & Green p.254, this is illustrates the interaction of a Bayesian player with private information and a player without private information in the setting of a prisoner's dilemma. 14 | 15 | ----------------------- 16 | -- 1. Types and payoffs 17 | 18 | -- 1.0 Single player coordinating with nature 19 | 20 | data CoordinateMove = A | B deriving (Eq, Ord, Show) 21 | 22 | -- | payoff for player is matching the right state of the world 23 | coordinateWithNaturePayoff :: CoordinateMove -> CoordinateMove -> Double 24 | coordinateWithNaturePayoff x y = if x == y then 1 else 0 25 | 26 | -- 1.1 Prisoner's dilemma 27 | data PDNature = Rat | NoRat deriving (Eq, Ord, Show) 28 | 29 | data PDMove = Confess | DontConfess deriving (Eq, Ord, Show) 30 | 31 | -- | standard PD payoff 32 | pdPayoff1 :: PDMove -> PDMove -> Double 33 | pdPayoff1 Confess Confess = -5 34 | pdPayoff1 Confess DontConfess = -1 35 | pdPayoff1 DontConfess Confess = -10 36 | pdPayoff1 DontConfess DontConfess = 0 37 | 38 | -- | different payoffs depending on player type ("Rat" - "NoRat") 39 | pdPayoff2 :: PDNature -> PDMove -> PDMove -> Double 40 | pdPayoff2 Rat Confess Confess = -5 41 | pdPayoff2 Rat Confess DontConfess = -10 42 | pdPayoff2 Rat DontConfess Confess = -1 43 | pdPayoff2 Rat DontConfess DontConfess = -2 44 | pdPayoff2 NoRat Confess Confess = -11 45 | pdPayoff2 NoRat Confess DontConfess = -10 46 | pdPayoff2 NoRat DontConfess Confess = -7 47 | pdPayoff2 NoRat DontConfess DontConfess = -2 48 | 49 | -------------------------- 50 | -- 2. Game representations 51 | -- 2.0. coordination with nature 52 | 53 | -- | Distribution of states of the world 54 | distributionNature probA = distFromList [(A, probA), (B, 1 - probA)] 55 | 56 | -- | signal structure, given precision probability that the correct state of nature is sent 57 | signal signalPrecision A = distFromList [(A, signalPrecision), (B, 1 - signalPrecision)] 58 | signal signalPrecision B = distFromList [(B, signalPrecision), (A, 1 - signalPrecision)] 59 | 60 | -- | This game represents a stochastic process: Nature draws from a distribution given _probA_ of A, then a signal is sent with a given probability _signalPrecision_ 61 | stochasticEnv probA signalPrecision = 62 | [opengame| 63 | inputs : ; 64 | feedback : ; 65 | 66 | :----------------------------: 67 | inputs : ; 68 | feedback : ; 69 | operation : nature (distributionNature probA); 70 | outputs : draw ; 71 | returns : ; 72 | 73 | inputs : draw ; 74 | feedback : ; 75 | operation : liftStochasticForward (signal signalPrecision); 76 | outputs : signalDraw ; 77 | returns : ; 78 | :----------------------------: 79 | 80 | outputs : (signalDraw,draw) ; 81 | returns : ; 82 | |] 83 | 84 | -- | The complete game 85 | coordinateWithNature probA signalPrecision = 86 | [opengame| 87 | inputs : ; 88 | feedback : ; 89 | 90 | :----------------------------: 91 | inputs : ; 92 | feedback : ; 93 | operation : stochasticEnv probA signalPrecision ; 94 | outputs : (signal,draw) ; 95 | returns : ; 96 | 97 | inputs : signal ; 98 | feedback : ; 99 | operation : dependentDecision "player" (const [A,B]); 100 | outputs : decision ; 101 | returns : coordinateWithNaturePayoff decision draw; 102 | 103 | :----------------------------: 104 | 105 | outputs : ; 106 | returns : ; 107 | |] 108 | 109 | -- 2.1. Prisoner's dilemma 110 | bayesianPD = 111 | [opengame| 112 | 113 | inputs : ; 114 | feedback : ; 115 | 116 | :----------------------------: 117 | inputs : ; 118 | feedback : ; 119 | operation : nature (uniformDist [Rat, NoRat]) ; 120 | outputs : prisoner2Type ; 121 | returns : ; 122 | 123 | inputs : ; 124 | feedback : ; 125 | operation : dependentDecision "prisoner1" (const [Confess, DontConfess]); 126 | outputs : decision1 ; 127 | returns : pdPayoff1 decision1 decision2; 128 | 129 | inputs : prisoner2Type ; 130 | feedback : ; 131 | operation : dependentDecision "prisoner2" (const [Confess, DontConfess]); 132 | outputs : decision2 ; 133 | returns : pdPayoff2 prisoner2Type decision1 decision2 ; 134 | 135 | :----------------------------: 136 | 137 | outputs : ; 138 | returns : ; 139 | |] 140 | 141 | -------------------------- 142 | -- 3. Equilibrium analysis 143 | 144 | -- 3.0. Coordinate with nature 145 | 146 | -- | Equilibrium function 147 | isEquilibriumCoordinationNature probA signalPrecision strat = generateIsEq $ evaluate (coordinateWithNature probA signalPrecision) strat void 148 | 149 | -- | We define two strategies _followSignal_ and _doOpposite_ 150 | followSignal, doOpposite :: Kleisli Stochastic CoordinateMove CoordinateMove 151 | followSignal = Kleisli (\x -> playDeterministically x) 152 | doOpposite = Kleisli (\case A -> playDeterministically B; B -> playDeterministically A) 153 | 154 | -- | Putting strategies into the list 155 | followSignalStrategy = followSignal :- Nil 156 | 157 | doOppositeStrategy = doOpposite :- Nil 158 | 159 | -- Example usage 160 | -- isEquilibriumCoordinationNature 0.6 0.7 followSignalStrategy 161 | 162 | -- 3.1. Bayesian Prisoner's Dilemma 163 | 164 | -- | Equilibrium function 165 | isEquilibriumBayesianPDE strat = generateIsEq $ evaluate bayesianPD strat void 166 | 167 | -- | Strategy player 1 168 | player1Strategy :: Kleisli Stochastic () PDMove 169 | player1Strategy = pureAction Confess 170 | 171 | -- | Strategy player 2 172 | player2Strategy :: Kleisli Stochastic PDNature PDMove 173 | player2Strategy = 174 | Kleisli 175 | ( \case 176 | Rat -> playDeterministically Confess 177 | NoRat -> playDeterministically DontConfess 178 | ) 179 | 180 | -- | Complete strategy tuple 181 | strategyTuplePD = player1Strategy :- player2Strategy :- Nil 182 | 183 | -- Example usage 184 | -- isEquilibriumBayesianPDE strategyTuplePD 185 | -------------------------------------------------------------------------------- /src/Examples/Decision.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Examples.Decision 6 | ( isOptimalSingleDecisionVerbose, 7 | pureIdentity, 8 | isOptimalSingleDecisionStoch, 9 | peak, 10 | ) 11 | where 12 | 13 | import OpenGames 14 | import OpenGames.Preprocessor 15 | 16 | --------------------------------------------- 17 | -- 0. A single decision w/o prior information 18 | -- We depict a single decision without 19 | -- interaction to the outside 20 | --------------------------------------------- 21 | -- 0.0. Game representations 22 | 23 | -- | A single decision with no prior input or output 24 | -- Requires a list of actions, and a payoff function 25 | singleDecisionVerbose actionSpace payoffFunction = 26 | [opengame| 27 | inputs : ; 28 | feedback : ; 29 | 30 | :----------------------------: 31 | inputs : ; 32 | feedback : ; 33 | operation : dependentDecision "player1" (const actionSpace); 34 | outputs : decisionPlayer1 ; 35 | returns : payoffFunction decisionPlayer1 ; 36 | :----------------------------: 37 | 38 | outputs : ; 39 | returns : ; 40 | |] 41 | 42 | -- | The same decision in the reduced style, i.e. ignoring empty fields 43 | -- Requires a list of actions, and a payoff function 44 | singleDecisionReduced actionSpace payoffFunction = 45 | [opengame| 46 | operation : dependentDecision "player1" (const actionSpace); 47 | outputs : decisionPlayer1 ; 48 | returns : payoffFunction decisionPlayer1 ; 49 | |] 50 | 51 | ------------------ 52 | -- 0.1. Parameters 53 | -- Next, we provide additional modelling parameters 54 | 55 | -- | An action space from 1 - 10 56 | actionSpace = [1.0 .. 10.0] 57 | 58 | -- | Some arbitrary payoff function with a clear max 59 | payoffFunction peak dec = -(peak - dec) ** 2 60 | 61 | -- | Instantiate the single decision with parameters 62 | -- We use the _payoff_ function with a peak at 5 63 | gameSingleDecisionVerbose = singleDecisionVerbose actionSpace (payoffFunction 5) 64 | 65 | ---------------- 66 | -- 0.2. Analysis 67 | -- We analyze the game and test whether certain actions are optimal 68 | -- Here, this is trivial, but it is useful to see it first at that simple level 69 | 70 | -- | This function defines a checker on the game _gameSingleDecisionVerbose_ 71 | -- It expects a strategy, here just a single action, as input and outputs information whether the action is optimal 72 | -- This is done by the _evaluate_ function. In a game with several players the same _evaluate_ will check for an equilibrium condition 73 | -- The _generateisEq_ transforms this output into an easier to digest format. 74 | -- NOTE: _void_ represents a context relative to which a game is evaluated. As the game used has 75 | -- no incoming or outcoming information, the context is empty (i.e. "void") 76 | isOptimalSingleDecisionVerbose strat = generateIsEq $ evaluate gameSingleDecisionVerbose strat void 77 | 78 | -- | Next, we define a strategu. We use the helper function _pureAction_ to determine a pure strategy 79 | -- This is as simples as it gets, the strategy expects an action and will play this 80 | -- action with certainty 81 | pureIdentity :: Double -> List '[Kleisli Stochastic () Double] 82 | pureIdentity action = pureAction action :- Nil 83 | 84 | -- | Now, we are ready to actually run this game and the optimality check. Example usages: 85 | -- isOptimalSingleDecisionVerbose (pureIdentity 4), or 86 | -- isOptimalSingleDecisionVerbose (pureIdentity 5), 87 | 88 | ---------------------------------- 89 | -- 1. A single decision with prior 90 | -- information and a stochastic 91 | -- environment 92 | ---------------------------------- 93 | -- 1.1 Game representation: Extended decision 94 | 95 | -- | A single decision with prior input 96 | -- This extends the previous decision under 0 97 | -- Requires a list of actions, and a payoff function 98 | -- NOTE: The payoff here depends on the external information _x_ 99 | singleDecisionPriorVerbose actionSpace payoffFunction = 100 | [opengame| 101 | inputs : x ; 102 | feedback : ; 103 | 104 | :----------------------------: 105 | inputs : x ; 106 | feedback : ; 107 | operation : dependentDecision "player1" (\x -> actionSpace); 108 | outputs : decisionPlayer1 ; 109 | returns : payoffFunction decisionPlayer1 x ; 110 | :----------------------------: 111 | 112 | outputs : ; 113 | returns : ; 114 | |] 115 | 116 | -- | The same decision in the reduced style, i.e. ignoring empty fields 117 | -- Requires a list of actions, and a payoff function 118 | singleDecisionPriorReduced actionSpace payoffFunction = 119 | [opengame| 120 | inputs : x ; 121 | :----------------------------: 122 | inputs : x ; 123 | operation : dependentDecision "player1" (\x -> actionSpace); 124 | outputs : decisionPlayer1 ; 125 | returns : payoffFunction decisionPlayer1 ; 126 | |] 127 | 128 | ----------------------------------- 129 | -- 1.2. Game representation: Nature 130 | 131 | -- | This game represents a simple stochastic process and expects a distribution as input 132 | stochasticEnv distribution = 133 | [opengame| 134 | inputs : ; 135 | feedback : ; 136 | 137 | :----------------------------: 138 | inputs : ; 139 | feedback : ; 140 | operation : nature distribution; 141 | outputs : draw ; 142 | returns : ; 143 | :----------------------------: 144 | 145 | outputs : draw ; 146 | returns : ; 147 | |] 148 | 149 | -- | NOTE: the same functionality as above is available as an auxiliary function -- natureDraw_ 150 | stochasticEnvAtomic distribution = natureDraw distribution 151 | 152 | ----------------------------------------------- 153 | -- 1.3. Game representation: The combined game 154 | 155 | -- | We combine the stochastic process with a decision stage. 156 | -- Such combinations are important as other games will rely on them heavily 157 | singleDecStoch distribution actionSpace payoffFunction = 158 | [opengame| 159 | inputs : ; 160 | feedback : ; 161 | 162 | :----------------------------: 163 | inputs : ; 164 | feedback : ; 165 | operation : stochasticEnv distribution ; 166 | outputs : draw ; 167 | returns : ; 168 | 169 | inputs : draw ; 170 | feedback : ; 171 | operation : singleDecisionPriorVerbose actionSpace payoffFunction; 172 | outputs : ; 173 | returns : ; 174 | :----------------------------: 175 | 176 | outputs : ; 177 | returns : ; 178 | |] 179 | 180 | ----------------- 181 | -- 1.4 Parameters 182 | 183 | -- | We define a uniform distribution for a peak; check the payoff function above for information 184 | -- We can use the auxiliary _uniformDist_ which creates a uniform distribution from a list. 185 | distributionUniformPeak = uniformDist actionSpace 186 | 187 | -- | As an alternative, we create a custom-made distribution which expects a list of tuples (outcome, weight) 188 | -- We can use the auxiliary _distFromList_ 189 | distributionCustomPeak = distFromList [(1, 2), (2, 2), (3, 4), (5, 5), (6, 4), (7, 2), (8, 2), (9, 1)] 190 | 191 | -- | Instantiate the single decision with random parameter 192 | gameSingleDecisionStoch = singleDecStoch distributionUniformPeak actionSpace payoffFunction 193 | 194 | isOptimalSingleDecisionStoch strat = generateIsEq $ evaluate gameSingleDecisionStoch strat void 195 | 196 | ---------------- 197 | -- 1.5. Analysis 198 | 199 | -- | Next, we define a strategy which makes an observation and uses that observation as the action 200 | -- again using the helper _pureAction_ 201 | peak :: List '[Kleisli Stochastic Double Double] 202 | peak = (Kleisli $ (\x -> playDeterministically x)) :- Nil 203 | 204 | -- | Example usage 205 | -- isOptimalSingleDecisionStoch peak 206 | -------------------------------------------------------------------------------- /src/Examples/Markov/NStageMarkov.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Examples.Markov.NStageMarkov where 8 | 9 | import Control.Monad.State hiding (lift, state, void) 10 | import qualified Control.Monad.State as ST 11 | import Data.Tuple.Extra (uncurry3) 12 | import Examples.SimultaneousMoves (ActionPD (..)) 13 | import Numeric.Probability.Distribution hiding (filter, lift, map) 14 | import OpenGames 15 | import OpenGames.Preprocessor 16 | 17 | -- Here we consider an even simpler version how to implement an N stage markov game where solely the payoffs depend on a stage; actions are identical 18 | 19 | -------- 20 | -- Types 21 | 22 | type EndState = Bool 23 | 24 | type EndStateN = Int 25 | 26 | ---------- 27 | -- Payoffs 28 | 29 | discountFactor = 0.9 30 | 31 | -- | Payoff for a specific game state 32 | payoffGameN 0 = 0.5 33 | payoffGameN 1 = 0.3 34 | payoffGameN 2 = 1 35 | payoffGameN 3 = 0.2 36 | payoffGameN _ = 0 37 | 38 | ---------------------- 39 | -- Auxiliary functions 40 | 41 | -- The transition happens deterministically if one of the players does not play _Cooperate_ 42 | transitionEndStateDetermN :: EndStateN -> ActionPD -> ActionPD -> Stochastic EndStateN 43 | transitionEndStateDetermN 3 _ _ = playDeterministically 3 44 | transitionEndStateDetermN 0 Cooperate Cooperate = playDeterministically 0 45 | transitionEndStateDetermN 0 _ _ = playDeterministically 1 46 | transitionEndStateDetermN 1 Cooperate Cooperate = playDeterministically 1 47 | transitionEndStateDetermN 1 _ _ = playDeterministically 2 48 | transitionEndStateDetermN 2 Cooperate Cooperate = playDeterministically 2 49 | transitionEndStateDetermN 2 _ _ = playDeterministically 3 50 | 51 | ------------- 52 | -- Open games 53 | 54 | -- The baseline stage game: prisoner's dilemma 55 | basicGame :: 56 | OpenGame 57 | StochasticStatefulOptic 58 | StochasticStatefulContext 59 | ( '[ Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD, 60 | Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD 61 | ] 62 | ) 63 | ( '[ [DiagnosticInfoBayesian (ActionPD, ActionPD, EndStateN) ActionPD], 64 | [DiagnosticInfoBayesian (ActionPD, ActionPD, EndStateN) ActionPD] 65 | ] 66 | ) 67 | (ActionPD, ActionPD, EndStateN) 68 | () 69 | (ActionPD, ActionPD) 70 | () 71 | basicGame = 72 | [opengame| 73 | 74 | inputs : (dec1Old,dec2Old,endState) ; 75 | feedback : ; 76 | 77 | :----------------------------: 78 | inputs : (dec1Old,dec2Old,endState) ; 79 | feedback : ; 80 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 81 | outputs : decisionPlayer1 ; 82 | returns : payoffGameN endState ; 83 | 84 | inputs : (dec1Old,dec2Old,endState) ; 85 | feedback : ; 86 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 87 | outputs : decisionPlayer2 ; 88 | returns : payoffGameN endState ; 89 | 90 | :----------------------------: 91 | 92 | outputs : (decisionPlayer1,decisionPlayer2) ; 93 | returns : ; 94 | |] 95 | 96 | ----------------- 97 | -- Complete Games 98 | 99 | -- define the whole game, here with pathological endgame 100 | completeGame = 101 | [opengame| 102 | 103 | inputs : (dec1Old,dec2Old,gameStateOld) ; 104 | feedback : ; 105 | 106 | :----------------------------: 107 | inputs : (dec1Old,dec2Old,gameStateOld); 108 | feedback : ; 109 | operation : basicGame ; 110 | outputs : (dec1New,dec2New) ; 111 | returns : ; 112 | 113 | inputs : (gameStateOld,dec1New,dec2New) ; 114 | feedback : ; 115 | operation : liftStochasticForward $ uncurry3 transitionEndStateDetermN; 116 | outputs : gameStateNew; 117 | returns : ; 118 | 119 | operation : discount "player1" (\x -> x * discountFactor) ; 120 | 121 | operation : discount "player2" (\x -> x * discountFactor) ; 122 | 123 | 124 | :----------------------------: 125 | 126 | outputs : (dec1New,dec2New,gameStateNew) ; 127 | returns : ; 128 | |] 129 | 130 | ------------- 131 | -- Strategies 132 | 133 | -- Add strategy for stage game 134 | -- NOTE the payoffs 135 | strategyEq :: Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD 136 | strategyEq = 137 | Kleisli $ 138 | ( \case 139 | (_, _, 0) -> playDeterministically Defect 140 | -- \^ If in stage 0, play to get to stage 1 141 | (_, _, 1) -> playDeterministically Defect 142 | -- \^ If in stage 1, play to get to stage 2 143 | (_, _, 2) -> playDeterministically Cooperate 144 | -- \^ If in stage 2, stay there 145 | (_, _, _) -> uniform [Cooperate, Defect] 146 | ) 147 | 148 | -- \^ If in stage 3, play whatever you want 149 | 150 | strategyAlt :: Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD 151 | strategyAlt = Kleisli $ 152 | \(_, _, _) -> uniform [Cooperate, Defect] 153 | 154 | -- \^ Randomize 155 | 156 | -- Strategy tuple for complete game 157 | strategyTupleEq = strategyEq :- strategyEq :- Nil 158 | 159 | -- Strategy tuple for complete game with randomization in first stage 160 | strategyTupleAlt = strategyAlt :- strategyAlt :- Nil 161 | 162 | ----------------------- 163 | -- Continuation payoffs 164 | 165 | -- Extract continuation 166 | extractContinuation :: StochasticStatefulOptic s () a () -> s -> StateT Vector Stochastic () 167 | extractContinuation (StochasticStatefulOptic v u) x = do 168 | (z, a) <- ST.lift (v x) 169 | u z () 170 | 171 | -- Extract next state (action) 172 | extractNextState :: StochasticStatefulOptic s () (a, a, EndStateN) () -> s -> Stochastic (a, a, EndStateN) 173 | extractNextState (StochasticStatefulOptic v _) x = do 174 | (z, a) <- v x 175 | pure a 176 | 177 | -- Determine continuation for iterator, with the same repeated strategy, using the pathological endgame 178 | determineContinuationPayoffs :: 179 | Integer -> 180 | List 181 | '[ Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD, 182 | Kleisli Stochastic (ActionPD, ActionPD, EndStateN) ActionPD 183 | ] -> 184 | (ActionPD, ActionPD, EndStateN) -> 185 | StateT Vector Stochastic () 186 | determineContinuationPayoffs 1 strat action = pure () 187 | determineContinuationPayoffs iterator strat action = do 188 | extractContinuation executeStrat action 189 | nextInput <- ST.lift $ extractNextState executeStrat action 190 | determineContinuationPayoffs (pred iterator) strat nextInput 191 | where 192 | executeStrat = play completeGame strat 193 | 194 | ---------- 195 | -- Context 196 | 197 | -- Context used for the evaluation of the pathological end state 198 | contextCont iterator strat initialAction = StochasticStatefulContext (pure ((), initialAction)) (\_ action -> determineContinuationPayoffs iterator strat action) 199 | 200 | -------------- 201 | -- Equilibrium 202 | 203 | -- equilibria of repeated game with continuation payoff 204 | repeatedCompleteGameEq iterator strat initialAction = evaluate completeGame strat context 205 | where 206 | context = contextCont iterator strat initialAction 207 | 208 | -- Show output 209 | eqOutput iterator strat initialAction = generateIsEq $ repeatedCompleteGameEq iterator strat initialAction 210 | 211 | -- NOTE: check the equilibrium for all possible states! 212 | -------------------------------------------------------------------------------- /src/Examples/Markov/RepeatedPD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Examples.Markov.RepeatedPD where 8 | 9 | import Control.Monad.State hiding (lift, state, void) 10 | import qualified Control.Monad.State as ST 11 | import Examples.SimultaneousMoves (ActionPD (..), prisonersDilemmaMatrix) 12 | import OpenGames 13 | import OpenGames.Preprocessor 14 | 15 | prisonersDilemma :: 16 | OpenGame 17 | StochasticStatefulOptic 18 | StochasticStatefulContext 19 | ( '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 20 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 21 | ] 22 | ) 23 | ( '[ [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD], 24 | [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD] 25 | ] 26 | ) 27 | (ActionPD, ActionPD) 28 | () 29 | (ActionPD, ActionPD) 30 | () 31 | 32 | discountFactor = 0.5 33 | 34 | prisonersDilemma = 35 | [opengame| 36 | 37 | inputs : (dec1Old,dec2Old) ; 38 | feedback : ; 39 | 40 | :----------------------------: 41 | inputs : (dec1Old,dec2Old) ; 42 | feedback : ; 43 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 44 | outputs : decisionPlayer1 ; 45 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 ; 46 | 47 | inputs : (dec1Old,dec2Old) ; 48 | feedback : ; 49 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 50 | outputs : decisionPlayer2 ; 51 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 ; 52 | 53 | operation : discount "player1" (\x -> x * discountFactor) ; 54 | 55 | operation : discount "player2" (\x -> x * discountFactor) ; 56 | 57 | :----------------------------: 58 | 59 | outputs : (decisionPlayer1,decisionPlayer2) ; 60 | returns : ; 61 | |] 62 | 63 | -- Add strategy for stage game 64 | stageStrategy :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 65 | stageStrategy = 66 | Kleisli $ 67 | ( \case 68 | (Cooperate, Cooperate) -> playDeterministically Cooperate 69 | (_, _) -> playDeterministically Defect 70 | ) 71 | 72 | -- Stage strategy tuple 73 | strategyTuple = stageStrategy :- stageStrategy :- Nil 74 | 75 | -- Testing for stoch behavior and slow down 76 | stageStrategyTest :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 77 | stageStrategyTest = Kleisli $ const $ distFromList [(Cooperate, 0.9), (Defect, 0.1)] 78 | 79 | -- Stage strategy tuple 80 | strategyTupleTest = stageStrategyTest :- stageStrategyTest :- Nil 81 | 82 | -- extract continuation 83 | extractContinuation :: StochasticStatefulOptic s () a () -> s -> StateT Vector Stochastic () 84 | extractContinuation (StochasticStatefulOptic v u) x = do 85 | (z, a) <- ST.lift (v x) 86 | u z () 87 | 88 | -- extract next state (action) 89 | extractNextState :: StochasticStatefulOptic s () a () -> s -> Stochastic a 90 | extractNextState (StochasticStatefulOptic v _) x = do 91 | (z, a) <- v x 92 | pure a 93 | 94 | executeStrat strat = play prisonersDilemma strat 95 | 96 | -- determine continuation for iterator, with the same repeated strategy 97 | determineContinuationPayoffs :: 98 | Integer -> 99 | List 100 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 101 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 102 | ] -> 103 | (ActionPD, ActionPD) -> 104 | StateT Vector Stochastic () 105 | determineContinuationPayoffs 1 strat action = pure () 106 | determineContinuationPayoffs iterator strat action = do 107 | extractContinuation executeStrat action 108 | nextInput <- ST.lift $ extractNextState executeStrat action 109 | determineContinuationPayoffs (pred iterator) strat nextInput 110 | where 111 | executeStrat = play prisonersDilemma strat 112 | 113 | -- fix context used for the evaluation 114 | contextCont iterator strat initialAction = StochasticStatefulContext (pure ((), initialAction)) (\_ action -> determineContinuationPayoffs iterator strat action) 115 | 116 | repeatedPDEq iterator strat initialAction = evaluate prisonersDilemma strat context 117 | where 118 | context = contextCont iterator strat initialAction 119 | 120 | eqOutput iterator strat initialAction = generateIsEq $ repeatedPDEq iterator strat initialAction 121 | -------------------------------------------------------------------------------- /src/Examples/Markov/RepeatedPDNonState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Examples.Markov.RepeatedPDNonState where 8 | 9 | import OpenGames hiding 10 | ( Agent (..), 11 | StochasticStatefulBayesianOpenGame (..), 12 | StochasticStatefulOptic, 13 | dependentDecision, 14 | dependentEpsilonDecision, 15 | discount, 16 | distFromList, 17 | fromFunctions, 18 | fromLens, 19 | playDeterministically, 20 | pureAction, 21 | uniformDist, 22 | ) 23 | import OpenGames.Engine.BayesianGamesNonState 24 | import OpenGames.Preprocessor 25 | 26 | -- 1.0. Prisoner's dilemma 27 | data ActionPD = Cooperate | Defect 28 | deriving (Eq, Ord, Show) 29 | 30 | -- | Payoff matrix for player i given i's action and j's action 31 | prisonersDilemmaMatrix :: ActionPD -> ActionPD -> Double 32 | prisonersDilemmaMatrix Cooperate Cooperate = 3 33 | prisonersDilemmaMatrix Cooperate Defect = 0 34 | prisonersDilemmaMatrix Defect Cooperate = 5 35 | prisonersDilemmaMatrix Defect Defect = 1 36 | 37 | discountFactor = 0.5 38 | 39 | prisonersDilemmaCont = 40 | [opengame| 41 | 42 | inputs : (dec1Old,dec2Old) ; 43 | feedback : (prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 + return1,prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 + return2) ; 44 | 45 | :----------------------------: 46 | inputs : (dec1Old,dec2Old) ; 47 | feedback : ; 48 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 49 | outputs : decisionPlayer1 ; 50 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 + return1; 51 | 52 | inputs : (dec1Old,dec2Old) ; 53 | feedback : ; 54 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 55 | outputs : decisionPlayer2 ; 56 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 + return2; 57 | 58 | :----------------------------: 59 | 60 | outputs : (decisionPlayer1,decisionPlayer2) ; 61 | returns : (return1,return2) ; 62 | |] 63 | 64 | -- Add strategy for stage game 65 | stageStrategy1, stageStrategy2 :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 66 | stageStrategy1 = 67 | Kleisli $ 68 | ( \case 69 | (Cooperate, Cooperate) -> playDeterministically Cooperate 70 | (_, _) -> playDeterministically Defect 71 | ) 72 | stageStrategy2 = 73 | Kleisli $ 74 | ( \case 75 | (Cooperate, Cooperate) -> playDeterministically Cooperate 76 | (_, _) -> playDeterministically Defect 77 | ) 78 | 79 | -- Stage strategy tuple 80 | strategyTuple = stageStrategy1 :- stageStrategy2 :- Nil 81 | 82 | -- For a an optic (derived from a play for a given strategy), and state (which is also the action), derive a new StateT 83 | extractContinuation :: StochasticOptic s (Double, Double) a (Double, Double) -> s -> (Double, Double) -> Stochastic (Double, Double) 84 | extractContinuation (StochasticOptic v u) x r = do 85 | (z, _) <- (v x) 86 | u z r 87 | 88 | -- For an optic (derived from a play for a given strategy), and state derive the action which was played, which in turn is then the next state 89 | extractNextState :: StochasticOptic s t a b -> s -> Stochastic a 90 | extractNextState (StochasticOptic v _) x = do 91 | (z, a) <- v x 92 | pure a 93 | 94 | -- What is that payoff? Given a strategy and an action evaluate how the rounds will play out. 95 | continuationPayoffs :: 96 | (Eq t, Num t, Enum t) => 97 | t -> 98 | List 99 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 100 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 101 | ] -> 102 | (ActionPD, ActionPD) -> 103 | (Double, Double) -> 104 | Stochastic (Double, Double) 105 | continuationPayoffs iterator strat action return@(r1, r2) 106 | | iterator == 1 = pure return -- extractContinuation (execute strat) action return 107 | | otherwise = do 108 | (r1', r2') <- extractContinuation (execute strat) action (r1, r2) 109 | actionNew <- nextState strat action 110 | continuationPayoffs (pred iterator) strat actionNew (r1' * discountFactor, r2' * discountFactor) 111 | where 112 | execute strat' = play prisonersDilemmaCont strat' -- results in an optic 113 | nextState strat' action' = extractNextState (execute strat') action' 114 | 115 | -- Gives the context with the initial condition, the state, and for an action taken determines the continuation payoff 116 | contextCont :: 117 | (Eq t1, Num t1, Enum t1) => 118 | t1 -> 119 | List 120 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 121 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 122 | ] -> 123 | (ActionPD, ActionPD) -> 124 | StochasticContext 125 | (ActionPD, ActionPD) 126 | (Double, Double) 127 | (ActionPD, ActionPD) 128 | (Double, Double) 129 | contextCont iterator strat initialAction = StochasticContext (pure ((), initialAction)) (\_ action -> continuationPayoffs iterator strat action (0, 0)) 130 | 131 | -- evaluate the one stage game with a given strategy and a given initial state, as context, use the payoff derived from continuously playing that stage game 132 | evaluateIteratedPD iterator strat initialAction = generateOutput $ evaluate prisonersDilemmaCont strat context 133 | where 134 | context = contextCont iterator strat initialAction 135 | 136 | checkEq iterator initialAction = generateIsEq $ evaluate prisonersDilemmaCont strategyTuple context 137 | where 138 | context = contextCont iterator strategyTuple initialAction 139 | -------------------------------------------------------------------------------- /src/Examples/Markov/TestSimpleMonteCarlo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Examples.Markov.TestSimpleMonteCarlo where 8 | 9 | import Debug.Trace 10 | import Examples.Markov.TestSimpleMonteCarlo.Continuation 11 | import Examples.SimultaneousMoves (ActionPD (..), prisonersDilemmaMatrix) 12 | import OpenGames 13 | import OpenGames.Preprocessor 14 | 15 | ------------------------------------------------------------ 16 | -- Combines Bayesian game evaluation of the first stage with 17 | -- a continuation based on Monte Carlo 18 | 19 | prisonersDilemma :: 20 | OpenGame 21 | StochasticStatefulOptic 22 | StochasticStatefulContext 23 | ( '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 24 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 25 | ] 26 | ) 27 | ( '[ [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD], 28 | [DiagnosticInfoBayesian (ActionPD, ActionPD) ActionPD] 29 | ] 30 | ) 31 | (ActionPD, ActionPD) 32 | () 33 | (ActionPD, ActionPD) 34 | () 35 | prisonersDilemma = 36 | [opengame| 37 | 38 | inputs : (dec1Old,dec2Old) ; 39 | feedback : ; 40 | 41 | :----------------------------: 42 | 43 | inputs : (dec1Old,dec2Old) ; 44 | feedback : ; 45 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 46 | outputs : decisionPlayer1 ; 47 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 ; 48 | 49 | inputs : (dec1Old,dec2Old) ; 50 | feedback : ; 51 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 52 | outputs : decisionPlayer2 ; 53 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 ; 54 | 55 | 56 | operation : discount "player1" (\x -> x * discountFactor) ; 57 | 58 | operation : discount "player2" (\x -> x * discountFactor) ; 59 | 60 | :----------------------------: 61 | 62 | outputs : (decisionPlayer1,decisionPlayer2) ; 63 | returns : ; 64 | |] 65 | 66 | -- Add strategy for stage game 67 | stageStrategy :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 68 | stageStrategy = 69 | Kleisli $ 70 | ( \case 71 | (Cooperate, Cooperate) -> playDeterministically Cooperate 72 | (_, _) -> playDeterministically Defect 73 | ) 74 | 75 | -- Stage strategy tuple 76 | strategyTuple = stageStrategy :- stageStrategy :- Nil 77 | 78 | -- Testing for stoch behavior and slow down 79 | stageStrategyTest :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 80 | stageStrategyTest = Kleisli $ const $ distFromList [(Cooperate, 0.9), (Defect, 0.1)] 81 | 82 | -- Stage strategy tuple 83 | strategyTupleTest = stageStrategyTest :- stageStrategyTest :- Nil 84 | 85 | -- fix context used for the evaluation 86 | contextCont sampleSize iterator strat initialAction = StochasticStatefulContext (pure ((), initialAction)) (\_ action -> trace "cont" (sampleDetermineContinuationPayoffsStoch sampleSize iterator strat action)) 87 | 88 | repeatedPDEq sampleSize iterator strat initialAction = evaluate prisonersDilemma strat context 89 | where 90 | context = contextCont sampleSize iterator strat initialAction 91 | 92 | eqOutput sampleSize iterator strat initialAction = generateIsEq $ repeatedPDEq sampleSize iterator strat initialAction 93 | -------------------------------------------------------------------------------- /src/Examples/Markov/TestSimpleMonteCarlo/Continuation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Examples.Markov.TestSimpleMonteCarlo.Continuation 9 | ( sampleDetermineContinuationPayoffsStoch, 10 | discountFactor, 11 | ) 12 | where 13 | 14 | import Control.Monad.State hiding (lift, state, void) 15 | import qualified Control.Monad.State as ST 16 | import Data.Utils 17 | import qualified Data.Vector as V 18 | import Examples.SimultaneousMoves (ActionPD (..), prisonersDilemmaMatrix) 19 | import Numeric.Probability.Distribution hiding (filter, lift, map) 20 | import OpenGames hiding (Agent, discount, fromFunctions, fromLens) 21 | import OpenGames.Engine.IOGames 22 | import OpenGames.Preprocessor 23 | import System.IO.Unsafe 24 | import System.Random.MWC.CondensedTable 25 | 26 | --------------------------------------------- 27 | -- Contains a first, very, very shaky version 28 | -- that does Monte Carlo through the evaluate 29 | --------------------------------------------- 30 | 31 | discountFactor = 1.0 32 | 33 | prisonersDilemmaCont :: 34 | OpenGame 35 | MonadOptic 36 | MonadContext 37 | ( '[ Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD, 38 | Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD 39 | ] 40 | ) 41 | ('[IO (DiagnosticsMC ActionPD), IO (DiagnosticsMC ActionPD)]) 42 | (ActionPD, ActionPD) 43 | () 44 | (ActionPD, ActionPD) 45 | () 46 | prisonersDilemmaCont = 47 | [opengame| 48 | 49 | inputs : (dec1Old,dec2Old) ; 50 | feedback : ; 51 | 52 | :----------------------------: 53 | inputs : (dec1Old,dec2Old) ; 54 | feedback : ; 55 | operation : dependentDecisionIO "player1" 100 [Cooperate,Defect]; 56 | outputs : decisionPlayer1 ; 57 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 ; 58 | 59 | inputs : (dec1Old,dec2Old) ; 60 | feedback : ; 61 | operation : dependentDecisionIO "player2" 100 [Cooperate,Defect]; 62 | outputs : decisionPlayer2 ; 63 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 ; 64 | 65 | operation : discount "player1" (\x -> x * discountFactor) ; 66 | 67 | operation : discount "player2" (\x -> x * discountFactor) ; 68 | 69 | :----------------------------: 70 | 71 | outputs : (decisionPlayer1,decisionPlayer2) ; 72 | returns : ; 73 | |] 74 | 75 | transformStrat :: Kleisli Stochastic x y -> Kleisli CondensedTableV x y 76 | transformStrat strat = 77 | Kleisli 78 | ( \x -> 79 | let y = runKleisli strat x 80 | ls = decons y 81 | v = V.fromList ls 82 | in tableFromProbabilities v 83 | ) 84 | 85 | transformStratTuple :: 86 | List 87 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 88 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 89 | ] -> 90 | List 91 | '[ Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD, 92 | Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD 93 | ] 94 | transformStratTuple (x :- y :- Nil) = 95 | transformStrat x 96 | :- transformStrat y 97 | :- Nil 98 | 99 | -- extract continuation 100 | extractContinuation :: MonadOptic s () a () -> s -> StateT Vector IO () 101 | extractContinuation (MonadOptic v u) x = do 102 | (z, a) <- ST.lift (v x) 103 | u z () 104 | 105 | -- extract next state (action) 106 | extractNextState :: MonadOptic s () a () -> s -> IO a 107 | extractNextState (MonadOptic v _) x = do 108 | (z, a) <- v x 109 | pure a 110 | 111 | executeStrat strat = play prisonersDilemmaCont strat 112 | 113 | -------------------------------- 114 | -- This is for the mixed setting 115 | -- which includes the Bayesian setup 116 | -- determine continuation for iterator, with the same repeated strategy 117 | determineContinuationPayoffs :: 118 | Integer -> 119 | List 120 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 121 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 122 | ] -> 123 | (ActionPD, ActionPD) -> 124 | StateT Vector IO () 125 | determineContinuationPayoffs 1 strat action = pure () 126 | determineContinuationPayoffs iterator strat action = do 127 | extractContinuation executeStrat action 128 | nextInput <- ST.lift $ extractNextState executeStrat action 129 | determineContinuationPayoffs (pred iterator) strat nextInput 130 | where 131 | executeStrat = play prisonersDilemmaCont (transformStratTuple strat) 132 | 133 | sampleDetermineContinuationPayoffs :: 134 | -- | Sample size 135 | Int -> 136 | -- | How many rounds are explored? 137 | Integer -> 138 | List 139 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 140 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 141 | ] -> 142 | (ActionPD, ActionPD) -> 143 | StateT Vector IO () 144 | sampleDetermineContinuationPayoffs sampleSize iterator strat initialValue = do 145 | replicateM_ sampleSize (determineContinuationPayoffs iterator strat initialValue) 146 | v <- ST.get 147 | ST.put (average sampleSize v) 148 | 149 | -- NOTE EVIL EVIL 150 | sampleDetermineContinuationPayoffsStoch :: 151 | -- | Sample size 152 | Int -> 153 | -- | How many rounds are explored? 154 | Integer -> 155 | List 156 | '[ Kleisli Stochastic (ActionPD, ActionPD) ActionPD, 157 | Kleisli Stochastic (ActionPD, ActionPD) ActionPD 158 | ] -> 159 | (ActionPD, ActionPD) -> 160 | StateT Vector Stochastic () 161 | sampleDetermineContinuationPayoffsStoch sampleSize iterator strat initialValue = do 162 | transformStateTIO $ sampleDetermineContinuationPayoffs sampleSize iterator strat initialValue 163 | where 164 | transformStateTIO :: StateT Vector IO () -> StateT Vector Stochastic () 165 | transformStateTIO sTT = StateT (\s -> unsafeTransformIO $ ST.runStateT sTT s) 166 | unsafeTransformIO :: IO a -> Stochastic a 167 | unsafeTransformIO a = 168 | let a' = unsafePerformIO a 169 | in certainly a' 170 | 171 | ----------------------------- 172 | -- For IO only 173 | -- determine continuation for iterator, with the same repeated strategy 174 | determineContinuationPayoffsIO :: 175 | Integer -> 176 | List 177 | [ Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD, 178 | Kleisli CondensedTableV (ActionPD, ActionPD) ActionPD 179 | ] -> 180 | (ActionPD, ActionPD) -> 181 | StateT Vector IO () 182 | determineContinuationPayoffsIO 1 strat action = pure () 183 | determineContinuationPayoffsIO iterator strat action = do 184 | extractContinuation executeStrat action 185 | nextInput <- ST.lift $ extractNextState executeStrat action 186 | determineContinuationPayoffsIO (pred iterator) strat nextInput 187 | where 188 | executeStrat = play prisonersDilemmaCont strat 189 | 190 | -- fix context used for the evaluation 191 | contextCont iterator strat initialAction = MonadContext (pure ((), initialAction)) (\_ action -> determineContinuationPayoffsIO iterator strat action) 192 | 193 | repeatedPDEq iterator strat initialAction = evaluate prisonersDilemmaCont strat context 194 | where 195 | context = contextCont iterator strat initialAction 196 | 197 | printOutput iterator strat initialAction = do 198 | let (result1 :- result2 :- Nil) = repeatedPDEq iterator strat initialAction 199 | result1' <- result1 200 | result2' <- result2 201 | putStrLn "Player1" 202 | print result1' 203 | putStrLn "Player2" 204 | print result2' 205 | 206 | ---------------------------------------------------- 207 | -- This is taken from the other MonteCarloTest setup 208 | -- Needs to be transformed in order to be tested 209 | 210 | -- Add strategy for stage game 211 | stageStrategy :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 212 | stageStrategy = 213 | Kleisli $ 214 | ( \case 215 | (Cooperate, Cooperate) -> playDeterministically Cooperate 216 | (_, _) -> playDeterministically Defect 217 | ) 218 | 219 | -- Stage strategy tuple 220 | strategyTuple = stageStrategy :- stageStrategy :- Nil 221 | 222 | -- Testing for stoch behavior and slow down 223 | stageStrategyTest :: Kleisli Stochastic (ActionPD, ActionPD) ActionPD 224 | stageStrategyTest = Kleisli $ const $ distFromList [(Cooperate, 0.5), (Defect, 0.5)] 225 | 226 | -- Stage strategy tuple 227 | strategyTupleTest = stageStrategyTest :- stageStrategyTest :- Nil 228 | 229 | -- Example usage: 230 | {-- 231 | printOutput 20 (transformStratTuple strategyTupleTest) (Cooperate,Cooperate) 232 | Own util 1 233 | 45.296 234 | Other actions 235 | [43.957,45.309] 236 | Own util 2 237 | 44.944 238 | Other actions 239 | [44.415,45.746]-} 240 | -------------------------------------------------------------------------------- /src/Examples/SequentialMoves.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Examples.SequentialMoves where 6 | 7 | import OpenGames 8 | import OpenGames.Preprocessor 9 | 10 | -------------- 11 | -- 0. Overview 12 | -- This file contains three simple sequential move games: the ultimatum game, the trust game, and a sequential version of rock paper scissors 13 | 14 | ----------------------- 15 | -- 1. Types and payoffs 16 | 17 | -- 1.0 Ultimatum Game 18 | 19 | type Pie = Double 20 | 21 | type Proposal = Double 22 | 23 | data ResponderAction = Accept | Reject 24 | deriving (Eq, Ord, Show) 25 | 26 | ultimatumGamePayoffProposer, ultimatumGamePayoffResponder :: Pie -> Proposal -> ResponderAction -> Payoff 27 | ultimatumGamePayoffProposer pie proposal reaction = 28 | if reaction == Accept then pie - proposal else 0 29 | ultimatumGamePayoffResponder pie proposal reaction = 30 | if reaction == Accept then proposal else 0 31 | 32 | -- 1.1 Trust Game 33 | type Sent = Double 34 | 35 | type SentBack = Double 36 | 37 | type Factor = Double 38 | 39 | trustGamePayoffProposer, trustGamePayoffResponder :: Factor -> Sent -> SentBack -> Payoff 40 | trustGamePayoffProposer factor send reaction = reaction 41 | trustGamePayoffResponder factor proposal reaction = proposal * factor - reaction 42 | 43 | -- 1.2. Sequential rockPaperScissors 44 | data ActionRPS = Rock | Paper | Scissors 45 | deriving (Eq, Ord, Show) 46 | 47 | rockPaperScissorsMatrix :: ActionRPS -> ActionRPS -> Double 48 | rockPaperScissorsMatrix Rock Scissors = 1 49 | rockPaperScissorsMatrix Rock Paper = -1 50 | rockPaperScissorsMatrix Rock Rock = 0 51 | rockPaperScissorsMatrix Scissors Rock = -1 52 | rockPaperScissorsMatrix Scissors Paper = 1 53 | rockPaperScissorsMatrix Scissors Scissors = 0 54 | rockPaperScissorsMatrix Paper Rock = 1 55 | rockPaperScissorsMatrix Paper Scissors = -1 56 | rockPaperScissorsMatrix Paper Paper = -1 57 | 58 | -------------------- 59 | -- 1. Representation 60 | -- 1.0. Ultimatum Game 61 | ultimatumGame pie = 62 | [opengame| 63 | 64 | inputs : ; 65 | feedback : ; 66 | 67 | :----------------------------: 68 | inputs : ; 69 | feedback : ; 70 | operation : dependentDecision "proposer" (const [1..pie]); 71 | outputs : proposal ; 72 | returns : ultimatumGamePayoffProposer pie proposal reaction; 73 | 74 | inputs : proposal ; 75 | feedback : ; 76 | operation : dependentDecision "responder" (const [Accept,Reject]); 77 | outputs : reaction ; 78 | returns : ultimatumGamePayoffResponder pie proposal reaction ; 79 | 80 | :----------------------------: 81 | 82 | outputs : ; 83 | returns : ; 84 | |] 85 | 86 | -- 1.1. Trust Game 87 | trustGame pie factor = 88 | [opengame| 89 | 90 | inputs : ; 91 | feedback : ; 92 | 93 | :----------------------------: 94 | inputs : ; 95 | feedback : ; 96 | operation : dependentDecision "proposer" (const [1..pie]); 97 | outputs : sent ; 98 | returns : trustGamePayoffProposer factor sent sentBack; 99 | 100 | inputs : sent; 101 | feedback : ; 102 | operation : dependentDecision "responder" (\x -> [0,x]); 103 | outputs : sentBack ; 104 | returns : trustGamePayoffResponder factor sent sentBack ; 105 | 106 | :----------------------------: 107 | 108 | outputs : ; 109 | returns : ; 110 | |] 111 | 112 | -- 1.2. A sequential version of Rock Paper Scissors in verbose form 113 | rockPaperScissorsSeqVerbose = 114 | [opengame| 115 | 116 | inputs : ; 117 | feedback : ; 118 | 119 | :----------------------------: 120 | inputs : ; 121 | feedback : ; 122 | operation : dependentDecision "player1" (const [Rock,Paper,Scissors]); 123 | outputs : decisionPlayer1 ; 124 | returns : rockPaperScissorsMatrix decisionPlayer1 decisionPlayer2 ; 125 | 126 | inputs : decisionPlayer1 ; 127 | feedback : ; 128 | operation : dependentDecision "player2" (const [Rock,Paper,Scissors]); 129 | outputs : decisionPlayer2 ; 130 | returns : rockPaperScissorsMatrix decisionPlayer2 decisionPlayer1 ; 131 | 132 | :----------------------------: 133 | 134 | outputs : ; 135 | returns : ; 136 | |] 137 | 138 | -- | Same game in reduced form 139 | rockPaperScissorsSeqReduced = 140 | [opengame| 141 | 142 | inputs : ; 143 | feedback : ; 144 | operation : dependentDecision "player1" (const [Rock,Paper,Scissors]); 145 | outputs : decisionPlayer1 ; 146 | returns : rockPaperScissorsMatrix decisionPlayer1 decisionPlayer2 ; 147 | 148 | inputs : decisionPlayer1 ; 149 | feedback : ; 150 | operation : dependentDecision "player2" (const [Rock,Paper,Scissors]); 151 | outputs : decisionPlayer2 ; 152 | returns : rockPaperScissorsMatrix decisionPlayer2 decisionPlayer1 ; 153 | 154 | |] 155 | 156 | --------------- 157 | -- 2. Analysis 158 | -- 2.0. Ultimatum Game 159 | isEquilibriumUltimatumGame pie strat = generateIsEq $ evaluate (ultimatumGame pie) strat void 160 | 161 | -- proposer plays selfish 162 | proposerSelfishStrategyUG :: Kleisli Stochastic () Proposal 163 | proposerSelfishStrategyUG = pureAction 1 164 | 165 | -- responder accepts all proposals 166 | responderStrategyUG :: Kleisli Stochastic Proposal ResponderAction 167 | responderStrategyUG = pureAction Accept 168 | 169 | -- illustration of another responder strategy 170 | responderStrategy' :: Kleisli Stochastic Proposal ResponderAction 171 | responderStrategy' = Kleisli acceptThreshold 172 | where 173 | acceptThreshold :: Proposal -> Stochastic ResponderAction 174 | acceptThreshold proposal = if proposal > 5 then playDeterministically Accept else uniformDist [Accept, Reject] 175 | 176 | -- strategy Tuple 177 | stratTupleUG = proposerSelfishStrategyUG :- responderStrategyUG :- Nil 178 | 179 | -- Example usage 180 | -- isEquilibriumUltimatumGame 10 stratTupleUG 181 | 182 | -- 2.1. Trust Game 183 | isEquilibriumTrustGame pie factor strat = generateIsEq $ evaluate (trustGame pie factor) strat void 184 | 185 | -- proposer plays selfish 186 | proposerSelfishStrategyTG :: Kleisli Stochastic () Sent 187 | proposerSelfishStrategyTG = pureAction 1 188 | 189 | -- responder sends back nothing 190 | responderSelfishStrategyTG :: Kleisli Stochastic Sent SentBack 191 | responderSelfishStrategyTG = pureAction 0 192 | 193 | -- strategy Tuple 194 | stratTupleTG = proposerSelfishStrategyTG :- responderSelfishStrategyTG :- Nil 195 | 196 | -- Example usage 197 | -- isEquilibriumTrustGame 10 2 stratTupleTG 198 | 199 | -- 2.2. Sequential Rock Paper Scissors 200 | 201 | -- | Equilibrium definition 202 | isEquilibriumRPSSeq strat = generateIsEq $ evaluate rockPaperScissorsSeqReduced strat void 203 | 204 | -- | Fix an arbitrary strategy by player 1 205 | stratPlayer1 :: ActionRPS -> Kleisli Stochastic () ActionRPS 206 | stratPlayer1 x = pureAction x 207 | 208 | -- | Optimal reply by player 2 209 | optimalReplyPlayer2 Paper = playDeterministically Scissors 210 | optimalReplyPlayer2 Rock = playDeterministically Paper 211 | optimalReplyPlayer2 Scissors = playDeterministically Rock 212 | 213 | -- | Fix the winning strategy 214 | stratPlayer2 :: Kleisli Stochastic ActionRPS ActionRPS 215 | stratPlayer2 = Kleisli $ optimalReplyPlayer2 216 | 217 | -- | Define the strategy tuple for two players 218 | stratTupleRPSSSeq actionPlayer1 = stratPlayer1 actionPlayer1 :- stratPlayer2 :- Nil 219 | 220 | -- Example usage 221 | -- isEquilibriumRPSSSeq (stratTuple Rock) 222 | -------------------------------------------------------------------------------- /src/Examples/SimultaneousMoves.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Examples.SimultaneousMoves where 6 | 7 | import OpenGames 8 | import OpenGames.Preprocessor 9 | 10 | -------------- 11 | -- 0. Overview 12 | -- This file contains three simple simultaneous move games: prisoner dilemma (a social dilemma), meeting in new york (coordination game), and matching pennies (anti-coordination game) 13 | 14 | ----------------------- 15 | -- 1. Types and payoffs 16 | 17 | -- 1.0. Prisoner's dilemma 18 | data ActionPD = Cooperate | Defect 19 | deriving (Eq, Ord, Show) 20 | 21 | -- | Payoff matrix for player i given i's action and j's action 22 | prisonersDilemmaMatrix :: ActionPD -> ActionPD -> Payoff 23 | prisonersDilemmaMatrix Cooperate Cooperate = 3 24 | prisonersDilemmaMatrix Cooperate Defect = 0 25 | prisonersDilemmaMatrix Defect Cooperate = 5 26 | prisonersDilemmaMatrix Defect Defect = 1 27 | 28 | -- 1.1. Meeting in New York 29 | data Location = EmpireState | GrandCentral deriving (Eq, Ord, Show) 30 | 31 | -- | Payoff matrix for player i and j 32 | meetingInNYMatrix :: Location -> Location -> Payoff 33 | meetingInNYMatrix x y = if x == y then 1 else 0 34 | 35 | -- 1.2. Matching pennies 36 | data Coin = Heads | Tails 37 | deriving (Eq, Ord, Show) 38 | 39 | -- | Payoff matrix for player 1 and player 2 40 | -- NOTE: We use two functions here as payoffs are asymmetric 41 | -- This results in differences how we use payoffs in the game definition below 42 | matchingPenniesMatrix1, matchingPenniesMatrix2 :: Coin -> Coin -> Payoff 43 | matchingPenniesMatrix1 x y = if x == y then 1 else 0 44 | matchingPenniesMatrix2 x y = if x == y then 0 else 1 45 | 46 | -------------------- 47 | -- 1. Representation 48 | -- 1.0 Prisoner's dilemma 49 | 50 | -- | Prisoner's dilemma in verbose form 51 | -- NOTE there are no ingoing or outgoing arrows 52 | -- This is a feature that any representation of a classical game shares 53 | -- NOTE the switch of the payoff 54 | prisonersDilemmaVerbose = 55 | [opengame| 56 | 57 | inputs : ; 58 | feedback : ; 59 | 60 | :----------------------------: 61 | inputs : ; 62 | feedback : ; 63 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 64 | outputs : decisionPlayer1 ; 65 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 ; 66 | 67 | inputs : ; 68 | feedback : ; 69 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 70 | outputs : decisionPlayer2 ; 71 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 ; 72 | 73 | :----------------------------: 74 | 75 | outputs : ; 76 | returns : ; 77 | |] 78 | 79 | -- | Same game as above but without empty fields 80 | prisonersDilemmaReduced = 81 | [opengame| 82 | 83 | operation : dependentDecision "player1" (const [Cooperate,Defect]); 84 | outputs : decisionPlayer1 ; 85 | returns : prisonersDilemmaMatrix decisionPlayer1 decisionPlayer2 ; 86 | 87 | operation : dependentDecision "player2" (const [Cooperate,Defect]); 88 | outputs : decisionPlayer2 ; 89 | returns : prisonersDilemmaMatrix decisionPlayer2 decisionPlayer1 ; 90 | 91 | |] 92 | 93 | -- 1.1 Meeting in New York 94 | meetingInNYReduced = 95 | [opengame| 96 | 97 | operation : dependentDecision "player1" (const [EmpireState,GrandCentral]); 98 | outputs : decisionPlayer1 ; 99 | returns : meetingInNYMatrix decisionPlayer1 decisionPlayer2 ; 100 | 101 | operation : dependentDecision "player2" (const [EmpireState,GrandCentral]); 102 | outputs : decisionPlayer2 ; 103 | returns : meetingInNYMatrix decisionPlayer2 decisionPlayer1 ; 104 | 105 | |] 106 | 107 | -- 1.2. Matching pennies 108 | matchingPenniesReduced = 109 | [opengame| 110 | 111 | operation : dependentDecision "player1" (const [Heads, Tails]) ; 112 | outputs : decisionPlayer1 ; 113 | returns : matchingPenniesMatrix1 decisionPlayer1 decisionPlayer2 ; 114 | 115 | operation : dependentDecision "player1" (const [Heads, Tails]) ; 116 | outputs : decisionPlayer2 ; 117 | returns : matchingPenniesMatrix2 decisionPlayer2 decisionPlayer1 ; 118 | 119 | |] 120 | 121 | -------------------------- 122 | -- 2. Equilibrium analysis 123 | -- We provide ways to evaluate the games as well as example strategies which are in equilibrium 124 | 125 | -- 2.0. Prisoner's dilemma 126 | 127 | -- | Evaluate the prisoner's dilemma 128 | -- This function expects a strategy tuple and checks whether this strategy is in equilibrium 129 | -- NOTE As for the other games, we give a _void_ context to the _evaluate_ function as there is no ingoing and outgoing information flow 130 | isEquilibriumPrisonersDilemma strat = generateIsEq $ evaluate prisonersDilemmaReduced strat void 131 | 132 | -- | Define pure single player strategies 133 | cooperateStrategy :: Kleisli Stochastic () ActionPD 134 | cooperateStrategy = pureAction Cooperate 135 | -- ^ play _Cooperate_ with certainty 136 | 137 | defectStrategy :: Kleisli Stochastic () ActionPD 138 | defectStrategy = pureAction Defect 139 | -- ^ play _Defect_ with certainty 140 | 141 | -- | Combine single player's strategies into a tuple 142 | strategTupleCooperate = cooperateStrategy :- cooperateStrategy :- Nil 143 | -- ^ Both players cooperate with certainty 144 | 145 | strategTupleDefect = defectStrategy :- defectStrategy :- Nil 146 | -- ^ Both players defect with certainty 147 | 148 | -- isEquilibriumPrisonersDilemma strategTupleCooperate -- NOT an eq 149 | -- isEquilibriumPrisonersDilemma strategTupleDefect -- eq 150 | 151 | -- 2.1 Meeting in New York 152 | 153 | -- | Evaluate the meeting in New York game 154 | isEquilibriumMeetingInNY strat = generateIsEq $ evaluate meetingInNYReduced strat void 155 | 156 | -- | Define pure single player strategies 157 | empireStateStrategy :: Kleisli Stochastic () Location 158 | empireStateStrategy = pureAction EmpireState 159 | -- ^ play _EmpireState_ with certainty 160 | 161 | grandCentralStrategy :: Kleisli Stochastic () Location 162 | grandCentralStrategy = pureAction GrandCentral 163 | -- ^ play _GrandCentral_ with certainty 164 | 165 | -- | Combine single player's strategies into a tuple 166 | strategyTupleEmpireState = empireStateStrategy :- empireStateStrategy :- Nil 167 | -- ^ Both players meet at EmpireState with certainty 168 | 169 | strategyTupleGrandCentral = grandCentralStrategy :- grandCentralStrategy :- Nil 170 | -- ^ Both players meet at EmpireState with certainty 171 | 172 | strategyTupleGrandAndEmpire = grandCentralStrategy :- empireStateStrategy :- Nil 173 | -- ^ Player 1 meets at grand central and player 2 meets at empire state 174 | 175 | -- isEquilibriumMeetingInNY strategyTupleGrandAndEmpire - NOT eq 176 | -- isEquilibriumMeetingInNY strategyTupleEmpireState - eq 177 | -- isEquilibriumMeetingInNY strategyTupleGrandCentral - eq 178 | 179 | -- 2.2 Matching Pennies 180 | 181 | -- | Evaluate the meeting in New York game 182 | isEquilibriumMatchingPennies strat = generateIsEq $ evaluate matchingPenniesReduced strat void 183 | 184 | -- | Define pure single player strategies 185 | headsStrategy :: Kleisli Stochastic () Coin 186 | headsStrategy = pureAction Heads 187 | -- ^ play _Heads_ with certainty 188 | 189 | tailsStrategy :: Kleisli Stochastic () Coin 190 | tailsStrategy = pureAction Tails 191 | -- ^ play _Tails_ with certainty 192 | 193 | -- | Define MIXED single player strategy 194 | uniformActionDist = uniformDist [Heads, Tails] 195 | -- ^ Define the uniform distribution on action space 196 | 197 | mixedStrategy = Kleisli $ const uniformActionDist 198 | -- ^ Define proper mixed strategy 199 | 200 | -- | Combine single player's strategies into a tuple 201 | strategyTupleHeads = headsStrategy :- headsStrategy :- Nil 202 | -- ^ Both players meet at EmpireState with certainty 203 | 204 | strategyTupleTails = tailsStrategy :- tailsStrategy :- Nil 205 | -- ^ Both players meet at EmpireState with certainty 206 | 207 | strategyTupleMixed = mixedStrategy :- mixedStrategy :- Nil 208 | -- ^ Both players choose both action with equal probability 209 | 210 | -- isEquilibriumMatchingPennies strategyTupleHeads - NOT an eq 211 | -- isEquilibriumMatchingPennies strategyTupleTails - NOT an eq 212 | -- isEquilibriumMatchingPennies strategyTupleMixed - is an eq 213 | -------------------------------------------------------------------------------- /src/Examples/Token/Concrete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Examples.Token.Concrete where 6 | 7 | -- - concrete token 8 | -- - abstract token 9 | -- - 10 | 11 | import Data.HashMap as M 12 | import Data.Maybe 13 | import OpenGames 14 | import OpenGames.Preprocessor 15 | 16 | type Address = String 17 | 18 | type TokenState = (Map Address Int) 19 | 20 | balance :: Address -> TokenState -> Int 21 | balance add st = fromMaybe 0 (M.lookup add (st)) 22 | 23 | set :: Address -> Int -> TokenState -> TokenState 24 | set = M.insert 25 | 26 | transfer :: Address -> Address -> Int -> TokenState -> TokenState 27 | transfer source target amount st = 28 | let local = balance source st 29 | in if local < amount 30 | then st 31 | else 32 | let s1 = set source (local - amount) st 33 | in set target (balance target s1 + amount) s1 34 | 35 | data Action 36 | = Transfer Address Address Int 37 | deriving (Show, Eq, Ord) 38 | 39 | performOperation :: (Action, TokenState) -> TokenState 40 | performOperation (Transfer from to x, st) = transfer from to x st 41 | 42 | generateActions :: [Address] -> [Int] -> [Action] 43 | generateActions actors amounts = do 44 | p1 <- actors 45 | p2 <- actors 46 | a <- amounts 47 | pure (Transfer p1 p2 a) 48 | 49 | at :: [a] -> Int -> a 50 | at = (!!) 51 | 52 | initialState :: TokenState 53 | initialState = M.insert "player2" 20 empty 54 | 55 | defaultContext :: StochasticStatefulContext TokenState () TokenState () 56 | defaultContext = 57 | let h = return ((), initialState) 58 | k () = const $ return () 59 | in StochasticStatefulContext h k 60 | 61 | transferGame playerIndex addresses amounts = 62 | [opengame| 63 | 64 | inputs : state ; 65 | 66 | :---: 67 | 68 | inputs : state ; 69 | operation : dependentDecision (at addresses playerIndex) (const $ generateActions addresses amounts) ; 70 | outputs : action ; 71 | returns : fromIntegral $ balance (at addresses playerIndex) newState ; 72 | 73 | inputs : action, state ; 74 | operation : fromFunctions performOperation id ; 75 | outputs : newState ; 76 | 77 | :---: 78 | 79 | outputs : newState; |] 80 | 81 | defaultAmounts :: [Int] 82 | defaultAmounts = [0, 5, 10] 83 | 84 | defaultAddresses = ["player1", "player2", "player3"] 85 | 86 | player0 = transferGame 0 defaultAddresses defaultAmounts 87 | 88 | player1 = transferGame 1 defaultAddresses defaultAmounts 89 | 90 | player2 = transferGame 2 defaultAddresses defaultAmounts 91 | 92 | evaluated = 93 | evaluate 94 | (player0 >>> player1 >>> player2) 95 | ( pure (Transfer "player2" "player1" 10) 96 | :- pure (Transfer "player1" "player2" 10) 97 | :- pure (Transfer "player2" "player3" 10) 98 | :- Nil 99 | ) 100 | defaultContext 101 | -------------------------------------------------------------------------------- /src/Graphics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Graphics where 8 | 9 | import Control.Lens.Combinators 10 | import Data.Data.Lens 11 | import Data.Graph.Inductive.Graph 12 | import Data.Graph.Inductive.PatriciaTree 13 | import Data.GraphViz as GV hiding (Both) 14 | import Data.Maybe 15 | import Debug.Trace 16 | import Language.Haskell.TH 17 | import OpenGames.Preprocessor.BlockSyntax 18 | 19 | freshLabel :: [String] -> [LNode String] 20 | freshLabel = freshLabelsStateful 0 21 | where 22 | freshLabelsStateful :: Int -> [String] -> [LNode String] 23 | freshLabelsStateful curr [] = [] 24 | freshLabelsStateful curr (n : ns) = (curr, n) : freshLabelsStateful (curr + 1) ns 25 | 26 | -- | A Data type to store tell if an edge label is a covariant or contravariant arrow in the graph 27 | data ArrowType = Contravariant String | Covariant String | Both String 28 | deriving (Show, Eq) 29 | 30 | -- | ArrowTypes are labellable using the string they wrap 31 | instance Labellable ArrowType where 32 | toLabelValue (Contravariant s) = toLabelValue s 33 | toLabelValue (Covariant s) = toLabelValue s 34 | toLabelValue (Both x) = undefined 35 | 36 | -- | An expression contains the name `Name` if any of the constructor of `Exp` uses it 37 | containsName :: Name -> Exp -> Bool 38 | containsName nm exp = trace ("searching for " ++ show nm ++ " in expression " ++ show exp) $ anyOf (template @Exp @Name) (== nm) exp 39 | 40 | -- | Swap the two elements of a pair 41 | swap :: (a, b) -> (b, a) 42 | swap (a, b) = (b, a) 43 | 44 | isOpposite :: ArrowType -> ArrowType -> Bool 45 | isOpposite (Covariant _) (Contravariant _) = True 46 | isOpposite (Contravariant _) (Covariant _) = True 47 | isOpposite _ _ = False 48 | 49 | getName :: ArrowType -> String 50 | getName (Covariant nm) = nm 51 | getName (Contravariant nm) = nm 52 | getName (Graphics.Both nm) = nm 53 | 54 | remove :: Int -> [a] -> [a] 55 | remove 0 (x : xs) = xs 56 | remove n (y : ys) = y : remove (n - 1) ys 57 | remove _ _ = error "cannot remove from an empty list" 58 | 59 | convertBoth :: (a -> a -> Bool) -> (a -> a) -> [a] -> [a] 60 | convertBoth test map [] = [] 61 | convertBoth test map (a : as) = case ifind (const $ test a) as of 62 | Just (idx, val) -> map val : convertBoth test map (remove idx as) 63 | Nothing -> a : convertBoth test map as 64 | 65 | -- | Return all the edges from one `Line` 66 | getEdgesFromName :: 67 | -- | The name of the line 68 | Name -> 69 | -- | The id of the line 70 | Int -> 71 | -- | The list of all the other lines 72 | [Line (String, Int) Pat Exp] -> 73 | -- | The list of edges from the line with given name and id to all the other lines 74 | [LEdge ArrowType] 75 | getEdgesFromName name id lines = 76 | [ (id, snd (label ln), Contravariant (show name)) 77 | | ln <- lines, 78 | any (containsName name) ((contravariantInputs ln)) 79 | ] 80 | ++ [ (id, snd (label ln), Covariant (show name)) 81 | | ln <- lines, 82 | any (containsName name) ((covariantInputs ln)) 83 | ] 84 | 85 | -- | Get the edges for all lines by looking at each covariant and contravariant outputs and mapping it to the list 86 | -- of lines which references them. 87 | getEdges :: [Line (String, Int) Pat Exp] -> Line (String, Int) Pat Exp -> [LEdge ArrowType] 88 | getEdges allLines line = 89 | let outputs = traverse getName (covariantOutputs line ++ contravariantOutputs line) 90 | labels = concat [getEdgesFromName x (snd . label $ line) allLines | x <- fromMaybe [] outputs] 91 | in labels 92 | where 93 | getName :: Pat -> Maybe Name 94 | getName (VarP n) = Just n 95 | getName _ = Nothing 96 | 97 | -- | Convert a line with optional labels to lines with a label and an id 98 | -- if the line has no label the label will be `line_id_n` where `n` is the id of the line 99 | convertLines :: [Line (Maybe String) Pat Exp] -> [Line (String, Int) Pat Exp] 100 | convertLines ln = convertLinesRec 0 ln 101 | where 102 | convertLinesRec :: Int -> [Line (Maybe String) Pat Exp] -> [Line (String, Int) Pat Exp] 103 | convertLinesRec n [] = [] 104 | convertLinesRec n (Line nm a b c d e : ls) = Line (fromMaybe ("line_id_" ++ show n) nm, n) a b c d e : convertLinesRec (n + 1) ls 105 | 106 | -- | Build a graph using lines as nodes and argument dependency for nodes 107 | toGraph :: [Line (String, Int) Pat Exp] -> Gr String ArrowType 108 | toGraph ln = 109 | let edges = concat $ map (getEdges ln) ln 110 | in mkGraph (map (swap . label) ln) (trace ("edges are " ++ show edges) edges) 111 | 112 | -- | Given a block, convert it into a graph using all lines as nodes and dependencies between them as arrows 113 | convertBlock :: Block Pat Exp -> Gr String ArrowType 114 | convertBlock = toGraph . convertLines . blockLines 115 | -------------------------------------------------------------------------------- /src/OpenGames.hs: -------------------------------------------------------------------------------- 1 | module OpenGames 2 | ( module OG, 3 | Kleisli (..), 4 | ) 5 | where 6 | 7 | import OpenGames.Engine.Diagnostics as OG 8 | import OpenGames.Engine.Engine as OG 9 | import OpenGames.Engine.TLL as OG 10 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/AtomicGames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module OpenGames.Engine.AtomicGames 7 | ( decision, 8 | decisionNoObs, 9 | forwardFunction, 10 | backwardFunction, 11 | natureDraw, 12 | liftStochasticForward, 13 | ) 14 | where 15 | 16 | import OpenGames.Engine.BayesianGames 17 | import OpenGames.Engine.OpenGames 18 | import OpenGames.Engine.OpticClass 19 | import OpenGames.Preprocessor 20 | 21 | --------------------------------------- 22 | -- 0. A single action making a generic -- parameterized -- decision 23 | decision actionSpace payoffFunction playerName = 24 | [opengame| 25 | 26 | inputs : x ; 27 | feedback : ; 28 | 29 | :-----: 30 | inputs : x ; 31 | feedback : ; 32 | operation : dependentDecision playerName (\y -> actionSpace) ; 33 | outputs : y ; 34 | returns : payoffFunction y x r ; 35 | :-----: 36 | 37 | outputs : y ; 38 | returns : r ; 39 | 40 | |] 41 | 42 | -- 1. A single action making a decision without prior observations 43 | decisionNoObs actionSpace payoffFunction playerName = 44 | [opengame| 45 | 46 | inputs : ; 47 | feedback : ; 48 | 49 | :-----: 50 | inputs : ; 51 | feedback : ; 52 | operation : dependentDecision playerName (\y -> actionSpace) ; 53 | outputs : y ; 54 | returns : payoffFunction y r ; 55 | :-----: 56 | 57 | outputs : y ; 58 | returns : r ; 59 | 60 | |] 61 | 62 | -- 2. "Forward" (covariant) function: from past to future 63 | forwardFunction function = 64 | [opengame| 65 | 66 | inputs : x ; 67 | feedback : ; 68 | 69 | :-----: 70 | inputs : x ; 71 | feedback : ; 72 | operation : fromFunctions function id ; 73 | outputs : y ; 74 | returns : ; 75 | :-----: 76 | 77 | outputs : y ; 78 | returns : ; 79 | 80 | |] 81 | 82 | -- 3. "Backward" (contravariant) function: from future to past 83 | backwardFunction function = 84 | [opengame| 85 | 86 | inputs : ; 87 | feedback : s ; 88 | 89 | :-----: 90 | inputs : ; 91 | feedback : ; 92 | operation : fromFunctions id function ; 93 | outputs : s ; 94 | returns : r ; 95 | :-----: 96 | 97 | outputs : ; 98 | returns : r ; 99 | 100 | |] 101 | 102 | -- 4. Drawing from a probability distribution 103 | natureDraw distribution = 104 | [opengame| 105 | 106 | inputs : ; 107 | feedback : ; 108 | 109 | :-----: 110 | inputs : ; 111 | feedback : ; 112 | operation : nature distribution ; 113 | outputs : draw ; 114 | returns : ; 115 | :-----: 116 | 117 | outputs : draw ; 118 | returns : ; 119 | 120 | |] 121 | 122 | -- 5. lift a stochasticProcess forward 123 | liftStochasticForward process = 124 | [opengame| 125 | 126 | inputs : x ; 127 | feedback : ; 128 | 129 | :-----: 130 | inputs : x ; 131 | feedback : ; 132 | operation : liftStochastic process; 133 | outputs : draw ; 134 | returns : ; 135 | :-----: 136 | 137 | outputs : draw ; 138 | returns : ; 139 | 140 | |] 141 | 142 | -- generateGame "pureDecision2" ["actionSpace","payoffFunction","playerName"] $ 143 | -- (Block ["observation"] [] 144 | -- [mkLine [[|observation|]] [] [|dependentDecision playerName (\y -> actionSpace)|] ["action"] [[|payoffFunction observation action returns|]]] 145 | -- [[|action|]] ["returns"]) 146 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/BayesianGamesNonState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module OpenGames.Engine.BayesianGamesNonState 11 | ( StochasticBayesianOpenGame (..), 12 | dependentDecision, 13 | dependentEpsilonDecision, 14 | fromLens, 15 | fromFunctions, 16 | nature, 17 | liftStochastic, 18 | uniformDist, 19 | distFromList, 20 | pureAction, 21 | playDeterministically, 22 | ) 23 | where 24 | 25 | import Control.Arrow hiding ((+:+)) 26 | import Data.Foldable 27 | import Data.Ord (comparing) 28 | import Numeric.Probability.Distribution hiding (filter, lift, map) 29 | import OpenGames.Engine.Diagnostics 30 | import OpenGames.Engine.OpenGames hiding (lift) 31 | import OpenGames.Engine.OpticClass 32 | import OpenGames.Engine.TLL 33 | 34 | --------------------------------------------- 35 | -- Reimplements stateful bayesian from before 36 | 37 | type StochasticBayesianOpenGame a b x s y r = OpenGame StochasticOptic StochasticContext a b x s y r 38 | 39 | type Agent = String 40 | 41 | support :: Stochastic x -> [x] 42 | support = map fst . decons 43 | 44 | bayes :: (Eq y) => Stochastic (x, y) -> y -> Stochastic x 45 | bayes a y = mapMaybe (\(x, y') -> if y' == y then Just x else Nothing) a 46 | 47 | deviationsInContext :: 48 | (Show x, Show y, Ord y, Show theta) => 49 | Double -> 50 | Agent -> 51 | x -> 52 | theta -> 53 | Stochastic y -> 54 | (y -> Double) -> 55 | [y] -> 56 | [DiagnosticInfoBayesian x y] 57 | deviationsInContext epsilon name x theta strategy u ys = 58 | [ DiagnosticInfoBayesian 59 | { equilibrium = strategicPayoff >= optimalPayoff - epsilon, 60 | player = name, 61 | payoff = strategicPayoff, 62 | optimalMove = optimalPlay, 63 | optimalPayoff = optimalPayoff, 64 | context = u, 65 | state = x, 66 | unobservedState = show theta, 67 | strategy = strategy 68 | } 69 | ] 70 | where 71 | strategicPayoff = expected (fmap u strategy) 72 | (optimalPlay, optimalPayoff) = maximumBy (comparing snd) [(y, u y) | y <- ys] 73 | 74 | dependentDecision :: (Eq x, Show x, Ord y, Show y) => String -> (x -> [y]) -> StochasticBayesianOpenGame '[Kleisli Stochastic x y] '[[DiagnosticInfoBayesian x y]] x () y Double 75 | dependentDecision name ys = 76 | OpenGame 77 | { play = \(a :- Nil) -> 78 | let v x = do y <- runKleisli a x; return ((), y) 79 | u () _ = return () 80 | in StochasticOptic v u, 81 | evaluate = \(a :- Nil) (StochasticContext h k) -> 82 | ( concat 83 | [ let u y = 84 | expected 85 | ( do 86 | t <- (bayes h x) 87 | k t y 88 | ) 89 | strategy = runKleisli a x 90 | in deviationsInContext 0 name x theta strategy u (ys x) 91 | | (theta, x) <- support h 92 | ] 93 | ) 94 | :- Nil 95 | } 96 | 97 | dependentEpsilonDecision :: (Eq x, Show x, Ord y, Show y) => Double -> String -> (x -> [y]) -> StochasticBayesianOpenGame '[Kleisli Stochastic x y] '[[DiagnosticInfoBayesian x y]] x () y Double 98 | dependentEpsilonDecision epsilon name ys = 99 | OpenGame 100 | { play = \(a :- Nil) -> 101 | let v x = do y <- runKleisli a x; return ((), y) 102 | u () _ = return () 103 | in StochasticOptic v u, 104 | evaluate = \(a :- Nil) (StochasticContext h k) -> 105 | ( concat 106 | [ let u y = 107 | expected 108 | ( do 109 | t <- (bayes h x) 110 | k t y 111 | ) 112 | strategy = runKleisli a x 113 | in deviationsInContext epsilon name x theta strategy u (ys x) 114 | | (theta, x) <- support h 115 | ] 116 | ) 117 | :- Nil 118 | } 119 | 120 | -- Support functionality for constructing open games 121 | fromLens :: (x -> y) -> (x -> r -> s) -> StochasticBayesianOpenGame '[] '[] x s y r 122 | fromLens v u = 123 | OpenGame 124 | { play = \Nil -> StochasticOptic (\x -> return (x, v x)) (\x r -> return (u x r)), 125 | evaluate = \Nil _ -> Nil 126 | } 127 | 128 | fromFunctions :: (x -> y) -> (r -> s) -> StochasticBayesianOpenGame '[] '[] x s y r 129 | fromFunctions f g = fromLens f (const g) 130 | 131 | nature :: Stochastic x -> StochasticBayesianOpenGame '[] '[] () () x () 132 | nature a = 133 | OpenGame 134 | { play = \Nil -> StochasticOptic (\() -> do x <- a; return ((), x)) (\() () -> return ()), 135 | evaluate = \Nil _ -> Nil 136 | } 137 | 138 | liftStochastic :: (x -> Stochastic y) -> StochasticBayesianOpenGame '[] '[] x () y () 139 | liftStochastic f = 140 | OpenGame 141 | { play = \Nil -> StochasticOptic (\x -> do y <- f x; return ((), y)) (\() () -> return ()), 142 | evaluate = \_ _ -> Nil 143 | } 144 | 145 | -- Support functionality for stochastic processes (also interface to the probability module in use) 146 | 147 | -- uniform distribution 148 | uniformDist = uniform 149 | 150 | -- tailored distribution from a list 151 | distFromList = fromFreqs 152 | 153 | -- pure action (no randomization) 154 | pureAction x = Kleisli $ const $ certainly x 155 | 156 | playDeterministically :: a -> Stochastic a 157 | playDeterministically = certainly 158 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module OpenGames.Engine.Diagnostics 13 | ( DiagnosticInfoBayesian (..), 14 | generateOutput, 15 | generateIsEq, 16 | ) 17 | where 18 | 19 | import OpenGames.Engine.OpticClass 20 | import OpenGames.Engine.TLL 21 | 22 | -------------------------------------------------------- 23 | -- Diagnosticinformation and processesing of information 24 | -- for standard game-theoretic analysis 25 | 26 | -- Defining the necessary types for outputting information of a BayesianGame 27 | data DiagnosticInfoBayesian x y = DiagnosticInfoBayesian 28 | { equilibrium :: Bool, 29 | player :: String, 30 | optimalMove :: y, 31 | strategy :: Stochastic y, 32 | optimalPayoff :: Double, 33 | context :: (y -> Double), 34 | payoff :: Double, 35 | state :: x, 36 | unobservedState :: String 37 | } 38 | 39 | -- prepare string information for Bayesian game 40 | showDiagnosticInfo :: (Show y, Ord y, Show x) => DiagnosticInfoBayesian x y -> String 41 | showDiagnosticInfo info = 42 | "\n" 43 | ++ "Player: " 44 | ++ player info 45 | ++ "\n" 46 | ++ "Optimal Move: " 47 | ++ (show $ optimalMove info) 48 | ++ "\n" 49 | ++ "Current Strategy: " 50 | ++ (show $ strategy info) 51 | ++ "\n" 52 | ++ "Optimal Payoff: " 53 | ++ (show $ optimalPayoff info) 54 | ++ "\n" 55 | ++ "Current Payoff: " 56 | ++ (show $ payoff info) 57 | ++ "\n" 58 | ++ "Observable State: " 59 | ++ (show $ state info) 60 | ++ "\n" 61 | ++ "Unobservable State: " 62 | ++ (show $ unobservedState info) 63 | 64 | -- output string information for a subgame expressions containing information from several players - bayesian 65 | showDiagnosticInfoL :: (Show y, Ord y, Show x) => [DiagnosticInfoBayesian x y] -> String 66 | showDiagnosticInfoL [] = "\n --No more information--" 67 | showDiagnosticInfoL (x : xs) = showDiagnosticInfo x ++ "\n --other game-- " ++ showDiagnosticInfoL xs 68 | 69 | -- checks equilibrium and if not outputs relevant deviations 70 | checkEqL :: (Show y, Ord y, Show x) => [DiagnosticInfoBayesian x y] -> String 71 | checkEqL ls = 72 | let xs = fmap equilibrium ls 73 | ys = filter (\x -> equilibrium x == False) ls 74 | isEq = and xs 75 | in if isEq == True 76 | then "\n Strategies are in equilibrium" 77 | else "\n Strategies are NOT in equilibrium. Consider the following profitable deviations: \n" ++ showDiagnosticInfoL ys 78 | 79 | ---------------------------------------------------------- 80 | -- providing the relevant functionality at the type level 81 | -- for show output 82 | 83 | data ShowDiagnosticOutput = ShowDiagnosticOutput 84 | 85 | instance (Show y, Ord y, Show x) => Apply ShowDiagnosticOutput [DiagnosticInfoBayesian x y] String where 86 | apply _ x = showDiagnosticInfoL x 87 | 88 | data PrintIsEq = PrintIsEq 89 | 90 | instance (Show y, Ord y, Show x) => Apply PrintIsEq [DiagnosticInfoBayesian x y] String where 91 | apply _ x = checkEqL x 92 | 93 | instance (Show y, Ord y, Show x) => Apply PrintIsEq (Maybe [DiagnosticInfoBayesian x y]) String where 94 | apply _ x = checkEqL (maybe [] id x) 95 | 96 | data PrintOutput = PrintOutput 97 | 98 | instance (Show y, Ord y, Show x) => Apply PrintOutput [DiagnosticInfoBayesian x y] String where 99 | apply _ x = showDiagnosticInfoL x 100 | 101 | instance (Show y, Ord y, Show x) => Apply PrintOutput (Maybe [DiagnosticInfoBayesian x y]) String where 102 | apply _ x = showDiagnosticInfoL (maybe [] id x) 103 | 104 | data Concat = Concat 105 | 106 | instance Apply Concat String (String -> String) where 107 | apply _ x = \y -> x ++ "\n NEWGAME: \n" ++ y 108 | 109 | --------------------- 110 | -- main functionality 111 | 112 | -- all information for all players 113 | generateOutput :: 114 | forall xs. 115 | ( MapL PrintOutput xs (ConstMap String xs), 116 | FoldrL Concat String (ConstMap String xs) 117 | ) => 118 | List xs -> 119 | IO () 120 | generateOutput hlist = 121 | putStrLn $ 122 | "----Analytics begin----" ++ (foldrL Concat "" $ mapL @_ @_ @(ConstMap String xs) PrintOutput hlist) ++ "----Analytics end----\n" 123 | 124 | -- output equilibrium relevant information 125 | generateIsEq :: 126 | forall xs. 127 | ( MapL PrintIsEq xs (ConstMap String xs), 128 | FoldrL Concat String (ConstMap String xs) 129 | ) => 130 | List xs -> 131 | IO () 132 | generateIsEq hlist = 133 | putStrLn $ 134 | "----Analytics begin----" ++ (foldrL Concat "" $ mapL @_ @_ @(ConstMap String xs) PrintIsEq hlist) ++ "----Analytics end----\n" 135 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/Engine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitNamespaces #-} 2 | 3 | module OpenGames.Engine.Engine 4 | ( decision, 5 | decisionNoObs, 6 | forwardFunction, 7 | backwardFunction, 8 | nature, 9 | natureDraw, 10 | liftStochasticForward, 11 | StochasticStatefulBayesianOpenGame (..), 12 | Agent (..), 13 | Payoff (..), 14 | dependentDecision, 15 | dependentEpsilonDecision, 16 | fromFunctions, 17 | fromLens, 18 | uniformDist, 19 | distFromList, 20 | pureAction, 21 | playDeterministically, 22 | discount, 23 | DiagnosticInfoBayesian (..), 24 | generateOutput, 25 | generateIsEq, 26 | OpenGame (..), 27 | lift, 28 | reindex, 29 | (>>>), 30 | (&&&), 31 | Stochastic (..), 32 | Vector (..), 33 | StochasticStatefulOptic (..), 34 | StochasticStatefulContext (..), 35 | StochasticOptic (..), 36 | StochasticContext (..), 37 | MonadOptic (..), 38 | MonadContext (..), 39 | Optic (..), 40 | Precontext (..), 41 | Context (..), 42 | ContextAdd (..), 43 | identity, 44 | List (..), 45 | Apply (..), 46 | Unappend (..), 47 | MapL (..), 48 | FoldrL (..), 49 | ConstMap (..), 50 | SequenceList (..), 51 | IndexList (..), 52 | type (+:+), 53 | (+:+), 54 | Kleisli (..), 55 | ) 56 | where 57 | 58 | -- \| File organizes the imports of the engine to streamline the import of relevant functionality 59 | 60 | import Control.Arrow (Kleisli (..)) 61 | import OpenGames.Engine.AtomicGames 62 | import OpenGames.Engine.BayesianGames hiding (liftStochastic) 63 | import OpenGames.Engine.Diagnostics 64 | import OpenGames.Engine.OpenGames 65 | import OpenGames.Engine.OpticClass 66 | import OpenGames.Engine.TLL 67 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/IOGames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module OpenGames.Engine.IOGames 14 | ( IOOpenGame (..), 15 | Agent (..), 16 | DiagnosticsMC (..), 17 | dependentDecisionIO, 18 | fromLens, 19 | fromFunctions, 20 | nature, 21 | discount, 22 | ) 23 | where 24 | 25 | import Control.Arrow hiding ((+:+)) 26 | import Control.Monad.State hiding (state) 27 | import Data.Foldable 28 | import Data.HashMap as HM hiding (map, mapMaybe, null) 29 | import Data.Ord (comparing) 30 | import Data.Utils 31 | import OpenGames.Engine.OpenGames hiding (lift) 32 | import OpenGames.Engine.OpticClass 33 | import OpenGames.Engine.TLL 34 | import System.Random 35 | import System.Random.MWC.CondensedTable 36 | import System.Random.Stateful 37 | 38 | -- TODO implement printout 39 | 40 | type IOOpenGame a b x s y r = OpenGame MonadOptic MonadContext a b x s y r 41 | 42 | type Agent = String 43 | 44 | data DiagnosticsMC y = DiagnosticsMC 45 | { playerNameMC :: String, 46 | averageUtilStrategyMC :: Double, 47 | samplePayoffsMC :: [Double], 48 | optimalMoveMC :: y, 49 | optimalPayoffMC :: Double 50 | } 51 | deriving (Show) 52 | 53 | -- NOTE This ignores the state 54 | dependentDecisionIO :: (Eq x, Show x, Ord y, Show y) => String -> Int -> [y] -> IOOpenGame '[Kleisli CondensedTableV x y] '[IO (DiagnosticsMC y)] x () y Double 55 | -- s t a b 56 | 57 | -- ^ (average utility of current strategy, [average utility of all possible alternative actions]) 58 | dependentDecisionIO name sampleSize ys = OpenGame {play, evaluate} 59 | where 60 | -- \^ ys is the list of possible actions 61 | play = \(strat :- Nil) -> 62 | let v x = do 63 | g <- newStdGen 64 | gS <- newIOGenM g 65 | action <- genFromTable (runKleisli strat x) gS 66 | return ((), action) 67 | u () r = modify (adjustOrAdd (+ r) r name) 68 | in MonadOptic v u 69 | 70 | evaluate (strat :- Nil) (MonadContext h k) = output :- Nil 71 | where 72 | output = do 73 | zippedLs <- samplePayoffs 74 | let samplePayoffs' = map snd zippedLs 75 | let (optimalPlay, optimalPayoff0) = maximumBy (comparing snd) zippedLs 76 | (currentMove, averageUtilStrategy') <- averageUtilStrategy 77 | return 78 | DiagnosticsMC 79 | { playerNameMC = name, 80 | averageUtilStrategyMC = averageUtilStrategy', 81 | samplePayoffsMC = samplePayoffs', 82 | optimalMoveMC = optimalPlay, 83 | optimalPayoffMC = optimalPayoff0 84 | } 85 | where 86 | action = do 87 | (_, x) <- h 88 | g <- newStdGen 89 | gS <- newIOGenM g 90 | genFromTable (runKleisli strat x) gS 91 | u y = do 92 | (z, _) <- h 93 | evalStateT 94 | ( do 95 | r <- k z y 96 | -- \^ utility <- payoff function given other players strategies and my own action y 97 | gets ((+ r) . HM.findWithDefault 0.0 name) 98 | ) 99 | HM.empty 100 | -- Sample the average utility from current strategy 101 | averageUtilStrategy = do 102 | (_, x) <- h 103 | actionLS' <- replicateM sampleSize action 104 | utilLS <- mapM u actionLS' 105 | let average = (sum utilLS / fromIntegral sampleSize) 106 | return (x, average) 107 | -- Sample the average utility from a single action 108 | sampleY y = do 109 | ls1 <- replicateM sampleSize (u y) 110 | let average = (sum ls1 / fromIntegral sampleSize) 111 | pure (y, average) 112 | -- Sample the average utility from all actions 113 | samplePayoffs = mapM sampleY ys 114 | 115 | -- Support functionality for constructing open games 116 | fromLens :: (x -> y) -> (x -> r -> s) -> IOOpenGame '[] '[] x s y r 117 | fromLens v u = 118 | OpenGame 119 | { play = \Nil -> MonadOptic (\x -> return (x, v x)) (\x r -> return (u x r)), 120 | evaluate = \Nil _ -> Nil 121 | } 122 | 123 | fromFunctions :: (x -> y) -> (r -> s) -> IOOpenGame '[] '[] x s y r 124 | fromFunctions f g = fromLens f (const g) 125 | 126 | nature :: CondensedTableV x -> IOOpenGame '[] '[] () () x () 127 | nature table = OpenGame {play, evaluate} 128 | where 129 | play _ = 130 | MonadOptic v u 131 | where 132 | v () = do 133 | g <- newStdGen 134 | gS <- newIOGenM g 135 | draw <- genFromTable table gS 136 | return ((), draw) 137 | u _ _ = return () 138 | 139 | evaluate = \_ _ -> Nil 140 | 141 | -- discount Operation for repeated structures 142 | discount :: String -> (Double -> Double) -> IOOpenGame '[] '[] () () () () 143 | discount name f = 144 | OpenGame 145 | { play = \_ -> 146 | let v () = return ((), ()) 147 | u () () = modify (adjustOrAdd f (f 0) name) 148 | in MonadOptic v u, 149 | evaluate = \_ _ -> Nil 150 | } 151 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/Nat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | 5 | module OpenGames.Engine.Nat where 6 | 7 | -- Natural numbers as a unary data type 8 | data Nat = Z | S Nat 9 | 10 | -- Singleton type for natural numbers 11 | data Natural (n :: Nat) where 12 | Zero :: Natural Z 13 | Succ :: Natural n -> Natural (S n) 14 | 15 | minus :: Nat -> Nat -> Nat 16 | minus = undefined 17 | 18 | plus :: Nat -> Nat -> Nat 19 | plus = undefined 20 | 21 | -- Converts a TNat to its `int` value, an O(n) operation 22 | natToInt :: Natural n -> Int 23 | natToInt Zero = 0 24 | natToInt (Succ n) = 1 + natToInt n 25 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/OpenGames.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module OpenGames.Engine.OpenGames 6 | ( OpenGame (..), 7 | lift, 8 | reindex, 9 | (>>>), 10 | (&&&), 11 | ) 12 | where 13 | 14 | import OpenGames.Engine.OpticClass 15 | import OpenGames.Engine.TLL 16 | 17 | data OpenGame o c a b x s y r = OpenGame 18 | { play :: List a -> o x s y r, 19 | evaluate :: List a -> c x s y r -> List b 20 | } 21 | 22 | lift :: o x s y r -> OpenGame o c '[] '[] x s y r 23 | lift o = 24 | OpenGame 25 | { play = \Nil -> o, 26 | evaluate = \Nil _ -> Nil 27 | } 28 | 29 | reindex :: 30 | (List a -> List a') -> 31 | (List a -> List b' -> List b) -> 32 | OpenGame o c a' b' x s y r -> 33 | OpenGame o c a b x s y r 34 | reindex v u g = 35 | OpenGame 36 | { play = \a -> play g (v a), 37 | evaluate = \a c -> u a (evaluate g (v a) c) 38 | } 39 | 40 | (>>>) :: 41 | (Optic o, Context c o, Unappend a, Unappend b) => 42 | OpenGame o c a b x s y r -> 43 | OpenGame o c a' b' y r z q -> 44 | OpenGame o c (a +:+ a') (b +:+ b') x s z q 45 | (>>>) g h = 46 | OpenGame 47 | { play = \as -> case unappend as of (a, a') -> play g a >>>> play h a', 48 | evaluate = \as c -> case unappend as of 49 | (a, a') -> 50 | evaluate g a (cmap identity (play h a') c) 51 | +:+ evaluate h a' (cmap (play g a) identity c) 52 | } 53 | 54 | (&&&) :: 55 | (Optic o, Context c o, Unappend a, Unappend b, Show x, Show x') => 56 | OpenGame o c a b x s y r -> 57 | OpenGame o c a' b' x' s' y' r' -> 58 | OpenGame o c (a +:+ a') (b +:+ b') (x, x') (s, s') (y, y') (r, r') 59 | (&&&) g h = 60 | OpenGame 61 | { play = \as -> case unappend as of (a, a') -> play g a &&&& play h a', 62 | evaluate = \as c -> case unappend as of 63 | (a, a') -> 64 | evaluate g a (play h a' \\ c) 65 | +:+ evaluate h a' (play g a // c) 66 | } 67 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/TLL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneKindSignatures #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | -- Parts of this file were written by Sjoerd Visscher 18 | 19 | module OpenGames.Engine.TLL where 20 | 21 | -- ( List(..) 22 | -- , Apply(..) 23 | -- , Unappend(..) 24 | -- , MapL(..) 25 | -- , FoldrL(..) 26 | -- , ConstMap(..) 27 | -- , SequenceList(..) 28 | -- , Natural(..) 29 | -- , IndexList(..) 30 | -- , type (+:+) 31 | -- , (+:+) 32 | -- ) where 33 | 34 | import Control.Applicative 35 | import Data.Kind 36 | import OpenGames.Engine.Nat 37 | 38 | infixr 6 :- 39 | 40 | data List ts where 41 | Nil :: List '[] 42 | (:-) :: t -> List ts -> List (t ': ts) 43 | 44 | instance Show (List '[]) where 45 | show Nil = "Nil" 46 | 47 | instance 48 | (Show (List as), Show a) => 49 | Show (List (a ': as)) 50 | where 51 | show (a :- rest) = 52 | show a ++ " :- " ++ show rest 53 | 54 | -- type family (+:+) as bs = r | r -> a 55 | type family (+:+) (as :: [*]) (bs :: [*]) :: [*] where 56 | '[] +:+ bs = bs 57 | (a ': as) +:+ bs = a ': (as +:+ bs) 58 | 59 | (+:+) :: List as -> List bs -> List (as +:+ bs) 60 | (+:+) Nil bs = bs 61 | (+:+) (a :- as) bs = a :- as +:+ bs 62 | 63 | class Unappend as where 64 | unappend :: List (as +:+ bs) -> (List as, List bs) 65 | 66 | instance Unappend '[] where 67 | unappend bs = (Nil, bs) 68 | 69 | instance (Unappend as) => Unappend (a ': as) where 70 | unappend (a :- abs) = case unappend abs of (as, bs) -> (a :- as, bs) 71 | 72 | class RepNothing (as :: [*]) where 73 | rep :: List (TMap Maybe as) 74 | 75 | instance RepNothing '[] where 76 | rep = Nil 77 | 78 | instance (RepNothing xs) => RepNothing (x ': xs) where 79 | rep = Nothing :- rep @xs 80 | 81 | --------------------------------- 82 | -- Operations to transform output 83 | -- Preliminary apply class 84 | 85 | class Apply f a b where 86 | apply :: f -> a -> b 87 | 88 | -- Map 89 | class MapL f xs ys where 90 | mapL :: f -> List xs -> List ys 91 | 92 | instance MapL f '[] '[] where 93 | mapL _ _ = Nil 94 | 95 | type family TMap (f :: * -> *) (ls :: [*]) :: [*] where 96 | TMap f '[] = '[] 97 | TMap f (x ': xs) = f x : TMap f xs 98 | 99 | vmap :: -- forall (f :: * -> *) (xs :: [*]) . 100 | (forall ty. ty -> f ty) -> 101 | List xs -> 102 | List (TMap f xs) 103 | vmap f Nil = Nil 104 | vmap f (x :- xs) = f x :- vmap f xs 105 | 106 | instance 107 | (Apply f x y, MapL f xs ys) => 108 | MapL f (x ': xs) (y ': ys) 109 | where 110 | mapL f (x :- xs) = apply f x :- mapL f xs 111 | 112 | -- Foldr 113 | class FoldrL f acc xs where 114 | foldrL :: f -> acc -> List xs -> acc 115 | 116 | instance FoldrL f acc '[] where 117 | foldrL _ acc _ = acc 118 | 119 | instance 120 | (Apply f x (acc -> acc), FoldrL f acc xs) => 121 | FoldrL f acc (x ': xs) 122 | where 123 | foldrL f acc (x :- xs) = apply f x $ foldrL f acc xs 124 | 125 | type family ConstMap (t :: *) (xs :: [*]) :: [*] where 126 | ConstMap _ '[] = '[] 127 | ConstMap t (x ': xs) = t ': (ConstMap t xs) 128 | 129 | ---------------------------------------- 130 | -- Features to ease feeding back outputs 131 | -- 132 | class (Applicative m) => SequenceList m a b | a -> b, m b -> a where 133 | sequenceListA :: List a -> m (List b) 134 | 135 | instance (Applicative m) => SequenceList m '[] '[] where 136 | sequenceListA _ = pure Nil 137 | 138 | instance (Applicative m, SequenceList m as bs) => SequenceList m (m a ': as) (a ': bs) where 139 | sequenceListA (a :- b) = liftA2 (:-) a (sequenceListA b) 140 | 141 | -- Indexing on the list 142 | 143 | class IndexList (n :: Nat) (xs :: [Type]) (i :: Type) | n xs -> i where 144 | fromIndex :: Natural n -> List xs -> i 145 | 146 | instance IndexList Z (x ': xs) x where 147 | fromIndex Zero (x :- _) = x 148 | 149 | instance (IndexList n xs a) => IndexList (S n) (x ': xs) a where 150 | fromIndex (Succ n) (_ :- xs) = fromIndex n xs 151 | 152 | -------------------------------------- 153 | -- List functionality 154 | 155 | headL :: List (a ': as) -> a 156 | headL (x :- _) = x 157 | 158 | tailL :: List (a ': as) -> List as 159 | tailL (_ :- xs) = xs 160 | 161 | type family LastL xs where 162 | LastL '[x] = x 163 | LastL (x ': xs) = LastL xs 164 | 165 | lastL :: List (a ': as) -> LastL (a ': as) 166 | lastL (x :- Nil) = x 167 | lastL (x :- xs@(_ :- _)) = lastL xs 168 | 169 | -------------------------------------- 170 | -- Repeated Lists and vectors 171 | 172 | -- :type family Repeat (n :: Nat) (e :: t) :: Vec n t where 173 | -- : Repeat Z e = 'Empty 174 | -- : Repeat (S n) e = e :> Repeat n e 175 | 176 | type family RepeatLs (n :: Nat) (e :: [*]) :: [[*]] where 177 | RepeatLs Z ls = '[] 178 | 179 | -- Repeats a TLL `n` times, concatenating each instance to the next 180 | type family CatRepeat (n :: Nat) (ls :: [*]) :: [*] where 181 | CatRepeat Z ls = '[] 182 | CatRepeat (S n) ls = ls +:+ CatRepeat n ls 183 | -------------------------------------------------------------------------------- /src/OpenGames/Engine/Vec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module OpenGames.Engine.Vec where 9 | 10 | import OpenGames.Engine.Nat 11 | import Prelude hiding (map, replicate) 12 | 13 | infixr 6 :> 14 | 15 | data Vec (n :: Nat) (t :: *) where 16 | Empty :: Vec n a 17 | (:>) :: t -> Vec n t -> Vec (S n) t 18 | 19 | -- Given a function from a to b, map a vector preserving its length 20 | map :: (a -> b) -> Vec n a -> Vec n b 21 | map f Empty = Empty 22 | map f (x :> xs) = f x :> map f xs 23 | 24 | -- given a nat, generate the list of numbers for it starting with 0 25 | enumerate :: Natural n -> Vec n Int 26 | enumerate Zero = Empty 27 | enumerate (Succ n) = 0 :> map (1 +) (enumerate n) 28 | 29 | -- replicate an element `n` times into a vector 30 | replicate :: Natural n -> a -> Vec n a 31 | replicate Zero _ = Empty 32 | replicate (Succ n) a = a :> replicate n a 33 | 34 | -- given an element, make a non-empty vector containing that element 35 | mkVec :: a -> Vec (S Z) a 36 | mkVec a = a :> Empty 37 | 38 | -- Given a non-empty vector, get its first element 39 | vecHead :: Vec (S n) a -> a 40 | vecHead (x :> _) = x 41 | vecHead _ = error "impossible" 42 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor.hs: -------------------------------------------------------------------------------- 1 | module OpenGames.Preprocessor 2 | ( module Preprocessor, 3 | ) 4 | where 5 | 6 | import OpenGames.Preprocessor.BlockSyntax as Preprocessor 7 | import OpenGames.Preprocessor.Codegen as Preprocessor 8 | import OpenGames.Preprocessor.CompileBlock as Preprocessor 9 | import OpenGames.Preprocessor.CompileSyntax as Preprocessor 10 | import OpenGames.Preprocessor.Parser as Preprocessor 11 | import OpenGames.Preprocessor.RuntimeAST as Preprocessor 12 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor/BlockSyntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module OpenGames.Preprocessor.BlockSyntax where 8 | 9 | import Control.Comonad 10 | import Data.Bifunctor 11 | 12 | -- The user interacts with the preprocessor by creating instances of the datatypes in this file 13 | -- and then calling functions from Compiler on it 14 | 15 | -- The only reason there is no concrete syntax is that I have no idea how to write a parser 16 | -- Somebody can probably fix that in half an hour 17 | -- My idea for the concrete syntax of a line is 18 | -- cvo, ..., cvo' | cno, ..., cno' <- matrix -< cvi, ..., cvi' | cni, ..., cvi' 19 | 20 | -- covariant input = X, covariant output = Y, contravariant input = R, contravariant output = S 21 | -- 22 | -- ┌──────┐ 23 | -- covIn/X ─┤ ├─ Y/conIn 24 | -- │ │ 25 | -- covOut/S ─┤ ├─ R/conOut 26 | -- └──────┘ 27 | -- 28 | -- There is an important duality that the types can't express: half of these are lists of Haskell variables 29 | -- (they could probably be patterns) that create new bindings, and half of them are lists of Haskell expressions 30 | -- Line outputs and block inputs are variables/patterns, line inputs and block outputs are expressions 31 | 32 | -- Variables/patterns: covariantOutput, contravariantOutput, blockCovariantInput, blockContravariantInput 33 | -- Expressions: covariantInput, contravariantInput, blockCovariantOutput, blockContravariantOutput 34 | 35 | -- I decided to keep the record field names verbose, and I expect the user to specify lines in constructor syntax 36 | -- rather than record syntax 37 | 38 | data Line lbl p e = Line 39 | { label :: lbl, 40 | covariantInputs :: [e], 41 | contravariantOutputs :: [p], 42 | matrix :: e, 43 | covariantOutputs :: [p], 44 | contravariantInputs :: [e] 45 | } 46 | deriving (Eq, Show, Functor) 47 | 48 | mkLine :: [e] -> [p] -> e -> [p] -> [e] -> Line (Maybe String) p e 49 | mkLine = Line Nothing 50 | 51 | instance (Semigroup lbl) => Comonad (Line (Maybe lbl) p) where 52 | extract (Line _ _ _ e _ _) = e 53 | extend f v = pure (f v) 54 | 55 | instance Bifunctor (Line lbl) where 56 | first f (Line lbl covi cono m covo coni) = 57 | Line lbl covi (fmap f cono) m (fmap f covo) coni 58 | second = fmap 59 | 60 | pureLine :: forall p a lbl. a -> Line (Maybe lbl) p a 61 | pureLine v = Line Nothing [] [] v [] [] 62 | 63 | instance (Semigroup lbl) => Applicative (Line (Maybe lbl) p) where 64 | pure = pureLine 65 | (Line lbl1 _ _ f _ _) <*> (Line lbl2 covIn conOut m covOut conIn) = 66 | Line (lbl1 <> lbl2) (fmap f covIn) conOut (f m) covOut (fmap f conIn) 67 | 68 | instance Foldable (Line lbl p) where 69 | foldr f init (Line _ _ _ arg _ _) = f arg init 70 | 71 | instance Traversable (Line lbl p) where 72 | traverse f (Line lbl covIn conOut m covOut conIn) = 73 | pure (Line lbl) 74 | <*> traverse f covIn 75 | <*> pure conOut 76 | <*> f m 77 | <*> pure covOut 78 | <*> traverse f conIn 79 | 80 | -- `p` stands for "pattern", `e` for "expression" 81 | data Block p e = Block 82 | { blockCovariantInputs :: [p], 83 | blockContravariantOutputs :: [e], 84 | blockLines :: [Line (Maybe String) p e], 85 | blockCovariantOutputs :: [e], 86 | blockContravariantInputs :: [p] 87 | } 88 | deriving (Eq, Show, Functor) 89 | 90 | instance Applicative (Block p) where 91 | pure v = Block [] [] (pure (pure v)) [] [] 92 | (<*>) :: Block p (a -> b) -> Block p a -> Block p b 93 | (Block _ _ f _ _) <*> (Block covIn conOut m covOut conIn) = 94 | let v = fmap (<*>) f 95 | in Block 96 | covIn 97 | (mapLines f conOut) 98 | (fmap (<*>) f <*> m) 99 | (mapLines f covOut) 100 | conIn 101 | where 102 | mapLines :: [Line (Maybe String) p (a -> b)] -> [a] -> [b] 103 | mapLines f as = fmap extract f <*> as 104 | 105 | instance Foldable (Block p) where 106 | foldr f init (Block _ _ arg _ _) = 107 | foldr (\l b -> foldr f b l) init arg 108 | 109 | instance Traversable (Block p) where 110 | traverse f (Block covi cono l covo coni) = 111 | pure Block 112 | <*> pure covi 113 | <*> traverse f cono 114 | <*> traverse (traverse f) l 115 | <*> traverse f covo 116 | <*> pure coni 117 | 118 | instance Bifunctor Block where 119 | first f (Block covi cono l covo coni) = 120 | Block (fmap f covi) cono (fmap (first f) l) covo (fmap f coni) 121 | second = fmap 122 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor/Codegen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module OpenGames.Preprocessor.Codegen 5 | ( Variables (..), 6 | Expressions (..), 7 | FreeOpenGame (..), 8 | FunctionExpression (..), 9 | interpretOpenGame, 10 | interpretFunction, 11 | ) 12 | where 13 | 14 | import Language.Haskell.TH 15 | import OpenGames.Preprocessor.RuntimeAST 16 | 17 | combinePats :: [Pat] -> Pat 18 | combinePats [x] = x 19 | combinePats xs = TupP xs 20 | 21 | apply :: Exp -> [Exp] -> Exp 22 | apply fn [] = fn 23 | apply fn (x : xs) = apply (AppE fn x) xs 24 | 25 | mkTup :: [Exp] -> Exp 26 | mkTup [e] = e 27 | mkTup e = TupE (map Just e) 28 | 29 | patToExp :: Pat -> Exp 30 | patToExp (VarP e) = VarE e 31 | patToExp (TupP e) = mkTup (map (patToExp) e) 32 | patToExp (LitP e) = LitE e 33 | patToExp (ListP e) = ListE (fmap patToExp e) 34 | patToExp (ConP n _ e) = apply (VarE n) (fmap patToExp e) 35 | patToExp _ = error "unsupported pattern" 36 | 37 | interpretFunction :: FunctionExpression Pat Exp -> Q Exp 38 | interpretFunction Identity = [|id|] 39 | interpretFunction Copy = [|\x -> (x, x)|] 40 | interpretFunction (Lambda (Variables vars) (Expressions {exps})) = 41 | pure $ LamE (pure $ combinePats vars) (mkTup exps) 42 | interpretFunction (CopyLambda (Variables [vars]) (Expressions [exps])) = 43 | pure $ LamE (pure vars) (mkTup [patToExp vars, exps]) 44 | interpretFunction (CopyLambda (Variables {vars}) (Expressions [exps])) = 45 | pure $ LamE (pure $ combinePats vars) (mkTup [mkTup $ map patToExp vars, exps]) 46 | interpretFunction (CopyLambda (Variables [vars]) (Expressions {exps})) = 47 | pure $ LamE (pure vars) (mkTup [patToExp vars, mkTup exps]) 48 | interpretFunction (CopyLambda (Variables {vars}) (Expressions {exps})) = 49 | pure $ LamE (pure $ combinePats vars) (mkTup [mkTup $ map patToExp vars, mkTup exps]) 50 | interpretFunction (Multiplex (Variables {vars}) (Variables {vars = vars'})) = 51 | pure $ LamE (pure $ TupP [combinePats vars, combinePats vars']) (mkTup $ map patToExp (vars ++ vars')) 52 | interpretFunction (Curry f) = [|curry $(interpretFunction f)|] 53 | 54 | interpretOpenGame :: FreeOpenGame Pat Exp -> Q Exp 55 | interpretOpenGame (Atom n) = pure n 56 | interpretOpenGame (Lens f1 f2) = [|lift (lens $(interpretFunction f1) $(interpretFunction f2))|] 57 | interpretOpenGame (Function f1 f2) = [|fromFunctions $(interpretFunction f1) $(interpretFunction f2)|] 58 | interpretOpenGame Counit = [|counit|] 59 | interpretOpenGame (Sequential g1 g2) = [|$(interpretOpenGame g1) >>> $(interpretOpenGame g2)|] 60 | interpretOpenGame (Simultaneous g1 g2) = [|$(interpretOpenGame g1) &&& $(interpretOpenGame g2)|] 61 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor/CompileBlock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module OpenGames.Preprocessor.CompileBlock 9 | ( LineWithContext (..), 10 | SLine, 11 | QLine, 12 | compileBlock, 13 | param, 14 | asPat, 15 | compileLine, 16 | generateGame, 17 | opengame, 18 | parseTree, 19 | ) 20 | where 21 | 22 | import Data.Bifunctor 23 | import Data.Char 24 | import Data.List (inits, tails) 25 | import Language.Haskell.TH.Quote 26 | import Language.Haskell.TH.Syntax 27 | import OpenGames.Preprocessor.BlockSyntax 28 | import OpenGames.Preprocessor.Codegen 29 | import OpenGames.Preprocessor.CompileSyntax 30 | import OpenGames.Preprocessor.Parser 31 | import OpenGames.Preprocessor.RuntimeAST 32 | 33 | type SLine = Line (Maybe String) Pat Exp 34 | 35 | type QLine = Line (Maybe String) String (Q Exp) 36 | 37 | type GBlock = Block SLine 38 | 39 | data LineWithContext p e = LineWithContext 40 | { line :: Line (Maybe String) p e, 41 | covariantContext :: Variables p, 42 | contravariantContext :: Variables p 43 | } 44 | 45 | class ToLine pat exp where 46 | toLine :: Line (Maybe String) pat exp -> Q SLine 47 | 48 | instance ToLine Pat Exp where 49 | toLine = pure 50 | 51 | instance ToLine String (Q Exp) where 52 | toLine = compileQLine 53 | 54 | class ToExpr blockExpr where 55 | toExpr :: blockExpr -> Q Exp 56 | 57 | instance ToExpr String where 58 | toExpr = pure . VarE . mkName 59 | 60 | instance ToExpr Exp where 61 | toExpr = pure 62 | 63 | instance ToExpr (Q Exp) where 64 | toExpr = id 65 | 66 | -- The business end of the compiler 67 | 68 | compileLine :: LineWithContext p e -> FreeOpenGame p e 69 | compileLine (LineWithContext l cov con) = Sequential (Sequential l1 l2) l3 70 | where 71 | l1 = Function (CopyLambda cov (Expressions (covariantInputs l))) (Multiplex con (Variables (contravariantOutputs l))) 72 | l2 = Simultaneous (Function Identity Identity) (Atom (matrix l)) 73 | l3 = 74 | Function 75 | (Multiplex cov (Variables $ (covariantOutputs l))) 76 | (CopyLambda con (Expressions (contravariantInputs l))) 77 | 78 | compileBlock :: forall p e. Block p e -> FreeOpenGame p e 79 | compileBlock block = Sequential (Sequential l1 l2) l3 80 | where 81 | lines :: [LineWithContext p e] 82 | lines = linesWithContext block 83 | covariantBlockContext = 84 | flattenVariables 85 | [ covariantContext (last lines), 86 | Variables (covariantOutputs (line (last lines))) 87 | ] 88 | contravariantBlockContext = 89 | flattenVariables 90 | [ contravariantContext (head lines), 91 | Variables (contravariantOutputs (line (head lines))) 92 | ] 93 | l1 = Function Identity (Lambda contravariantBlockContext (Expressions (blockContravariantOutputs block))) 94 | l2 = foldl1 Sequential (map compileLine lines) 95 | l3 = 96 | Lens 97 | (Lambda covariantBlockContext (Expressions (blockCovariantOutputs block))) 98 | (Curry (Multiplex covariantBlockContext (Variables (blockContravariantInputs block)))) 99 | 100 | covariantContexts :: Block p e -> [Variables p] 101 | covariantContexts block = map f (init (inits (map (Variables . covariantOutputs) (blockLines block)))) 102 | where 103 | f contexts = flattenVariables (Variables (blockCovariantInputs block) : contexts) 104 | 105 | contravariantContexts :: Block p e -> [Variables p] 106 | contravariantContexts block = map (f . reverse) (tail (tails (map (Variables . contravariantOutputs) (blockLines block)))) 107 | where 108 | f contexts = 109 | flattenVariables 110 | ( concat 111 | [ [Variables (blockCovariantInputs block)], 112 | map (Variables . covariantOutputs) (blockLines block), 113 | [Variables (blockContravariantInputs block)], 114 | contexts 115 | ] 116 | ) 117 | 118 | linesWithContext :: Block p e -> [LineWithContext p e] 119 | linesWithContext block = zipWith3 LineWithContext (blockLines block) (covariantContexts block) (contravariantContexts block) 120 | 121 | param :: String -> Q Exp 122 | param = pure . VarE . mkName 123 | 124 | asPat :: String -> Q Pat 125 | asPat = pure . VarP . mkName 126 | 127 | compileQLine :: QLine -> Q SLine 128 | compileQLine qline = do 129 | covIn <- traverse id $ covariantInputs qline 130 | conIn <- traverse id $ contravariantInputs qline 131 | exp <- matrix qline 132 | let covOut = fmap (VarP . mkName) (covariantOutputs qline) 133 | let conOut = fmap (VarP . mkName) (contravariantOutputs qline) 134 | pure $ Line Nothing covIn conOut exp covOut conIn 135 | 136 | class GameCompiler term where 137 | generateGame :: String -> [String] -> term -> Q [Dec] 138 | 139 | instance GameCompiler (Block Pat Exp) where 140 | generateGame name args block = 141 | do 142 | game <- interpretOpenGame (compileBlock block) 143 | pure $ [FunD (mkName name) [Clause (fmap (VarP . mkName) args) (NormalB game) []]] 144 | 145 | extract :: Block (Q p) (Q e) -> Q (Block p e) 146 | extract (Block covIn conOut lines covOut conIn) = 147 | do 148 | covIn' <- sequence covIn 149 | conOut' <- sequence conOut 150 | lines' <- traverse extractLines lines 151 | covOut' <- sequence covOut 152 | conIn' <- sequence conIn 153 | pure (Block covIn' conOut' lines' covOut' conIn') 154 | where 155 | extractLines :: Line (Maybe String) (Q p) (Q e) -> Q (Line (Maybe String) p e) 156 | extractLines (Line lbl covIn conOut m covOut conIn) = do 157 | covIn' <- sequence covIn 158 | conOut' <- sequence conOut 159 | body <- m 160 | covOut' <- sequence covOut 161 | conIn' <- sequence conIn 162 | pure (Line lbl covIn' conOut' body covOut' conIn') 163 | 164 | instance GameCompiler (Block (Q Pat) (Q Exp)) where 165 | generateGame name args block = 166 | extract block 167 | >>= generateGame name args 168 | 169 | instance GameCompiler (Block String (Q Exp)) where 170 | generateGame name args block = do 171 | b <- sequence block 172 | generateGame name args (first (VarP . mkName) b) 173 | 174 | instance GameCompiler ([QLine]) where 175 | generateGame name args lines = do 176 | lines <- traverse compileQLine lines 177 | generateGame name args $ Block [] [] lines [] [] 178 | 179 | parseLambdaAsOpenGame :: String -> Maybe (FreeOpenGame Pat Exp) 180 | parseLambdaAsOpenGame input = 181 | case parseLambda input of 182 | Left _ -> Nothing 183 | Right v -> Just $ compileBlock $ convertGame v 184 | 185 | parseLambdaAsExp :: String -> Q Exp 186 | parseLambdaAsExp input = case parseLambda input of 187 | Left err -> error (show err) 188 | Right v -> (interpretOpenGame $ compileBlock $ convertGame v) 189 | 190 | game :: QuasiQuoter 191 | game = 192 | QuasiQuoter 193 | { quoteExp = parseLambdaAsExp . dropWhile isSpace, 194 | quotePat = error "expected expr", 195 | quoteType = error "expected expr", 196 | quoteDec = error "expected expr" 197 | } 198 | 199 | parseOrFail :: String -> Block Pattern Lambda 200 | parseOrFail input = case parseVerbose input of 201 | Left err -> error (show err) 202 | Right parsed -> parsed 203 | 204 | getParseTree = convertGame . parseOrFail 205 | 206 | parseVerboseGame :: String -> Q Exp 207 | parseVerboseGame = interpretOpenGame . compileBlock . getParseTree 208 | 209 | opengame :: QuasiQuoter 210 | opengame = 211 | QuasiQuoter 212 | { quoteExp = parseVerboseGame . dropWhile isSpace, 213 | quotePat = error "expected expr", 214 | quoteType = error "expected expr", 215 | quoteDec = error "expected expr" 216 | } 217 | 218 | parseTree :: QuasiQuoter 219 | parseTree = 220 | QuasiQuoter 221 | { quoteExp = \str -> [|getParseTree . dropWhile isSpace $ str|], 222 | quotePat = error "expected expr", 223 | quoteType = error "expected expr", 224 | quoteDec = error "expected expr" 225 | } 226 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor/CompileSyntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module OpenGames.Preprocessor.CompileSyntax where 6 | 7 | import Data.Bifunctor 8 | import Data.Char 9 | -- import OpenGames.Preprocessor.CompileBlock 10 | 11 | import Language.Haskell.TH as TH 12 | import OpenGames.Preprocessor.BlockSyntax 13 | import OpenGames.Preprocessor.Parser 14 | import Prelude hiding (lines) 15 | 16 | compileLiteral :: Literal -> Exp 17 | compileLiteral (LInt i) = LitE $ IntegerL i 18 | compileLiteral (LBool True) = ConE (mkName "True") 19 | compileLiteral (LBool False) = ConE (mkName "False") 20 | compileLiteral (LString str) = LitE $ StringL str 21 | 22 | compileRange :: LRange -> TH.Range 23 | compileRange (LFromR from) = FromR (compileLambda from) 24 | compileRange (LFromThenR from step) = FromThenR (compileLambda from) (compileLambda step) 25 | compileRange (LFromToR from to) = FromToR (compileLambda from) (compileLambda to) 26 | compileRange (LFromThenToR from step to) = FromThenToR (compileLambda from) (compileLambda step) (compileLambda to) 27 | 28 | compileLambda :: Lambda -> Exp 29 | compileLambda (Lit l) = compileLiteral l 30 | compileLambda (Var s) 31 | | isUpper (head s) = ConE (mkName s) 32 | | otherwise = VarE (mkName s) 33 | compileLambda (App f a) = AppE (compileLambda f) (compileLambda a) 34 | compileLambda (Lam pat body) = LamE [compilePattern pat] (compileLambda body) 35 | compileLambda (LList ls) = ListE $ map compileLambda ls 36 | compileLambda (Do sm) = DoE Nothing (map toStatement sm) 37 | where 38 | toStatement :: (Maybe String, Lambda) -> Stmt 39 | toStatement (Nothing, lam) = NoBindS (compileLambda lam) 40 | toStatement (Just pat, lam) = BindS (VarP (mkName pat)) (compileLambda lam) 41 | compileLambda (Tuple f s r) = TupE (map (Just . compileLambda) (f : s : r)) 42 | compileLambda (Range range) = ArithSeqE (compileRange range) 43 | compileLambda (IfThenElse prd thn els) = CondE (compileLambda prd) (compileLambda thn) (compileLambda els) 44 | compileLambda (Ifix op left right) = 45 | InfixE 46 | (Just $ compileLambda left) 47 | (VarE $ mkName op) 48 | (Just $ compileLambda right) 49 | compileLambda (PFix "-" arg) = AppE (VarE (mkName "negate")) (compileLambda arg) 50 | compileLambda (PFix op arg) = error $ "unsupported prefix operator: " ++ op 51 | compileLambda (LLet pat val body) = 52 | LetE 53 | [ ValD 54 | (compilePattern pat) 55 | (NormalB (compileLambda val)) 56 | [] 57 | ] 58 | (compileLambda body) 59 | compileLambda (LComp stmts) = CompE (map compileStmt stmts) 60 | 61 | compileStmt :: LStmt -> Stmt 62 | compileStmt (LBindS pat exp) = BindS (compilePattern pat) (compileLambda exp) 63 | compileStmt (LNoBindS exp) = NoBindS (compileLambda exp) 64 | compileStmt (LLetS pat exp) = LetS [ValD (compilePattern pat) (NormalB $ compileLambda exp) []] 65 | 66 | compilePattern :: Pattern -> Pat 67 | compilePattern (PLit (LInt i)) = LitP $ IntegerL i 68 | compilePattern (PLit (LBool True)) = ConP (mkName "True") [] [] 69 | compilePattern (PLit (LBool False)) = ConP (mkName "False") [] [] 70 | compilePattern (PLit (LString str)) = LitP $ StringL str 71 | compilePattern (PList ls) = ListP $ fmap compilePattern ls 72 | compilePattern (PTuple ts) = TupP $ fmap compilePattern ts 73 | compilePattern (PVar i) = VarP (mkName i) 74 | compilePattern (PCon nm args) = ConP (mkName nm) [] (fmap compilePattern args) 75 | 76 | compLine :: Line (Maybe String) Pattern Lambda -> Line (Maybe String) Pat Exp 77 | compLine = bimap compilePattern compileLambda 78 | 79 | convertGame :: Block Pattern Lambda -> Block Pat Exp 80 | convertGame = bimap compilePattern compileLambda 81 | -------------------------------------------------------------------------------- /src/OpenGames/Preprocessor/RuntimeAST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module OpenGames.Preprocessor.RuntimeAST where 5 | 6 | import Data.List (intercalate) 7 | import Language.Haskell.TH 8 | 9 | newtype Variables p = Variables {vars :: [p]} deriving (Eq) 10 | 11 | newtype Expressions e = Expressions {exps :: [e]} deriving (Eq, Functor) 12 | 13 | tuple :: [String] -> String 14 | tuple [x] = x 15 | tuple xs = "(" ++ intercalate ", " xs ++ ")" 16 | 17 | instance Show (Variables String) where show = tuple . vars 18 | 19 | instance Show (Expressions String) where show = tuple . exps 20 | 21 | -- newtype AtomExpression = AtomExpression String 22 | -- 23 | -- instance Show AtomExpression where 24 | -- show (AtomExpression e) = concat ["(", e, ")"] 25 | 26 | -- Function expressions are Haskell expressions used as inputs to fromLens (from the class OG) 27 | data FunctionExpression p e 28 | = Identity -- \x -> x 29 | | Copy -- \x -> (x, x) 30 | | Lambda (Variables p) (Expressions e) -- \(x1, ..., xm) -> (e1, ..., en) 31 | | CopyLambda (Variables p) (Expressions e) -- \(x1, ..., xm) -> ((x1, ..., xm), (e1, ..., en)) 32 | | Multiplex (Variables p) (Variables p) -- \((x1, ..., xm), (y1, ..., yn)) -> (x1, ..., xm, y1, ..., yn) 33 | | Curry (FunctionExpression p e) -- curry f 34 | deriving (Eq, Functor) 35 | 36 | flattenVariables :: [Variables p] -> Variables p 37 | flattenVariables = Variables . concat . map vars 38 | 39 | instance Show (FunctionExpression String String) where 40 | show Identity = "\\x -> x" 41 | show Copy = "\\x -> (x, x)" 42 | show (Lambda x e) = concat ["\\", show x, " -> ", show e] 43 | show (CopyLambda x e) = concat ["\\", show x, " -> (", show x, ", ", show e, ")"] 44 | show (Multiplex x y) = concat ["\\(", show x, ", ", show y, ") -> ", show (flattenVariables [x, y])] 45 | show (Curry f) = concat ["curry (", show f, ")"] 46 | 47 | -- The main abstract datatype targeted by the compiler 48 | data FreeOpenGame p e 49 | = Atom e 50 | | Lens (FunctionExpression p e) (FunctionExpression p e) 51 | | Function (FunctionExpression p e) (FunctionExpression p e) 52 | | Counit 53 | | Sequential (FreeOpenGame p e) (FreeOpenGame p e) 54 | | Simultaneous (FreeOpenGame p e) (FreeOpenGame p e) 55 | deriving (Eq, Functor) 56 | 57 | instance Show (FreeOpenGame String String) where 58 | show (Atom e) = concat [")", e, ")"] 59 | show (Lens v u) = concat ["fromLens (", show v, ") (", show u, ")"] 60 | show (Function f g) = concat ["fromFunctions (", show f, ") (", show g, ")"] 61 | show Counit = "counit" 62 | show (Sequential g h) = concat ["(", show g, ") >>> (", show h, ")"] 63 | show (Simultaneous g h) = concat ["(", show g, ") &&& (", show h, ")"] 64 | 65 | instance Show (FreeOpenGame String Exp) where 66 | show game = show $ fmap show game 67 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-20.22 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | extra-deps: 38 | - HSH-2.1.3@sha256:71ded11b224f5066373ce985ec63b10c87129850b33916736dd64fa2bea9ea0a,1705 39 | - restless-git-0.7@sha256:346a5775a586f07ecb291036a8d3016c3484ccdc188b574bcdec0a82c12db293,968 40 | - s-cargot-0.1.4.0@sha256:61ea1833fbb4c80d93577144870e449d2007d311c34d74252850bb48aa8c31fb,3525 41 | - semver-range-0.2.8@sha256:44918080c220cf67b6e7c8ad16f01f3cfe1ac69d4f72e528e84d566348bb23c3,1941 42 | # - text-format-0.3.2@sha256:2a3fc17cf87120fcfdbca62a0da59759755549285841cdc1483081c35fb3d115,1814 43 | - probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 44 | # - random-1.2.0 45 | - splitmix-0.1 46 | - mwc-random-0.15.0.2 47 | - monad-bayes-1.1.0 48 | - smt2-parser-0.1.0.1 49 | - spawn-0.3 50 | - spool-0.1 51 | - hevm-0.51.0 52 | - git: https://github.com/ethereum/act.git 53 | subdirs: 54 | - src 55 | commit: 52e99daf3121a4e6a6cb28255e862cf8e83cf4cd 56 | 57 | allow-newer: true 58 | 59 | # - acme-missiles-0.3 60 | # - git: https://github.com/commercialhaskell/stack.git 61 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 62 | # 63 | # Override default flag values for local packages and extra-deps 64 | # flags: {} 65 | 66 | # Extra package databases containing global packages 67 | # extra-package-dbs: [] 68 | 69 | # Control whether we use the GHC we find on the path 70 | # system-ghc: true 71 | # 72 | # Require a specific version of stack, using version ranges 73 | # require-stack-version: -any # Default 74 | # require-stack-version: ">=2.1" 75 | # 76 | # Override the architecture used by stack, especially useful on Windows 77 | # Change to x86_64 for Intel and aarch64 for ARM/apple silicon 78 | arch: x86_64 79 | # 80 | # Extra directories used by stack for building 81 | # extra-include-dirs: [/path/to/dir] 82 | # extra-lib-dirs: [/path/to/dir] 83 | # 84 | # Allow a newer minor version of GHC than the snapshot specifies 85 | # compiler-check: newer-minor 86 | # 87 | ghc-options: 88 | "$locals": -fwarn-incomplete-patterns 89 | 90 | nix: 91 | enable: true 92 | packages: [libff, secp256k1, zlib] 93 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: HSH-2.1.3@sha256:71ded11b224f5066373ce985ec63b10c87129850b33916736dd64fa2bea9ea0a,1705 9 | pantry-tree: 10 | sha256: 95f49f9dad6e4976d1b53c59fd4405a978ca8baecc721d508a030615241d69be 11 | size: 473 12 | original: 13 | hackage: HSH-2.1.3@sha256:71ded11b224f5066373ce985ec63b10c87129850b33916736dd64fa2bea9ea0a,1705 14 | - completed: 15 | hackage: restless-git-0.7@sha256:346a5775a586f07ecb291036a8d3016c3484ccdc188b574bcdec0a82c12db293,968 16 | pantry-tree: 17 | sha256: 26b37a66c08215e18a914600aae8a61a6ba4611243a0b31ea27437d6c83701cb 18 | size: 269 19 | original: 20 | hackage: restless-git-0.7@sha256:346a5775a586f07ecb291036a8d3016c3484ccdc188b574bcdec0a82c12db293,968 21 | - completed: 22 | hackage: s-cargot-0.1.4.0@sha256:61ea1833fbb4c80d93577144870e449d2007d311c34d74252850bb48aa8c31fb,3525 23 | pantry-tree: 24 | sha256: 280c1899ea1a905f01785e175ff029748e9913388d25e02a8e4cdceb9a92b722 25 | size: 1467 26 | original: 27 | hackage: s-cargot-0.1.4.0@sha256:61ea1833fbb4c80d93577144870e449d2007d311c34d74252850bb48aa8c31fb,3525 28 | - completed: 29 | hackage: semver-range-0.2.8@sha256:44918080c220cf67b6e7c8ad16f01f3cfe1ac69d4f72e528e84d566348bb23c3,1941 30 | pantry-tree: 31 | sha256: fd72964da8246cc09d477b4c6e6f20971de058917d08d9f8183f5c0e2116f9c6 32 | size: 401 33 | original: 34 | hackage: semver-range-0.2.8@sha256:44918080c220cf67b6e7c8ad16f01f3cfe1ac69d4f72e528e84d566348bb23c3,1941 35 | - completed: 36 | hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 37 | pantry-tree: 38 | sha256: ee8953628fe301a29be9ef64ebd96f8c704969fec2b4e0b39243e6499911b767 39 | size: 2711 40 | original: 41 | hackage: probability-0.2.7@sha256:3e9fe130af3bd75e791e1add902eb2caab170cc95373281c0a9626b01fc3b104,2869 42 | - completed: 43 | hackage: splitmix-0.1@sha256:d50c4d0801a35be7875a040470c09863342514930c82a7d25780a6c2efc4fda9,5249 44 | pantry-tree: 45 | sha256: 2c884d06818f79030551aab192eee23734fd499361f4f4dcb4c51d1b1b2d786e 46 | size: 1148 47 | original: 48 | hackage: splitmix-0.1 49 | - completed: 50 | hackage: mwc-random-0.15.0.2@sha256:109e0fb72ce64bda468fc44d9cb5abbf455d6337140b57eb851a8183baba0597,3372 51 | pantry-tree: 52 | sha256: 67732b8c3612c58e5286541213550899dc9495a09ca5283fab4437c489e624b9 53 | size: 721 54 | original: 55 | hackage: mwc-random-0.15.0.2 56 | - completed: 57 | hackage: monad-bayes-1.1.0@sha256:8929887b2883e553b928dcc9b1326171c87b6aa26f11800dc8c55b119a9e9649,6123 58 | pantry-tree: 59 | sha256: bf7f9b1351226a957c7ebd0c42316505be713690cd9d44425bd9cfd494a94161 60 | size: 3568 61 | original: 62 | hackage: monad-bayes-1.1.0 63 | - completed: 64 | hackage: smt2-parser-0.1.0.1@sha256:1e1a4565915ed851c13d1e6b8bb5185cf5d454da3b43170825d53e221f753d77,1421 65 | pantry-tree: 66 | sha256: c048b3037a35ab6ca5b33d865d7a0b0f56a0ccc942dd57cbbab6af380770ee13 67 | size: 447 68 | original: 69 | hackage: smt2-parser-0.1.0.1 70 | - completed: 71 | hackage: spawn-0.3@sha256:b91e01d8f2b076841410ae284b32046f91471943dc799c1af77d666c72101f02,1162 72 | pantry-tree: 73 | sha256: 3fa87961ef3166c0093ebae68dea83cf2d7b9e131a2db28687b696f077c6f81a 74 | size: 262 75 | original: 76 | hackage: spawn-0.3 77 | - completed: 78 | hackage: spool-0.1@sha256:77780cbfc2c0be23ff2ea9e474062f3df97fcd9db946ee0b3508280a923b83e2,1461 79 | pantry-tree: 80 | sha256: 48eada528a8eda2fcf0d3517a239c59a699acff96111f427833ba2b04bd6111f 81 | size: 322 82 | original: 83 | hackage: spool-0.1 84 | - completed: 85 | hackage: hevm-0.51.0@sha256:6116fac8aa1434685e41e839dce6b107a64f94e1bc09609d467e81b55f434172,9294 86 | pantry-tree: 87 | sha256: a4ed66030cbef539ce248f4fd056582ba80e3994fd989a113cdd5c7ca29e25f8 88 | size: 4296 89 | original: 90 | hackage: hevm-0.51.0 91 | - completed: 92 | commit: 52e99daf3121a4e6a6cb28255e862cf8e83cf4cd 93 | git: https://github.com/ethereum/act.git 94 | name: act 95 | pantry-tree: 96 | sha256: 78cc4643860657a2be70ba2f95d675f130c312800393a1cb52c88ec6701ce7bd 97 | size: 1217 98 | subdir: src 99 | version: 0.1.0.0 100 | original: 101 | commit: 52e99daf3121a4e6a6cb28255e862cf8e83cf4cd 102 | git: https://github.com/ethereum/act.git 103 | subdir: src 104 | snapshots: 105 | - completed: 106 | sha256: dcf4fc28f12d805480ddbe8eb8c370e11db12f0461d0110a4240af27ac88d725 107 | size: 650255 108 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/22.yaml 109 | original: lts-20.22 110 | -------------------------------------------------------------------------------- /tests/ArrowTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module ArrowTest where 8 | 9 | import Data.Bifunctor 10 | import Data.Bool 11 | import Data.List 12 | import Engine.Diagnostics 13 | import Examples.Bayesian as B 14 | import GHC.Real 15 | import Language.Haskell.TH.Syntax as TH 16 | import Numeric.Probability.Distribution 17 | import Preprocessor.AbstractSyntax 18 | import Preprocessor.Lambda 19 | import Preprocessor.Parser 20 | import Preprocessor.THSyntax 21 | import Test.Hspec as Spec 22 | import Test.QuickCheck 23 | 24 | btest = 25 | "t | <- nature (uniform [Rat, Omerta]) -< | ;" 26 | ++ "x | pdMatrix1 x y <- reindex const (decision \"prisoner1\" [Confess, DontConfess]) -< | ;" 27 | ++ "y | pdMatrix2 t x y <- decision \"prisoner2\" [Confess, DontConfess] -< | t ;" 28 | 29 | doTest = 30 | "t1, t2 | <- nature (do {t1 <- uniform [BOSType1, BOSType2]; t2 <- uniform [BOSType1, BOSType2]; return (t1, t2)}) -< | ;" 31 | ++ " x | bos_bayesian_matrix1 t1 x y <- decision \"man\" [BayesianB, BayesianS] -< | t1;" 32 | ++ " y | bos_bayesian_matrix2 t2 x y <- decision \"woman\" [BayesianB, BayesianS] -< | t2;" 33 | 34 | value :: GameAST String Lambda 35 | value = 36 | MkParsedBlock 37 | [] 38 | [] 39 | [ MkParsedLine ["t"] [] (App (Var "nature") (App (Var "uniform") (LList [Var "Rat", Var "Omerta"]))) [] [], 40 | MkParsedLine 41 | ["x"] 42 | [App (App (Var "pdMatrix1") (Var "x")) (Var "y")] 43 | (App (App (Var "reindex") (Var "const")) (App (App (Var "decision") (Lit $ LString "prisoner1")) (LList [Var "Confess", Var "DontConfess"]))) 44 | [] 45 | [], 46 | MkParsedLine 47 | ["y"] 48 | [App (App (App (Var "pdMatrix2") (Var "t")) (Var "x")) (Var "y")] 49 | (App (App (Var "decision") (Lit $ LString "prisoner2")) (LList [Var "Confess", Var "DontConfess"])) 50 | [] 51 | [Var "t"] 52 | ] 53 | [] 54 | [] 55 | 56 | simpleLine :: ParsedLine String String 57 | simpleLine = MkParsedLine ["output"] ["input"] "middle" ["input2"] ["output2"] 58 | 59 | simpleLam :: ParsedLine Pattern Lambda 60 | simpleLam = undefined -- bimap undefined Var simpleLine 61 | 62 | rangeTest = 63 | "t1 | <- nature (uniform [0 .. 6]) -< | ;" 64 | ++ "t2 | <- nature (uniform [0 .. 6]) -< | ;" 65 | ++ "x | playerOneUtility t1 x y <- decision \"player1\" [0 .. 12] -< | t1;" 66 | ++ "y | playerTwoUtility t2 x y <- decision \"player2\" [0 .. 12] -< | t2;" 67 | 68 | simple = 69 | [ Line [] [] [|nature (uniform [0 .. 6])|] ["t1"] [], 70 | Line [] [] [|nature (uniform [0 .. 6])|] ["t2"] [], 71 | Line [[|t1|]] [] [|decision "player1" [0 .. 12]|] ["x"] [[|playerOneUtility t1 x y|]], 72 | Line [[|t2|]] [] [|decision "player2" [0 .. 12]|] ["y"] [[|playerTwoUtility t2 x y|]] 73 | ] 74 | 75 | convertLines :: [Line p (Q Exp)] -> Q (Block p Exp) 76 | convertLines lines = do 77 | lines <- sequence $ fmap sequence lines 78 | pure (Block [] [] lines [] []) 79 | 80 | -- main :: IO () 81 | -- main = do 82 | -- hspec $ parallel $ do 83 | -- describe "testing quasiquoted AST" $ parallel $ do 84 | -- ref <- Spec.runIO $ TH.runQ $ (Just . THS.compileBlock <$> convertLines simple) 85 | -- it "should parse the same freeOpenGame" $ do 86 | -- parseLambdaAsOpenGame rangeTest 87 | -- `shouldBe` ref 88 | -- 89 | -- it "should be the same bayesian AST" $ 90 | -- parseLambda btest 91 | -- `shouldBe` 92 | -- Right value 93 | --------------------------------------------------------------------------------