implemented arbitrary rung selection
This commit is contained in:
parent
a3259f3b7d
commit
04e90481de
|
@ -28,6 +28,7 @@ module Abacus.App.Actions (
|
|||
-- * Rung Selection
|
||||
moveUp,
|
||||
moveDown,
|
||||
selRung,
|
||||
-- * Bead Movement
|
||||
beadLeft,
|
||||
beadRight,
|
||||
|
@ -49,6 +50,13 @@ moveDown :: AppState -> AppState
|
|||
moveDown s = s & rungNum %~
|
||||
(min (pred $ getNumRungs $ s^.abacus) . succ)
|
||||
|
||||
-- | Selectes a specified rung
|
||||
selRung :: Int -> AppState -> AppState
|
||||
selRung n s = s & rungNum .~ n' where
|
||||
n' = if n < 0
|
||||
then 0
|
||||
else min n $ pred $ getNumRungs $ s^.abacus
|
||||
|
||||
-- | Moves a bead on the selected row to the left
|
||||
beadLeft :: AppState -> AppState
|
||||
beadLeft s = s & abacus.rungL (s^.rungNum) %~ pred
|
||||
|
|
|
@ -43,6 +43,7 @@ import Brick.Keybindings
|
|||
, shift
|
||||
)
|
||||
import Control.Monad.State.Class (modify)
|
||||
import Data.Char (chr, ord)
|
||||
import Data.Either (fromRight)
|
||||
import Graphics.Vty.Input.Events
|
||||
(Key (KUp, KDown, KLeft, KRight, KHome, KEnd))
|
||||
|
@ -75,7 +76,11 @@ eventBindings =
|
|||
modify rungLeft
|
||||
, onEvent RungRightE "Moves all beads to the right of the rung" $
|
||||
modify rungRight
|
||||
]
|
||||
] ++ map
|
||||
( \n -> onEvent (SelRungE n) "Moves to a numbered rung" $
|
||||
modify $ selRung n
|
||||
)
|
||||
[0..9]
|
||||
|
||||
-- | Key bindings
|
||||
keyBindings :: [(KeyEventID, [Binding])]
|
||||
|
@ -117,6 +122,12 @@ keyBindings =
|
|||
, bind 'L'
|
||||
]
|
||||
)
|
||||
]
|
||||
] ++ map
|
||||
( \n ->
|
||||
( SelRungE n
|
||||
, [bind $ chr $ ord '0' + n]
|
||||
)
|
||||
)
|
||||
[0..9]
|
||||
|
||||
--jl
|
||||
|
|
|
@ -58,6 +58,7 @@ data KeyEventID
|
|||
| BeadRightE
|
||||
| RungLeftE
|
||||
| RungRightE
|
||||
| SelRungE Int
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
makeLenses ''AppState
|
||||
|
|
|
@ -33,6 +33,7 @@ spec :: Spec
|
|||
spec = describe "Actions" $ do
|
||||
moveUpSpec
|
||||
moveDownSpec
|
||||
selRungSpec
|
||||
beadLeftSpec
|
||||
beadRightSpec
|
||||
rungLeftSpec
|
||||
|
@ -68,6 +69,20 @@ moveDownSpec = describe "moveDown" $ mapM_
|
|||
elsewhere = initialState & rungNum .~ 8
|
||||
movedDown = initialState & rungNum .~ 1
|
||||
|
||||
selRungSpec :: Spec
|
||||
selRungSpec = describe "selRung" $ mapM_
|
||||
( \(desc, rung, expected) -> context desc $
|
||||
it ("should be " ++ show expected) $
|
||||
selRung rung initialState `shouldBe` expected
|
||||
)
|
||||
[ ( "negative rung", -1, initialState )
|
||||
, ( "valid rung", 5, rung5 )
|
||||
, ( "large rung", 11, rung9 )
|
||||
]
|
||||
where
|
||||
rung5 = initialState & rungNum .~ 5
|
||||
rung9 = initialState & rungNum .~ 9
|
||||
|
||||
beadLeftSpec :: Spec
|
||||
beadLeftSpec = describe "beadLeft" $ let
|
||||
state = initialState
|
||||
|
|
Loading…
Reference in New Issue
Block a user