feat: basic constraint solving

purescript/factorio-throughput/.gitignore

@@ -0,0 +1,10 @@
+/bower_components/
+/node_modules/
+/.pulp-cache/
+/output/
+/generated-docs/
+/.psc-package/
+/.psc*
+/.purs*
+/.psa*
+/.spago

purescript/factorio-throughput/packages.dhall

@@ -0,0 +1,27 @@
+let upstream =
+      https://github.com/purescript/package-sets/releases/download/psc-0.14.0-20210324/packages.dhall sha256:b4564d575da6aed1c042ca7936da97c8b7a29473b63f4515f09bb95fae8dddab
+
+let additions =
+      { debugged =
+        { dependencies =
+          [ "prelude"
+          , "console"
+          , "ordered-collections"
+          , "either"
+          , "tuples"
+          , "lists"
+          , "strings"
+          , "arrays"
+          , "bifunctors"
+          , "record"
+          , "effect"
+          , "datetime"
+          , "enums"
+          , "unordered-collections"
+          ]
+        , repo = "https://github.com/hdgarrood/purescript-debugged"
+        , version = "master"
+        }
+      }
+
+in  upstream // additions

purescript/factorio-throughput/spago.dhall

@@ -0,0 +1,19 @@
+{-
+Welcome to a Spago project!
+You can edit this file as you like.
+-}
+{ name = "my-project"
+, dependencies =
+  [ "console"
+  , "debug"
+  , "effect"
+  , "filterable"
+  , "profunctor-lenses"
+  , "psci-support"
+  , "run"
+  , "strings"
+  , "unordered-collections"
+  ]
+, packages = ./packages.dhall
+, sources = [ "src/**/*.purs", "test/**/*.purs" ]
+}

purescript/factorio-throughput/src/Lens.purs

@@ -0,0 +1,62 @@
+module Functorio.Lens where
+
+import Prelude
+
+import Data.HashMap (HashMap)
+import Data.HashMap as H
+import Data.HashSet (HashSet)
+import Data.HashSet as S
+import Data.Hashable (class Hashable)
+import Data.Lens (AGetter, Fold, Iso', Lens', Setter, iso, lens, over, preview, set, view)
+import Data.Maybe (Maybe(..), maybe')
+import Data.Maybe.First (First)
+import Run (Run)
+import Run.Reader (READER, ask)
+import Run.State (STATE, get, modify)
+
+---------- Missing instances
+atHashMap :: forall k v. Hashable k => k -> Lens' (HashMap k v) (Maybe v)
+atHashMap k =
+    lens (H.lookup k) \m ->
+      maybe' (\_ -> H.delete k m) \v -> H.insert k v m
+
+-- | At implementation for hash sets
+atHashSetRaw :: forall v. Hashable v => v -> Lens' (HashSet v) (Maybe Unit)
+atHashSetRaw x = lens get (flip update)
+    where
+      get xs =
+        if S.member x xs
+           then Just unit
+           else Nothing
+      update Nothing = S.delete x
+      update (Just _) = S.insert x
+
+-- | Boolean implementation for AT on hash sets
+atHashSet :: forall v. Hashable v => v -> Lens' (HashSet v) Boolean
+atHashSet v = atHashSetRaw v <<< maybeUnitToBoolean
+
+-- | Helper fro implementing atHashSet'
+maybeUnitToBoolean :: Iso' (Maybe Unit) Boolean
+maybeUnitToBoolean = iso to from
+    where
+    from true = Just unit
+    from false = Nothing 
+    
+    to Nothing = false
+    to _ = true 
+
+--------- Helpers for monadic state
+getAt :: forall s t a b r. AGetter s t a b -> Run (STATE s r) a
+getAt optic = view optic <$> get
+
+getPreview :: forall r s t a b. Fold (First a) s t a b -> Run (STATE s r) (Maybe a)
+getPreview optic = preview optic <$> get
+
+setAt :: forall s a b r. Setter s s a b -> b -> Run (STATE s r) Unit
+setAt optic value = set optic value # modify
+
+modifyAt :: forall s a b r. Setter s s a b -> (a -> b) -> Run (STATE s r) Unit
+modifyAt optic f = over optic f # modify
+
+askAt :: forall s t a b r. AGetter s t a b -> Run (READER s r) a
+askAt optic = ask <#> view optic  

purescript/factorio-throughput/src/Main.purs

@@ -0,0 +1,40 @@
+module Main where
+
+import Prelude
+
+import Data.Compactable (compact)
+import Data.Either (Either(..))
+import Data.Foldable (for_)
+import Data.HashMap as HashMap
+import Data.String (joinWith)
+import Data.Tuple (Tuple(..))
+import Data.Tuple.Nested ((/\))
+import Effect (Effect)
+import Effect.Class.Console (logShow)
+import Effect.Console (log)
+import RealFunction (PortSide(..), RealFunction, SolveM, _constraints, collectConstraints, myFactory, runSolveM, tryFindBound)
+import Run.Except (runFail)
+import Run.Reader.Extra (fromState')
+
+p :: SolveM (Array RealFunction)
+p = do
+  collectConstraints
+  a <- fromState' _constraints $ runFail $ tryFindBound (0 /\ Input)
+  b <- fromState' _constraints $ runFail $ tryFindBound (0 /\ Output)
+  c <- fromState' _constraints $ runFail $ tryFindBound (1 /\ Input)
+  d <- fromState' _constraints $ runFail $ tryFindBound (1 /\ Output)
+  e <- fromState' _constraints $ runFail $ tryFindBound (2 /\ Input)
+  f <- fromState' _constraints $ runFail $ tryFindBound (2 /\ Output)
+  g <- fromState' _constraints $ runFail $ tryFindBound (4 /\ Input)
+  h <- fromState' _constraints $ runFail $ tryFindBound (4 /\ Output)
+  pure $ compact [a, b, c, d, e, f, g, h]
+
+main :: Effect Unit
+main = do
+  for_ (HashMap.toArrayBy Tuple myFactory) \(Tuple key value) -> log $ show key <> ": " <> show value
+
+  case runSolveM myFactory p of
+    Left err -> log err
+    Right (Tuple s f) -> do
+      log $ joinWith "\n" $ show <$> s.constraints
+      logShow $ f <*> pure 0.0

purescript/factorio-throughput/src/Run/Fail.purs

@@ -0,0 +1,12 @@
+module Run.Fail.Extra where
+
+import Prelude
+
+import Data.Compactable (class Compactable, compact)
+import Data.Traversable (class Traversable, traverse)
+import Run (Run)
+import Run.Except (FAIL, runFail)
+
+-- | `Compact` / `MapMaybe` usnig the `Fail` ability
+traverseFail :: forall r t a b. Compactable t => Traversable t => (a -> Run (FAIL r) b) -> t a -> Run r (t b)
+traverseFail f = traverse (f >>> runFail) >>> map compact

purescript/factorio-throughput/src/Run/Reader.purs

@@ -0,0 +1,18 @@
+module Run.Reader.Extra where
+
+import Prelude
+
+import Data.Lens (AGetter)
+import Functorio.Lens (getAt)
+import Run (Run)
+import Run.Reader (READER, runReader)
+import Run.State (STATE, get)
+import Type.Row (type (+))
+
+-- | Use state from the environemtn to eliminate a reader monad.
+fromState :: forall r s a. Run (STATE s + READER s r) a -> Run (STATE s r) a
+fromState m = get >>= flip runReader  m
+
+-- | Focus on some state in the environemtn to eliminate a reader monad.
+fromState' :: forall s t a b r x. AGetter s t a b -> Run (STATE s + READER a r) x -> Run (STATE s r) x 
+fromState' optic m = getAt optic >>= flip runReader m

purescript/factorio-throughput/src/Run/Visited.purs

@@ -0,0 +1,35 @@
+-- | Allows the programmer to limit a monad to only run once (using a key)
+module Visited (VISITED, runVisited, once) where
+
+import Prelude
+
+import Data.HashSet (HashSet)
+import Data.HashSet as HashSet
+import Data.Hashable (class Hashable)
+import Run (Run)
+import Run.State (State, evalStateAt, getAt, modifyAt)
+import Type.Proxy (Proxy(..))
+
+-- | Monad keeping track of all the runned monad' keys
+type VISITED a r = ( visited :: State (HashSet a) | r )
+
+-- | Eliminate the Visited effect
+runVisited :: forall d a r. Hashable d => Run (VISITED d r) a -> Run r a
+runVisited = evalStateAt _visited mempty
+
+-- | Mark a key as visited
+visit :: forall a r. Hashable a => a -> Run (VISITED a r) Unit
+visit e = modifyAt _visited $ HashSet.insert e
+
+-- | Condition a monad to only run once. 
+-- | The first argument is a key, 
+-- | and the second is a default value to use when the monad has already run.
+once :: forall d a r. Hashable d => d -> Run (VISITED d r) a -> Run (VISITED d r) a -> Run (VISITED d r) a 
+once at default m = do
+    visited <- getAt _visited
+    if HashSet.member at visited
+        then default
+        else visit at *> m
+
+_visited :: Proxy "visited"
+_visited = Proxy

purescript/factorio-throughput/src/Throughput.purs

@@ -0,0 +1,256 @@
+module RealFunction where
+
+import Prelude
+
+import Data.Array (length, mapWithIndex)
+import Data.Array as Array
+import Data.Either (Either)
+import Data.Foldable (for_, minimum)
+import Data.FoldableWithIndex (forWithIndex_)
+import Data.Generic.Rep (class Generic)
+import Data.HashMap (HashMap)
+import Data.HashMap as HashMap
+import Data.HashMap as Map
+import Data.Int (toNumber)
+import Data.Lens (Lens')
+import Data.Lens.Record (prop)
+import Data.List (List(..), (:))
+import Data.List as List
+import Data.Maybe (Maybe(..), fromJust, fromMaybe)
+import Data.Number (infinity)
+import Data.Show.Generic (genericShow)
+import Data.Traversable (for)
+import Data.Tuple (Tuple(..), uncurry)
+import Data.Tuple.Nested (type (/\), (/\))
+import Functorio.Lens (getAt, modifyAt)
+import Partial.Unsafe (unsafeCrashWith, unsafePartial)
+import Run (Run, extract)
+import Run.Except (EXCEPT, fail, runExcept)
+import Run.Fail.Extra (traverseFail)
+import Run.Reader (READER, ask, runReader)
+import Run.State (STATE, runState)
+import Type.Proxy (Proxy(..))
+import Type.Row (type (+))
+import Visited (VISITED, once, runVisited)
+
+type RealFunction = Number -> Number
+type BeltConfig = 
+    { speed :: Number
+    , delay :: Number }
+
+type ChestConfig =
+    { maxContent :: Number
+    , delay :: Number }
+
+type PortId = Int
+type MachineId = Int
+
+data PortSide = Input | Output
+
+data Machine
+    = Belt { input :: PortId, output :: PortId, config :: BeltConfig }
+    | Chest { inputs :: Array PortId, outputs :: Array PortId, config :: ChestConfig }
+    | Provider (Array PortId) RealFunction
+    | Consumer PortId
+
+type Factory = HashMap MachineId Machine
+
+---------- Some configs
+yellowBelt :: BeltConfig
+yellowBelt = { speed: 15.0, delay: 1.0/3.0 }
+
+redBelt :: BeltConfig
+redBelt = { speed: 30.0, delay: 1.0/6.0 }
+
+blueBelt :: BeltConfig
+blueBelt = { speed: 45.0, delay: 1.0/8.0 }
+
+-- | Example factory
+myFactory :: Factory
+myFactory = Map.fromArray machines
+    where
+    machines = mapWithIndex Tuple 
+        [ Provider [0, 1, 2] $ const 80.0
+        , Belt { input: 0, output: 3, config: yellowBelt }
+        , Belt { input: 1, output: 4, config: redBelt }
+        , Belt { input: 2, output: 5, config: blueBelt }
+        , Consumer 3
+        , Consumer 4
+        , Consumer 5
+        ]
+
+---------- Monad for factory solving
+type PortData =
+    { id :: PortId
+    , maxInput :: Number -> Number
+    , maxOutput :: Number -> Number }
+
+data ConstraintExpression
+    = PortDependent (Array PortId) (Array PortData -> RealFunction)
+    | Function RealFunction
+    | Literal Number
+
+type BiRelationship =         
+    { p1top2 :: RealFunction
+    , p2top1 :: RealFunction
+    , p1 :: PortId /\ PortSide
+    , p2 :: PortId /\ PortSide }
+
+type BiRelationshipId = Int
+
+data ThroughputConstraint
+    = Limit ConstraintExpression PortSide PortId
+    | BiRelationship BiRelationshipId BiRelationship
+
+type Constraints = Array ThroughputConstraint
+
+type SolveState = 
+    { constraints :: Constraints 
+    , lastId :: Int }
+
+type SolveM = Run 
+    ( EXCEPT String 
+    + STATE SolveState 
+    + READER Factory
+    + () )
+
+runSolveM :: forall a. Factory -> SolveM a -> Either String (Tuple SolveState a)
+runSolveM factory = runReader factory >>> runState initialState >>> runExcept >>> extract
+
+initialState :: SolveState
+initialState = { constraints: [], lastId: 0 }
+
+focusBiRelationship :: PortId /\ PortSide -> BiRelationship -> Maybe BiRelationship
+focusBiRelationship place relationship | relationship.p1 == place = Just relationship
+                                       | relationship.p2 == place = Just $ flipBiRelationship relationship
+                                       | otherwise = Nothing 
+
+flipBiRelationship :: BiRelationship -> BiRelationship 
+flipBiRelationship { p1, p2, p1top2, p2top1 } = { p1: p2, p2: p1, p1top2: p2top1, p2top1: p1top2 }
+
+---------- System solving algorithm
+constrain :: ThroughputConstraint -> SolveM Unit
+constrain constraint = modifyAt _constraints $ push constraint
+    where
+    push = flip Array.snoc
+
+getId :: SolveM Int
+getId = modifyAt _lastId ((+) 1) *> getAt _lastId
+
+collectConstraints :: SolveM Unit
+collectConstraints = do
+    factory <- ask
+    for_ (HashMap.toArrayBy (/\) $ factory) $ uncurry collectConstraintsImpl
+
+getPortData :: forall r. PortId -> Run (READER Constraints r) PortData
+getPortData id = ado 
+    maxInput <- tryFindBound $ id /\ Input
+    maxOutput <- tryFindBound $ id /\ Output
+    in { id, maxInput, maxOutput }
+
+evalExpr :: forall r. ConstraintExpression -> Run (READER Constraints r) RealFunction
+evalExpr = case _ of
+    Literal a -> pure (const a)
+    Function f -> pure f
+    PortDependent portIds f -> for portIds getPortData <#> f
+
+tryFindBound :: forall r. PortId /\ PortSide -> Run (READER Constraints r) RealFunction
+tryFindBound at = tryFindBoundImpl at <#> \f time -> extract $ runVisited $ f time 
+
+tryFindBoundImpl :: forall r k. 
+    PortId /\ PortSide -> 
+    Run (READER Constraints r) (Number -> Run (VISITED BiRelationshipId k) Number) 
+tryFindBoundImpl (targetId /\ targetSide) = do
+    constraints <- ask
+    pure \time -> constraints
+        # traverseFail case _ of
+            Limit expr side id | side == targetSide && id == targetId -> 
+                evalExpr expr <*> pure time 
+            BiRelationship id raw 
+                | Just relationship <- focusBiRelationship (targetId /\ targetSide) raw -> do
+                    f <- once id fail $ tryFindBoundImpl relationship.p2 
+                    f (relationship.p1top2 time)
+            _ -> fail
+        # runReader constraints 
+        <#> minimum'
+    where
+    minimum' = minimum >>> fromMaybe infinity
+
+collectConstraintsImpl :: MachineId -> Machine -> SolveM Unit
+collectConstraintsImpl at = case _ of
+    Provider for amount -> do
+        forWithIndex_ for \index id -> do
+            let limit ports time 
+                  = outputs ports time
+                  # Array.findMap (\(id' /\ f) -> if id == id' then Just (f time) else Nothing)
+                  # unsafePartial fromJust -- TODO: error handling
+            constrain $ Limit (PortDependent for limit) Input id
+        where
+        outputs :: Array PortData -> Number -> Array (PortId /\ RealFunction)
+        outputs ports time 
+            = outputsImpl (length ports) (List.fromFoldable sorted) amount 
+            # Array.fromFoldable 
+            # Array.zipWith (_.id >>> Tuple) sorted
+            where
+            sorted :: Array PortData
+            sorted = Array.sortWith (_.maxOutput >>> (#) time) ports
+
+        outputsImpl :: Int -> List PortData -> RealFunction -> List RealFunction 
+        outputsImpl 1 (head:Nil) remaining = pure \time -> min (head.maxOutput time) (remaining time)
+        outputsImpl n (head:tail) remaining = current:(outputsImpl (n - 1) tail $ remaining - current)
+            where
+            current time 
+                | head.maxOutput time >= (remaining time) / (toNumber n) = (remaining time) / (toNumber n)
+                | otherwise = head.maxOutput time
+        outputsImpl _ _ _ = Nil
+
+    Consumer for -> pure unit
+    Belt { input, output, config } -> do
+        biId <- getId
+
+        constrain $ BiRelationship biId 
+            { p1: input /\ Output
+            , p2: output /\ Input
+            , p1top2: (+) config.delay
+            , p2top1: (+) (-config.delay) }
+
+        constrain $ Limit (Literal config.speed) Output input
+        constrain $ Limit (Literal config.speed) Input output
+
+    _ -> unsafeCrashWith "unimplemented"
+
+---------- Lenses
+_lastId :: Lens' SolveState Int
+_lastId = prop (Proxy :: _ "lastId")
+
+_constraints :: Lens' SolveState (Array ThroughputConstraint) 
+_constraints = prop (Proxy :: _ "constraints")
+
+---------- Typeclass instances
+derive instance genericMachine :: Generic Machine _
+derive instance genericPortSide :: Generic PortSide _
+derive instance eqPortSide :: Eq PortSide
+
+instance showMachine :: Show Machine where
+    show = case _ of
+        Provider for _ -> "Provider<" <> show for <> ">"
+        Consumer for -> "Consumer<" <> show for <> ">"
+        Belt { config, input, output } -> "Belt<" <> show input <> " -> " <> show output <> ", " <> show config <> ">"
+        Chest { inputs, outputs, config } -> "Chest<" <> show inputs <> " -> " <> show outputs <> ", " <> show config <> ">"
+
+instance showConstraint :: Show ThroughputConstraint where
+    show = case _ of
+        Limit f side id -> show f <> " !> " <> showPort (id /\ side)
+        BiRelationship _ { p1, p2 } -> showPort p1 <> " <-> " <> showPort p2
+        where
+        showPort (p /\ side) = "?" <> show p <> case side of
+            Input -> "<-"
+            Output -> "<-"
+
+instance showConstraintExpression :: Show ConstraintExpression where
+    show (Literal i) = show i
+    show (Function f) = "<Function>"
+    show (PortDependent ids f) = "(" <> show ids <> " -> <Function>)"  
+
+instance showPortSide :: Show PortSide where
+    show = genericShow

purescript/factorio-throughput/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."