diff --git a/purescript/README.md b/purescript/README.md index b8278f7..b11e339 100644 --- a/purescript/README.md +++ b/purescript/README.md @@ -21,5 +21,6 @@ | [purpleflow](./purpleflow) | Unfinished dependently-typed programming language | | [slice](./slice) | Basic benchmarks and a `Slice` type | | [sprint](./sprint) | Failled effect-system based on typelevel lists | +| [strategy](./strategy) | Unfinished attempt at implementing a mixed strategy nash equilibrium solver | | [streams](./streams) | Playing with `purescript-pipes` | | [typelevel](./typelevel) | Typelevel naturals, vectors, sum-types, orderings and lambda-calculus evaluation and a value-level bounded-type GADT | diff --git a/purescript/strategy/.gitignore b/purescript/strategy/.gitignore new file mode 100644 index 0000000..30efe19 --- /dev/null +++ b/purescript/strategy/.gitignore @@ -0,0 +1,10 @@ +/bower_components/ +/node_modules/ +/.pulp-cache/ +/output/ +/generated-docs/ +/.psc-package/ +/.psc* +/.purs* +/.psa* +/.spago diff --git a/purescript/strategy/packages.dhall b/purescript/strategy/packages.dhall new file mode 100644 index 0000000..aaab175 --- /dev/null +++ b/purescript/strategy/packages.dhall @@ -0,0 +1,105 @@ +{- +Welcome to your new Dhall package-set! + +Below are instructions for how to edit this file for most use +cases, so that you don't need to know Dhall to use it. + +## Use Cases + +Most will want to do one or both of these options: +1. Override/Patch a package's dependency +2. Add a package not already in the default package set + +This file will continue to work whether you use one or both options. +Instructions for each option are explained below. + +### Overriding/Patching a package + +Purpose: +- Change a package's dependency to a newer/older release than the + default package set's release +- Use your own modified version of some dependency that may + include new API, changed API, removed API by + using your custom git repo of the library rather than + the package set's repo + +Syntax: +where `entityName` is one of the following: +- dependencies +- repo +- version +------------------------------- +let upstream = -- +in upstream + with packageName.entityName = "new value" +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with halogen.version = "master" + with halogen.repo = "https://example.com/path/to/git/repo.git" + + with halogen-vdom.version = "v4.0.0" + with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies +------------------------------- + +### Additions + +Purpose: +- Add packages that aren't already included in the default package set + +Syntax: +where `` is: +- a tag (i.e. "v4.0.0") +- a branch (i.e. "master") +- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") +------------------------------- +let upstream = -- +in upstream + with new-package-name = + { dependencies = + [ "dependency1" + , "dependency2" + ] + , repo = + "https://example.com/path/to/git/repo.git" + , version = + "" + } +------------------------------- + +Example: +------------------------------- +let upstream = -- +in upstream + with benchotron = + { dependencies = + [ "arrays" + , "exists" + , "profunctor" + , "strings" + , "quickcheck" + , "lcg" + , "transformers" + , "foldable-traversable" + , "exceptions" + , "node-fs" + , "node-buffer" + , "node-readline" + , "datetime" + , "now" + ] + , repo = + "https://github.com/hdgarrood/purescript-benchotron.git" + , version = + "v7.0.0" + } +------------------------------- +-} +let upstream = + https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220921/packages.dhall + sha256:169bd823a71ae033eaf4f77776e184f12c656163feae14e7f649a48932ca6ac0 + +in upstream diff --git a/purescript/strategy/spago.dhall b/purescript/strategy/spago.dhall new file mode 100644 index 0000000..7d41bcb --- /dev/null +++ b/purescript/strategy/spago.dhall @@ -0,0 +1,30 @@ +{- +Welcome to a Spago project! +You can edit this file as you like. + +Need help? See the following resources: +- Spago documentation: https://github.com/purescript/spago +- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html + +When creating a new Spago project, you can use +`spago init --no-comments` or `spago init -C` +to generate this file without the comments in this block. +-} +{ name = "my-project" +, dependencies = + [ "arrays" + , "console" + , "dodo-printer" + , "effect" + , "either" + , "fast-vect" + , "foldable-traversable" + , "maybe" + , "prelude" + , "random" + , "safe-coerce" + , "tuples" + ] +, packages = ./packages.dhall +, sources = [ "src/**/*.purs", "test/**/*.purs" ] +} diff --git a/purescript/strategy/src/Data/Game.purs b/purescript/strategy/src/Data/Game.purs new file mode 100644 index 0000000..c5d812d --- /dev/null +++ b/purescript/strategy/src/Data/Game.purs @@ -0,0 +1,203 @@ +module EG.Data.Game where + +import Prelude + +import Data.Number as Number +import Data.Array as Array +import Data.Foldable (maximum, maximumBy, sum) +import Data.Function (on) +import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Number (infinity) +import Data.Profunctor.Strong (second, (&&&)) +import Data.Tuple (fst, snd) +import Data.Tuple.Nested (type (/\), (/\)) +import Dodo (Doc) +import Dodo as DD +import EG.Data.Payoff (Payoff(..)) +import EG.Data.Tuple (TupleIndex) +import EG.Data.Tuple as ETuple +import Effect (Effect) +import Effect.Random (randomInt) +import Safe.Coerce (coerce) + +type Player = TupleIndex + +newtype Game state choice = Game + { state :: state + , choices :: Array (choice /\ (Game state choice)) + } + +newtype GameReplay state choice = GameReplay + { state :: state + , next :: Maybe (choice /\ GameReplay state choice) + } + +newtype SolvedState state choice = SolvedState + { state :: state + , choice :: Maybe (choice /\ Game (SolvedState state choice) choice) + , payoffs :: Maybe (Payoff /\ Payoff) + } + +type PayoffFunction s = Int -> s -> Maybe (Payoff /\ Payoff) + +---------- Helpers +solvedStatePayoffs :: forall s c. SolvedState s c -> Maybe (Payoff /\ Payoff) +solvedStatePayoffs (SolvedState { payoffs }) = payoffs + +gameNodeCount :: forall s c. Game s c -> Int +gameNodeCount (Game { choices }) = 1 + sum (map (gameNodeCount <<< snd) choices) + +gameLeafCount :: forall s c. Game s c -> Int +gameLeafCount (Game { choices: [] }) = 1 +gameLeafCount (Game { choices }) = sum (map (gameLeafCount <<< snd) choices) + +gameDepth :: forall s c. Game s c -> Int +gameDepth (Game { choices }) = maybe 0 ((+) 1) + $ maximum + $ map (snd >>> gameDepth) choices + +randomGame :: forall s c. Game s c -> Effect (GameReplay s c) +randomGame (Game { choices, state }) = do + index <- randomInt 0 (Array.length choices - 1) + next <- case Array.index choices index of + Nothing -> pure Nothing + Just (choice /\ next) -> do + next <- randomGame next + pure (Just (choice /\ next)) + pure $ GameReplay { state, next } + +displayReplay :: forall s c a. (s -> Doc a) -> (c -> Doc a) -> GameReplay s c -> Doc a +displayReplay printState printChoice (GameReplay { state, next }) = + DD.lines + [ DD.indent (printState state) + , case next of + Nothing -> mempty + Just (choice /\ next) -> + DD.lines + [ Array.intercalate DD.space + [ DD.text "----" + , printChoice choice + , DD.text "---->" + ] + , displayReplay printState printChoice next + ] + + ] + +gameState :: forall s c. Game s c -> s +gameState (Game { state }) = state + +computePayoffs + :: forall s c + . Player + -> PayoffFunction s + -> Game s c + -> Game (SolvedState s c) c +computePayoffs player calculatePayoffs game = go player 0 game + where + go player depth (Game { state, choices }) = case choices of + [] -> Game + { choices: [] + , state: SolvedState + { state + , payoffs: calculatePayoffs depth state + , choice: Nothing + } + } + choices -> Game + { choices: nested + , state: SolvedState + { state + , payoffs: map _.payoff optimalChoice + , choice: map (_.choice &&& _.game) optimalChoice + } + } + where + nested = choices + # map (second (go (ETuple.other player) (depth + 1))) + + optimalChoice = nested + # map + ( \(choice /\ game) -> + { choice + , game + , payoff: game + # gameState + # solvedStatePayoffs + # fromMaybe (hell /\ hell) + } + ) + # maximumBy (on compare (_.payoff >>> ETuple.lookupPair player)) + + hell = Payoff (-infinity) + +-- minmax :: forall s c. PayoffFunction s -> Player -> Game s c -> Maybe (c /\ Game s c) +-- minmax calculatePayoffs player (Game { choices, state }) = +-- choices +-- # Array.mapMaybe +-- ( \(choice /\ game) -> case calculatePayoffs state of +-- Just payoffs -> Just { choice, game, payoffs } +-- Nothing -> Nothing +-- ) +-- # maximumBy (on compare (_.payoffs >>> ETuple.lookup player)) +-- # map \{ choice, game } -> choice /\ game + +---------- Display stuff +displaySolvedState :: forall a s c. (s -> Doc a) -> (c -> Doc a) -> SolvedState s c -> Doc a +displaySolvedState displayState displayChoice (SolvedState { payoffs, choice, state }) = DD.lines + [ DD.indent (displayState state) + , Array.intercalate DD.space + [ DD.text "Payoffs:" + , displayUnknown displayPayoffs payoffs + ] + , Array.intercalate DD.space + [ DD.text "Optimal choice:" + , displayUnknown displayChoice (map fst choice) + ] + ] + + where + displayUnknown :: forall e. (e -> Doc a) -> Maybe e -> Doc a + displayUnknown f (Just a) = f a + displayUnknown f Nothing = DD.text "???" + + displayPayoffs (l /\ r) = Array.fold + [ DD.text "(" + , displayNum (coerce l) + , DD.text "," + , DD.space + , displayNum (coerce r) + , DD.text ")" + ] + where + displayNum num = DD.text (show $ Number.floor (num * precision) / precision) + precision = 1000.0 + +-- newtype Payoff = Payoff Int +-- +-- newtype PayoffTreeNode label state choice = PayoffTreeNode +-- { expectedPayoff :: Payoff /\ Payoff +-- , children :: PayoffTree label state choicehoi-- +-- +-- newtype PayoffTree label state choice = PayoffTree +-- { label :: label +-- , state :: state +-- , choices :: Array (PayoffTreeNode label state choice) +-- } + +-- minmax +-- :: forall label choice +-- . Foldable choice +-- => Player +-- -> PayoffTree label choice +-- -> PayoffTreeNode label choice +-- minmax player (PayoffTree { label, choices }) = choice +-- where +-- choice = choices # maximumBy +-- ( on compare \(PayoffTreeNode { expectedPayoff, children }) -> +-- ETuple.lookup player expectedPayoff +-- ) + +---------- Typeclass instances +-- derive instance Eq Payoff +-- derive instance Ord Payoff diff --git a/purescript/strategy/src/Data/Payoff.purs b/purescript/strategy/src/Data/Payoff.purs new file mode 100644 index 0000000..d240245 --- /dev/null +++ b/purescript/strategy/src/Data/Payoff.purs @@ -0,0 +1,13 @@ +module EG.Data.Payoff where + +import Prelude +import Data.FastVect.FastVect (Vect) + +newtype Payoff = Payoff Number + +newtype PayoffMatrix p1 p2 = PayoffMatrix (Vect p1 (Vect p2 Payoff)) + +---------- Typeclass instances +derive instance Eq Payoff +derive instance Ord Payoff +derive newtype instance Show Payoff diff --git a/purescript/strategy/src/Data/Tuple.purs b/purescript/strategy/src/Data/Tuple.purs new file mode 100644 index 0000000..8ce3b99 --- /dev/null +++ b/purescript/strategy/src/Data/Tuple.purs @@ -0,0 +1,32 @@ +module EG.Data.Tuple (TupleIndex, left, right, lookupPair, lookup, other) where + +import Data.Either (Either(..)) +import Data.Either.Nested (type (\/)) +import Data.HeytingAlgebra (not) +import Data.Tuple.Nested (type (/\), (/\)) +import Safe.Coerce (coerce) + +-- | Position in a tuple. +-- | Logically equivalent to a boolean +-- | Constructable using `left` and `right` +newtype TupleIndex = TupleIndex Boolean + +other :: TupleIndex -> TupleIndex +other = coerce (not :: Boolean -> Boolean) + +left :: TupleIndex +left = TupleIndex false + +right :: TupleIndex +right = TupleIndex true + +lookupPair :: forall a. TupleIndex -> a /\ a -> a +lookupPair (TupleIndex inner) (a /\ b) = + if inner then b + else a + +lookup :: forall a b. TupleIndex -> a /\ b -> a \/ b +lookup (TupleIndex inner) (a /\ b) = + if inner then Right b + else Left a + diff --git a/purescript/strategy/src/Games/Tictactoe.purs b/purescript/strategy/src/Games/Tictactoe.purs new file mode 100644 index 0000000..f51c7a8 --- /dev/null +++ b/purescript/strategy/src/Games/Tictactoe.purs @@ -0,0 +1,188 @@ +module EG.Games.Tictactoe where + +import Prelude + +import Data.Array (findMap, foldl, intercalate) +import Data.Array as Array +import Data.Int as Int +import Data.Maybe (Maybe(..), isJust) +import Data.Tuple.Nested (type (/\), (/\)) +import Dodo (Doc) +import Dodo as DD +import EG.Data.Game (Game(..)) +import EG.Data.Payoff (Payoff(..)) +import EG.Data.Tuple as ETuple + +---------- Types +data Piece = X | O + +type Board = Array (Maybe Piece) +type Player = ETuple.TupleIndex + +data TurnState = NextMove Player | WonBy Player | Draw + +newtype State = State + { board :: Board + , turnState :: TurnState + } + +type GameGenerationState = { board :: Board, player :: Player } + +type Choice = Int -- mod 9 + +type TictactoeGame = Game State Choice + +---------- Helpers +initialState :: GameGenerationState +initialState = + { board: Array.replicate 9 Nothing + , player: ETuple.left + } + +pieceToPlayer :: Piece -> Player +pieceToPlayer X = ETuple.left +pieceToPlayer O = ETuple.right + +playerToPiece :: Player -> Piece +playerToPiece player = ETuple.lookupPair player (X /\ O) + +winner :: Board -> Maybe Player +winner = case _ of + [ a11 + , a12 + , a13 + , a21 + , a22 + , a23 + , a31 + , a32 + , a33 + -- For 10 element version + -- , a41 + ] -> + patterns # findMap (allEqual >=> map pieceToPlayer) + where + patterns = + [ [ a11, a12, a13 ] + , [ a21, a22, a23 ] + , [ a31, a32, a33 ] + , [ a11, a21, a31 ] + , [ a12, a22, a32 ] + , [ a13, a23, a33 ] + , [ a11, a22, a33 ] + , [ a13, a22, a31 ] + -- for weird version + -- , [ a11, a23, a32 ] + -- , [ a33, a12, a21 ] + -- even more weird version + -- , [ a13, a32, a21 ] + -- , [ a31, a23, a12 ] + + -- for 10 element version + -- , [ a21, a31, a41 ] + -- , [ a23, a32, a41 ] + + -- for 12 element version + -- , [ a41, a42, a43 ] + -- , [ a21, a31, a41 ] + -- , [ a22, a32, a42 ] + -- , [ a23, a33, a43 ] + -- , [ a21, a32, a43 ] + -- , [ a23, a32, a41 ] + ] + _ -> Nothing + where + allEqual :: forall a. Eq a => Array a -> Maybe a + allEqual = foldl go (Just Nothing) >>> join + where + go (Just Nothing) e = Just (Just e) + go whole@(Just (Just p)) e + | e == p = whole + go _ _ = Nothing + +---------- Game related functions +game :: TictactoeGame +game = go initialState + where + go { board, player } + | Just player <- winner board = Game + { state: State { board, turnState: WonBy player } + , choices: [] + } + | Array.all isJust board = Game + { state: State { board, turnState: Draw } + , choices: [] + } + | otherwise = Game + { state: State { board, turnState: NextMove player } + , choices: do + emptySpot <- board + # Array.mapWithIndex (/\) + # Array.mapMaybe \(index /\ piece) -> case piece of + Nothing -> Just index + Just _ -> Nothing + + let + state = + { player: ETuple.other player + , board: board # + Array.modifyAtIndices + [ emptySpot ] + (const $ Just $ playerToPiece player) + } + + pure (emptySpot /\ (go state)) + } + +payoff :: Int -> State -> Maybe (Payoff /\ Payoff) +payoff depth (State { turnState }) = case turnState of + WonBy player -> Just $ ETuple.lookupPair player ((pos /\ neg) /\ (neg /\ pos)) + Draw -> Just (mid /\ mid) + _ -> Nothing + where + depth' = Int.toNumber depth + pos = Payoff (1.0 / depth') + mid = Payoff 0.0 + neg = Payoff (-1.0 / depth') + +---------- Display stuff +displayChoice :: forall a. Choice -> Doc a +displayChoice num = Array.intercalate DD.space + [ DD.text "Place a piece at" + , DD.text "(" + <> DD.text (show (num `mod` 3)) + <> DD.text "," + <> DD.space + <> DD.text (show (num / 3)) + <> DD.text ")" + ] + +displayState :: forall a. State -> Doc a +displayState (State { board, turnState }) = DD.lines + [ intercalate DD.space (map printPiece $ Array.slice 0 3 board) + , intercalate DD.space (map printPiece $ Array.slice 3 6 board) + , intercalate DD.space (map printPiece $ Array.slice 6 9 board) + + -- for 10 element version + -- , intercalate DD.space (map printPiece $ Array.slice 9 10 board) + , DD.text "State: " <> printTurnState turnState + ] + where + printPiece (Just X) = DD.text "X" + printPiece (Just O) = DD.text "O" + printPiece Nothing = DD.text "-" + + printTurnState Draw = DD.text "Draw!" + printTurnState (NextMove player) = Array.intercalate DD.space + [ DD.text "player " + , DD.text (ETuple.lookupPair player ("1" /\ "2")) + , DD.text "should make a move" + ] + printTurnState (WonBy player) = Array.intercalate DD.space + [ DD.text "won by - " + , DD.text (ETuple.lookupPair player ("X player" /\ "O player")) + ] + +---------- Typeclass instances +derive instance Eq Piece + diff --git a/purescript/strategy/src/Main.purs b/purescript/strategy/src/Main.purs new file mode 100644 index 0000000..5c18dca --- /dev/null +++ b/purescript/strategy/src/Main.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude + +import Effect (Effect) +import Effect.Console (log) + +main :: Effect Unit +main = do + log "🍝" diff --git a/purescript/strategy/test/Main.purs b/purescript/strategy/test/Main.purs new file mode 100644 index 0000000..f91f98c --- /dev/null +++ b/purescript/strategy/test/Main.purs @@ -0,0 +1,11 @@ +module Test.Main where + +import Prelude + +import Effect (Effect) +import Effect.Class.Console (log) + +main :: Effect Unit +main = do + log "🍝" + log "You should add some tests."