mixed-strategies (empty) → 0.1.0.0

raw patch · 5 files changed

+345/−0 lines, 5 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, mixed-strategies, simple-tabular

Files

• COPYING +25/−0
• Data/MixedStrategies.hs +216/−0
• Setup.hs +2/−0
• mixed-strategies.cabal +79/−0
• oms.hs +23/−0

@@ -0,0 +1,25 @@+Copyright © 2011 Bart Massey++[This program is licensed under the "MIT License"]++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:++The above copyright notice and this permission notice shall+be included in all copies or substantial portions of the+Software.++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.

@@ -0,0 +1,216 @@+-- Copyright © 2011 Bart Massey+-- [This program is licensed under the "MIT License"]+-- Please see the file COPYING in the source+-- distribution of this software for license terms.++-- | Calculate an optimal mixed strategy given the payoff+-- matrix of a two-player zero-sum single-round iterated+-- simultaneous game.  Follows the method of Chapter 6 of+-- J.D. Williams' \"The Compleat Strategyst\" (McGraw-Hill+-- 1954). Throughout, the player playing the rows (strategies+-- on the left) is assumed to be the \"maximizer\" and the+-- player playing the columns (strategies on top) is assumed+-- to be the \"minimizer\".++module Data.MixedStrategies (+  Schema(..), +  Edge(..),+  readSchema, +  pivot, +  Solution(..), +  extractSolution, +  solved,+  solve+) where++import Prelude hiding (Left, Right, lookup)+import Data.Array+import Data.Function (on)+import Data.List hiding (lookup)+import Data.Map (lookup, fromList)+import Data.Ord (comparing)+import Text.Printf+import Text.SimpleTabular++dim :: Array Int t -> Int+dim a = let (1, ix) = bounds a in ix++dims :: Array (Int, Int) t -> (Int, Int)+dims a = let ((1, 1), ixs) = bounds a in ixs++-- | An 'Edge' of a 'Schema' contains annotations of the Schema.+data Edge = Left | Top | Right | Bottom deriving (Ord, Eq, Ix)++-- | Schema describing a two-player hidden information game.+data Schema = Schema {+  -- | Score offset to make the game fair.+  offset :: Double,+  -- | \"Determinant\".+  d :: Double,+  -- | Strategy \"names\", given as labels along an edge of the+  -- payoff matrix.+  names :: Array Edge (Array Int (Maybe Int)),+  -- | Payoff matrix.+  payoffs :: Array (Int, Int) Double+}++-- | Show a 'Schema' in tabular format.+instance Show Schema where+  show s =+    let tab =       +          ["" : printNameVec Top] +++          map printRow [1 .. nr - 1] +++          ["" : printRowM nr] +++          ["" : printNameVec Bottom]+        in+    printf "O = %.2f, D = %.2f\n" (offset s) (d s) +++    tabular (replicate (nc + 1) 'r' ++ "l") tab+    where+      (nr, nc) = dims $ payoffs s+      printRowM i =+        printVec $ ixmap (1, nc) (\j -> (i, j)) (payoffs s)+        where+          printVec a =+            map (printf "%.2f" . (a !)) [1 .. dim a]+      printName e i =+        case names s ! e ! i of+          Just v -> printf "%d" v+          Nothing -> ""+      printNameVec e =+        map (printName e) [1 .. dim (names s ! e)]+      printRow i =+        [printName Left i] ++ +        printRowM i ++ +        [printName Right i]++-- | Read a 'Schema' (actually a payoff matrix) from standard input.+readSchema :: IO Schema+readSchema =+  construct `fmap` getContents+  where+    construct s = +      let o = minimum $ elems ps in+      let core = map (\(c, x) -> (c, x - o)) $ assocs ps+          augr = zip (zip (repeat (nr + 1)) [1..nc]) (repeat (-1))+          augc = zip (zip [1..nr] (repeat (nc + 1))) (repeat 1)+          augv = ((nr + 1, nc + 1), 0)+          bounds' = ((1, 1), (nr + 1, nc + 1)) in+      let ps' = array bounds' $ core ++ augr ++ augc ++ [augv] in+      Schema {+        offset = o,+        d = 1,+        names = mkNames,+        payoffs = ps' }+      where+        ps = mkPayoffs $ map (map read . words) $ lines s+        (nr, nc) = dims ps+        mkNames =+          array (Left, Bottom) [namesLeft, namesTop, namesRight, namesBottom]+          where+            namesLeft = (Left, listArray (1, nr) [Just n | n <- [1..nr]])+            namesTop = (Top, listArray (1, nc) [Just n | n <- [1..nc]])+            namesRight = (Right, listArray (1, nr) (replicate nr Nothing))+            namesBottom = (Bottom, listArray (1, nc) (replicate nc Nothing))+        mkPayoffs :: [[Double]] -> Array (Int, Int) Double+        mkPayoffs l@(e : es)+          | all ((== length e) . length) es =+              listArray ((1, 1), (length l, length e)) $ concat l+        mkPayoffs _ = error "bad payoff matrix format"++-- | Execute one pivot step in the 'Schema' reduction.+pivot :: Schema -> Schema+pivot s =+  Schema {+    offset = offset s,+    d = pv,+    names = updateNames,+    payoffs = updatePayoffs }+  where+    ps = payoffs s+    (nr, nc) = dims ps+    ((pr, pc), pv) = +        maximumBy pivotCompare $+        map (minimumBy pivotCompare) $+        groupBy ((==) `on` (snd . fst)) $ +        sortBy (comparing (snd . fst)) potPivots+        where+          potPivots = +            filter okPivot $ assocs ps+            where+              okPivot ((_, c), v) = v > 0 && (ps ! (nr, c)) < 0+          pivotCompare =+            comparing pivotCriteria+            where+              pivotCriteria ((r, c), p) =+                - (ps ! (nr, c)) * (ps ! (r, nc)) / p+    updateNames = +      array (Left, Bottom) [+        updateName Left Bottom pr pc,+        updateName Bottom Left pc pr,+        updateName Right Top pr pc,+        updateName Top Right pc pr ]+      where+        updateName e e' i i' =+          (e, (names s ! e) // [(i, names s ! e' ! i')])+    updatePayoffs = +      listArray (bounds ps) $ map updatePayoff $ assocs $ ps+      where+        updatePayoff ((r, c), n)+          | r == pr && c == pc = d s+          | r == pr = n+          | c == pc = -n+          | otherwise = (n * pv - (ps ! (pr, c)) * (ps ! (r, pc))) / d s++-- | A game solution, given as the value of the game and+-- an optimal mixed strategy for each player.+data Solution = Solution {+  value :: Double,+  leftStrategy, topStrategy :: [Double] }++instance Show Solution where+  show soln =+    printf "value = %.2f\n" (value soln) +++    printf "leftmax = %s\n" (showStrategy leftStrategy) +++    printf "topmin = %s" (showStrategy topStrategy)+    where+      showStrategy strat =+        unwords $ map (uncurry (printf "%d:%.2f")) $ +        zip [(1::Int)..] $ strat soln++-- | Given a solved 'Schema', extract the 'Solution'+-- implied by that 'Schema'.+extractSolution :: Schema -> Solution+extractSolution s | solved s = Solution {+  value = offset s + d s / (ps ! ds),+  leftStrategy = strat Bottom $ ixmap (1, nc - 1) (\j -> (nr, j)) ps,+  topStrategy = strat Right $ ixmap (1, nr - 1) (\j -> (j, nc)) ps }+  where+    ps = payoffs s+    ds@(nr, nc) = dims ps+    strat e odds =+      let strats = zip (elems (names s ! e)) (elems odds) in+      let mStrats = fromList [(nm, pr) | (Just nm, pr) <- strats] in+      let vStrats = map (zeroInactive mStrats) [1 .. dim odds] in+      [o / sum vStrats | o <- vStrats]+      where+        zeroInactive m nm =+          case lookup nm m of+            Just o -> o+            Nothing -> 0+extractSolution _ = error "refusing to extract solution from unsolved schema"++-- | Returns 'True' if the given 'Schema' is fully reduced (\"solved\");+-- 'False' otherwise.+solved :: Schema -> Bool+solved s =+  let ps = payoffs s in+  let ((1,1), (nr, nc)) = bounds ps in+  all (>= 0) [v | ((r, c), v) <- assocs ps, r == nr || c == nc]++-- | Keep reducing the given 'Schema' until a fixed+-- point is reached, and then return the corresponding+-- 'Solution'.+solve :: Schema -> Solution+solve s+  | solved s = extractSolution s+  | otherwise = solve (pivot s)

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,79 @@+-- Initial mixed-strategies.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                mixed-strategies++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            Find optimal mixed strategies for two-player games++-- A longer description of the package.++description:         A Haskell implementation of the method of+                     Chapter 6 of The Compleat Strategyst+                     (J.D. Williams, McGraw-Hill 1955) for+                     finding optimal mixed strategies for+                     two-player hidden information games+                     given a payoff matrix.++-- URL for the project homepage or repository.+homepage:            http://wiki.cs.pdx.edu/bartforge/oms++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        COPYING++-- The package author(s).+author:              Bart Massey++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          bart@cs.pdx.edu++-- A copyright notice.+-- copyright:           ++category:            Math++build-type:          Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.8++source-repository head+    type:            git+    location:        http://github.com/BartMassey/mixed-strategies.git++source-repository this+    type:            git+    location:        http://github.com/BartMassey/mixed-strategies.git+    tag:             v0.1++library+  -- Modules exported by the library.+  exposed-modules:     Data.MixedStrategies+  +  -- Modules included in this library but not exported.+  other-modules:       +  +  -- Other library packages from which modules are imported.+  build-depends:       base ==4.5.*, array ==0.4.*, containers ==0.5.*,+                       simple-tabular ==0.1.*++executable oms+  -- .hs or .lhs file containing the Main module.+  main-is:             oms.hs++  -- Other library packages from which modules are imported.+  build-depends:       base ==4.5.*, array ==0.4.*, containers ==0.5.*,+                       simple-tabular ==0.1.*, mixed-strategies

@@ -0,0 +1,23 @@+-- Copyright © 2011 Bart Massey+-- [This program is licensed under the "MIT License"]+-- Please see the file COPYING in the source+-- distribution of this software for license terms.++import Data.MixedStrategies++untilM :: Monad m => (v -> Bool) -> (v -> m v) -> v -> m v+untilM p _ v | p v = return v+untilM p a v = a v >>= untilM p a++step :: Schema -> IO Schema+step s = do+  let s' = pivot s+  print s'+  return s'++main :: IO ()+main = do+  s0 <- readSchema+  print s0+  s <- untilM solved step s0+  print $ extractSolution s