implemented moving to top and bottom rungs
This commit is contained in:
parent
04e90481de
commit
2f50ed51be
|
@ -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
|
||||||
|
|
|
@ -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'
|
||||||
|
|
|
@ -54,6 +54,8 @@ data KeyEventID
|
||||||
= QuitE
|
= QuitE
|
||||||
| MoveUpE
|
| MoveUpE
|
||||||
| MoveDownE
|
| MoveDownE
|
||||||
|
| TopRungE
|
||||||
|
| BottomRungE
|
||||||
| BeadLeftE
|
| BeadLeftE
|
||||||
| BeadRightE
|
| BeadRightE
|
||||||
| RungLeftE
|
| RungLeftE
|
||||||
|
|
|
@ -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 $
|
||||||
|
|
Loading…
Reference in New Issue
Block a user