wip

app/frontend/packs/App/App.purs

@@ -4,7 +4,8 @@ import Prelude
 
 import App.Channel.GameChannel as GameChannel
 import App.Command.Command as Command
-import App.Command.Manager as CommandManager
+import App.Command.CommandGroup as CommandGroup
+import App.Command.CommandManager as CommandManager
 import App.Game (Game)
 import App.Game as Game
 import App.Interactor.BrowserInteractor as BrowserInteractor
@@ -171,7 +172,8 @@ setupUi game app = do
 
   CommandManager.onCommit \cmds -> do
     progress <- Game.progress game
-    when (Array.any Command.isMerge cmds.commands) $
+    f <- CommandGroup.any Command.isMerge cmds
+    when f $
       query "#progressbar"
       >>= Element.setAttribute "style" ("width:" <> show (progress * 100.0) <> "%")
 
@@ -191,7 +193,8 @@ connectGameChannel game = do
   sub <- GameChannel.subscribe game
   CommandManager.onCommit(GameChannel.commit sub)
   CommandManager.onCommit \cmds -> do
-    when (not cmds.extrinsic && Array.any Command.isMerge cmds.commands) $
+    f <- CommandGroup.any Command.isMerge cmds
+    when (not cmds.extrinsic && f) $
       Game.progress game
       >>= GameChannel.report_progress sub
 

app/frontend/packs/App/Channel/GameChannel.purs

@@ -2,7 +2,7 @@ module App.Channel.GameChannel where
 
 import Prelude
 
-import App.Command.Manager (CommandGroup)
+import App.Command.CommandGroup (CommandGroup)
 import App.Game (Game)
 import Effect (Effect)
 

app/frontend/packs/App/Command/Command.purs

@@ -33,6 +33,15 @@ isValid puzzle = case _ of
   Translate cmd -> TranslateCommand.isValid puzzle cmd
   Rotate cmd -> RotateCommand.isValid puzzle cmd
 
+execute :: Puzzle -> Command -> Effect Unit
+execute puzzle cmd = do
+  b <- isValid puzzle cmd
+  when b case cmd of
+    Merge cmd' -> MergeCommand.execute puzzle cmd'
+    Translate cmd' -> TranslateCommand.execute puzzle cmd'
+    Rotate cmd' -> RotateCommand.execute puzzle cmd'
+
+
 isMerge :: Command -> Boolean
 isMerge = case _ of
   Merge _ -> true

app/frontend/packs/App/Command/CommandGroup.purs

@@ -0,0 +1,38 @@
+module App.Command.CommandGroup where
+
+import Prelude
+
+import App.Command.Command (Command)
+import App.Command.Command as Command
+import Data.Array as Array
+import Data.Maybe (fromMaybe)
+import Effect (Effect)
+import Effect.Ref (Ref)
+import Effect.Ref as Ref
+
+type CommandGroup =
+  { extrinsic :: Boolean
+  , commands :: Ref (Array Command)
+  }
+
+create :: Effect CommandGroup
+create = do
+  commands <- Ref.new []
+  pure { extrinsic: false, commands }
+
+createExtrinsic :: Effect CommandGroup
+createExtrinsic = do
+  commands <- Ref.new []
+  pure { extrinsic: true, commands }
+
+squash :: Command -> CommandGroup -> Effect Unit
+squash cmd group =
+  group.commands # Ref.modify_ \cmds ->
+    fromMaybe (Array.snoc cmds cmd) do
+      { init, last } <- Array.unsnoc cmds
+      cmd' <- Command.squash cmd last
+      pure $ Array.snoc init cmd'
+
+any :: (Command -> Boolean) -> CommandGroup -> Effect Boolean
+any pred group =
+  Ref.read group.commands <#> Array.any pred

app/frontend/packs/App/Command/CommandManager.purs

@@ -0,0 +1,63 @@
+module App.Command.CommandManager where
+
+import Prelude
+
+import App.Command.Command (Command)
+import App.Command.Command as Command
+import App.Command.CommandGroup (CommandGroup)
+import App.Command.CommandGroup as CommandGroup
+import App.Model.Puzzle (Puzzle)
+import Data.Array as Array
+import Data.Traversable (traverse_)
+import Effect (Effect)
+import Effect.Ref (Ref)
+import Effect.Ref as Ref
+import Effect.Unsafe (unsafePerformEffect)
+
+type CommandManager =
+  { current :: CommandGroup
+  , postHandlers :: Array (Command -> Effect Unit)
+  , commitHandlers :: Array (CommandGroup -> Effect Unit)
+  }
+
+self :: Ref CommandManager
+self = unsafePerformEffect do
+  current <- CommandGroup.create
+  Ref.new
+    { current
+    , postHandlers: []
+    , commitHandlers: []
+    }
+
+onPost :: (Command -> Effect Unit) -> Effect Unit
+onPost f = self # Ref.modify_ \obj ->
+  obj { postHandlers = Array.snoc obj.postHandlers f }
+
+onCommit :: (CommandGroup -> Effect Unit) -> Effect Unit
+onCommit f = self # Ref.modify_ \obj ->
+  obj { commitHandlers = Array.snoc obj.commitHandlers f }
+
+commit :: Effect Unit
+commit = do
+  obj <- self # Ref.read
+  let group = obj.current
+  next <- CommandGroup.create
+  self # Ref.write obj { current = next }
+  traverse_ (_ $ group) obj.commitHandlers
+
+post :: Puzzle -> Command -> Effect Unit
+post puzzle cmd = do
+  b <- Command.isValid puzzle cmd
+  when b do
+    obj <- self # Ref.read
+    CommandGroup.squash cmd obj.current
+    traverse_ (_ $ cmd) obj.postHandlers
+
+receive :: Puzzle -> Array Command -> Effect Unit
+receive puzzle cmds = do
+  traverse_ (Command.execute puzzle) cmds
+  group <- CommandGroup.createExtrinsic
+  traverse_ (\cmd -> CommandGroup.squash cmd group) cmds
+  obj <- self # Ref.read
+  traverse_ (_ $ group) obj.commitHandlers
+