added additional tests for path segment

package.json

@@ -14,14 +14,12 @@
   "devDependencies": {
     "esbuild": "^0.18.15",
     "less": "^4.2.0",
-    "nodemon": "^3.0.1",
     "purescript": "^0.15.14",
     "purs-backend-es": "^1.4.2",
     "spago": "^0.21.0"
   },
   "dependencies": {
     "driver.js": "^1.3.1",
-    "rough-notation": "^0.5.1",
-    "typeit": "^8.8.3"
+    "rough-notation": "^0.5.1"
   }
 }

packages.dhall

@@ -103,8 +103,4 @@ let upstream =
         sha256:f91d36c7e4793fe4d7e042c57fef362ff3f9e9ba88454cd38686701e30bf545a
 in  upstream
   with halogen-svg-elems.repo = "https://github.com/MitchStevens/purescript-halogen-svg-elems.git"
-  with halogen-svg-elems.version = "df7b35f"
-
-  with veither.repo = "https://github.com/MitchStevens/purescript-veither.git"
-  with veither.version = "e8e369ec2cd6272c96b047c0e7f6ea9b5e2c649e"
-  with veither.dependencies = [ "prelude" ]
+  with halogen-svg-elems.version = "df7b35f"

spago.dhall

@@ -46,6 +46,7 @@ to generate this file without the comments in this block.
   , "ordered-collections"
   , "partial"
   , "parsing"
+  , "parallel"
   , "prelude"
   , "profunctor"
   , "profunctor-lenses"

src/Game/Board/PathSegment.purs

@@ -2,105 +2,117 @@ module Game.Board.PathSegment where
 
 import Prelude
 
-import Control.Monad.Error.Class (class MonadError, throwError)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError)
 import Data.Array as A
+import Data.Generic.Rep (class Generic)
 import Data.List (List(..))
 import Data.List as L
 import Data.Map (Map)
 import Data.Map as M
 import Data.Maybe (Maybe(..), fromMaybe, isJust)
 import Data.Set as S
+import Data.Show.Generic (genericShow)
 import Data.Tuple (Tuple(..))
 import Data.Zipper (Zipper)
 import Game.Board.PieceInfo (PieceInfo)
 import Game.Capacity (Capacity(..))
 import Game.Direction (CardinalDirection, clockwiseRotation, rotateDirection)
 import Game.Direction as Direction
 import Game.Location (directionTo)
-import Game.Piece (chickenPiece, cornerCutPiece, crossPiece, mkWirePiece, reverseChickenPiece)
-import Game.Rotation (Rotation(..))
+import Game.Piece (Piece(..), Simplification(..), chickenPiece, cornerCutPiece, crossPiece, isSimplifiable, mkWirePiece, reverseChickenPiece)
+import Game.Rotation (Rotation(..), rotation)
 import Halogen.Svg.Attributes (m)
 import Partial.Unsafe (unsafeCrashWith)
 
 {-
   Assertions:
 
 -}
+type SinglePathSegment = { from :: CardinalDirection, to :: CardinalDirection }
+
 data PathSegment
-  = SinglePath { from :: CardinalDirection, to :: CardinalDirection }
-  | DualPath
-    { from1 :: CardinalDirection
-    , to1 :: CardinalDirection
-    , from2 :: CardinalDirection
-    , to2 :: CardinalDirection
-    }
+  = SinglePath SinglePathSegment
+  | DualPath SinglePathSegment SinglePathSegment
+derive instance Generic PathSegment _
+derive instance Eq PathSegment
+instance Show PathSegment where
+  show = genericShow
+
+rotatePathSegment :: Rotation -> PathSegment -> PathSegment
+rotatePathSegment rot = case _ of
+  SinglePath path -> SinglePath (r path)
+  DualPath path1 path2 -> DualPath (r path1) (r path2)
+  where
+    r { from, to } =
+      { from: rotateDirection from rot, to: rotateDirection to rot }
 
 data PathSegmentError
-  = NoOverlay PathSegment PathSegment
-  | InvalidSinglePath CardinalDirection CardinalDirection
-  | PathSegmentError
+  = InvalidSinglePath SinglePathSegment
+  | InvalidDualPath SinglePathSegment SinglePathSegment
+  | NoSimplificationForPiece Piece
+derive instance Generic PathSegmentError _
+derive instance Eq PathSegmentError
+instance Show PathSegmentError where
+  show = genericShow
+
 
 singlePath :: forall m
-  .  MonadError PathSegmentError m
-  =>  CardinalDirection -> CardinalDirection -> m PathSegment
+  .  MonadThrow PathSegmentError m
+  =>  CardinalDirection -> CardinalDirection -> m SinglePathSegment
 singlePath from to =
   if from /= to
-    then pure (SinglePath {from, to})
-    else throwError (InvalidSinglePath from to)
-
-dualPath :: forall m. MonadError PathSegmentError m
-  => { from :: CardinalDirection, to :: CardinalDirection }
-  -> { from :: CardinalDirection, to :: CardinalDirection }
-  -> m PathSegment
-dualPath s1 s2 =
-  if A.length (A.nub [s1.from, s1.to, s2.from, s2.to]) == 4
-    then pure (DualPath { from1: s1.from, to1: s1.to, from2: s2.from, to2: s2.to })
-    else throwError PathSegmentError
-
---combineSegments :: forall m
---  .  MonadError PathSegment m
---  => PathSegment -> PathSegment -> m PathSegment
---combineSegments p1 p2 = case p1, p2 of
---  SinglePath s1, SinglePath s2 -> dualPath s1 s2
---  _, _ -> throwError (NoOverlay p1 p2)
---
+    then pure {from, to}
+    else throwError (InvalidSinglePath {from, to})
+
+dualPath :: forall m. MonadThrow PathSegmentError m
+  => SinglePathSegment -> SinglePathSegment -> m PathSegment
+dualPath sp1 sp2 =
+  if A.length (A.nub [sp1.from, sp1.to, sp2.from, sp2.to]) == 4
+    then pure (DualPath (min sp1 sp2) (max sp1 sp2))
+    else throwError (InvalidDualPath (min sp1 sp2) (max sp1 sp2))
+
 --pathSegmentAt :: CardinalDirection -> CardinalDirection -> Zipper Location -> m PathSegment
 --pathSegmentAt initialDirection terminalDirection (Zipper ls v rs) = do
 --  let from = fromMaybe initialDirection   (L.head ls >>= directionTo v)
 --  let to   = fromMaybe terminalDirection  (L.head rs >>= directionTo v)
 --  singlePath from to
 --
---fromPiece :: forall m. MonadError PathSegmentError m
---  => PieceInfo -> m PathSegment
---fromPiece {piece, rotation} = do
---  simplification <- isSimplifiable piece
---  case simplification of
---    IsConstant _ ->
---    IsConnection connections -> case M.toUnfoldable connections of
---      [Tuple from to ]
---      [Tuple from1 to1, Tuple from2 to2] -> dualPath from1 
---
---
---{-
---  Using the assertions of the `PathSegment` type, this function is made total via `crashWith`
----}
---toPiece :: PathSegment -> PieceInfo
---toPiece (SinglePath {from, to}) =
---  let rotation = clockwiseRotation Direction.Left from
---  in Tuple (mkWirePiece { capacity: OneBit, outputs: S.singleton (rotateDirection to rot) }) rot
---toPiece (DualPath {from1, to1,  from2, to2}) =
---  let Rotation r1 = clockwiseRotation from1 to1
---      Rotation r2 = clockwiseRotation from1 from2
---      Rotation r3 = clockwiseRotation from1 to2
---      rotation = clockwiseRotation Direction.Left from1
---  in case r1, r2, r3 of
---    1, 2, 3 -> Tuple reverseChickenPiece rotation
---    1, 3, 2 -> Tuple cornerCutPiece      (rotation <> Rotation 1 )
---    2, 1, 3 -> Tuple crossPiece          rotation
---    2, 3, 1 -> Tuple crossPiece          (rotation <> Rotation 1)
---    3, 1, 2 -> Tuple cornerCutPiece      rotation
---    3, 2, 1 -> Tuple chickenPiece        rotation
---    _       -> unsafeCrashWith ("couldn't create a piece")
+
+fromPiece :: forall m. MonadThrow PathSegmentError m
+  => PieceInfo -> m PathSegment
+fromPiece {piece, rotation} = rotatePathSegment rotation <$>
+  case isSimplifiable piece of
+    Just (IsConnection connections) -> case M.toUnfoldable connections of
+      [Tuple from to ] -> SinglePath <$> singlePath from to
+      [Tuple from1 to1, Tuple from2 to2] ->
+        dualPath { from: from1, to: to1 }  { from: from2, to: to2 }
+      _ -> throwError (NoSimplificationForPiece piece)
+    _ -> throwError (NoSimplificationForPiece piece)
+
+
+{-
+  Using the assertions of the `PathSegment` type, this function is made total via `crashWith`
+-}
+toPiece :: PathSegment -> PieceInfo
+toPiece (SinglePath {from, to}) =
+  let rotation = clockwiseRotation Direction.Left from
+  in 
+   { piece: mkWirePiece { capacity: OneBit, outputs: S.singleton (rotateDirection to (-rotation)) }
+   , rotation
+   }
+toPiece (DualPath sp1 sp2) =
+  let Rotation r1 = clockwiseRotation sp1.from sp1.to
+      Rotation r2 = clockwiseRotation sp1.from sp2.from
+      Rotation r3 = clockwiseRotation sp1.from sp2.to
+      rotation = clockwiseRotation Direction.Left sp1.from
+  in case r1, r2, r3 of
+    1, 2, 3 -> { piece: reverseChickenPiece, rotation}
+    1, 3, 2 -> { piece: cornerCutPiece,      rotation: (rotation <> Rotation 1 )}
+    2, 1, 3 -> { piece: crossPiece,          rotation}
+    2, 3, 1 -> { piece: crossPiece,          rotation: (rotation <> Rotation 1)}
+    3, 1, 2 -> { piece: cornerCutPiece,      rotation}
+    3, 2, 1 -> { piece: chickenPiece,        rotation}
+    _, _, _ -> unsafeCrashWith ("couldn't create a piece")
 
 
 

src/Game/Direction.purs

@@ -1,4 +1,11 @@
-module Game.Direction where
+module Game.Direction
+  ( CardinalDirection(..)
+  , allDirections
+  , clockwiseRotation
+  , oppositeDirection
+  , rotateDirection
+  )
+  where
 
 import Prelude
 

src/Game/Piece/Types.purs

@@ -42,7 +42,23 @@ derive instance Ord PieceId
 instance Show PieceId where
   show (PieceId id) = id
 
+{-
+  This "Simplification" data type is kinda confusing
+
+  A `Simplification` is a short hand way of describing *some* simple pieces. These simplifications are used when compiling an `EvaluableBoard` into a more effecient `CompiledBoard`. Simplifications come in two forms:
+  
+  - If a piece can be simplified to `IsConstant`, the outputs of the  
+
 
+  An obvious question: why not define `Simplification`:
+  ```
+  type Simplification = Map CardinalDirection (Either CardinalDirection Signal)
+  ```
+  Which would allow for the simplification of pieces that are a combination of `IsConstant` and `IsConnection`?
+
+    1. Such a piece would be rare and not worth the additional complexity, and
+    2. It's useful for creating paths (See `PathSegment.purs`)
+-}
 data Simplification
   = IsConstant (Map CardinalDirection Signal)
   | IsConnection (Map CardinalDirection CardinalDirection)

src/Game/Piece/WirePiece.purs

@@ -16,7 +16,7 @@ import Game.Capacity (Capacity(..))
 import Game.Direction (CardinalDirection)
 import Game.Direction as Direction
 import Game.Piece.Complexity as Complexity
-import Game.Piece.Types (Piece(..), PieceId(..), mkPiece, name)
+import Game.Piece.Types (Piece(..), PieceId(..), Simplification(..), isSimplifiable, mkPiece, name)
 import Game.Port (PortType(..), inputPort, outputPort)
 import Game.Signal (Signal(..))
 import Partial.Unsafe (unsafeCrashWith)
@@ -52,10 +52,9 @@ wirePieceNames =
     right = S.singleton Direction.Right
     down  = S.singleton Direction.Down
 
-
 mkWirePiece :: WirePiece -> Piece
 mkWirePiece wire = mkPiece
-  { name: fromMaybe' (\_ -> unsafeCrashWith "impossible to create wirePiece with no outputs") (M.lookup wire.outputs wirePieceNames)
+  { name: fromMaybe' nameErr (M.lookup wire.outputs wirePieceNames)
   , eval: \inputs -> 
       let signal = fromMaybe (Signal 0) (M.lookup Direction.Left inputs)
       in S.toMap wire.outputs $> signal
@@ -80,7 +79,15 @@ mkWirePiece wire = mkPiece
           if S.isEmpty newOutputs
             then pure $ mkWirePiece (wire { outputs = S.singleton Direction.Right} )
             else pure $ mkWirePiece (wire { outputs = newOutputs })
+  , isSimplifiable:
+      let connections = M.fromFoldable $ S.map (\out -> Tuple out Direction.Left) wire.outputs
+      in Just (IsConnection connections)
+
   }
+  where
+    nameErr :: Unit -> PieceId
+    nameErr _ =  unsafeCrashWith $
+      "Can't find wire piece with outputs: " <> show wire.outputs
 
 isWirePiece :: Piece -> Boolean
 isWirePiece piece = name piece `elem` wirePieceNames