refactored Signal.purs (lots of files touch Signal)

spago.dhall

@@ -37,6 +37,7 @@ to generate this file without the comments in this block.
   , "halogen-store"
   , "identity"
   , "integers"
+  , "invariant"
   , "lists"
   , "machines"
   , "maybe"
@@ -62,6 +63,7 @@ to generate this file without the comments in this block.
   , "transformers"
   , "tuples"
   , "unfoldable"
+  , "uint"
   , "unsafe-coerce"
   , "uuidv4"
   , "web-dom"

src/AppM.purs

@@ -45,4 +45,4 @@ runAppM component = do
 
   where
     unLogger :: forall m a. MonadEffect m => LoggerT m a -> m a
-    unLogger loggerT = runLoggerT loggerT (logMessage Debug)
+    unLogger loggerT = runLoggerT loggerT (logMessage Info)

src/Component/Board.purs

@@ -57,15 +57,14 @@ import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Class.Console (log, logShow)
 import Game.Board (Board(..), BoardError, BoardM, _pieces, _size, addPath, addPiece, buildEvaluableBoard, capacityRipple, decreaseSize, evalBoardM, evalWithPortInfo, execBoardM, getBoardPortEdge, getPieceInfo, increaseSize, pieceDropped, removePiece, rotatePieceBy, runBoardM, runEvaluableM, toLocalInputs)
-import Game.Capacity (maxValue)
 import Game.Direction (CardinalDirection, allDirections)
 import Game.Direction as Direction
 import Game.GameEvent (BoardEvent(..))
 import Game.Location (Location(..), location)
 import Game.Port (isInput, portCapacity)
 import Game.PortInfo (PortInfo)
 import Game.Rotation (Rotation(..))
-import Game.Signal (Signal(..))
+import Game.Signal (Signal(..), maxValue)
 import GlobalState (GlobalState, newBoardEvent)
 import Halogen (AttrName(..), ClassName(..), Component, ComponentHTML, ComponentSlot, HalogenM(..), HalogenQ, Slot, mkComponent, mkEval, raise, subscribe, tell)
 import Halogen as H
@@ -227,7 +226,7 @@ component = mkComponent { eval , initialState , render }
 
         DecrementInput dir -> do
           gets (_.boardPorts >>> M.lookup dir) >>= traverse_ \port ->
-            _inputs <<< ix dir %= \(Signal n) -> if n == 0 then maxValue (portCapacity port) else Signal (n-1)
+            _inputs <<< ix dir %= \n -> if n == zero then maxValue (portCapacity port) else n - one
           handleAction EvaluateBoard
 
         SetOutputs outputs -> do

src/Component/Board/Types.purs

@@ -40,7 +40,7 @@ import Game.Location (Location(..))
 import Game.Piece (Piece(..))
 import Game.Port (Port(..))
 import Game.PortInfo (PortInfo)
-import Game.Signal (Signal(..))
+import Game.Signal (Signal)
 import Halogen (Slot)
 import Type.Proxy (Proxy(..))
 import Web.Event.Internal.Types (Event)
@@ -149,7 +149,7 @@ boardPortInfo = do
   board <- use _board
   forWithIndex boardPorts \dir port -> do
     let relEdge = evalState (getBoardPortEdge dir) board
-    gets (_.lastEvalWithPortInfo >>> M.lookup relEdge >>> fromMaybe { connected: false, port, signal: Signal 0})
+    gets (_.lastEvalWithPortInfo >>> M.lookup relEdge >>> fromMaybe { connected: false, port, signal: zero})
 
 --liftBoardM :: forall m a. MonadState State m => BoardM a -> m (Either BoardError (Tuple a Board))
 --liftBoardM boardM = do

src/Component/DataAttribute.purs

@@ -12,6 +12,7 @@ import Data.Maybe (Maybe(..), isJust, maybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.String (Pattern(..), split, stripPrefix, stripSuffix, toLower)
 import Data.String.CodeUnits (fromCharArray)
+import Data.UInt (UInt, fromInt)
 import Effect (Effect)
 import Game.Capacity (Capacity(..))
 import Game.Direction (CardinalDirection)
@@ -83,6 +84,9 @@ int = dataAttribute (AttrName "int") show attrParse
       digitStr <- fromCharArray <<< A.fromFoldable <$> many1 digit
       maybe (fail digitStr) pure (Int.fromString digitStr)
 
+uint :: DataAttribute UInt
+uint = dataAttribute (AttrName "uint") show (map fromInt int.attrParse)
+
 boolean :: DataAttribute Boolean
 boolean = dataAttribute (AttrName "boolean") attrPrint attrParse
   where
@@ -139,8 +143,8 @@ rotation = wrapAttribute (AttrName "data-rotation") int
 isConnected :: DataAttribute Boolean
 isConnected = boolean { attrName = AttrName "data-is-connected" } 
 
-signal :: DataAttribute Signal
-signal = wrapAttribute (AttrName "data-signal") int
+--signal :: DataAttribute Signal
+--signal = dataAttribute (AttrName "data-signal") () (map mkSignal uint.attrParse)
 
 isDragging :: DataAttribute Boolean
 isDragging = boolean { attrName = AttrName "data-is-dragging" } 
@@ -154,8 +158,8 @@ completionStatus = dataAttribute (AttrName "data-completion-status") attrPrint a
       NotEvaluable _ -> "not-evaluable"
       PortMismatch _ -> "port-mismatch"
       ReadyForTesting -> "ready-for-testing"
-      RunningTest _ -> "running-test"
-      FailedTestCase _ -> "failed-test-case"
+      RunningTestCase _ -> "running-test"
+      TestCaseOutcome _ -> "testCaseOutcome"
       Completed -> "completed"
     attrParse = fail "no parser for completion status!"
 

src/Component/Level.purs

@@ -3,29 +3,24 @@ module Component.Level where
 import Prelude
 
 import AppM (AppM)
-import Capability.Progress as Progress
+import Capability.Navigate (Route(..), navigateTo)
 import Component.Board as Board
-import Component.Chat as Chat
 import Component.GameEventLogger as GameEventLogger
 import Component.Marginalia.Types (Marginalia, marginalia)
 import Component.Marginalium as Marginalium
-import Component.Sidebar (Output(..))
 import Component.Sidebar as Sidebar
 import Control.Alt ((<|>))
 import Control.Monad.Cont (ContT(..), callCC, lift, runContT)
 import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Monad.Logger.Class (class MonadLogger, debug, info)
 import Control.Monad.State (evalState, modify_)
-import Data.Array (intercalate, intersperse)
 import Data.Array as A
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..), either, isRight)
 import Data.Foldable (fold, foldMap, for_, length, traverse_)
 import Data.FoldableWithIndex (forWithIndex_)
 import Data.Int (toNumber)
 import Data.Lens ((^.))
-import Data.List (List(..))
-import Data.List as L
 import Data.Map (Map)
 import Data.Map as M
 import Data.Maybe (Maybe(..), fromMaybe)
@@ -35,19 +30,16 @@ import Data.TraversableWithIndex (forWithIndex)
 import Data.Tuple (Tuple(..), fst, snd)
 import Data.UUID.Random (UUIDv4)
 import Data.UUID.Random as UUID
-import Debug (spy)
-import Effect.Aff (delay)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Class.Console (log)
 import Game.Board (Board(..), _size, firstEmptyLocation, getBoardPorts, standardBoard)
 import Game.Direction (CardinalDirection)
-import Game.GameEvent (GameEvent)
 import Game.Level (LevelId, Level)
-import Game.Level.Completion (CompletionStatus(..), FailedTestCase, isReadyForTesting, runSingleTest)
+import Game.Level.Completion (CompletionStatus(..), RunningTestCase, isReadyForTesting, runSingleTest)
 import Game.Piece (Piece(..), pieceLookup)
 import Game.Port (Port(..))
-import Game.Signal (Signal(..))
+import Game.Signal (Base, Signal(..), SignalRepresentation)
 import GlobalState (GlobalState, newBoardEvent)
 import Halogen (ClassName(..), Component, HalogenM, HalogenQ, Slot, gets, modify_)
 import Halogen as H
@@ -70,6 +62,7 @@ type State =
   , completionStatus :: CompletionStatus
   , boardSize :: Int
   , boardPorts :: Map CardinalDirection Port
+  , base :: Base
   }
 
 --data Query a
@@ -108,14 +101,17 @@ component = H.mkComponent { eval , initialState , render }
     , boardSize: initialBoard.size
     , boardPorts: evalState getBoardPorts (Board initialBoard)
     , marginalia: M.empty
+    , base: level.options.base
     }
 
   --render :: State -> HalogenM State Action Slots o m Unit
-  render { level, levelId, marginalia, completionStatus, boardSize, boardPorts } = HH.div
+  render { level, levelId, marginalia, completionStatus, boardSize, boardPorts, base } = HH.div
     [ HP.id "puzzle-component"]
-    [ HH.slot _board    unit Board.component { board: Board initialBoard} BoardOutput
+    [ HH.slot _board unit Board.component { board: Board initialBoard} BoardOutput
     --, HH.slot_ _chat    unit Chat.component { conversation: level.conversation }
-    , HH.slot _sidebar  unit Sidebar.component { problem: level.problem, completionStatus, boardSize, boardPorts } SidebarOutput
+    , HH.slot _sidebar unit Sidebar.component
+        { problem: level.problem, completionStatus, boardSize, boardPorts, base }
+        SidebarOutput
     , HH.div [ HP.id "marginalia" ] ((M.toUnfoldable marginalia :: Array _) <#> \(Tuple uuid m) -> HH.slot _marginalia uuid Marginalium.component { uuid, marginalia: m } MarginaliumOutput)
     , HH.slot_ _gameEventLogger unit GameEventLogger.component unit
     ]
@@ -163,39 +159,47 @@ component = H.mkComponent { eval , initialState , render }
         maybeLocation <- H.request _board unit (Board.GetMouseOverLocation)
         for_ maybeLocation \loc -> 
           H.request _board unit (Board.AddPiece loc (pieceLookup pieceId))
-      Sidebar.PieceAdded pieceId -> do
-        H.request _board unit Board.GetBoard >>= traverse_ \board -> do
-          for_ (firstEmptyLocation board) \loc ->
-            H.request _board unit (Board.AddPiece loc (pieceLookup pieceId))
-      Sidebar.BoardSizeIncremented ->
-        H.tell _board unit Board.IncrementBoardSize
-      Sidebar.BoardSizeDecremented ->
-        void $ H.request _board unit Board.DecrementBoardSize
-      Sidebar.TestsTriggered -> do
-        let minTotalTestDurationMs = 2000
-        problem <- gets (_.level.problem)
-        let numTests = A.length problem.testCases
-        let delayDuration =  Milliseconds (toNumber (minTotalTestDurationMs `div` numTests))
-
-        testResult <- runExceptT $ forWithIndex problem.testCases \testIndex testCase  -> do
-          modify_ $ _ { completionStatus = RunningTest { testIndex, numTests } }
-          res <- ExceptT $ runSingleTest problem.goal testIndex testCase testEval
-          liftAff (delay delayDuration)
-          pure res
-
-        case testResult of
-          Left failedTestCase -> do
-            modify_ $ _ { completionStatus = FailedTestCase failedTestCase }
-          Right _  -> do
-            levelId <-  gets (_.levelId)
-            liftEffect $ Progress.saveLevelProgress levelId Progress.Completed
-            modify_ $ _ { completionStatus = Completed }
-      UndoTriggered -> do
-        H.tell _board unit Board.Undo
-      RedoTriggered -> do
-        H.tell _board unit Board.Redo
-      ClearTriggered -> do
-        H.tell _board unit Board.Clear
+      Sidebar.ButtonOutput button -> case button of
+        Sidebar.AddPiece pieceId -> do
+          H.request _board unit Board.GetBoard >>= traverse_ \board -> do
+            for_ (firstEmptyLocation board) \loc ->
+              H.request _board unit (Board.AddPiece loc (pieceLookup pieceId))
+        Sidebar.BackToLevelSelect  ->
+          liftEffect $ navigateTo LevelSelect
+        Sidebar.IncrementBoardSize ->
+          H.tell _board unit Board.IncrementBoardSize
+        Sidebar.DecrementBoardSize ->
+          void $ H.request _board unit Board.DecrementBoardSize
+        Sidebar.Undo ->
+          H.tell _board unit Board.Undo
+        Sidebar.Redo ->
+          H.tell _board unit Board.Redo
+        Sidebar.RunTests -> do
+          let minTotalTestDurationMs = 2000
+          problem <- gets (_.level.problem)
+          let numTests = A.length problem.testCases
+          let delayDuration =  Milliseconds (toNumber (minTotalTestDurationMs `div` numTests))
+
+          --testResult <- runExceptT $ forWithIndex problem.testCases \testIndex testCase  -> do
+          --  modify_ $ _ { completionStatus = RunningTestCase { testIndex, numTests } }
+          --  res <- ExceptT $ runSingleTest problem.goal testIndex testCase testEval
+          --  liftAff (delay delayDuration)
+          --  pure res
+
+          --pure unit
+          --case testResult of
+          --  Left failedTestCase -> do
+          --    modify_ $ _ { completionStatus = FailedTestCase failedTestCase }
+          --  Right _  -> do
+          --    levelId <-  gets (_.levelId)
+          --    liftEffect $ Progress.saveLevelProgress levelId Progress.Completed
+          --    modify_ $ _ { completionStatus = Completed }
+          pure unit
+        Sidebar.Clear ->
+          H.tell _board unit Board.Clear
+        Sidebar.Base base ->
+          modify_ $ _ { base = base }
+
 
     MarginaliumOutput marginaliaOutput -> case marginaliaOutput of
       Marginalium.TriggerNext marginalia -> do

src/Component/Multimeter.purs

@@ -26,7 +26,7 @@ import Game.Board (RelativeEdge)
 import Game.Capacity (Capacity(..), toInt)
 import Game.Port (portCapacity)
 import Game.PortInfo (PortInfo)
-import Game.Signal (Signal(..), nthBit)
+import Game.Signal (Signal(..))
 import Halogen (ClassName(..), RefLabel(..), gets, modify_)
 import Halogen as H
 import Halogen.HTML (HTML(..), PlainHTML, fromPlainHTML)
@@ -175,20 +175,21 @@ multimeterText = A.zipWith ($) prefixes <<< maybe defaultValues multimeterTextVa
 
 
 multimeterTextValues :: PortInfo -> Array String
-multimeterTextValues info = [ binaryText , decimalText , capacityText , connectedText ]
-  where
-    binaryText =
-      (enumFromTo (toInt (portCapacity info.port) - 1) 0 :: Array _)
-        <#> nthBit info.signal
-        # foldMap (\b -> if b then "1" else "0")
-        # padStart " " 8
-
-    decimalText =
-      let Signal n = info.signal
-      in padStart "0" 3 (show n)
-
-    capacityText = show (toInt (portCapacity info.port)) <> "bit"
-    connectedText = if info.connected then "true" else "fals"
+multimeterTextValues _ = [ "FIX ME" ]
+--multimeterTextValues info = [ binaryText , decimalText , capacityText , connectedText ]
+--  where
+--    binaryText =
+--      (enumFromTo (toInt (portCapacity info.port) - 1) 0 :: Array _)
+--        <#> nthBit info.signal
+--        # foldMap (\b -> if b then "1" else "0")
+--        # padStart " " 8
+--    
+--    decimalText =
+--      let Signal n = info.signal
+--      in padStart "0" 3 (show n)
+--
+--    capacityText = show (toInt (portCapacity info.port)) <> "bit"
+--    connectedText = if info.connected then "true" else "fals"
 
 defaultValues :: Array String
 defaultValues =

src/Component/Piece/Types.purs

@@ -24,7 +24,7 @@ import Game.Location (Location(..), location)
 import Game.Piece (Piece(..))
 import Game.PortInfo (PortInfo)
 import Game.Rotation (Rotation(..), rotation)
-import Game.Signal (Signal(..))
+import Game.Signal (Signal)
 import Type.Proxy (Proxy(..))
 import Web.HTML.Event.DragEvent (DragEvent)
 import Web.UIEvent.KeyboardEvent (KeyboardEvent)
@@ -75,7 +75,7 @@ initialState { piece: Piece p, location } =
   , rotation: rotation 0
   , isRotating: Nothing
   , isDragging: false
-  , portStates: map (\port -> { port, signal: Signal 0, connected: false }) $ p.ports
+  , portStates: map (\port -> { port, signal: zero, connected: false }) $ p.ports
   }
 
 _portStates :: Lens' State (Map CardinalDirection PortInfo)

src/Component/Rendering/Gradient.purs

@@ -35,7 +35,7 @@ createPortGradient { port, connected, signal } = { id, def }
 
     id = intercalate "-" [ "port-gradient", portId, signalId, capacityId ]
     portId = if isInput port then "in" else "out"
-    signalId = if signal == Signal 0 then "off" else "on"
+    signalId = if signal == zero then "off" else "on"
     capacityId = show (toInt (portCapacity port)) <> "bit"
 
 setAlpha :: Number -> Color -> Color
@@ -45,7 +45,7 @@ setAlpha alpha = case _ of
   color -> color
 
 portColor :: Port -> Signal -> Color
-portColor port signal = (if signal == Signal 0 then shadeColor (-30) else identity) $
+portColor port signal = (if signal == zero then shadeColor (-30) else identity) $
   case portCapacity port of
     OneBit    -> portColours.teal
     TwoBit    -> portColours.blue

src/Component/Sidebar.purs

@@ -26,9 +26,7 @@ import Halogen as H
 component :: forall m. MonadAff m => Component Query Input Output m
 component = mkComponent { eval , initialState , render }
   where
-  initialState { problem, boardSize, completionStatus, boardPorts } =
-    { problem , completionStatus , boardSize, boardPorts  }
-
+  initialState = identity
 
   eval :: forall slots. HalogenQ Query Action Input ~> HalogenM State Action slots Output m
   eval = mkEval
@@ -37,16 +35,7 @@ component = mkComponent { eval , initialState , render }
         Initialise input -> put (initialState input)
         PieceOnDrop piece _ -> do
           H.raise (PieceDropped piece)
-        PieceOnClick piece _ ->
-          H.raise (PieceAdded piece)
-        BackToLevelSelect _ -> do
-          navigateTo LevelSelect
-        IncrementBoardSize _ -> H.raise BoardSizeIncremented
-        DecrementBoardSize _ -> H.raise BoardSizeDecremented
-        RunTests _ -> H.raise TestsTriggered
-        Undo _ -> H.raise UndoTriggered
-        Redo _ -> H.raise RedoTriggered
-        Clear _ -> H.raise ClearTriggered
+        ButtonClicked button _ -> H.raise (ButtonOutput button)
         DoNothing -> pure unit
     , handleQuery: \_ -> pure Nothing
     , initialize: Nothing