From 8ebe233bec579128c9cb6cc549373561a4cf2876 Mon Sep 17 00:00:00 2001
From: Matei Adriel <rafaeladriel11@gmail.com>
Date: Sun, 29 Oct 2023 02:53:29 +0100
Subject: [PATCH] Added `strategy`

---
 purescript/README.md                         |   1 +
 purescript/strategy/.gitignore               |  10 +
 purescript/strategy/packages.dhall           | 105 ++++++++++
 purescript/strategy/spago.dhall              |  30 +++
 purescript/strategy/src/Data/Game.purs       | 203 +++++++++++++++++++
 purescript/strategy/src/Data/Payoff.purs     |  13 ++
 purescript/strategy/src/Data/Tuple.purs      |  32 +++
 purescript/strategy/src/Games/Tictactoe.purs | 188 +++++++++++++++++
 purescript/strategy/src/Main.purs            |  10 +
 purescript/strategy/test/Main.purs           |  11 +
 10 files changed, 603 insertions(+)
 create mode 100644 purescript/strategy/.gitignore
 create mode 100644 purescript/strategy/packages.dhall
 create mode 100644 purescript/strategy/spago.dhall
 create mode 100644 purescript/strategy/src/Data/Game.purs
 create mode 100644 purescript/strategy/src/Data/Payoff.purs
 create mode 100644 purescript/strategy/src/Data/Tuple.purs
 create mode 100644 purescript/strategy/src/Games/Tictactoe.purs
 create mode 100644 purescript/strategy/src/Main.purs
 create mode 100644 purescript/strategy/test/Main.purs

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 `<version>` 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 =
+        "<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."