Add canopy

purescript/canopy/.gitignore

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

purescript/canopy/README.md

@@ -0,0 +1,12 @@
+# Canopy
+
+This directory contains an (unfinished) attempt at writing a [Diplomacy](<https://en.wikipedia.org/wiki/Diplomacy_(game)>) adjudecation engine.
+
+## File structure
+
+| File                                 | Description                                                                    |
+| ------------------------------------ | ------------------------------------------------------------------------------ |
+| [Tagless.purs](./src/Tagless.purs)   | Experiments regarding tagless representations of inductive types               |
+| [Graph.purs](./src/Graph.purs)       | Simple directed-graph type                                                     |
+| [DipMap.purs](./src/DipMap.purs)     | Representation for diplomacy maps                                              |
+| [DipMap.purs](./src/Adjudecate.purs) | Types for logical propositions. The adjudecation logic was supposed to go here |

purescript/canopy/packages.dhall

@@ -0,0 +1,105 @@
+{-
+Welcome to your new Dhall package-set!
+
+Below are instructions for how to edit this file for most use
+cases, so that you don't need to know Dhall to use it.
+
+## Use Cases
+
+Most will want to do one or both of these options:
+1. Override/Patch a package's dependency
+2. Add a package not already in the default package set
+
+This file will continue to work whether you use one or both options.
+Instructions for each option are explained below.
+
+### Overriding/Patching a package
+
+Purpose:
+- Change a package's dependency to a newer/older release than the
+    default package set's release
+- Use your own modified version of some dependency that may
+    include new API, changed API, removed API by
+    using your custom git repo of the library rather than
+    the package set's repo
+
+Syntax:
+where `entityName` is one of the following:
+- dependencies
+- repo
+- version
+-------------------------------
+let upstream = --
+in  upstream
+  with packageName.entityName = "new value"
+-------------------------------
+
+Example:
+-------------------------------
+let upstream = --
+in  upstream
+  with halogen.version = "master"
+  with halogen.repo = "https://example.com/path/to/git/repo.git"
+
+  with halogen-vdom.version = "v4.0.0"
+  with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies
+-------------------------------
+
+### Additions
+
+Purpose:
+- Add packages that aren't already included in the default package set
+
+Syntax:
+where `<version>` is:
+- a tag (i.e. "v4.0.0")
+- a branch (i.e. "master")
+- commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977")
+-------------------------------
+let upstream = --
+in  upstream
+  with new-package-name =
+    { dependencies =
+       [ "dependency1"
+       , "dependency2"
+       ]
+    , repo =
+       "https://example.com/path/to/git/repo.git"
+    , version =
+        "<version>"
+    }
+-------------------------------
+
+Example:
+-------------------------------
+let upstream = --
+in  upstream
+  with benchotron =
+      { dependencies =
+          [ "arrays"
+          , "exists"
+          , "profunctor"
+          , "strings"
+          , "quickcheck"
+          , "lcg"
+          , "transformers"
+          , "foldable-traversable"
+          , "exceptions"
+          , "node-fs"
+          , "node-buffer"
+          , "node-readline"
+          , "datetime"
+          , "now"
+          ]
+      , repo =
+          "https://github.com/hdgarrood/purescript-benchotron.git"
+      , version =
+          "v7.0.0"
+      }
+-------------------------------
+-}
+let upstream =
+      https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20221229/packages.dhall
+        sha256:a6af1091425f806ec0da34934bb6c0ab0ac1598620bbcbb60a7d463354e7d87c
+
+in  upstream

purescript/canopy/spago.dhall

@@ -0,0 +1,17 @@
+{-
+Welcome to a Spago project!
+You can edit this file as you like.
+
+Need help? See the following resources:
+- Spago documentation: https://github.com/purescript/spago
+- Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html
+
+When creating a new Spago project, you can use
+`spago init --no-comments` or `spago init -C`
+to generate this file without the comments in this block.
+-}
+{ name = "my-project"
+, dependencies = [ "arrays", "console", "effect", "lists", "maybe", "prelude" ]
+, packages = ./packages.dhall
+, sources = [ "src/**/*.purs", "test/**/*.purs" ]
+}

purescript/canopy/src/Adjudecate.purs

@@ -0,0 +1,120 @@
+module Canopy.Adjudecate where
+
+import Prelude
+
+import Control.Bind (bind)
+import Data.Foldable (class Foldable, any, foldMap, foldlDefault, foldrDefault)
+import Data.List (List(..))
+import Data.List as List
+import Data.Tuple.Nested (type (/\), (/\))
+import Partial.Unsafe (unsafeCrashWith)
+import Prim.Row (class Cons)
+
+type Index = Int
+
+data Proposition a
+  = False
+  | True
+  | Disj (Proposition a) (Proposition a)
+  | Conj (Proposition a) (Proposition a)
+  | Negation (Proposition a)
+  | Other a
+
+derive instance Functor Proposition
+
+instance Apply Proposition where
+  apply = ap
+
+instance Applicative Proposition where
+  pure = Other
+
+instance Bind Proposition where
+  bind (Other a) f = f a
+  bind False _ = False
+  bind True _ = True
+  bind (Negation p) f = Negation (bind p f)
+  bind (Conj l r) f = Conj (bind l f) (bind r f)
+  bind (Disj l r) f = Disj (bind l f) (bind r f)
+
+instance Foldable Proposition where
+  foldMap f (Other a) = f a
+  foldMap f (Disj l r) = foldMap f l <> foldMap f r
+  foldMap f (Conj l r) = foldMap f l <> foldMap f r
+  foldMap f (Negation p) = foldMap f p
+  foldMap _ _ = mempty
+
+  foldr = foldrDefault
+  foldl = foldlDefault
+
+instance Monad Proposition
+
+derive instance Eq a => Eq (Proposition a)
+
+simp :: forall a. Eq a => Proposition a -> Proposition a
+simp (Conj False _) = False
+simp (Conj _ False) = False
+simp (Disj True _) = True
+simp (Disj _ True) = True
+simp (Negation True) = False
+simp (Negation False) = True
+simp (Negation (Negation p)) = simp p
+simp (Conj l r) | l == r = simp l
+simp (Disj l r) | l == r = simp l
+simp (Negation (Disj l r)) = simp $ Conj (simp $ Negation l) (simp $ Negation r)
+simp (Negation (Conj l r)) = simp $ Disj (simp $ Negation l) (simp $ Negation r)
+simp (Conj l (Negation r)) | l == r = False
+simp (Disj l (Negation r)) | l == r = True
+simp (Negation p) = Negation (simp p)
+simp (Conj l r) = Conj (simp l) (simp r)
+simp (Disj l r) = Disj (simp l) (simp r)
+simp o = o
+
+-- Put this inside a proposition to have
+-- two wildcard (self and target)
+data BinaryWildcard = BSelf | BTarget | BRef Index
+
+-- Put this inside a proposition to have
+-- a single wildcard (target)
+data UnaryWildcard = UTarget | URef Index
+
+newtype Entry = Entry
+  -- Expression which must be true for us to also be true.
+  { requires :: Proposition Index
+
+  -- We can add arbitrary logic to entries already in the graph
+  , contributes :: List (Proposition BinaryWildcard)
+  }
+
+data MoveImplications
+  = Empty
+  | AddEntry Entry MoveImplications
+
+referencesSelf :: Proposition UnaryWildcard -> Boolean
+referencesSelf = any case _ of
+    URef 0 -> true
+    _ -> false
+
+applyContributions :: List (Proposition UnaryWildcard) -> MoveImplications -> MoveImplications
+applyContributions Nil Empty = Empty
+applyContributions (Cons contribution rest) (AddEntry entry implications) = AddEntry entry' (applyContributions rest implications')
+  where
+  entry' = ?e
+  implications' = ?i
+
+  contributions = implications # List.partition referencesSelf
+
+applyContributions _ _ = unsafeCrashWith "Different amounts of contributions and implications"
+
+
+resolveMoveImplications :: MoveImplications -> List Boolean
+resolveMoveImplications Empty = List.Nil
+resolveMoveImplications (AddEntry (Entry { requires, contributes }) implications) =
+  ?w
+  where
+  unaryContributions :: List (Proposition UnaryWildcard)
+  unaryContributions = contributes <#> \proposition -> do
+    wildcard <- proposition
+    case wildcard of
+      BTarget -> pure UTarget
+      BRef i -> pure $ URef i
+      BSelf -> map URef requires

purescript/canopy/src/DipMap.purs

@@ -0,0 +1,28 @@
+module Canopy.DipMap where
+
+import Canopy.Graph (Graph)
+import Data.List (List)
+import Data.Maybe (Maybe)
+
+newtype DipUnit c = DipUnit
+  { nation :: c
+  , isFleet :: Boolean
+  }
+
+newtype Territory c = Territory
+  { isSea :: Boolean
+  , unit :: Maybe (DipUnit c)
+  }
+
+type DipMap c = Graph (Territory c)
+
+-- Index in some DipMap
+type Loc = Int
+
+data Move
+  = Attack Loc
+  | Support Loc Loc
+  | Convoy Loc Loc
+  | Hold
+
+type DipMoves = List Move

purescript/canopy/src/Graph.purs

@@ -0,0 +1,25 @@
+module Canopy.Graph where
+
+import Prelude
+
+import Data.Array as Array
+import Data.List (List(..))
+
+newtype Node v = Node
+  { adjacentTo :: Array Index
+  , value :: v
+  }
+
+type Graph v = List (Node v)
+type Index = Int
+
+adjacentTo :: forall v. Node v -> Array Index
+adjacentTo (Node {adjacentTo}) = adjacentTo
+
+areAdjacent :: forall v. Index -> Index -> Graph v -> Boolean
+areAdjacent first second Nil = false
+areAdjacent first second whole@(Cons node graph)
+  | first == second = false
+  | first > second = areAdjacent second first whole
+  | first == 0 = Array.elem second (adjacentTo node)
+  | otherwise = areAdjacent (first - 1) (second - 1) graph

purescript/canopy/src/Main.purs

@@ -0,0 +1,10 @@
+module Main where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Console (log)
+
+main :: Effect Unit
+main = do
+  log "🍝"

purescript/canopy/src/Tagless.purs

@@ -0,0 +1,52 @@
+module Canopy.Tagless where
+
+import Safe.Coerce (coerce)
+import Type.Proxy (Proxy(..))
+
+foreign import data Nat :: Type
+foreign import data S :: Nat -> Nat
+foreign import data Z :: Nat
+
+type FinDict f =
+  { fz :: forall (n :: Nat). f (S n)
+  , fs :: forall (n :: Nat). f n -> f (S n)
+  }
+
+type VecDict f a =
+  { empty :: f Z
+  , cons :: forall a (n :: Nat). a -> f n -> f (S n)
+  }
+
+type Fin n = forall f. Proxy f -> FinDict f -> f n
+type Vec n a = forall f. Proxy f -> VecDict f a -> f n
+
+newtype Const a b = Const a
+newtype IndexT a n = IndexT (Vec n a -> a)
+
+index :: forall n a. Fin n -> Const a n
+index  fin = ?f
+  where
+  firstStep :: IndexT a n
+  firstStep = fin (Proxy :: _ (IndexT a)) finDict
+
+  finDict :: FinDict (IndexT a)
+  finDict =
+    { fz: IndexT \vec -> caseZero vec
+    , fs: ?s
+    }
+    where
+      caseZero :: forall n. Vec (S n) a -> a
+      caseZero vec = coerce const
+         where 
+           const :: Const a (S n)
+           const = vec (Proxy :: _ (Const a)) dict
+
+           dict :: VecDict (Const a) a
+           dict = {
+              empty: ?e, 
+              cons: ?c
+             }
+
+
+test :: Vec _ String
+test = \_ d -> d.cons "hey" (d.cons "ho" d.empty)

purescript/canopy/test/Main.purs

@@ -0,0 +1,11 @@
+module Test.Main where
+
+import Prelude
+
+import Effect (Effect)
+import Effect.Class.Console (log)
+
+main :: Effect Unit
+main = do
+  log "🍝"
+  log "You should add some tests."