From 0bb81bfc46f54838613fd9e4b02839aa35ca6d79 Mon Sep 17 00:00:00 2001 From: Matei Adriel Date: Sun, 4 Apr 2021 00:37:14 +0300 Subject: [PATCH] feat: basic rendering --- purescript/factorio-throughput/src/Main.purs | 39 ++++---- .../factorio-throughput/src/Render.purs | 18 ++++ .../factorio-throughput/src/Run/Id.purs | 33 +++++++ .../factorio-throughput/src/Throughput.purs | 90 ++++++++++++++----- purescript/factorio-throughput/src/index.js | 38 ++++++++ 5 files changed, 172 insertions(+), 46 deletions(-) create mode 100644 purescript/factorio-throughput/src/Render.purs create mode 100644 purescript/factorio-throughput/src/Run/Id.purs create mode 100644 purescript/factorio-throughput/src/index.js diff --git a/purescript/factorio-throughput/src/Main.purs b/purescript/factorio-throughput/src/Main.purs index ae3eebb..0f2e3fd 100644 --- a/purescript/factorio-throughput/src/Main.purs +++ b/purescript/factorio-throughput/src/Main.purs @@ -2,39 +2,34 @@ 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') +import Moontorio.Render (RenderFn, renderFactory) +import RealFunction (PortSide(..), RealFunction, SolveM, collectConstraints, myFactory, runSolveM, tryFindBoundSolveM) 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] + a <- tryFindBoundSolveM (0 /\ Input) + b <- tryFindBoundSolveM (0 /\ Output) + c <- tryFindBoundSolveM (1 /\ Input) + d <- tryFindBoundSolveM (1 /\ Output) + e <- tryFindBoundSolveM (2 /\ Input) + f <- tryFindBoundSolveM (2 /\ Output) + g <- tryFindBoundSolveM (4 /\ Input) + h <- tryFindBoundSolveM (4 /\ Output) + pure [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 +main :: RenderFn -> Effect Unit +main render = 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 \ No newline at end of file + renderFactory render myFactory s.constraints + -- log $ joinWith "\n" $ show <$> s.constraints + -- logShow $ f <*> pure 0.0 \ No newline at end of file diff --git a/purescript/factorio-throughput/src/Render.purs b/purescript/factorio-throughput/src/Render.purs new file mode 100644 index 0000000..ab7391b --- /dev/null +++ b/purescript/factorio-throughput/src/Render.purs @@ -0,0 +1,18 @@ +module Moontorio.Render where + +import Prelude + +import Data.Foldable (for_) +import Data.Tuple.Nested ((/\)) +import Effect (Effect) +import RealFunction (Constraints, Factory, PortSide(..), RealFunction, factoryPorts, tryFindBoundPure, tryFindValuePure) + +type RenderFn = String -> Array RealFunction -> Effect Unit + +renderFactory :: RenderFn -> Factory -> Constraints -> Effect Unit +renderFactory render factory constraints = for_ (factoryPorts factory) \portId -> do + let inputMax = tryFindBoundPure (portId /\ Input) constraints + let outputMax = tryFindBoundPure (portId /\ Output) constraints + let actual = tryFindValuePure portId constraints + + render ("Port " <> show portId) [inputMax, outputMax, actual] \ No newline at end of file diff --git a/purescript/factorio-throughput/src/Run/Id.purs b/purescript/factorio-throughput/src/Run/Id.purs new file mode 100644 index 0000000..962de55 --- /dev/null +++ b/purescript/factorio-throughput/src/Run/Id.purs @@ -0,0 +1,33 @@ +module Run.Supply where + +import Prelude + +import Data.Tuple (Tuple(..)) +import Run (Run, Step(..), lift, on, runAccumPure) +import Type.Proxy (Proxy(..)) + +-- | Monad providing an infinite supply of values of a particular type. +-- | Example use cases: generating unique ids. +data SupplyF s a = Supply (s -> a) + +type SUPPLY s r = ( supply :: SupplyF s | r ) + +generate :: forall r s. Run (SUPPLY s r) s +generate = lift _supply (Supply identity) + +-- | Elimininate the supply monad using a function generating the next value +runSupply :: forall r s a. (s -> s) -> s -> Run (SUPPLY s r) a -> Run r a +runSupply next + = runAccumPure + (next >>> \current -> on _supply (Loop <<< handleSupply current) Done) + (\s a -> a) + where + handleSupply :: forall i. s -> SupplyF s i -> Tuple s i + handleSupply current (Supply continue) = Tuple current (continue current) + +---------- Typeclass instances +derive instance functorSupply :: Functor (SupplyF s) + +--------- SProxies +_supply :: Proxy "supply" +_supply = Proxy \ No newline at end of file diff --git a/purescript/factorio-throughput/src/Throughput.purs b/purescript/factorio-throughput/src/Throughput.purs index 7a4d3d6..1f03ea7 100644 --- a/purescript/factorio-throughput/src/Throughput.purs +++ b/purescript/factorio-throughput/src/Throughput.purs @@ -5,12 +5,13 @@ import Prelude import Data.Array (length, mapWithIndex) import Data.Array as Array import Data.Either (Either) -import Data.Foldable (for_, minimum) +import Data.Foldable (foldMap, 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.HashSet as HashSet import Data.Int (toNumber) import Data.Lens (Lens') import Data.Lens.Record (prop) @@ -20,15 +21,18 @@ 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 (Tuple(..), fst, uncurry) import Data.Tuple.Nested (type (/\), (/\)) -import Functorio.Lens (getAt, modifyAt) +import Functorio.Lens (modifyAt) +import Math (sin) 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.Reader.Extra (fromState') import Run.State (STATE, runState) +import Run.Supply (SUPPLY, generate, runSupply) import Type.Proxy (Proxy(..)) import Type.Row (type (+)) import Visited (VISITED, once, runVisited) @@ -57,28 +61,34 @@ type Factory = HashMap MachineId Machine ---------- Some configs yellowBelt :: BeltConfig -yellowBelt = { speed: 15.0, delay: 1.0/3.0 } +yellowBelt = { speed: 15.0, delay: 4.0/3.0 } redBelt :: BeltConfig -redBelt = { speed: 30.0, delay: 1.0/6.0 } +redBelt = { speed: 30.0, delay: 4.0/6.0 } blueBelt :: BeltConfig -blueBelt = { speed: 45.0, delay: 1.0/8.0 } +blueBelt = { speed: 45.0, delay: 4.0/8.0 } -- | Example factory myFactory :: Factory myFactory = Map.fromArray machines where machines = mapWithIndex Tuple - [ Provider [0, 1, 2] $ const 80.0 + [ Provider [0, 1] $ startsAtZero $ \t -> 40.0 + 10.0 * sin t , Belt { input: 0, output: 3, config: yellowBelt } , Belt { input: 1, output: 4, config: redBelt } - , Belt { input: 2, output: 5, config: blueBelt } + -- , Belt { input: 2, output: 5, config: blueBelt } , Consumer 3 , Consumer 4 - , Consumer 5 ] +---------- Helpers for real functions +type Endomorphism a = a -> a + +startsAtZero :: Endomorphism RealFunction +startsAtZero f x | x >= 0.0 = f x + | otherwise = 0.0 + ---------- Monad for factory solving type PortData = { id :: PortId @@ -105,38 +115,44 @@ data ThroughputConstraint type Constraints = Array ThroughputConstraint type SolveState = - { constraints :: Constraints - , lastId :: Int } + { constraints :: Constraints } type SolveM = Run ( EXCEPT String + STATE SolveState + READER Factory + + SUPPLY Int + () ) 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 } +runSolveM factory = runReader factory >>> runState mempty >>> runExcept >>> runSupply ((+) 1) 0 >>> extract focusBiRelationship :: PortId /\ PortSide -> BiRelationship -> Maybe BiRelationship focusBiRelationship place relationship | relationship.p1 == place = Just relationship | relationship.p2 == place = Just $ flipBiRelationship relationship | otherwise = Nothing +focusBiRelationshipWithoutSide :: PortId -> BiRelationship -> Maybe BiRelationship +focusBiRelationshipWithoutSide id relationship | fst relationship.p1 == id = Just relationship + | fst relationship.p2 == id = Just $ flipBiRelationship relationship + | otherwise = Nothing + flipBiRelationship :: BiRelationship -> BiRelationship flipBiRelationship { p1, p2, p1top2, p2top1 } = { p1: p2, p2: p1, p1top2: p2top1, p2top1: p1top2 } +factoryPorts :: Factory -> HashSet.HashSet PortId +factoryPorts = foldMap case _ of + Belt { input, output } -> HashSet.fromArray [input, output] + Provider outputs _ -> HashSet.fromArray outputs + Chest { inputs, outputs } -> HashSet.fromArray (inputs <> outputs) + Consumer input -> HashSet.singleton input + ---------- 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 @@ -157,6 +173,12 @@ evalExpr = case _ of tryFindBound :: forall r. PortId /\ PortSide -> Run (READER Constraints r) RealFunction tryFindBound at = tryFindBoundImpl at <#> \f time -> extract $ runVisited $ f time +tryFindBoundSolveM :: PortId /\ PortSide -> SolveM RealFunction +tryFindBoundSolveM at = fromState' _constraints $ tryFindBound at + +tryFindBoundPure :: PortId /\ PortSide -> Constraints -> RealFunction +tryFindBoundPure at constraints = extract $ runReader constraints $ tryFindBound at + tryFindBoundImpl :: forall r k. PortId /\ PortSide -> Run (READER Constraints r) (Number -> Run (VISITED BiRelationshipId k) Number) @@ -174,7 +196,29 @@ tryFindBoundImpl (targetId /\ targetSide) = do # runReader constraints <#> minimum' where - minimum' = minimum >>> fromMaybe infinity + minimum' = minimum >>> fromMaybe 0.0 + +tryFindValue :: forall r. PortId -> Run (READER Constraints r) RealFunction +tryFindValue at = tryFindValueImpl at <#> \f time -> extract $ runVisited $ f time + +tryFindValueImpl :: forall r k. PortId -> Run (READER Constraints r) (Number -> Run (VISITED BiRelationshipId k) Number) +tryFindValueImpl targetId = do + constraints <- ask + pure \time -> constraints + # traverseFail case _ of + Limit expr _ id | id == targetId -> evalExpr expr <*> pure time + BiRelationship id raw + | Just relationship <- focusBiRelationshipWithoutSide targetId raw -> do + f <- once id fail $ tryFindValueImpl $ fst relationship.p2 + f (relationship.p1top2 time) + _ -> fail + # runReader constraints + <#> minimum' + where + minimum' = minimum >>> fromMaybe 0.0 + +tryFindValuePure :: PortId -> Constraints -> RealFunction +tryFindValuePure at constraints = extract $ runReader constraints $ tryFindValue at collectConstraintsImpl :: MachineId -> Machine -> SolveM Unit collectConstraintsImpl at = case _ of @@ -204,9 +248,10 @@ collectConstraintsImpl at = case _ of | otherwise = head.maxOutput time outputsImpl _ _ _ = Nil - Consumer for -> pure unit + Consumer for -> do + constrain $ Limit (Literal infinity) Output for Belt { input, output, config } -> do - biId <- getId + biId <- generate constrain $ BiRelationship biId { p1: input /\ Output @@ -220,9 +265,6 @@ collectConstraintsImpl at = case _ of _ -> unsafeCrashWith "unimplemented" ---------- Lenses -_lastId :: Lens' SolveState Int -_lastId = prop (Proxy :: _ "lastId") - _constraints :: Lens' SolveState (Array ThroughputConstraint) _constraints = prop (Proxy :: _ "constraints") diff --git a/purescript/factorio-throughput/src/index.js b/purescript/factorio-throughput/src/index.js new file mode 100644 index 0000000..5e19d4b --- /dev/null +++ b/purescript/factorio-throughput/src/index.js @@ -0,0 +1,38 @@ +import { main } from "Main.purs"; +import functionPlot from "function-plot"; + +let lastId = 0; +const root = document.body; + +const width = 400; +const height = 250; + +const render = (name) => (functions) => () => { + const currentId = ++lastId; + + console.log("Renering!!!"); + + const node = document.createElement("div"); + node.id = currentId; + node.title = name; + node.className = "graph"; + + root.appendChild(node); + + const functionData = functions.map((fn) => ({ + fn: (scope) => fn(scope.x), + graphType: "polyline", + })); + + functionPlot({ + target: node, + width, + height, + yAxis: { domain: [-5, 35] }, + xAxis: { domain: [-1, 5] }, + grid: true, + data: functionData, + }); +}; + +main(render)();