1
Fork 0

Add 'factorio-throughput'

This commit is contained in:
prescientmoon 2024-03-04 14:32:38 +01:00
commit 40db6f8b37
Signed by: prescientmoon
SSH key fingerprint: SHA256:UUF9JT2s8Xfyv76b8ZuVL7XrmimH4o49p4b+iexbVH4
23 changed files with 1150 additions and 25 deletions

View file

@ -1,27 +1,28 @@
# Purescript
| Name | Description |
| ---------------------------------------- | -------------------------------------------------------------------------------------------------------------------- |
| [abilities](./abilities/) | Typeclass-dictionary abuse enabling the creation of a barebones effect system |
| [bug](./bug/) | Unknown reason of existence |
| [canopy](./canopy/) | Unfinished attempt at writing a [Diplomacy](<https://en.wikipedia.org/wiki/Diplomacy_(game)>) adjudecation engine |
| [compose](./compose/) | Overload do-notation for function composition and existential types |
| [ecs](./ecs/) | Purescript-wrapper for [thi.ng/ecs](thi.ng/ecs) |
| [existentials-blog](./existentials-blog) | Perhaps supposed to turn into a blog about existentials? |
| [existentials](./existentials) | Experiment regarding the Church-encoding of existential types |
| [free](./free/) | Experiments regarding free monads and interpreting algebras |
| [gadts](./gadts) | Experiment regarding ways to encode GADTs in Purescript |
| [kombinators](./kombinators) | Attempt at generating factorio combinator networks programmatically |
| [lambda-calculus](./lambda-calculus) | Lambda calculus evaluator |
| [lunarline](./lunarline) | Attempt at optimizing a functional language using compile-time partial evaluation |
| [lune](./lune) | Failed effect-system project |
| [maps](./maps) | Attempt at implementing maps with membership proofs |
| [proofs](./proofs) | Attempt at expressing mathematical proofs using Purescript's effect system |
| [purebird](./purebird) | Flappy-bird game |
| [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` |
| [thumbor](./thumbor) | Dropped attempt at writing purescript bindings for [thumbor-ts](https://github.com/Brettm12345/thumbor-ts) |
| [typelevel](./typelevel) | Typelevel naturals, vectors, sum-types, orderings and lambda-calculus evaluation and a value-level bounded-type GADT |
| Name | Description |
| --------------------------------------------- | -------------------------------------------------------------------------------------------------------------------- |
| [abilities](./abilities/) | Typeclass-dictionary abuse enabling the creation of a barebones effect system |
| [bug](./bug/) | Unknown reason of existence |
| [canopy](./canopy/) | Unfinished attempt at writing a [Diplomacy](<https://en.wikipedia.org/wiki/Diplomacy_(game)>) adjudecation engine |
| [compose](./compose/) | Overload do-notation for function composition and existential types |
| [ecs](./ecs/) | Purescript-wrapper for [thi.ng/ecs](thi.ng/ecs) |
| [existentials-blog](./existentials-blog) | Perhaps supposed to turn into a blog about existentials? |
| [existentials](./existentials) | Experiment regarding the Church-encoding of existential types |
| [free](./free/) | Experiments regarding free monads and interpreting algebras |
| [factorio-throughput](./factorio-throughput/) | Experiments with computing throughput of factorio systems |
| [gadts](./gadts) | Experiment regarding ways to encode GADTs in Purescript |
| [kombinators](./kombinators) | Attempt at generating factorio combinator networks programmatically |
| [lambda-calculus](./lambda-calculus) | Lambda calculus evaluator |
| [lunarline](./lunarline) | Attempt at optimizing a functional language using compile-time partial evaluation |
| [lune](./lune) | Failed effect-system project |
| [maps](./maps) | Attempt at implementing maps with membership proofs |
| [proofs](./proofs) | Attempt at expressing mathematical proofs using Purescript's effect system |
| [purebird](./purebird) | Flappy-bird game |
| [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` |
| [thumbor](./thumbor) | Dropped attempt at writing purescript bindings for [thumbor-ts](https://github.com/Brettm12345/thumbor-ts) |
| [typelevel](./typelevel) | Typelevel naturals, vectors, sum-types, orderings and lambda-calculus evaluation and a value-level bounded-type GADT |

View file

@ -0,0 +1,16 @@
/bower_components/
/node_modules/
/.pulp-cache/
/output/
/generated-docs/
/.psc-package/
/.psc*
/.purs*
/.psa*
/.spago
dist
*.aux
*.fls
*.fdb_*
*.synctex*
*.log

View file

@ -0,0 +1,22 @@
const esbuild = require("esbuild");
const PurescriptPlugin = require("esbuild-plugin-purescript");
const path = require("path");
const isProd = process.env.NODE_ENV === "production";
esbuild
.build({
entryPoints: ["src/index.js"],
bundle: true,
outdir: "dist",
watch: !isProd,
plugins: [
PurescriptPlugin({
output: isProd ? path.resolve(__dirname, "dce-output") : undefined,
}),
],
define: {
global: "window",
},
})
.catch((_e) => process.exit(1));

Binary file not shown.

View file

@ -0,0 +1,94 @@
\documentclass[a4paper, 12pt]{article}
\newcommand{\bold}{\textbf}
\usepackage[english]{babel}
\usepackage{amsmath}
\usepackage{tikz}
\usepackage{indentfirst}
\begin{document}
\newcommand{\q2}{\quad\quad}
\title{\Large{\bold{Moontorio}}}
\author{Matei Adriel}
\date {}
\maketitle
\section{Example 1}
Solve the following factory:
\vspace*{20pt}
\begin{figure}[h]
\centering
\begin{tikzpicture}[shorten >=1pt, auto, node distance={30mm},
main/.style = {draw, rectangle}]
\node[main] (3) {$consumer_1$};
\node[main] (1) [above left of=3] {$provider_1$};
\node[main] (2) [below left of=3] {$provider_2$};
\node[main] (4) [right of=2] {$consumer_2$};
\draw[->] (1) edge node{$p_1$} (3);
\draw[->] (2) edge node{$p_2$} (3);
\draw[->] (2) edge node{$p_3$} (4);
\end{tikzpicture}
\caption{Factory}
\label{fig:Factory}
\end{figure}
Generating the constraints:
\begin{figure}[h]
\centering
\begin{equation}
p_1(t) < provider_1(t)
\end{equation}
\begin{equation}
p_3(t) < consumer_2(t)
\end{equation}
\begin{equation}
\begin{split}
\begin{cases}
\begin{cases}
p_2(t) &< \displaystyle\frac{consumer_1(t)}{2}\\
p_1(t) &< consumer_1(t) - p_2(t)
\end{cases}
\ ,&\;\mbox{if } p_1(t) \geq p_2(t)\\\\
\begin{cases}
p_1(t) &< \displaystyle\frac{consumer_1(t)}{2}\\
p_2(t) &< consumer_1(t) - p_1(t)
\end{cases}
\ ,&\;\mbox{if } p_1(t) < p_2(t)
\end{cases}
\end{split}
\end{equation}
\begin{equation}
\begin{split}
\begin{cases}
\begin{cases}
p_3(t) &< \displaystyle\frac{provider_2(t)}{2}\\
p_2(t) &< provider_2(t) - p_3(t)
\end{cases}
\ ,&\;\mbox{if } p_2(t) \geq p_3(t)\\\\
\begin{cases}
p_2(t) &< \displaystyle\frac{provider_2(t)}{2}\\
p_3(t) &< provider_2(t) - p_3(t)
\end{cases}
\ ,&\;\mbox{if } p_2(t) < p_3(t)
\end{cases}
\end{split}
\end{equation}
\caption{Constraints}
\label{fig:Constraints}
\end{figure}
\end{document}

Binary file not shown.

View file

@ -0,0 +1,77 @@
\documentclass[a4paper, 12pt]{article}
\newcommand{\bold}{\textbf}
\usepackage[english]{babel}
\usepackage{amsmath}
\usepackage{tikz}
\usepackage{indentfirst}
\begin{document}
\newcommand{\q2}{\quad\quad}
\title{\Large{\bold{Moontorio}}}
\author{Matei Adriel}
\date {}
\maketitle
\section{Describing a factory}
A factory is made out of machines. A machine is either a provider, a belt or a consumer. Machines are connected by ports.
\begin{figure}[h]
\begin{equation}
\begin{split}
Machines\ A,\ B,\ C\ &::=\; belt\ p_i\ p_o \\
&\quad|\quad provider\ p_1,\ p_2,\ ...\ p_n \\
&\quad|\quad consumer\ p_1,\ p_2,\ ...\ p_n
\end{split}
\end{equation}
\caption{Machines}
\label{Machines}
\end{figure}
We can represent the factory as a directed graph, with the machines being the nodes and the ports being the edges:
\vspace*{20pt}
\begin{figure}[h]
\centering
\begin{tikzpicture}[shorten >=1pt, auto, node distance={50mm},
main/.style = {draw, rectangle}]
\node[main] (1) {$provider_1$};
\node[main] (2) [right of=1] {$belt_1$};
\node[main] (3) [right of=2] {$consumer_1$};
\draw[->] (1) edge node{$p_1$} (2);
\draw[->] (2) edge node{$p_2$} (3);
\end{tikzpicture}
\caption{Example of a simple factory}
\label{SimpleFactory}
\end{figure}
\section{Constraints}
The first step of the factory solving process is the constraint generation.
We currently use 3 different types of constraints (Figure \ref{Constraints}).
Let's take them one step at a time. The first two constrains (
$p_k(t) <_{\Leftarrow} f(t)$ and $p_k(t) <_{\Rightarrow} f(t)$
) are pretty similar, both limiting the flow through a port.
\begin{figure}[ht]
\begin{equation}
\begin{split}
Constraints\quad C_k\ &::=\; p_k(t) <_{\Leftarrow} f(t) \\
&\quad|\quad p_k(t) <_{\Rightarrow} f(t) \\
&\quad|\quad p_1(t) = p_2(f(t))
\end{split}
\end{equation}
\caption{Constraints}
\label{Constraints}
\end{figure}
\end{document}

View file

@ -0,0 +1,13 @@
{
"name": "moontorio",
"scripts": {
"build": "node build.js"
},
"dependencies": {
"calculess": "^1.0.2",
"esbuild": "^0.11.4",
"esbuild-plugin-purescript": "^1.0.0",
"events": "^3.3.0",
"function-plot": "^1.22.7"
}
}

View file

@ -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

View file

@ -0,0 +1,228 @@
dependencies:
calculess: 1.0.2
esbuild: 0.11.4
esbuild-plugin-purescript: 1.0.0
events: 3.3.0
function-plot: 1.22.7
lockfileVersion: 5.1
packages:
/@types/assert/1.5.4:
dev: false
resolution:
integrity: sha512-CaFVW21Ulu0J9sUaEWJjwmhkDkeoxa4fniVSERzZC13sU9v8NNM2lMlkfZZv60j47D+qDt0Lyo8skVP3CTXUdA==
/built-in-math-eval/0.3.0:
dependencies:
math-codegen: 0.3.5
dev: false
resolution:
integrity: sha1-JA3CHLOJQ5WIxhxGDrAHZJfvxBw=
/calculess/1.0.2:
dev: false
resolution:
integrity: sha512-9VCZJhW9fp7JmMgn6aTZ0U8NhcbJRFdD3vPlaYWMKIVIH1z4F/ZgDZKqx28fABjn4HaM4VT1ZoQzsONvI2LrCA==
/clamp/1.0.1:
dev: false
resolution:
integrity: sha1-ZqDmQBGBbjcZaCj9yMjBRzEshjQ=
/d3-array/2.12.1:
dependencies:
internmap: 1.0.1
dev: false
resolution:
integrity: sha512-B0ErZK/66mHtEsR1TkPEEkwdy+WDesimkM5gpZr5Dsg54BiTA5RXtYW5qTLIAcekaS9xfZrzBLF/OAkB3Qn1YQ==
/d3-axis/2.1.0:
dev: false
resolution:
integrity: sha512-z/G2TQMyuf0X3qP+Mh+2PimoJD41VOCjViJzT0BHeL/+JQAofkiWZbWxlwFGb1N8EN+Cl/CW+MUKbVzr1689Cw==
/d3-color/2.0.0:
dev: false
resolution:
integrity: sha512-SPXi0TSKPD4g9tw0NMZFnR95XVgUZiBH+uUTqQuDu1OsE2zomHU7ho0FISciaPvosimixwHFl3WHLGabv6dDgQ==
/d3-dispatch/2.0.0:
dev: false
resolution:
integrity: sha512-S/m2VsXI7gAti2pBoLClFFTMOO1HTtT0j99AuXLoGFKO6deHDdnv6ZGTxSTTUTgO1zVcv82fCOtDjYK4EECmWA==
/d3-drag/2.0.0:
dependencies:
d3-dispatch: 2.0.0
d3-selection: 2.0.0
dev: false
resolution:
integrity: sha512-g9y9WbMnF5uqB9qKqwIIa/921RYWzlUDv9Jl1/yONQwxbOfszAWTCm8u7HOTgJgRDXiRZN56cHT9pd24dmXs8w==
/d3-ease/2.0.0:
dev: false
resolution:
integrity: sha512-68/n9JWarxXkOWMshcT5IcjbB+agblQUaIsbnXmrzejn2O82n3p2A9R2zEB9HIEFWKFwPAEDDN8gR0VdSAyyAQ==
/d3-format/2.0.0:
dev: false
resolution:
integrity: sha512-Ab3S6XuE/Q+flY96HXT0jOXcM4EAClYFnRGY5zsjRGNy6qCYrQsMffs7cV5Q9xejb35zxW5hf/guKw34kvIKsA==
/d3-interpolate/2.0.1:
dependencies:
d3-color: 2.0.0
dev: false
resolution:
integrity: sha512-c5UhwwTs/yybcmTpAVqwSFl6vrQ8JZJoT5F7xNFK9pymv5C0Ymcc9/LIJHtYIggg/yS9YHw8i8O8tgb9pupjeQ==
/d3-path/2.0.0:
dev: false
resolution:
integrity: sha512-ZwZQxKhBnv9yHaiWd6ZU4x5BtCQ7pXszEV9CU6kRgwIQVQGLMv1oiL4M+MK/n79sYzsj+gcgpPQSctJUsLN7fA==
/d3-scale/3.2.4:
dependencies:
d3-array: 2.12.1
d3-format: 2.0.0
d3-interpolate: 2.0.1
d3-time: 2.0.0
d3-time-format: 3.0.0
dev: false
resolution:
integrity: sha512-PG6gtpbPCFqKbvdBEswQcJcTzHC8VEd/XzezF5e68KlkT4/ggELw/nR1tv863jY6ufKTvDlzCMZvhe06codbbA==
/d3-selection/2.0.0:
dev: false
resolution:
integrity: sha512-XoGGqhLUN/W14NmaqcO/bb1nqjDAw5WtSYb2X8wiuQWvSZUsUVYsOSkOybUrNvcBjaywBdYPy03eXHMXjk9nZA==
/d3-shape/2.1.0:
dependencies:
d3-path: 2.0.0
dev: false
resolution:
integrity: sha512-PnjUqfM2PpskbSLTJvAzp2Wv4CZsnAgTfcVRTwW03QR3MkXF8Uo7B1y/lWkAsmbKwuecto++4NlsYcvYpXpTHA==
/d3-time-format/3.0.0:
dependencies:
d3-time: 2.0.0
dev: false
resolution:
integrity: sha512-UXJh6EKsHBTjopVqZBhFysQcoXSv/5yLONZvkQ5Kk3qbwiUYkdX17Xa1PT6U1ZWXGGfB1ey5L8dKMlFq2DO0Ag==
/d3-time/2.0.0:
dev: false
resolution:
integrity: sha512-2mvhstTFcMvwStWd9Tj3e6CEqtOivtD8AUiHT8ido/xmzrI9ijrUUihZ6nHuf/vsScRBonagOdj0Vv+SEL5G3Q==
/d3-timer/2.0.0:
dev: false
resolution:
integrity: sha512-TO4VLh0/420Y/9dO3+f9abDEFYeCUr2WZRlxJvbp4HPTQcSylXNiL6yZa9FIUvV1yRiFufl1bszTCLDqv9PWNA==
/d3-transition/2.0.0_d3-selection@2.0.0:
dependencies:
d3-color: 2.0.0
d3-dispatch: 2.0.0
d3-ease: 2.0.0
d3-interpolate: 2.0.1
d3-selection: 2.0.0
d3-timer: 2.0.0
dev: false
peerDependencies:
d3-selection: '2'
resolution:
integrity: sha512-42ltAGgJesfQE3u9LuuBHNbGrI/AJjNL2OAUdclE70UE6Vy239GCBEYD38uBPoLeNsOhFStGpPI0BAOV+HMxog==
/d3-zoom/2.0.0:
dependencies:
d3-dispatch: 2.0.0
d3-drag: 2.0.0
d3-interpolate: 2.0.1
d3-selection: 2.0.0
d3-transition: 2.0.0_d3-selection@2.0.0
dev: false
resolution:
integrity: sha512-fFg7aoaEm9/jf+qfstak0IYpnesZLiMX6GZvXtUSdv8RH2o4E2qeelgdU09eKS6wGuiGMfcnMI0nTIqWzRHGpw==
/double-bits/1.1.1:
dev: false
resolution:
integrity: sha1-WKu6RUlNpND6Nrc60RoobJGEscY=
/esbuild-plugin-purescript/1.0.0:
dev: false
resolution:
integrity: sha512-WdSdRtpm5AoRyDj3vEnmLsMsTY9kl3znRUTQe5ilbtcK/JIJv3Nz6d8lsEA079vmWgjc3JtR7Ii1y1omoz/wLg==
/esbuild/0.11.4:
dev: false
hasBin: true
requiresBuild: true
resolution:
integrity: sha512-qWGlOOTwyTn4f846LoR47Mif4Aek4rY9ChdXN7q7G15HpDYq3pxwnPFWe2os/jOq8naFh2Z+FqWfkq8ZP6kATw==
/events/3.3.0:
dev: false
engines:
node: '>=0.8.x'
resolution:
integrity: sha512-mQw+2fkQbALzQ7V0MY0IqdnXNOeTtP4r0lN9z7AAawCXgqea7bDii20AYrIBrFd/Hx0M2Ocz6S111CaFkUcb0Q==
/extend/3.0.2:
dev: false
resolution:
integrity: sha512-fjquC59cD7CyW6urNXK0FBufkZcoiGG80wTuPujX590cB5Ttln20E2UB4S/WARVqhXffZl2LNgS+gQdPIIim/g==
/function-plot/1.22.7:
dependencies:
built-in-math-eval: 0.3.0
clamp: 1.0.1
d3-axis: 2.1.0
d3-color: 2.0.0
d3-format: 2.0.0
d3-interpolate: 2.0.1
d3-scale: 3.2.4
d3-selection: 2.0.0
d3-shape: 2.1.0
d3-zoom: 2.0.0
interval-arithmetic-eval: 0.4.7
dev: false
resolution:
integrity: sha512-rB6FeVqvgNECmt5PhIvFFEOyEjM9AWLIpMkj9Nzbzq9f81Irgn3ZrXAuv5+qnuzM99jPL7ZM4kK3+ImiKXcSHA==
/internmap/1.0.1:
dev: false
resolution:
integrity: sha512-lDB5YccMydFBtasVtxnZ3MRBHuaoE8GKsppq+EchKL2U4nK/DmEpPHNH8MZe5HkMtpSiTSOZwfN0tzYjO/lJEw==
/interval-arithmetic-eval/0.4.7:
dependencies:
interval-arithmetic: 1.0.6
math-codegen: 0.3.5
dev: false
resolution:
integrity: sha512-ClK+N4efbsgjlZR8h0qd0LQbyzUzJ9IkrjmTnD5MVb4Ytebd0lesoVP4AxLclcsEI+nIieskQ8cepHIWUPaRhQ==
/interval-arithmetic/1.0.6:
dependencies:
'@types/assert': 1.5.4
is-safe-integer: 2.0.0
nextafter: 1.0.0
typedarray: 0.0.6
dev: false
resolution:
integrity: sha512-eVotDGYPNiEaJ63oa4CeEHgOczZJ3gNHqG5wfVQ2o8sN2CEczQyR82Sjey/Bp36x8e7PtBcBvitcMnw6VUpjgQ==
/is-safe-integer/2.0.0:
dependencies:
max-safe-integer: 1.0.1
deprecated: This package is no longer relevant as ES2015 support is widespread.
dev: false
engines:
node: '>=0.10.0'
resolution:
integrity: sha512-eDaA39/1+3SNtYTRP28lRYOHMwiB1gfqXQaXcf/+f4mLwKgm8TTDkwJldsdtbgrK1R5CoDbf6AQ0KqP7BKoGtQ==
/math-codegen/0.3.5:
dependencies:
extend: 3.0.2
mr-parser: 0.2.1
dev: false
resolution:
integrity: sha1-R5nuRnfe0Ud2bQA8ykt4ee3UDMo=
/max-safe-integer/1.0.1:
dev: false
engines:
node: '>=0.10.0'
resolution:
integrity: sha1-84BgvixWPYwC5tSK85Ei/YO29BA=
/mr-parser/0.2.1:
dev: false
resolution:
integrity: sha1-hhi5ukF+KOn0OaQcaVtVTq/u2Sc=
/nextafter/1.0.0:
dependencies:
double-bits: 1.1.1
dev: false
resolution:
integrity: sha1-t9d7U1MQ4+CX5gJauwqQNHfsGjo=
/typedarray/0.0.6:
dev: false
resolution:
integrity: sha1-hnrHTjhkGHsdPUfZlqeOxciDB3c=
specifiers:
calculess: ^1.0.2
esbuild: ^0.11.4
esbuild-plugin-purescript: ^1.0.0
events: ^3.3.0
function-plot: ^1.22.7

View file

@ -0,0 +1,24 @@
{-
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"
, "quickcheck"
, "quickcheck-laws"
, "run"
, "spec"
, "spec-discovery"
, "spec-quickcheck"
, "strings"
, "unordered-collections"
]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}

View file

@ -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

View file

@ -0,0 +1,35 @@
module Main where
import Prelude
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Console (log)
import Moontorio.Render (RenderFn, renderFactory)
import RealFunction (PortSide(..), RealFunction, SolveM, collectConstraints, myFactory, runSolveM, tryFindBoundSolveM)
p :: SolveM (Array RealFunction)
p = do
collectConstraints
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 :: 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
renderFactory render myFactory s.constraints
-- log $ joinWith "\n" $ show <$> s.constraints
-- logShow $ f <*> pure 0.0

View file

@ -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]

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -0,0 +1,308 @@
module RealFunction where
import Prelude
import Data.Array (length, mapWithIndex)
import Data.Array as Array
import Data.Either (Either)
import Data.Foldable (foldMap, for_, minimum)
import Data.FoldableWithIndex (foldlWithIndex, 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)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Number (infinity)
import Data.Show.Generic (genericShow)
import Data.Traversable (for)
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Data.Tuple.Nested (type (/\), (/\))
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)
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: 4.0/3.0 }
redBelt :: BeltConfig
redBelt = { speed: 30.0, delay: 4.0/6.0 }
blueBelt :: BeltConfig
blueBelt = { speed: 45.0, delay: 4.0/8.0 }
-- | Example factory
myFactory1 :: Factory
myFactory1 = Map.fromArray machines
where
machines = mapWithIndex Tuple
[ 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 }
, Consumer 3
, Consumer 4
]
myFactory :: Factory
myFactory = Map.fromArray machines
where
machines = mapWithIndex Tuple
[ Provider [0, 1, 2] $ startsAtZero $ \t -> 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
]
---------- 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
, 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 }
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 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
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
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)
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 $ tryFindValueImpl $ fst relationship.p2
f (relationship.p1top2 time)
_ -> fail
# runReader constraints
<#> minimum'
where
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
Provider for amount -> do
forWithIndex_ for \index id -> do
let limit ports time
= ports
# map (\port -> port.id /\ port.maxOutput time)
# outputs (amount time)
# Array.findMap (\(id' /\ f) -> if id == id' then Just f else Nothing)
# unsafePartial fromJust
constrain $ Limit (PortDependent for limit) Input id
where
outputs :: Number -> Array (PortId /\ Number) -> Array (PortId /\ Number)
outputs total ports
= ports
# Array.sortWith snd
# foldlWithIndex (\index (past /\ remaining) (id /\ value) -> do
let current
| lengthLeft <- remaining / toNumber (count - index), value >= lengthLeft = lengthLeft
| otherwise = value
((id /\ current):past) /\ (remaining - current))
(Nil /\ total)
# fst
# Array.fromFoldable
where
count = length ports
Consumer for -> do
constrain $ Limit (Literal infinity) Output for
Belt { input, output, config } -> do
biId <- generate
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
_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

View file

@ -0,0 +1,33 @@
module Moontorio.Ord.Extra (Side, left, right, OrderedArray, binarySearch) where
import Prelude
import Data.Array (length, unsafeIndex)
import Data.Maybe (Maybe(..))
import Partial.Unsafe (unsafePartial)
type OrderedArray = Array
newtype Side = Side Boolean
left :: Side
left = Side false
right :: Side
right = Side true
binarySearch :: forall a. (Int -> a -> Side) -> OrderedArray a -> Maybe Int
binarySearch f arr = unsafePartial $ findImpl 0 (length arr)
where
findImpl :: Partial => _
findImpl start length | length == 0 = Nothing
| length == 1 = Just start
| otherwise = do
let middle = start + length / 2
let element = unsafeIndex arr middle
if f middle element == left then
findImpl start (middle - start)
else
findImpl middle (length + start - middle)
---------- Typeclass instances
derive instance eqSide :: Eq Side

View file

@ -0,0 +1,20 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<meta http-equiv="X-UA-Compatible" content="IE=edge">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Moontorio</title>
<script defer src="../dist/index.js"></script>
<style>
body {
display: flex;
flex-wrap: wrap;
}
</style>
</head>
<body>
</body>
</html>

View file

@ -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)();

View file

@ -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."