From d03f997c6a2d55190d93b889b0102351f7bdf824 Mon Sep 17 00:00:00 2001
From: Jonathan Lamothe <jonathan@jlamothe.net>
Date: Thu, 22 Aug 2024 16:53:01 -0400
Subject: [PATCH] implemented movement of single beads

---
 src/Abacus/App/Actions.hs      | 17 ++++++++++++++++-
 src/Abacus/App/Events.hs       | 16 +++++++++++++++-
 src/Abacus/App/Types.hs        |  2 ++
 test/Abacus/App/ActionsSpec.hs | 22 ++++++++++++++++++++++
 4 files changed, 55 insertions(+), 2 deletions(-)

diff --git a/src/Abacus/App/Actions.hs b/src/Abacus/App/Actions.hs
index 9659324..e1bc2aa 100644
--- a/src/Abacus/App/Actions.hs
+++ b/src/Abacus/App/Actions.hs
@@ -24,7 +24,14 @@ License along with this program.  If not, see
 
 -}
 
-module Abacus.App.Actions (moveUp, moveDown) where
+module Abacus.App.Actions (
+  -- * Rung Selection
+  moveUp,
+  moveDown,
+  -- * Bead Movement
+  beadLeft,
+  beadRight,
+  ) where
 
 import Lens.Micro.Platform ((^.), (&), (%~))
 
@@ -40,4 +47,12 @@ moveDown :: AppState -> AppState
 moveDown s = s & rungNum %~
   (min (pred $ getNumRungs $ s^.abacus) . succ)
 
+-- | Moves a bead on the selected row to the left
+beadLeft :: AppState -> AppState
+beadLeft s = s & abacus.rungL (s^.rungNum) %~ pred
+
+-- | Moves a bead on the selected row to the right
+beadRight :: AppState -> AppState
+beadRight s = s & abacus.rungL (s^.rungNum) %~ succ
+
 --jl
diff --git a/src/Abacus/App/Events.hs b/src/Abacus/App/Events.hs
index dcf2c3c..b5e5127 100644
--- a/src/Abacus/App/Events.hs
+++ b/src/Abacus/App/Events.hs
@@ -43,7 +43,7 @@ import Brick.Keybindings
   )
 import Control.Monad.State.Class (modify)
 import Data.Either (fromRight)
-import Graphics.Vty.Input.Events (Key (KUp, KDown))
+import Graphics.Vty.Input.Events (Key (KUp, KDown, KLeft, KRight))
 
 import Abacus.App.Actions
 import Abacus.App.Types
@@ -65,6 +65,10 @@ eventBindings =
     modify moveUp
   , onEvent MoveDownE "Moves the cursor down" $
     modify moveDown
+  , onEvent BeadLeftE "Moves a bead to the left" $
+    modify beadLeft
+  , onEvent BeadRightE "Moves a bead to the right" $
+    modify beadRight
   ]
 
 -- | Key bindings
@@ -85,6 +89,16 @@ keyBindings =
       , bind 'j'
       ]
     )
+  , ( BeadLeftE
+    , [ bind KLeft
+      , bind 'h'
+      ]
+    )
+  , ( BeadRightE
+    , [ bind KRight
+      , bind 'l'
+      ]
+    )
   ]
 
 --jl
diff --git a/src/Abacus/App/Types.hs b/src/Abacus/App/Types.hs
index 6cdfbee..6455c6c 100644
--- a/src/Abacus/App/Types.hs
+++ b/src/Abacus/App/Types.hs
@@ -54,6 +54,8 @@ data KeyEventID
   = QuitE
   | MoveUpE
   | MoveDownE
+  | BeadLeftE
+  | BeadRightE
   deriving (Eq, Ord, Show)
 
 makeLenses ''AppState
diff --git a/test/Abacus/App/ActionsSpec.hs b/test/Abacus/App/ActionsSpec.hs
index b5afc2d..b1023a9 100644
--- a/test/Abacus/App/ActionsSpec.hs
+++ b/test/Abacus/App/ActionsSpec.hs
@@ -24,6 +24,8 @@ module Abacus.App.ActionsSpec (spec) where
 import Lens.Micro.Platform ((&), (.~))
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 
+import Abacus
+import Abacus.Internal
 import Abacus.App.Actions
 import Abacus.App.Types
 
@@ -31,6 +33,8 @@ spec :: Spec
 spec = describe "Actions" $ do
   moveUpSpec
   moveDownSpec
+  beadLeftSpec
+  beadRightSpec
 
 moveUpSpec :: Spec
 moveUpSpec = describe "moveUp" $ mapM_
@@ -62,4 +66,22 @@ moveDownSpec = describe "moveDown" $ mapM_
     elsewhere = initialState & rungNum .~ 8
     movedDown = initialState & rungNum .~ 1
 
+beadLeftSpec :: Spec
+beadLeftSpec = describe "beadLeft" $ let
+  state = initialState
+    & abacus .~ Abacus 10 [1..10]
+    & rungNum .~ 5
+  expected = state & abacus.rungL 5 .~ 5
+  in it ("should be " ++ show expected) $
+    beadLeft state `shouldBe` expected
+
+beadRightSpec :: Spec
+beadRightSpec = describe "beadRight" $ let
+  state = initialState
+    & abacus .~ Abacus 10 [1..10]
+    & rungNum .~ 5
+  expected = state & abacus.rungL 5 .~ 7
+  in it ("should be " ++ show expected) $
+    beadRight state `shouldBe` expected
+
 --jl