implemented shifting of entire rung
This commit is contained in:
parent
d03f997c6a
commit
a3259f3b7d
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -56,6 +56,8 @@ data KeyEventID
|
|||
| MoveDownE
|
||||
| BeadLeftE
|
||||
| BeadRightE
|
||||
| RungLeftE
|
||||
| RungRightE
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
makeLenses ''AppState
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user