jtdaugherty/brick
1
1
Fork 0
mirror of https://github.com/jtdaugherty/brick.git synced 2024-09-11 15:55:54 +03:00
Code Issues Projects Releases Wiki Activity

More exploration of a mouse demo program

Browse Source
This commit is contained in:
Jonathan Daugherty 2016-10-23 22:42:51 -07:00
parent 752369a9ee
commit 5bfd9a5537
1 changed files with 46 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
programs/MouseDemo.hs
View File

@ -17,6 +17,8 @@ import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Center as C
import Brick.Widgets.Core
data Name = MainUI | Layer | Info deriving (Show, Ord, Eq)
data DragState =
NotDragging
| LastLocation T.Location Bool
@ -25,20 +27,25 @@ data DragState =
data St =
St { _draggableLayerLocation :: T.Location
, _lastDragLoc :: DragState
, _clicked :: [T.Extent Name]
}
makeLenses ''St
drawUi :: St -> [Widget ()]
drawUi :: St -> [Widget Name]
drawUi st =
[ draggableLayer st
, infoLayer st
[ infoLayer st
, draggableLayer st
]
infoLayer :: St -> Widget ()
infoLayer st = fill ' ' <=> dragInfo st
infoLayer :: St -> Widget Name
infoLayer st = T.Widget T.Fixed T.Fixed $ do
c <- T.getContext
let h = c^.T.availHeightL
T.render $ translateBy (T.Location (0, h-2)) $
reportExtent Info $ dragInfo st
dragInfo :: St -> Widget ()
dragInfo :: St -> Widget Name
dragInfo st =
let infoStr = case st^.lastDragLoc of
NotDragging -> str "Not dragging"
@ -47,48 +54,51 @@ dragInfo st =
if b
then "(dragging layer)"
else "(dragging outside of layer)"
in withDefAttr "info" $ C.hCenter infoStr
in withDefAttr "info" $ C.hCenter (str $ show $ st^.clicked) <=> C.hCenter infoStr
draggableLayer :: St -> Widget ()
draggableLayer :: St -> Widget Name
draggableLayer st =
let highlight = case st^.lastDragLoc of
LastLocation _ True -> withDefAttr "dragging"
_ -> id
in translateBy (st^.draggableLayerLocation) $
reportExtent () $
in reportExtent MainUI $
(translateBy (st^.draggableLayerLocation) $
reportExtent Layer $
highlight $
B.border $ str $ "This layer can be dragged by\n" <>
"clicking and dragging anywhere\n" <>
"on or within its border."
"on or within its border.") <+> fill ' '
appEvent :: St -> V.Event -> T.EventM () (T.Next St)
appEvent :: St -> V.Event -> T.EventM Name (T.Next St)
appEvent st (V.EvKey V.KEsc []) = M.halt st
appEvent st ev = do
Just e <- M.lookupExtent ()
M.continue $ case ev of
Just e <- M.lookupExtent Layer
M.continue =<< case ev of
-- If the mouse button was released, stop dragging.
(V.EvMouseUp _ _ _) ->
st & lastDragLoc .~ NotDragging
(V.EvMouseDown c r V.BLeft _) ->
return $ st & lastDragLoc .~ NotDragging
(V.EvMouseDown c r V.BLeft _) -> do
let mouseLoc = T.Location (c, r)
in case st^.lastDragLoc of
NotDragging
-- If the mouse button was down in the layer and
-- we were not already dragging it, start dragging
-- the layer.
| M.clickedExtent (c, r) e -> st & lastDragLoc .~ LastLocation mouseLoc True
-- If the mouse button was down outside the layer,
-- start dragging outside the layer.
| otherwise -> st & lastDragLoc .~ LastLocation mouseLoc False
-- If the mouse button was down and we were already
-- dragging, update the drag location. If the drag
-- was a continuation of a layer movement, update the
-- layer location.
LastLocation (T.Location (lc, lr)) bound ->
let off = T.Location (c-lc, r-lr)
in st & lastDragLoc .~ LastLocation mouseLoc bound
& draggableLayerLocation %~ if bound then (<> off) else id
_ -> st
st' = case st^.lastDragLoc of
NotDragging
-- If the mouse button was down in the layer and
-- we were not already dragging it, start dragging
-- the layer.
| M.clickedExtent (c, r) e -> st & lastDragLoc .~ LastLocation mouseLoc True
-- If the mouse button was down outside the layer,
-- start dragging outside the layer.
| otherwise -> st & lastDragLoc .~ LastLocation mouseLoc False
-- If the mouse button was down and we were already
-- dragging, update the drag location. If the drag
-- was a continuation of a layer movement, update the
-- layer location.
LastLocation (T.Location (lc, lr)) bound ->
let off = T.Location (c-lc, r-lr)
in st & lastDragLoc .~ LastLocation mouseLoc bound
& draggableLayerLocation %~ if bound then (<> off) else id
es <- M.findClickedExtents (c, r)
return $ st' & clicked .~ es
_ -> return st
aMap :: AttrMap
aMap = attrMap V.defAttr
@ -96,7 +106,7 @@ aMap = attrMap V.defAttr
, ("dragging", V.black `on` V.yellow)
]
app :: M.App St V.Event ()
app :: M.App St V.Event Name
app =
M.App { M.appDraw = drawUi
, M.appStartEvent = return
@ -107,4 +117,4 @@ app =
}
main :: IO ()
main = void $ M.defaultMain app $ St (T.Location (0, 0)) NotDragging
main = void $ M.defaultMain app $ St (T.Location (0, 0)) NotDragging []