implemented moving to top and bottom rungs

This commit is contained in:
Jonathan Lamothe 2024-08-22 19:07:38 -04:00
parent 04e90481de
commit 2f50ed51be
4 changed files with 53 additions and 1 deletions

View File

@ -28,6 +28,8 @@ module Abacus.App.Actions (
-- * Rung Selection
moveUp,
moveDown,
topRung,
bottomRung,
selRung,
-- * Bead Movement
beadLeft,
@ -50,6 +52,14 @@ moveDown :: AppState -> AppState
moveDown s = s & rungNum %~
(min (pred $ getNumRungs $ s^.abacus) . succ)
-- | Selects the top rung
topRung :: AppState -> AppState
topRung = rungNum .~ 0
-- | Selects the bottom rung
bottomRung :: AppState -> AppState
bottomRung s = s & rungNum .~ pred (getNumRungs $ s^.abacus)
-- | Selectes a specified rung
selRung :: Int -> AppState -> AppState
selRung n s = s & rungNum .~ n' where

View File

@ -46,7 +46,17 @@ 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))
( Key
( KUp
, KDown
, KLeft
, KRight
, KHome
, KEnd
, KPageUp
, KPageDown
)
)
import Abacus.App.Actions
import Abacus.App.Types
@ -68,6 +78,10 @@ eventBindings =
modify moveUp
, onEvent MoveDownE "Moves the cursor down" $
modify moveDown
, onEvent TopRungE "Selects the top rung" $
modify topRung
, onEvent BottomRungE "Selects the bottom rung" $
modify bottomRung
, onEvent BeadLeftE "Moves a bead to the left" $
modify beadLeft
, onEvent BeadRightE "Moves a bead to the right" $
@ -105,6 +119,18 @@ keyBindings =
, bind 'h'
]
)
, ( TopRungE
, [ shift KUp
, bind KPageUp
, bind 'K'
]
)
, ( BottomRungE
, [ shift KDown
, bind KPageDown
, bind 'J'
]
)
, ( BeadRightE
, [ bind KRight
, bind 'l'

View File

@ -54,6 +54,8 @@ data KeyEventID
= QuitE
| MoveUpE
| MoveDownE
| TopRungE
| BottomRungE
| BeadLeftE
| BeadRightE
| RungLeftE

View File

@ -33,6 +33,8 @@ spec :: Spec
spec = describe "Actions" $ do
moveUpSpec
moveDownSpec
topRungSpec
bottomRungSpec
selRungSpec
beadLeftSpec
beadRightSpec
@ -69,6 +71,18 @@ moveDownSpec = describe "moveDown" $ mapM_
elsewhere = initialState & rungNum .~ 8
movedDown = initialState & rungNum .~ 1
topRungSpec :: Spec
topRungSpec = describe "topRung" $ let
state = initialState & rungNum .~ 5
in it ("should be " ++ show initialState) $
topRung state `shouldBe` initialState
bottomRungSpec :: Spec
bottomRungSpec = describe "bottomRung" $ let
expected = initialState & rungNum .~ 9
in it ("should be " ++ show expected) $
bottomRung initialState `shouldBe` expected
selRungSpec :: Spec
selRungSpec = describe "selRung" $ mapM_
( \(desc, rung, expected) -> context desc $