implemented movement of single beads

This commit is contained in:
Jonathan Lamothe 2024-08-22 16:53:01 -04:00
parent af72ca74af
commit d03f997c6a
4 changed files with 55 additions and 2 deletions

View File

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

View File

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

View File

@ -54,6 +54,8 @@ data KeyEventID
= QuitE
| MoveUpE
| MoveDownE
| BeadLeftE
| BeadRightE
deriving (Eq, Ord, Show)
makeLenses ''AppState

View File

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