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 -- * Rung Selection
moveUp, moveUp,
moveDown, moveDown,
topRung,
bottomRung,
selRung, selRung,
-- * Bead Movement -- * Bead Movement
beadLeft, beadLeft,
@ -50,6 +52,14 @@ moveDown :: AppState -> AppState
moveDown s = s & rungNum %~ moveDown s = s & rungNum %~
(min (pred $ getNumRungs $ s^.abacus) . succ) (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 -- | Selectes a specified rung
selRung :: Int -> AppState -> AppState selRung :: Int -> AppState -> AppState
selRung n s = s & rungNum .~ n' where 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.Char (chr, ord)
import Data.Either (fromRight) import Data.Either (fromRight)
import Graphics.Vty.Input.Events 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.Actions
import Abacus.App.Types import Abacus.App.Types
@ -68,6 +78,10 @@ eventBindings =
modify moveUp modify moveUp
, onEvent MoveDownE "Moves the cursor down" $ , onEvent MoveDownE "Moves the cursor down" $
modify moveDown 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" $ , onEvent BeadLeftE "Moves a bead to the left" $
modify beadLeft modify beadLeft
, onEvent BeadRightE "Moves a bead to the right" $ , onEvent BeadRightE "Moves a bead to the right" $
@ -105,6 +119,18 @@ keyBindings =
, bind 'h' , bind 'h'
] ]
) )
, ( TopRungE
, [ shift KUp
, bind KPageUp
, bind 'K'
]
)
, ( BottomRungE
, [ shift KDown
, bind KPageDown
, bind 'J'
]
)
, ( BeadRightE , ( BeadRightE
, [ bind KRight , [ bind KRight
, bind 'l' , bind 'l'

View File

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

View File

@ -33,6 +33,8 @@ spec :: Spec
spec = describe "Actions" $ do spec = describe "Actions" $ do
moveUpSpec moveUpSpec
moveDownSpec moveDownSpec
topRungSpec
bottomRungSpec
selRungSpec selRungSpec
beadLeftSpec beadLeftSpec
beadRightSpec beadRightSpec
@ -69,6 +71,18 @@ moveDownSpec = describe "moveDown" $ mapM_
elsewhere = initialState & rungNum .~ 8 elsewhere = initialState & rungNum .~ 8
movedDown = initialState & rungNum .~ 1 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 :: Spec
selRungSpec = describe "selRung" $ mapM_ selRungSpec = describe "selRung" $ mapM_
( \(desc, rung, expected) -> context desc $ ( \(desc, rung, expected) -> context desc $