implemented movement of single beads
This commit is contained in:
parent
af72ca74af
commit
d03f997c6a
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -54,6 +54,8 @@ data KeyEventID
|
|||
= QuitE
|
||||
| MoveUpE
|
||||
| MoveDownE
|
||||
| BeadLeftE
|
||||
| BeadRightE
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
makeLenses ''AppState
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user