implemented shifting of entire rung

This commit is contained in:
Jonathan Lamothe 2024-08-22 18:21:07 -04:00
parent d03f997c6a
commit a3259f3b7d
4 changed files with 53 additions and 2 deletions

View File

@ -31,9 +31,11 @@ module Abacus.App.Actions (
-- * Bead Movement
beadLeft,
beadRight,
rungLeft,
rungRight,
) where
import Lens.Micro.Platform ((^.), (&), (%~))
import Lens.Micro.Platform ((^.), (&), (.~), (%~))
import Abacus
import Abacus.App.Types
@ -55,4 +57,13 @@ beadLeft s = s & abacus.rungL (s^.rungNum) %~ pred
beadRight :: AppState -> AppState
beadRight s = s & abacus.rungL (s^.rungNum) %~ succ
-- | Moves all beads to the left of the rung
rungLeft :: AppState -> AppState
rungLeft s = s & abacus.rungL (s^.rungNum) .~ 0
-- | Moves all beads to the right of the rung
rungRight :: AppState -> AppState
rungRight s =
s & abacus.rungL (s^.rungNum) .~ getNumBeads (s^.abacus)
--jl

View File

@ -40,10 +40,12 @@ import Brick.Keybindings
, keyEvents
, newKeyConfig
, onEvent
, shift
)
import Control.Monad.State.Class (modify)
import Data.Either (fromRight)
import Graphics.Vty.Input.Events (Key (KUp, KDown, KLeft, KRight))
import Graphics.Vty.Input.Events
(Key (KUp, KDown, KLeft, KRight, KHome, KEnd))
import Abacus.App.Actions
import Abacus.App.Types
@ -69,6 +71,10 @@ eventBindings =
modify beadLeft
, onEvent BeadRightE "Moves a bead to the right" $
modify beadRight
, onEvent RungLeftE "Moves all beads to the left of the rung" $
modify rungLeft
, onEvent RungRightE "Moves all beads to the right of the rung" $
modify rungRight
]
-- | Key bindings
@ -99,6 +105,18 @@ keyBindings =
, bind 'l'
]
)
, ( RungLeftE
, [ shift KLeft
, bind KHome
, bind 'H'
]
)
, ( RungRightE
, [ shift KRight
, bind KEnd
, bind 'L'
]
)
]
--jl

View File

@ -56,6 +56,8 @@ data KeyEventID
| MoveDownE
| BeadLeftE
| BeadRightE
| RungLeftE
| RungRightE
deriving (Eq, Ord, Show)
makeLenses ''AppState

View File

@ -35,6 +35,8 @@ spec = describe "Actions" $ do
moveDownSpec
beadLeftSpec
beadRightSpec
rungLeftSpec
rungRightSpec
moveUpSpec :: Spec
moveUpSpec = describe "moveUp" $ mapM_
@ -84,4 +86,22 @@ beadRightSpec = describe "beadRight" $ let
in it ("should be " ++ show expected) $
beadRight state `shouldBe` expected
rungLeftSpec :: Spec
rungLeftSpec = describe "rungLeft" $ let
state = initialState
& rungNum .~ 5
& abacus .~ Abacus 10 [1..10]
expected = state & abacus.rungL 5 .~ 0
in it ("should be " ++ show expected) $
rungLeft state `shouldBe` expected
rungRightSpec :: Spec
rungRightSpec = describe "rungRight" $ let
state = initialState
& rungNum .~ 5
& abacus .~ Abacus 10 [1..10]
expected = state & abacus.rungL 5 .~ 10
in it ("should be " ++ show expected) $
rungRight state `shouldBe` expected
--jl