implemented arbitrary rung selection

This commit is contained in:
Jonathan Lamothe 2024-08-22 18:50:27 -04:00
parent a3259f3b7d
commit 04e90481de
4 changed files with 37 additions and 2 deletions

View File

@ -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

View File

@ -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

View File

@ -58,6 +58,7 @@ data KeyEventID
| BeadRightE
| RungLeftE
| RungRightE
| SelRungE Int
deriving (Eq, Ord, Show)
makeLenses ''AppState

View File

@ -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