From 04e90481dee5095342ccf9858a4c4abfe7339960 Mon Sep 17 00:00:00 2001
From: Jonathan Lamothe <jonathan@jlamothe.net>
Date: Thu, 22 Aug 2024 18:50:27 -0400
Subject: [PATCH] implemented arbitrary rung selection

---
 src/Abacus/App/Actions.hs      |  8 ++++++++
 src/Abacus/App/Events.hs       | 15 +++++++++++++--
 src/Abacus/App/Types.hs        |  1 +
 test/Abacus/App/ActionsSpec.hs | 15 +++++++++++++++
 4 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/src/Abacus/App/Actions.hs b/src/Abacus/App/Actions.hs
index ff5cc37..31b6c65 100644
--- a/src/Abacus/App/Actions.hs
+++ b/src/Abacus/App/Actions.hs
@@ -28,6 +28,7 @@ module Abacus.App.Actions (
   -- * Rung Selection
   moveUp,
   moveDown,
+  selRung,
   -- * Bead Movement
   beadLeft,
   beadRight,
@@ -49,6 +50,13 @@ moveDown :: AppState -> AppState
 moveDown s = s & rungNum %~
   (min (pred $ getNumRungs $ s^.abacus) . succ)
 
+-- | Selectes a specified rung
+selRung :: Int -> AppState -> AppState
+selRung n s = s & rungNum .~ n' where
+  n' = if n < 0
+    then 0
+    else min n $ pred $ getNumRungs $ s^.abacus
+
 -- | Moves a bead on the selected row to the left
 beadLeft :: AppState -> AppState
 beadLeft s = s & abacus.rungL (s^.rungNum) %~ pred
diff --git a/src/Abacus/App/Events.hs b/src/Abacus/App/Events.hs
index 1a2ff87..f6fb23e 100644
--- a/src/Abacus/App/Events.hs
+++ b/src/Abacus/App/Events.hs
@@ -43,6 +43,7 @@ import Brick.Keybindings
   , shift
   )
 import Control.Monad.State.Class (modify)
+import Data.Char (chr, ord)
 import Data.Either (fromRight)
 import Graphics.Vty.Input.Events
   (Key (KUp, KDown, KLeft, KRight, KHome, KEnd))
@@ -75,7 +76,11 @@ eventBindings =
     modify rungLeft
   , onEvent RungRightE "Moves all beads to the right of the rung" $
     modify rungRight
-  ]
+  ] ++ map
+    ( \n -> onEvent (SelRungE n) "Moves to a numbered rung" $
+      modify $ selRung n
+    )
+    [0..9]
 
 -- | Key bindings
 keyBindings :: [(KeyEventID, [Binding])]
@@ -117,6 +122,12 @@ keyBindings =
       , bind 'L'
       ]
     )
-  ]
+  ] ++ map
+    ( \n ->
+      ( SelRungE n
+      , [bind $ chr $ ord '0' + n]
+      )
+    )
+    [0..9]
 
 --jl
diff --git a/src/Abacus/App/Types.hs b/src/Abacus/App/Types.hs
index a580b18..c33815b 100644
--- a/src/Abacus/App/Types.hs
+++ b/src/Abacus/App/Types.hs
@@ -58,6 +58,7 @@ data KeyEventID
   | BeadRightE
   | RungLeftE
   | RungRightE
+  | SelRungE Int
   deriving (Eq, Ord, Show)
 
 makeLenses ''AppState
diff --git a/test/Abacus/App/ActionsSpec.hs b/test/Abacus/App/ActionsSpec.hs
index e42d454..2ec7d0d 100644
--- a/test/Abacus/App/ActionsSpec.hs
+++ b/test/Abacus/App/ActionsSpec.hs
@@ -33,6 +33,7 @@ spec :: Spec
 spec = describe "Actions" $ do
   moveUpSpec
   moveDownSpec
+  selRungSpec
   beadLeftSpec
   beadRightSpec
   rungLeftSpec
@@ -68,6 +69,20 @@ moveDownSpec = describe "moveDown" $ mapM_
     elsewhere = initialState & rungNum .~ 8
     movedDown = initialState & rungNum .~ 1
 
+selRungSpec :: Spec
+selRungSpec = describe "selRung" $ mapM_
+  ( \(desc, rung, expected) -> context desc $
+    it ("should be " ++ show expected) $
+      selRung rung initialState `shouldBe` expected
+  )
+  [ ( "negative rung", -1, initialState )
+  , ( "valid rung",     5, rung5        )
+  , ( "large rung",    11, rung9        )
+  ]
+  where
+    rung5 = initialState & rungNum .~ 5
+    rung9 = initialState & rungNum .~ 9
+
 beadLeftSpec :: Spec
 beadLeftSpec = describe "beadLeft" $ let
   state = initialState