Add kombinators
This commit is contained in:
Matei Adriel
parent
4a7a51cd17
commit
553809fc56
|
|
@ -11,6 +11,7 @@
|
|||
| [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 |
|
||||
|
|
|
|||
11
purescript/kombinators/.gitignore
vendored
Normal file
11
purescript/kombinators/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
/bower_components/
|
||||
/node_modules/
|
||||
/.pulp-cache/
|
||||
/output/
|
||||
/generated-docs/
|
||||
/.psc-package/
|
||||
/.psc*
|
||||
/.purs*
|
||||
/.psa*
|
||||
/.spago
|
||||
dist
|
||||
18
purescript/kombinators/build.js
Normal file
18
purescript/kombinators/build.js
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
const esbuild = require("esbuild");
|
||||
const PurescriptPlugin = require("esbuild-plugin-purescript");
|
||||
|
||||
const production = process.env.NODE_ENV === "production";
|
||||
|
||||
esbuild
|
||||
.build({
|
||||
platform: "node",
|
||||
entryPoints: ["src/Foreign/blueprint.ts"],
|
||||
bundle: true,
|
||||
minify: production,
|
||||
outdir: "dist",
|
||||
watch: true,
|
||||
plugins: [PurescriptPlugin()],
|
||||
sourcemap: "both",
|
||||
target: "es2016",
|
||||
})
|
||||
.catch((_e) => process.exit(1));
|
||||
1
purescript/kombinators/package.json
Normal file
1
purescript/kombinators/package.json
Normal file
|
|
@ -0,0 +1 @@
|
|||
{"dependencies":{"factorio-blueprint":"^2.4.0","prettyjson":"^1.2.1","victor":"^1.1.0"},"devDependencies":{"@types/node":"^16.11.6","esbuild":"^0.13.12","esbuild-plugin-purescript":"^1.1.1","typescript":"^4.4.4"}}
|
||||
35
purescript/kombinators/packages.dhall
Normal file
35
purescript/kombinators/packages.dhall
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
let upstream =
|
||||
https://github.com/purescript/package-sets/releases/download/psc-0.14.3-20210825/packages.dhall
|
||||
sha256:eee0765aa98e0da8fc414768870ad588e7cada060f9f7c23c37385c169f74d9f
|
||||
|
||||
let additions =
|
||||
{ run-supply =
|
||||
{ dependencies =
|
||||
[ "maybe", "prelude", "run", "tuples", "typelevel-prelude" ]
|
||||
, repo = "https://github.com/Mateiadrielrafael/purescript-run-supply/"
|
||||
, version = "585c281c8e631816246b7bb3c653c7beba85b490"
|
||||
}
|
||||
, debugged =
|
||||
{ dependencies =
|
||||
[ "prelude"
|
||||
, "console"
|
||||
, "ordered-collections"
|
||||
, "either"
|
||||
, "tuples"
|
||||
, "lists"
|
||||
, "strings"
|
||||
, "arrays"
|
||||
, "bifunctors"
|
||||
, "record"
|
||||
, "effect"
|
||||
, "datetime"
|
||||
, "enums"
|
||||
, "unordered-collections"
|
||||
, "fixed-points"
|
||||
]
|
||||
, repo = "https://github.com/Mateiadrielrafael/purescript-debugged"
|
||||
, version = "633220f91f87c9acbc4eebbf87628e6cdc658b7b"
|
||||
}
|
||||
}
|
||||
|
||||
in upstream // additions
|
||||
237
purescript/kombinators/pnpm-lock.yaml
Normal file
237
purescript/kombinators/pnpm-lock.yaml
Normal file
|
|
@ -0,0 +1,237 @@
|
|||
dependencies:
|
||||
factorio-blueprint: 2.4.0
|
||||
prettyjson: 1.2.1
|
||||
victor: 1.1.0
|
||||
devDependencies:
|
||||
'@types/node': 16.11.6
|
||||
esbuild: 0.13.12
|
||||
esbuild-plugin-purescript: 1.1.1
|
||||
typescript: 4.4.4
|
||||
lockfileVersion: 5.1
|
||||
packages:
|
||||
/@types/node/16.11.6:
|
||||
dev: true
|
||||
resolution:
|
||||
integrity: sha512-ua7PgUoeQFjmWPcoo9khiPum3Pd60k4/2ZGXt18sm2Slk0W0xZTqt5Y0Ny1NyBiN1EVQ/+FaF9NcY4Qe6rwk5w==
|
||||
/colors/1.4.0:
|
||||
dev: false
|
||||
engines:
|
||||
node: '>=0.1.90'
|
||||
resolution:
|
||||
integrity: sha512-a+UqTh4kgZg/SlGvfbzDHpgRu7AAQOmmqRHJnxhRZICKFUT91brVhNNt58CMWU9PsBbv3PDCZUHbVxuDiH2mtA==
|
||||
/esbuild-android-arm64/0.13.12:
|
||||
cpu:
|
||||
- arm64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- android
|
||||
resolution:
|
||||
integrity: sha512-TSVZVrb4EIXz6KaYjXfTzPyyRpXV5zgYIADXtQsIenjZ78myvDGaPi11o4ZSaHIwFHsuwkB6ne5SZRBwAQ7maw==
|
||||
/esbuild-darwin-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- darwin
|
||||
resolution:
|
||||
integrity: sha512-c51C+N+UHySoV2lgfWSwwmlnLnL0JWj/LzuZt9Ltk9ub1s2Y8cr6SQV5W3mqVH1egUceew6KZ8GyI4nwu+fhsw==
|
||||
/esbuild-darwin-arm64/0.13.12:
|
||||
cpu:
|
||||
- arm64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- darwin
|
||||
resolution:
|
||||
integrity: sha512-JvAMtshP45Hd8A8wOzjkY1xAnTKTYuP/QUaKp5eUQGX+76GIie3fCdUUr2ZEKdvpSImNqxiZSIMziEiGB5oUmQ==
|
||||
/esbuild-freebsd-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- freebsd
|
||||
resolution:
|
||||
integrity: sha512-r6On/Skv9f0ZjTu6PW5o7pdXr8aOgtFOEURJZYf1XAJs0IQ+gW+o1DzXjVkIoT+n1cm3N/t1KRJfX71MPg/ZUA==
|
||||
/esbuild-freebsd-arm64/0.13.12:
|
||||
cpu:
|
||||
- arm64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- freebsd
|
||||
resolution:
|
||||
integrity: sha512-F6LmI2Q1gii073kmBE3NOTt/6zLL5zvZsxNLF8PMAwdHc+iBhD1vzfI8uQZMJA1IgXa3ocr3L3DJH9fLGXy6Yw==
|
||||
/esbuild-linux-32/0.13.12:
|
||||
cpu:
|
||||
- ia32
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-U1UZwG3UIwF7/V4tCVAo/nkBV9ag5KJiJTt+gaCmLVWH3bPLX7y+fNlhIWZy8raTMnXhMKfaTvWZ9TtmXzvkuQ==
|
||||
/esbuild-linux-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-YpXSwtu2NxN3N4ifJxEdsgd6Q5d8LYqskrAwjmoCT6yQnEHJSF5uWcxv783HWN7lnGpJi9KUtDvYsnMdyGw71Q==
|
||||
/esbuild-linux-arm/0.13.12:
|
||||
cpu:
|
||||
- arm
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-SyiT/JKxU6J+DY2qUiSLZJqCAftIt3uoGejZ0HDnUM2MGJqEGSGh7p1ecVL2gna3PxS4P+j6WAehCwgkBPXNIw==
|
||||
/esbuild-linux-arm64/0.13.12:
|
||||
cpu:
|
||||
- arm64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-sgDNb8kb3BVodtAlcFGgwk+43KFCYjnFOaOfJibXnnIojNWuJHpL6aQJ4mumzNWw8Rt1xEtDQyuGK9f+Y24jGA==
|
||||
/esbuild-linux-mips64le/0.13.12:
|
||||
cpu:
|
||||
- mips64el
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-qQJHlZBG+QwVIA8AbTEtbvF084QgDi4DaUsUnA+EolY1bxrG+UyOuGflM2ZritGhfS/k7THFjJbjH2wIeoKA2g==
|
||||
/esbuild-linux-ppc64le/0.13.12:
|
||||
cpu:
|
||||
- ppc64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- linux
|
||||
resolution:
|
||||
integrity: sha512-2dSnm1ldL7Lppwlo04CGQUpwNn5hGqXI38OzaoPOkRsBRWFBozyGxTFSee/zHFS+Pdh3b28JJbRK3owrrRgWNw==
|
||||
/esbuild-netbsd-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- netbsd
|
||||
resolution:
|
||||
integrity: sha512-D4raxr02dcRiQNbxOLzpqBzcJNFAdsDNxjUbKkDMZBkL54Z0vZh4LRndycdZAMcIdizC/l/Yp/ZsBdAFxc5nbA==
|
||||
/esbuild-openbsd-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- openbsd
|
||||
resolution:
|
||||
integrity: sha512-KuLCmYMb2kh05QuPJ+va60bKIH5wHL8ypDkmpy47lzwmdxNsuySeCMHuTv5o2Af1RUn5KLO5ZxaZeq4GEY7DaQ==
|
||||
/esbuild-plugin-purescript/1.1.1:
|
||||
dev: true
|
||||
resolution:
|
||||
integrity: sha512-0DTgNMvVAuaOJCuIXpL4/70asdAfViyubiBkafO8EBQn9j+cL55489wQnz5tYHAMjwNxBuWjGeK7SEHegx6qVg==
|
||||
/esbuild-sunos-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- sunos
|
||||
resolution:
|
||||
integrity: sha512-jBsF+e0woK3miKI8ufGWKG3o3rY9DpHvCVRn5eburMIIE+2c+y3IZ1srsthKyKI6kkXLvV4Cf/E7w56kLipMXw==
|
||||
/esbuild-windows-32/0.13.12:
|
||||
cpu:
|
||||
- ia32
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- win32
|
||||
resolution:
|
||||
integrity: sha512-L9m4lLFQrFeR7F+eLZXG82SbXZfUhyfu6CexZEil6vm+lc7GDCE0Q8DiNutkpzjv1+RAbIGVva9muItQ7HVTkQ==
|
||||
/esbuild-windows-64/0.13.12:
|
||||
cpu:
|
||||
- x64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- win32
|
||||
resolution:
|
||||
integrity: sha512-k4tX4uJlSbSkfs78W5d9+I9gpd+7N95W7H2bgOMFPsYREVJs31+Q2gLLHlsnlY95zBoPQMIzHooUIsixQIBjaQ==
|
||||
/esbuild-windows-arm64/0.13.12:
|
||||
cpu:
|
||||
- arm64
|
||||
dev: true
|
||||
optional: true
|
||||
os:
|
||||
- win32
|
||||
resolution:
|
||||
integrity: sha512-2tTv/BpYRIvuwHpp2M960nG7uvL+d78LFW/ikPItO+2GfK51CswIKSetSpDii+cjz8e9iSPgs+BU4o8nWICBwQ==
|
||||
/esbuild/0.13.12:
|
||||
dev: true
|
||||
hasBin: true
|
||||
optionalDependencies:
|
||||
esbuild-android-arm64: 0.13.12
|
||||
esbuild-darwin-64: 0.13.12
|
||||
esbuild-darwin-arm64: 0.13.12
|
||||
esbuild-freebsd-64: 0.13.12
|
||||
esbuild-freebsd-arm64: 0.13.12
|
||||
esbuild-linux-32: 0.13.12
|
||||
esbuild-linux-64: 0.13.12
|
||||
esbuild-linux-arm: 0.13.12
|
||||
esbuild-linux-arm64: 0.13.12
|
||||
esbuild-linux-mips64le: 0.13.12
|
||||
esbuild-linux-ppc64le: 0.13.12
|
||||
esbuild-netbsd-64: 0.13.12
|
||||
esbuild-openbsd-64: 0.13.12
|
||||
esbuild-sunos-64: 0.13.12
|
||||
esbuild-windows-32: 0.13.12
|
||||
esbuild-windows-64: 0.13.12
|
||||
esbuild-windows-arm64: 0.13.12
|
||||
requiresBuild: true
|
||||
resolution:
|
||||
integrity: sha512-vTKKUt+yoz61U/BbrnmlG9XIjwpdIxmHB8DlPR0AAW6OdS+nBQBci6LUHU2q9WbBobMEIQxxDpKbkmOGYvxsow==
|
||||
/factorio-blueprint/2.4.0:
|
||||
dev: false
|
||||
resolution:
|
||||
integrity: sha512-pZt/hWPcJgqUb3V3siC1xS4C9Ak9kyyCM8OF8/fp/yAHZy23aWcVDEL6YddxT9QZWpEuQghoC+t+zRohhWGilg==
|
||||
/minimist/1.2.5:
|
||||
dev: false
|
||||
resolution:
|
||||
integrity: sha512-FM9nNUYrRBAELZQT3xeZQ7fmMOBg6nWNmJKTcgsJeaLstP/UODVpGsr5OhXhhXg6f+qtJ8uiZ+PUxkDWcgIXLw==
|
||||
/prettyjson/1.2.1:
|
||||
dependencies:
|
||||
colors: 1.4.0
|
||||
minimist: 1.2.5
|
||||
dev: false
|
||||
hasBin: true
|
||||
resolution:
|
||||
integrity: sha1-/P+rQdGcq0365eV15kJGYZsS0ok=
|
||||
/typescript/4.4.4:
|
||||
dev: true
|
||||
engines:
|
||||
node: '>=4.2.0'
|
||||
hasBin: true
|
||||
resolution:
|
||||
integrity: sha512-DqGhF5IKoBl8WNf8C1gu8q0xZSInh9j1kJJMqT3a94w1JzVaBU4EXOSMrz9yDqMT0xt3selp83fuFMQ0uzv6qA==
|
||||
/victor/1.1.0:
|
||||
dev: false
|
||||
resolution:
|
||||
integrity: sha1-3jzHexVYmxsMeyLD2tKXA0qwAro=
|
||||
specifiers:
|
||||
'@types/node': ^16.11.6
|
||||
esbuild: ^0.13.12
|
||||
esbuild-plugin-purescript: ^1.1.1
|
||||
factorio-blueprint: ^2.4.0
|
||||
prettyjson: ^1.2.1
|
||||
typescript: ^4.4.4
|
||||
victor: ^1.1.0
|
||||
28
purescript/kombinators/spago.dhall
Normal file
28
purescript/kombinators/spago.dhall
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
{-
|
||||
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 =
|
||||
[ "console"
|
||||
, "debugged"
|
||||
, "effect"
|
||||
, "prelude"
|
||||
, "psci-support"
|
||||
, "run"
|
||||
, "run-supply"
|
||||
, "sized-vectors"
|
||||
, "these"
|
||||
, "unordered-collections"
|
||||
]
|
||||
, packages = ./packages.dhall
|
||||
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
|
||||
}
|
||||
209
purescript/kombinators/src/Circuit.purs
Normal file
209
purescript/kombinators/src/Circuit.purs
Normal file
|
|
@ -0,0 +1,209 @@
|
|||
module Kombinator.Circuit where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Array as A
|
||||
import Data.Foldable (sum)
|
||||
import Data.HashMap (HashMap)
|
||||
import Data.Lens (Lens', _1, _2)
|
||||
import Data.Tuple (fst, snd, uncurry)
|
||||
import Data.Tuple.Nested (type (/\), (/\))
|
||||
import Kombinator.Network (RuntimeWireColor(..), UncoloredNetworkId(..))
|
||||
import Prim.Boolean (False, True)
|
||||
import Type.Proxy (Proxy(..))
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
---------- Constants
|
||||
-- | A network channel can be either green or red
|
||||
data NetworkChannel
|
||||
|
||||
-- | The green wire color
|
||||
foreign import data Green :: NetworkChannel
|
||||
|
||||
-- | The red wire color
|
||||
foreign import data Red :: NetworkChannel
|
||||
|
||||
---------- Types
|
||||
-- TODO: add all of them
|
||||
data DeciderOperation
|
||||
= GreaterThan
|
||||
| SmallerThan
|
||||
| Equal
|
||||
|
||||
data ArithemticOperation
|
||||
= Add
|
||||
| Multiply
|
||||
| Divide
|
||||
| Modulo
|
||||
| Substract
|
||||
|
||||
data Pin
|
||||
= IntegerInput Int
|
||||
| SignalPin String
|
||||
| Anything
|
||||
| Everything
|
||||
| Each
|
||||
|
||||
data ComputationComponent
|
||||
= Decider DeciderOperation Pin Pin Pin Boolean
|
||||
| Arithemtic ArithemticOperation Pin Pin Pin
|
||||
|
||||
type CompleteNetwork = NetworkId Red /\ NetworkId Green
|
||||
|
||||
data ComputationPort
|
||||
= Both (NetworkId Red) (NetworkId Green)
|
||||
| Single UncoloredNetworkId
|
||||
| None
|
||||
|
||||
data Component
|
||||
= ComputationComponent ComputationPort ComputationPort ComputationComponent
|
||||
| Constant ComputationPort (HashMap String Int)
|
||||
|
||||
newtype NetworkId :: NetworkChannel -> Type
|
||||
newtype NetworkId a = NetworkId Int
|
||||
|
||||
data Circuit
|
||||
=
|
||||
-- | Red /\ Green wires
|
||||
Network (CompleteNetwork -> Circuit)
|
||||
-- | Logical block to split the circuit at. Can have at most 4 external networks
|
||||
| Block String Circuit
|
||||
| Machine Component
|
||||
| Many (Array Circuit)
|
||||
|
||||
---------- Tokens used for the custom do notation
|
||||
data FreshNetwork =
|
||||
FreshNetwork
|
||||
|
||||
data FreshWire
|
||||
= FreshRedWire
|
||||
| FreshGreenWire
|
||||
|
||||
---------- Helpers
|
||||
appendComponent :: Circuit -> Component -> Circuit
|
||||
appendComponent (Many circuits) component = Many (A.snoc circuits (Machine component))
|
||||
appendComponent other component = Many [ other, Machine component ]
|
||||
|
||||
-- | Count the number of combinators inside a circuit
|
||||
componentCount :: Circuit -> Int
|
||||
componentCount (Machine _) = 1
|
||||
componentCount (Many subCircuits) = sum $ componentCount <$> subCircuits
|
||||
componentCount (Block _ block) = componentCount block
|
||||
componentCount (Network continue) = componentCount $ continue placeholderNetwork
|
||||
where
|
||||
placeholderNetwork :: CompleteNetwork
|
||||
placeholderNetwork = NetworkId (-1) /\ NetworkId (-1)
|
||||
|
||||
-- | Erase the typelevel data about the color of a wire,
|
||||
-- | instead opting to keep track of it at runtime
|
||||
forgetTypelevelColorData :: forall wire. IsWire wire => NetworkId wire -> UncoloredNetworkId
|
||||
forgetTypelevelColorData (NetworkId id) = UncoloredNetworkId (id /\ runtimeColor (Proxy :: _ wire))
|
||||
|
||||
---------- Typeclass based syntax-sugar
|
||||
class CircuitBind f a (d :: Boolean) | a -> f d where
|
||||
circuitBind :: a -> f -> Circuit
|
||||
|
||||
instance CircuitBind (Unit -> Circuit) Component True where
|
||||
circuitBind a f = appendComponent (f unit) a
|
||||
|
||||
instance CircuitBind (Unit -> Circuit) Circuit True where
|
||||
circuitBind a f = Many [ f unit, a ]
|
||||
|
||||
instance CircuitBind (NetworkId Red /\ NetworkId Green -> Circuit) FreshNetwork False where
|
||||
circuitBind = const Network
|
||||
|
||||
class IsComputationPort f where
|
||||
port :: f -> ComputationPort
|
||||
|
||||
instance IsComputationPort Unit where
|
||||
port _ = None
|
||||
|
||||
instance IsComputationPort ComputationPort where
|
||||
port = identity
|
||||
|
||||
instance IsWire a => IsComputationPort (NetworkId a) where
|
||||
port = forgetTypelevelColorData >>> Single
|
||||
|
||||
instance IsComputationPort (NetworkId Red /\ NetworkId Green) where
|
||||
port = uncurry Both
|
||||
|
||||
computation
|
||||
:: forall a b
|
||||
. IsComputationPort a
|
||||
=> IsComputationPort b
|
||||
=> a
|
||||
-> b
|
||||
-> ComputationComponent
|
||||
-> Component
|
||||
computation a b inner = ComputationComponent (port a) (port b) inner
|
||||
|
||||
circuitDiscard :: forall f a. CircuitBind f a True => a -> f -> Circuit
|
||||
circuitDiscard = circuitBind
|
||||
|
||||
emptyCircuit :: Circuit
|
||||
emptyCircuit = Many []
|
||||
|
||||
endCircuit :: Circuit
|
||||
endCircuit = emptyCircuit
|
||||
|
||||
---------- Type-level machinery for wires
|
||||
-- | Type-class for calculating the inverse of a wire color at the type level
|
||||
class MirrorableWire :: NetworkChannel -> NetworkChannel -> Constraint
|
||||
class MirrorableWire wire otherWire | wire -> otherWire, otherWire -> wire
|
||||
|
||||
instance MirrorableWire Red Green
|
||||
instance MirrorableWire Green Red
|
||||
|
||||
-- | -- | Class implementing operations which depend on the typelevel color of a network channel
|
||||
class IsWire :: NetworkChannel -> Constraint
|
||||
class IsWire wire where
|
||||
-- | Lookup a pair of red /\ green wires by a typelevel channel name
|
||||
lookupNetworkChannels :: Proxy wire -> CompleteNetwork -> NetworkId wire
|
||||
|
||||
-- | Cast a typelevel wire color to runtime
|
||||
runtimeColor :: Proxy wire -> RuntimeWireColor
|
||||
|
||||
instance IsWire Red where
|
||||
lookupNetworkChannels _ = fst
|
||||
runtimeColor _ = Red
|
||||
|
||||
instance IsWire Green where
|
||||
lookupNetworkChannels _ = snd
|
||||
runtimeColor _ = Green
|
||||
|
||||
-- | Index a tuple by assuming red = 0 and green = 1
|
||||
_atWire :: forall a. RuntimeWireColor -> Lens' (a /\ a) a
|
||||
_atWire Red = _1
|
||||
_atWire Green = _2
|
||||
|
||||
-- | Mirror a network channel
|
||||
otherChannel :: forall channel other. MirrorableWire channel other => Proxy channel -> Proxy other
|
||||
otherChannel = unsafeCoerce
|
||||
|
||||
-- | Lookup the network channel not matching a particular id
|
||||
lookupOtherNetworkChannels
|
||||
:: forall wire otherWire
|
||||
. MirrorableWire wire otherWire
|
||||
=> IsWire otherWire
|
||||
=> Proxy wire
|
||||
-> CompleteNetwork
|
||||
-> NetworkId otherWire
|
||||
lookupOtherNetworkChannels = otherChannel >>> lookupNetworkChannels
|
||||
|
||||
---------- Operators
|
||||
-- | Operations which still hasn't gotten it's output
|
||||
type NoOutputComputation = Pin -> ComputationComponent
|
||||
|
||||
-- | Provide an output for an operation
|
||||
outputTo :: NoOutputComputation -> NoOutputComputation
|
||||
outputTo f a = f a
|
||||
|
||||
computationAdd :: Pin -> Pin -> NoOutputComputation
|
||||
computationAdd = Arithemtic Add
|
||||
|
||||
computationMultiply :: Pin -> Pin -> NoOutputComputation
|
||||
computationMultiply = Arithemtic Multiply
|
||||
|
||||
infix 1 outputTo as /=>
|
||||
infix 2 computationAdd as /+
|
||||
infix 2 computationMultiply as /*
|
||||
40
purescript/kombinators/src/CircuitDo.purs
Normal file
40
purescript/kombinators/src/CircuitDo.purs
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
module Kombinator.CircuitDo where
|
||||
|
||||
import Prelude (otherwise, show, ($), (-), (<=), (<>), (==))
|
||||
import Data.Tuple.Nested ((/\))
|
||||
import Kombinator.Circuit
|
||||
import Prim.Boolean (True)
|
||||
|
||||
bind :: forall a d f. CircuitBind f a d => a -> f -> Circuit
|
||||
bind = circuitBind
|
||||
|
||||
discard :: forall f a. CircuitBind f a True => a -> f -> Circuit
|
||||
discard = circuitDiscard
|
||||
|
||||
---------- Examples
|
||||
counter :: forall a. IsWire a => String -> NetworkId a -> Circuit
|
||||
counter signal output = Block "Counter" do
|
||||
computation output output (SignalPin signal /+ IntegerInput 1 /=> SignalPin signal)
|
||||
endCircuit
|
||||
|
||||
buffer :: forall a b. IsComputationPort a => IsComputationPort b => a -> b -> Circuit
|
||||
buffer from to = do
|
||||
computation from to (Each /+ IntegerInput 0 /=> Each)
|
||||
endCircuit
|
||||
|
||||
-- | Delay a signal by n ticks
|
||||
delay :: forall a b. IsWire b => IsComputationPort a => Int -> a -> NetworkId b -> Circuit
|
||||
delay amount input output = Block ("Delay " <> show amount) $ go amount input
|
||||
where
|
||||
go :: forall i. IsComputationPort i => Int -> i -> Circuit
|
||||
go amount input
|
||||
| amount <= 0 = endCircuit
|
||||
| amount == 1 = do
|
||||
buffer input output
|
||||
endCircuit
|
||||
| otherwise = do
|
||||
wire /\ _ <- FreshNetwork
|
||||
buffer input wire
|
||||
go (amount - 1) wire
|
||||
endCircuit
|
||||
|
||||
90
purescript/kombinators/src/Data/Graph.purs
Normal file
90
purescript/kombinators/src/Data/Graph.purs
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
module Kombinator.Graph.Undirected
|
||||
( Graph
|
||||
, lookup
|
||||
, insert
|
||||
, delete
|
||||
, deleteConnection
|
||||
, empty
|
||||
, half
|
||||
, toHashMap
|
||||
, insertMany
|
||||
, connections
|
||||
, _atGraph
|
||||
, _atGraphConnection
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Array as Array
|
||||
import Data.Debug (class Debug, collection, constructor, debug)
|
||||
import Data.Foldable (foldr)
|
||||
import Data.HashMap (HashMap)
|
||||
import Data.HashMap as HashMap
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet as HashSet
|
||||
import Data.Hashable (class Hashable)
|
||||
import Data.Lens (Lens, Lens', lens)
|
||||
import Data.Maybe (Maybe(..), fromMaybe, maybe')
|
||||
import Data.Tuple (fst)
|
||||
import Data.Tuple.Nested ((/\), type (/\))
|
||||
import Safe.Coerce (coerce)
|
||||
|
||||
-- | A hashmap where `member a (lookup b h)` implies `member b (lookup a h)`
|
||||
newtype Graph key = Graph (HashMap key (HashSet key))
|
||||
|
||||
lookup :: forall key. Hashable key => key -> Graph key -> HashSet key
|
||||
lookup key (Graph hm) = fromMaybe HashSet.empty $ HashMap.lookup key hm
|
||||
|
||||
-- | Add a key to a Graph.
|
||||
-- | insert k v == insert v k
|
||||
insert :: forall key. Hashable key => key -> key -> Graph key -> Graph key
|
||||
insert from to = coerce (addToSet from to >>> addToSet to from)
|
||||
where
|
||||
addToSet from to = HashMap.insertWith HashSet.union from (HashSet.singleton to)
|
||||
|
||||
insertMany :: forall key. Hashable key => key -> HashSet key -> Graph key -> Graph key
|
||||
insertMany from = flip $ foldr (insert from)
|
||||
|
||||
delete :: forall key. Hashable key => key -> Graph key -> Graph key
|
||||
delete key = coerce (HashMap.delete key >>> map (HashSet.delete key))
|
||||
|
||||
deleteConnection :: forall key. Hashable key => key -> key -> Graph key -> Graph key
|
||||
deleteConnection from to = coerce (removeFromSet from to >>> removeFromSet to from)
|
||||
where
|
||||
removeFromSet from to = HashMap.update (HashSet.delete to >>> Just) from
|
||||
|
||||
empty :: forall t. Graph t
|
||||
empty = Graph HashMap.empty
|
||||
|
||||
toHashMap :: forall key. Graph key -> HashMap key (HashSet key)
|
||||
toHashMap (Graph hm) = hm
|
||||
|
||||
connections :: forall key. Ord key => Graph key -> Array (key /\ key)
|
||||
connections = toHashMap >>> HashMap.toArrayBy connections >>> join >>> map orderEach >>> Array.nub
|
||||
where
|
||||
connections k v = map (k /\ _) $ HashSet.toArray v
|
||||
orderEach (a /\ b) = if a > b then a /\ b else b /\ a
|
||||
|
||||
half :: forall key. Ord key => Graph key -> Array key
|
||||
half = connections >>> map fst
|
||||
|
||||
hasConnection :: forall key. Hashable key => key -> key -> Graph key -> Boolean
|
||||
hasConnection from to = lookup from >>> HashSet.member to
|
||||
|
||||
_atGraph :: forall k. Hashable k => k -> Lens (Graph k) (Graph k) (HashSet k) (Maybe k)
|
||||
_atGraph k =
|
||||
lens (lookup k) \m ->
|
||||
maybe' (\_ -> delete k m) \v -> insert k v m
|
||||
|
||||
_atGraphConnection :: forall k. Hashable k => k /\ k -> Lens' (Graph k) Boolean
|
||||
_atGraphConnection (from /\ to) =
|
||||
lens (hasConnection from to) \whole isThere ->
|
||||
if isThere then insert from to whole
|
||||
else deleteConnection from to whole
|
||||
|
||||
---------- Typeclass instances
|
||||
instance (Debug d, Ord d, Hashable d) => Debug (Graph d) where
|
||||
debug hm
|
||||
= connections hm
|
||||
# map (\(k /\ v) -> constructor "Pair" [ debug k, debug v ])
|
||||
# collection "Graph"
|
||||
18
purescript/kombinators/src/Data/Pair.purs
Normal file
18
purescript/kombinators/src/Data/Pair.purs
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
module Kombinator.Pair where
|
||||
|
||||
import Data.Lens (Traversal', wander)
|
||||
import Data.Tuple (fst, snd)
|
||||
import Data.Tuple.Nested (type (/\), (/\))
|
||||
import Prelude
|
||||
|
||||
---------- Types
|
||||
-- | Tuple with both elements having the same type
|
||||
type Pair a = a /\ a
|
||||
|
||||
---------- Lenses
|
||||
-- | Focus on both elements of a tuple
|
||||
_pair :: forall a. Traversal' (Pair a) a
|
||||
_pair = wander \f s -> ado
|
||||
a <- f (fst s)
|
||||
b <- f (snd s)
|
||||
in a /\ b
|
||||
202
purescript/kombinators/src/Data/Vector.purs
Normal file
202
purescript/kombinators/src/Data/Vector.purs
Normal file
|
|
@ -0,0 +1,202 @@
|
|||
-- | Vector2 utilies I keep using in a lot of my projects.
|
||||
-- | I need to publish this as it's own package soon.
|
||||
module Kombinator.Vector
|
||||
( Vec2
|
||||
, Axis(..)
|
||||
, x
|
||||
, y
|
||||
, toTuple
|
||||
, fromTuple
|
||||
, other
|
||||
, indexByAxis
|
||||
, mapAxis
|
||||
, lmapAxis
|
||||
, rmapAxis
|
||||
, bimapAxis
|
||||
, buildFromAxis
|
||||
, greaterThan
|
||||
, smallerThan
|
||||
, origin
|
||||
, _insideVector
|
||||
, _x
|
||||
, _y
|
||||
, _axis
|
||||
, _otherAxis
|
||||
) where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Lens (Lens', lens, over)
|
||||
import Data.Tuple (uncurry)
|
||||
import Data.Tuple.Nested (type (/\), (/\))
|
||||
import Data.Typelevel.Num (class Lt, class Nat, D2, d0, d1)
|
||||
import Data.Vec (Vec, vec2, (!!))
|
||||
import Data.Vec as Vec
|
||||
|
||||
-- | Sized array with 2 elements
|
||||
type Vec2 = Vec D2
|
||||
|
||||
-- | The origin of the coordinate system, with both elements at 0.
|
||||
origin :: forall a. Semiring a => Vec2 a
|
||||
origin = zero
|
||||
|
||||
-- | Get the first element of a vector
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | x (vec2 0 1) == 0
|
||||
-- | ```
|
||||
x :: forall a. Vec2 a -> a
|
||||
x = (_ !! d0)
|
||||
|
||||
-- | Get the second element of a vector
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | y (vec2 0 1) == 1
|
||||
-- | ```
|
||||
y :: forall a. Vec2 a -> a
|
||||
y = (_ !! d1)
|
||||
|
||||
-- | Convert a vec2 to a tuiple.
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | toTuple origin == 0 /\ 0
|
||||
-- | ```
|
||||
toTuple :: forall a. Vec2 a -> a /\ a
|
||||
toTuple vec = (vec !! d0) /\ (vec !! d1)
|
||||
|
||||
-- | Convert a tuple into a vec2
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | fromTuple (0 /\ 0) = origin
|
||||
-- | ```
|
||||
fromTuple :: forall a. a /\ a -> Vec2 a
|
||||
fromTuple = uncurry vec2
|
||||
|
||||
-- | Check if both elements of a vector are smaller than
|
||||
-- | both elements of another vector.
|
||||
smallerThan :: forall a. Ord a => Vec2 a -> Vec2 a -> Boolean
|
||||
smallerThan a b = x a < x b && y a < y b
|
||||
|
||||
-- | Check if both elements of a vector are greater than
|
||||
-- | both elements of another vector.
|
||||
greaterThan :: forall a. Ord a => Vec2 a -> Vec2 a -> Boolean
|
||||
greaterThan a b = x a > x b && y a > y b
|
||||
|
||||
---------- Stuff related to axis
|
||||
-- | An Axis represents either the x axis or the y axis
|
||||
data Axis = X | Y
|
||||
|
||||
-- | Get back the opposite axis of the one provided
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | other X == Y
|
||||
-- | other Y == X
|
||||
-- | ```
|
||||
other :: Axis -> Axis
|
||||
other X = Y
|
||||
other Y = X
|
||||
|
||||
-- | Lookup a vec2 by using an axis as the index
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | indexByAxis X (vec2 0 1) == 0
|
||||
-- | indexByAxis Y (vec2 0 1) == 1
|
||||
-- | ```
|
||||
indexByAxis :: forall a. Axis -> Vec2 a -> a
|
||||
indexByAxis X = x
|
||||
indexByAxis Y = y
|
||||
|
||||
-- | Construct a vector starting from a given axis.
|
||||
-- | Similar to `vec2`, except the first argument
|
||||
-- | is not always the x axis. Instead, the first argument
|
||||
-- | can be either the X or the Y axis.
|
||||
-- |
|
||||
-- | You can think of this function as:
|
||||
-- | ```purs
|
||||
-- | buildFromAxis X = vec2
|
||||
-- | buildFromAxis Y = flip vec2
|
||||
-- | ```
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | buildFromAxis X 0 1 == vec2 0 1
|
||||
-- | buildFromAxis Y 0 1 == vec2 1 0
|
||||
-- | ```
|
||||
buildFromAxis :: forall a. Axis -> a -> a -> Vec2 a
|
||||
buildFromAxis X a b = vec2 a b
|
||||
buildFromAxis Y a b = vec2 b a
|
||||
|
||||
-- | Map over the value at the given axis
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | mapAxis Y (_ + 1) origin == vec2 0 1
|
||||
-- | ```
|
||||
mapAxis :: forall a. Axis -> (a -> a) -> Vec2 a -> Vec2 a
|
||||
mapAxis axis = over (_axis axis)
|
||||
|
||||
-- | Alias for `mapAxis`
|
||||
lmapAxis :: forall a. Axis -> (a -> a) -> Vec2 a -> Vec2 a
|
||||
lmapAxis = mapAxis
|
||||
|
||||
-- | Run a function over the opposite of the provided axis.
|
||||
-- | EG: if the provided axis is X, run the function over the Y axis
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | rmapAxis X (_ + 1) origin = vec2 0.0 1.0
|
||||
-- | ```
|
||||
rmapAxis :: forall a. Axis -> (a -> a) -> Vec2 a -> Vec2 a
|
||||
rmapAxis = other >>> mapAxis
|
||||
|
||||
-- | Run 2 functions over the different axis of a vector.
|
||||
-- | The first function is run over the provided axis,
|
||||
-- | and the second function is run over the other axis
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | bimapAxis Y (_ + 1) (_ - 1) origin == vec2 (-1) 1
|
||||
-- | ```
|
||||
bimapAxis :: forall a. Axis -> (a -> a) -> (a -> a) -> Vec2 a -> Vec2 a
|
||||
bimapAxis axis f g = over (_axis axis) f >>> over (_otherAxis axis) g
|
||||
|
||||
---------- Lenses
|
||||
-- | Similar to `ix`, but for vectors.
|
||||
_insideVector :: forall a s i. Nat i => Lt i s => i -> Lens' (Vec s a) a
|
||||
_insideVector index = lens get set
|
||||
where
|
||||
get vec = vec !! index
|
||||
set vec newX = Vec.updateAt index newX vec
|
||||
|
||||
-- | Focus on the first element of a vector
|
||||
_x :: forall a. Lens' (Vec2 a) a
|
||||
_x = _insideVector d0
|
||||
|
||||
-- | Focus on the second element of a vector
|
||||
_y :: forall a. Lens' (Vec2 a) a
|
||||
_y = _insideVector d1
|
||||
|
||||
-- | Focus on the element of a vector matching a given axis.
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | f (_axis Y) == f _y
|
||||
-- | ```
|
||||
_axis :: forall a. Axis -> Lens' (Vec2 a) a
|
||||
_axis X = _x
|
||||
_axis Y = _y
|
||||
|
||||
-- | Focus on the elemnt of a vector matching
|
||||
-- | the opposite of a given axis.
|
||||
-- |
|
||||
-- | Ex:
|
||||
-- | ```purs
|
||||
-- | f (_axis Y) == f _x
|
||||
-- | ```
|
||||
_otherAxis :: forall a. Axis -> Lens' (Vec2 a) a
|
||||
_otherAxis axis = _axis (other axis)
|
||||
75
purescript/kombinators/src/Foreign/blueprint.ts
Normal file
75
purescript/kombinators/src/Foreign/blueprint.ts
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
import Blueprint from "factorio-blueprint/src";
|
||||
|
||||
export const createBlueprint = () => new Blueprint(undefined);
|
||||
|
||||
interface Position {
|
||||
x: number;
|
||||
y: number;
|
||||
}
|
||||
|
||||
const positionsAreEqual = (a: Position, b: Position) =>
|
||||
a.x === b.y && a.y === b.y;
|
||||
|
||||
export const connect =
|
||||
(
|
||||
bp: Blueprint,
|
||||
from: [number, number],
|
||||
to: [number, number],
|
||||
color: "green" | "red"
|
||||
) =>
|
||||
() => {
|
||||
const fromPosition = { x: from[0], y: from[1] };
|
||||
const toPosition = { x: to[0], y: to[1] };
|
||||
const eFrom = bp.findEntity(fromPosition);
|
||||
const eTo = bp.findEntity(toPosition);
|
||||
|
||||
if (eFrom === null) throw new Error(`No entity at ${from}`);
|
||||
if (eTo === null) throw new Error(`No entity at ${to}`);
|
||||
|
||||
const fromSide = positionsAreEqual(eFrom.position, fromPosition)
|
||||
? "out"
|
||||
: "in";
|
||||
const toSide = positionsAreEqual(eTo.position, toPosition) ? "out" : "in";
|
||||
|
||||
eFrom.connect(eTo, fromSide, toSide, color);
|
||||
};
|
||||
|
||||
export const generate = (bp: Blueprint) =>
|
||||
bp.encode({
|
||||
autoConnectPoles: false,
|
||||
});
|
||||
|
||||
const bp = createBlueprint();
|
||||
// @ts-ignore
|
||||
bp.createEntity(
|
||||
"decider_combinator",
|
||||
{ x: 0, y: 0 },
|
||||
Blueprint.RIGHT
|
||||
).setCondition({
|
||||
operator: ">",
|
||||
left: "signal_each",
|
||||
right: 0 as any,
|
||||
out: "signal_each",
|
||||
countFromInput: false,
|
||||
});
|
||||
|
||||
bp.createEntity(
|
||||
"decider-combinator",
|
||||
{ x: 2, y: 0 },
|
||||
Blueprint.RIGHT,
|
||||
false,
|
||||
false,
|
||||
false
|
||||
).setCondition({
|
||||
operator: ">",
|
||||
left: "signal_each",
|
||||
right: 0 as any,
|
||||
out: "signal_each",
|
||||
countFromInput: false,
|
||||
});
|
||||
|
||||
connect(bp, [1, 0], [2, 0], "green")();
|
||||
|
||||
bp.center();
|
||||
bp.name = "Combinators";
|
||||
console.log(generate(bp));
|
||||
138
purescript/kombinators/src/Layout.purs
Normal file
138
purescript/kombinators/src/Layout.purs
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
-- | Generate blueprint layouts from the circuit dsl
|
||||
module Kombinator.Layout where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Array as Array
|
||||
import Data.Foldable (for_)
|
||||
import Data.HashMap (HashMap)
|
||||
import Data.HashMap as HM
|
||||
import Data.Lens (Lens', over)
|
||||
import Data.Lens.Record (prop)
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Tuple.Nested ((/\))
|
||||
import Data.Vec (vec2)
|
||||
import Kombinator.Circuit (Circuit, CompleteNetwork, ComputationPort, forgetTypelevelColorData)
|
||||
import Kombinator.Circuit as Circuit
|
||||
import Kombinator.Network (RawNetworkId, UncoloredNetworkId(..))
|
||||
import Kombinator.PhysicalCircuit (PCMachine, PhysicalCircuit, Vec2, insertWire)
|
||||
import Kombinator.PhysicalCircuit as PC
|
||||
import Kombinator.Vector as Vec2
|
||||
import Run (Run)
|
||||
import Run.State (STATE, get, modify)
|
||||
import Run.Supply (SUPPLY, generate)
|
||||
import Type.Proxy (Proxy(..))
|
||||
import Type.Row (type (+))
|
||||
|
||||
---------- Constants
|
||||
combinatorsPerBlock :: Int
|
||||
combinatorsPerBlock = 46
|
||||
|
||||
---------- Effect types
|
||||
-- | State used while generating individual blocks
|
||||
type BlockState =
|
||||
{ circuit :: PhysicalCircuit
|
||||
, lastWireOccurences :: HashMap RawNetworkId Vec2
|
||||
}
|
||||
|
||||
type BlockM r = Run (STATE BlockState + SUPPLY CompleteNetwork + r)
|
||||
|
||||
---------- Effect helpers
|
||||
-- | Insert an entity at the end of the current physical circuit
|
||||
insertEntity :: forall r. PC.PCEntity -> BlockM r Unit
|
||||
insertEntity e = modify $ over _circuit $ PC.insertEntity e
|
||||
|
||||
-- | Push a new machine onto a physical circuit.
|
||||
-- | Does not ensure the circuit actually fits in the current block
|
||||
pushMachine :: forall r. PCMachine -> BlockM r Vec2
|
||||
pushMachine machine = do
|
||||
state <- get
|
||||
let machines = state.circuit.entities
|
||||
let
|
||||
nextPosition = case Array.last machines of
|
||||
Nothing -> Vec2.origin
|
||||
Just { position }
|
||||
| Vec2.x position < 8 -> position # Vec2.mapAxis Vec2.X \p -> p / 2 * 2 + 2
|
||||
| otherwise -> vec2 0 (Vec2.y position + 1)
|
||||
insertEntity
|
||||
{ position: nextPosition
|
||||
, machine
|
||||
}
|
||||
pure nextPosition
|
||||
|
||||
-- | Check the last position a network was used at.
|
||||
lastNetworkOccurence :: forall r. RawNetworkId -> BlockM r (Maybe Vec2)
|
||||
lastNetworkOccurence id = get <#> \s ->
|
||||
s.lastWireOccurences
|
||||
# HM.lookup id
|
||||
|
||||
-- | Update the last occurence of a network
|
||||
markNetworkUsage :: forall r. RawNetworkId -> Vec2 -> BlockM r Unit
|
||||
markNetworkUsage id position = modify $ over _lastWireOccurences
|
||||
$ HM.insert id position
|
||||
|
||||
---------- Implementation
|
||||
-- | Generate the necessary wiring for a single port
|
||||
handleRawNetworkId :: forall r. Vec2 -> UncoloredNetworkId -> BlockM r Unit
|
||||
handleRawNetworkId position (UncoloredNetworkId (id /\ color)) = do
|
||||
last <- lastNetworkOccurence id
|
||||
case last of
|
||||
Nothing -> pure unit
|
||||
Just previous -> do
|
||||
modify $ over _circuit $
|
||||
insertWire color (previous /\ position)
|
||||
markNetworkUsage id position
|
||||
|
||||
-- | Generate the necessary wiring for a computation port
|
||||
handleComputationPort :: forall r. Vec2 -> ComputationPort -> BlockM r Unit
|
||||
handleComputationPort position Circuit.None = pure unit
|
||||
handleComputationPort position (Circuit.Single id) = handleRawNetworkId position id
|
||||
handleComputationPort position (Circuit.Both red green) = do
|
||||
handleRawNetworkId position $ forgetTypelevelColorData red
|
||||
handleRawNetworkId position $ forgetTypelevelColorData green
|
||||
|
||||
-- | Generate an individual block of combinators.
|
||||
-- | Does not check the block does not overflow
|
||||
generateInBlockIndices :: forall r. Circuit -> BlockM r Unit
|
||||
generateInBlockIndices (Circuit.Machine (Circuit.Constant port signals)) = do
|
||||
-- | Add combinator and wire it to the things around it
|
||||
position <- pushMachine $ PC.Constant signals
|
||||
handleComputationPort position port
|
||||
|
||||
-- | Light is placed 1 tile over to the right
|
||||
let lightPosition = Vec2.mapAxis Vec2.X (_ + 1) position
|
||||
|
||||
-- | Add light to combinator
|
||||
insertEntity
|
||||
{ position: lightPosition
|
||||
, machine: PC.Light
|
||||
Circuit.GreaterThan
|
||||
Circuit.Anything
|
||||
(Circuit.IntegerInput 0)
|
||||
PC.defaultLightSettings
|
||||
}
|
||||
|
||||
-- | Wire light to surroundings
|
||||
handleComputationPort lightPosition port
|
||||
generateInBlockIndices (Circuit.Machine (Circuit.ComputationComponent input output operation)) = do
|
||||
position <- pushMachine component
|
||||
handleComputationPort position input
|
||||
handleComputationPort position input
|
||||
where
|
||||
component = case operation of
|
||||
Circuit.Arithemtic operation p1 p2 p3 -> PC.Arithemtic operation p1 p2 p3
|
||||
Circuit.Decider operation p1 p2 p3 output -> PC.Decider operation p1 p2 p3 output
|
||||
generateInBlockIndices (Circuit.Many circuits) = for_ circuits generateInBlockIndices
|
||||
generateInBlockIndices (Circuit.Network continue) = do
|
||||
network <- generate
|
||||
generateInBlockIndices $ continue network
|
||||
generateInBlockIndices (Circuit.Block name circuit) = do
|
||||
-- | TODO: do something witht he name
|
||||
generateInBlockIndices circuit
|
||||
|
||||
---------- Lenses
|
||||
_circuit :: Lens' BlockState PhysicalCircuit
|
||||
_circuit = prop (Proxy :: _ "circuit")
|
||||
|
||||
_lastWireOccurences :: Lens' BlockState (HashMap RawNetworkId Vec2)
|
||||
_lastWireOccurences = prop (Proxy :: _ "lastWireOccurences")
|
||||
4
purescript/kombinators/src/Machine.purs
Normal file
4
purescript/kombinators/src/Machine.purs
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
module Kombinator.Machine where
|
||||
|
||||
data Machine a
|
||||
= ConstantCombinator a
|
||||
10
purescript/kombinators/src/Main.purs
Normal file
10
purescript/kombinators/src/Main.purs
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
module Main where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Effect (Effect)
|
||||
import Effect.Console (log)
|
||||
|
||||
main :: Effect Unit
|
||||
main = do
|
||||
log "🍝"
|
||||
33
purescript/kombinators/src/Network.purs
Normal file
33
purescript/kombinators/src/Network.purs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
-- | General stuff related to wire networks
|
||||
module Kombinator.Network where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Hashable (class Hashable, hash)
|
||||
import Data.Tuple.Nested (type (/\), (/\))
|
||||
|
||||
---------- Types
|
||||
-- | Runtime representation for the color of a wire
|
||||
data RuntimeWireColor = Green | Red
|
||||
|
||||
-- | Network id which does not hold any typelevel evidence for it's color
|
||||
newtype UncoloredNetworkId = UncoloredNetworkId (Int /\ RuntimeWireColor)
|
||||
|
||||
-- | The raw, no color data, id of a network
|
||||
type RawNetworkId = Int
|
||||
|
||||
---------- Helpers
|
||||
-- | Extract the id from an uncolored network id
|
||||
uncoloredToRawId :: UncoloredNetworkId -> RawNetworkId
|
||||
uncoloredToRawId = hash
|
||||
|
||||
---------- Typeclass instances
|
||||
derive instance Eq RuntimeWireColor
|
||||
derive instance Eq UncoloredNetworkId
|
||||
|
||||
instance Hashable RuntimeWireColor where
|
||||
hash Green = 0
|
||||
hash Red = 1
|
||||
|
||||
instance Hashable UncoloredNetworkId where
|
||||
hash (UncoloredNetworkId (id /\ _)) = id
|
||||
73
purescript/kombinators/src/PhysicalCircuit.purs
Normal file
73
purescript/kombinators/src/PhysicalCircuit.purs
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
module Kombinator.PhysicalCircuit where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Array as Array
|
||||
import Data.HashMap (HashMap)
|
||||
import Data.Hashable (class Hashable, hash)
|
||||
import Data.Lens (Lens', over, set)
|
||||
import Data.Lens.Record (prop)
|
||||
import Data.Tuple.Nested (type (/\), (/\))
|
||||
import Data.Typelevel.Num (D2, d0, d1)
|
||||
import Data.Vec (Vec)
|
||||
import Data.Vec as Vec
|
||||
import Kombinator.Circuit (_atWire)
|
||||
import Kombinator.Circuit as C
|
||||
import Kombinator.Graph.Undirected (Graph, _atGraphConnection)
|
||||
import Kombinator.Network (RuntimeWireColor)
|
||||
import Safe.Coerce (coerce)
|
||||
import Type.Proxy (Proxy(..))
|
||||
|
||||
---------- Types
|
||||
type Vec2 = Vec D2 Int
|
||||
type Pair a = a /\ a
|
||||
newtype HashableVec2 = HashableVec2 Vec2
|
||||
|
||||
-- | All the different kind of poles we can use in factorio
|
||||
data PoleKind = Small | Medium | Large | Substation
|
||||
|
||||
-- | Settings lights can take in factorio
|
||||
type LightSettings = { colors :: Boolean }
|
||||
|
||||
-- | Individual machines which can appear inside blueprints
|
||||
data PCMachine
|
||||
= Constant (HashMap String Int)
|
||||
| Arithemtic C.ArithemticOperation C.Pin C.Pin C.Pin
|
||||
| Decider C.DeciderOperation C.Pin C.Pin C.Pin Boolean
|
||||
| Light C.DeciderOperation C.Pin C.Pin LightSettings
|
||||
| Pole PoleKind
|
||||
|
||||
type PCEntity =
|
||||
{ position :: Vec2
|
||||
, machine :: PCMachine
|
||||
}
|
||||
|
||||
type PhysicalCircuit =
|
||||
{ entities :: Array PCEntity
|
||||
, wires :: Pair (Graph HashableVec2)
|
||||
}
|
||||
|
||||
---------- Constants
|
||||
defaultLightSettings :: LightSettings
|
||||
defaultLightSettings = { colors: false }
|
||||
|
||||
---------- Helpers
|
||||
-- | Insert a wire into a physical circuit
|
||||
insertWire :: RuntimeWireColor -> Pair Vec2 -> PhysicalCircuit -> PhysicalCircuit
|
||||
insertWire color points = set (_wires <<< _atWire color <<< _atGraphConnection (coerce points)) true
|
||||
|
||||
-- | Insert an entity at the end of the entity list
|
||||
insertEntity :: PCEntity -> PhysicalCircuit -> PhysicalCircuit
|
||||
insertEntity e = over _entities $ flip Array.snoc e
|
||||
|
||||
---------- Lenses
|
||||
_wires :: Lens' PhysicalCircuit (Pair (Graph HashableVec2))
|
||||
_wires = prop (Proxy :: _ "wires")
|
||||
|
||||
_entities :: Lens' PhysicalCircuit (Array PCEntity)
|
||||
_entities = prop (Proxy :: _ "entities")
|
||||
|
||||
---------- Typeclass isntances
|
||||
derive instance Eq HashableVec2
|
||||
instance Hashable HashableVec2 where
|
||||
hash (HashableVec2 vec) = hash (vec `Vec.index` d0 /\ vec `Vec.index` d1)
|
||||
5
purescript/kombinators/src/Utils.purs
Normal file
5
purescript/kombinators/src/Utils.purs
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
module Kombinator.Utils where
|
||||
|
||||
import Data.Tuple.Nested (type (/\))
|
||||
|
||||
type Pair a = a /\ a
|
||||
11
purescript/kombinators/test/Main.purs
Normal file
11
purescript/kombinators/test/Main.purs
Normal 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."
|
||||
101
purescript/kombinators/tsconfig.json
Normal file
101
purescript/kombinators/tsconfig.json
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
{
|
||||
"compilerOptions": {
|
||||
/* Visit https://aka.ms/tsconfig.json to read more about this file */
|
||||
|
||||
/* Projects */
|
||||
// "incremental": true, /* Enable incremental compilation */
|
||||
// "composite": true, /* Enable constraints that allow a TypeScript project to be used with project references. */
|
||||
// "tsBuildInfoFile": "./", /* Specify the folder for .tsbuildinfo incremental compilation files. */
|
||||
// "disableSourceOfProjectReferenceRedirect": true, /* Disable preferring source files instead of declaration files when referencing composite projects */
|
||||
// "disableSolutionSearching": true, /* Opt a project out of multi-project reference checking when editing. */
|
||||
// "disableReferencedProjectLoad": true, /* Reduce the number of projects loaded automatically by TypeScript. */
|
||||
|
||||
/* Language and Environment */
|
||||
"target": "ES6",
|
||||
// "lib": [], /* Specify a set of bundled library declaration files that describe the target runtime environment. */
|
||||
// "jsx": "preserve", /* Specify what JSX code is generated. */
|
||||
// "experimentalDecorators": true, /* Enable experimental support for TC39 stage 2 draft decorators. */
|
||||
// "emitDecoratorMetadata": true, /* Emit design-type metadata for decorated declarations in source files. */
|
||||
// "jsxFactory": "", /* Specify the JSX factory function used when targeting React JSX emit, e.g. 'React.createElement' or 'h' */
|
||||
// "jsxFragmentFactory": "", /* Specify the JSX Fragment reference used for fragments when targeting React JSX emit e.g. 'React.Fragment' or 'Fragment'. */
|
||||
// "jsxImportSource": "", /* Specify module specifier used to import the JSX factory functions when using `jsx: react-jsx*`.` */
|
||||
// "reactNamespace": "", /* Specify the object invoked for `createElement`. This only applies when targeting `react` JSX emit. */
|
||||
// "noLib": true, /* Disable including any library files, including the default lib.d.ts. */
|
||||
// "useDefineForClassFields": true, /* Emit ECMAScript-standard-compliant class fields. */
|
||||
|
||||
/* Modules */
|
||||
"module": "commonjs" /* Specify what module code is generated. */,
|
||||
// "rootDir": "./", /* Specify the root folder within your source files. */
|
||||
"moduleResolution": "node" /* Specify how TypeScript looks up a file from a given module specifier. */,
|
||||
// "baseUrl": "./", /* Specify the base directory to resolve non-relative module names. */
|
||||
// "paths": {}, /* Specify a set of entries that re-map imports to additional lookup locations. */
|
||||
// "rootDirs": [], /* Allow multiple folders to be treated as one when resolving modules. */
|
||||
// "typeRoots": [], /* Specify multiple folders that act like `./node_modules/@types`. */
|
||||
// "types": [], /* Specify type package names to be included without being referenced in a source file. */
|
||||
// "allowUmdGlobalAccess": true, /* Allow accessing UMD globals from modules. */
|
||||
// "resolveJsonModule": true, /* Enable importing .json files */
|
||||
// "noResolve": true, /* Disallow `import`s, `require`s or `<reference>`s from expanding the number of files TypeScript should add to a project. */
|
||||
|
||||
/* JavaScript Support */
|
||||
// "allowJs": true, /* Allow JavaScript files to be a part of your program. Use the `checkJS` option to get errors from these files. */
|
||||
// "checkJs": true, /* Enable error reporting in type-checked JavaScript files. */
|
||||
// "maxNodeModuleJsDepth": 1, /* Specify the maximum folder depth used for checking JavaScript files from `node_modules`. Only applicable with `allowJs`. */
|
||||
|
||||
/* Emit */
|
||||
// "declaration": true, /* Generate .d.ts files from TypeScript and JavaScript files in your project. */
|
||||
// "declarationMap": true, /* Create sourcemaps for d.ts files. */
|
||||
// "emitDeclarationOnly": true, /* Only output d.ts files and not JavaScript files. */
|
||||
// "sourceMap": true, /* Create source map files for emitted JavaScript files. */
|
||||
// "outFile": "./", /* Specify a file that bundles all outputs into one JavaScript file. If `declaration` is true, also designates a file that bundles all .d.ts output. */
|
||||
// "outDir": "./", /* Specify an output folder for all emitted files. */
|
||||
// "removeComments": true, /* Disable emitting comments. */
|
||||
// "noEmit": true, /* Disable emitting files from a compilation. */
|
||||
// "importHelpers": true, /* Allow importing helper functions from tslib once per project, instead of including them per-file. */
|
||||
// "importsNotUsedAsValues": "remove", /* Specify emit/checking behavior for imports that are only used for types */
|
||||
"downlevelIteration": true /* Emit more compliant, but verbose and less performant JavaScript for iteration. */,
|
||||
// "sourceRoot": "", /* Specify the root path for debuggers to find the reference source code. */
|
||||
// "mapRoot": "", /* Specify the location where debugger should locate map files instead of generated locations. */
|
||||
// "inlineSourceMap": true, /* Include sourcemap files inside the emitted JavaScript. */
|
||||
// "inlineSources": true, /* Include source code in the sourcemaps inside the emitted JavaScript. */
|
||||
// "emitBOM": true, /* Emit a UTF-8 Byte Order Mark (BOM) in the beginning of output files. */
|
||||
// "newLine": "crlf", /* Set the newline character for emitting files. */
|
||||
// "stripInternal": true, /* Disable emitting declarations that have `@internal` in their JSDoc comments. */
|
||||
// "noEmitHelpers": true, /* Disable generating custom helper functions like `__extends` in compiled output. */
|
||||
// "noEmitOnError": true, /* Disable emitting files if any type checking errors are reported. */
|
||||
// "preserveConstEnums": true, /* Disable erasing `const enum` declarations in generated code. */
|
||||
// "declarationDir": "./", /* Specify the output directory for generated declaration files. */
|
||||
|
||||
/* Interop Constraints */
|
||||
// "isolatedModules": true, /* Ensure that each file can be safely transpiled without relying on other imports. */
|
||||
"allowSyntheticDefaultImports": true /* Allow 'import x from y' when a module doesn't have a default export. */,
|
||||
"esModuleInterop": true /* Emit additional JavaScript to ease support for importing CommonJS modules. This enables `allowSyntheticDefaultImports` for type compatibility. */,
|
||||
// "preserveSymlinks": true, /* Disable resolving symlinks to their realpath. This correlates to the same flag in node. */
|
||||
"forceConsistentCasingInFileNames": true /* Ensure that casing is correct in imports. */,
|
||||
|
||||
/* Type Checking */
|
||||
"strict": true /* Enable all strict type-checking options. */,
|
||||
// "noImplicitAny": true, /* Enable error reporting for expressions and declarations with an implied `any` type.. */
|
||||
// "strictNullChecks": true, /* When type checking, take into account `null` and `undefined`. */
|
||||
// "strictFunctionTypes": true, /* When assigning functions, check to ensure parameters and the return values are subtype-compatible. */
|
||||
// "strictBindCallApply": true, /* Check that the arguments for `bind`, `call`, and `apply` methods match the original function. */
|
||||
// "strictPropertyInitialization": true, /* Check for class properties that are declared but not set in the constructor. */
|
||||
// "noImplicitThis": true, /* Enable error reporting when `this` is given the type `any`. */
|
||||
// "useUnknownInCatchVariables": true, /* Type catch clause variables as 'unknown' instead of 'any'. */
|
||||
// "alwaysStrict": true, /* Ensure 'use strict' is always emitted. */
|
||||
// "noUnusedLocals": true, /* Enable error reporting when a local variables aren't read. */
|
||||
// "noUnusedParameters": true, /* Raise an error when a function parameter isn't read */
|
||||
// "exactOptionalPropertyTypes": true, /* Interpret optional property types as written, rather than adding 'undefined'. */
|
||||
// "noImplicitReturns": true, /* Enable error reporting for codepaths that do not explicitly return in a function. */
|
||||
// "noFallthroughCasesInSwitch": true, /* Enable error reporting for fallthrough cases in switch statements. */
|
||||
// "noUncheckedIndexedAccess": true, /* Include 'undefined' in index signature results */
|
||||
// "noImplicitOverride": true, /* Ensure overriding members in derived classes are marked with an override modifier. */
|
||||
// "noPropertyAccessFromIndexSignature": true, /* Enforces using indexed accessors for keys declared using an indexed type */
|
||||
// "allowUnusedLabels": true, /* Disable error reporting for unused labels. */
|
||||
// "allowUnreachableCode": true, /* Disable error reporting for unreachable code. */
|
||||
|
||||
/* Completeness */
|
||||
// "skipDefaultLibCheck": true, /* Skip type checking .d.ts files that are included with TypeScript. */
|
||||
"skipLibCheck": true /* Skip type checking all .d.ts files. */
|
||||
},
|
||||
"include": ["src"]
|
||||
}
|
||||
Loading…
Reference in a new issue