Implement floating camera

src/Dodge/Base/Coordinate.hs

@@ -2,6 +2,7 @@ module Dodge.Base.Coordinate (
     mouseWorldPos,
     cartePosToScreen,
     worldPosToScreen,
+    screenToWorldPos,
 ) where
 
 import Control.Lens
@@ -47,6 +48,11 @@ mouseWorldPos inp cam =
     (cam ^. camCenter)
         +.+ (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) (_mousePos inp)
 
+screenToWorldPos :: Camera -> Point2 -> Point2
+screenToWorldPos cam p = 
+    (cam ^. camCenter)
+        +.+ (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p
+
 ---- | The mouse position in map coordinates
 --mouseCartePos :: World -> Point2
 --mouseCartePos w = (thehud ^. carteCenter)

src/Dodge/Creature/Impulse/UseItem.hs

@@ -55,7 +55,7 @@ itemEffect cr it w = case it ^. itUse of
 
 tryReload :: Creature -> Item -> Input -> (World -> World) -> World -> World
 tryReload cr it theinput f
-    | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just False =
+    | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just 1 =
         cWorld . lWorld . creatures . ix cid %~ crToggleReloading
     | otherwise =
         (runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . heldHammer .~ HammerDown)))

src/Dodge/Creature/YourControl.hs

@@ -104,7 +104,7 @@ wasdDir :: World -> Point2
 wasdDir = foldl' (flip $ (+.+) . wasdM) (V2 0 0) . M.keys . _pressedKeys . _input
 
 -- | Set posture according to mouse presses.
-mouseActionsCr :: M.Map SDL.MouseButton Bool -> Creature -> Creature
+mouseActionsCr :: M.Map SDL.MouseButton Int -> Creature -> Creature
 mouseActionsCr pkeys cr
     | rbPressed && noaction =
         cr & crStance . posture .~ Aiming
@@ -115,7 +115,7 @@ mouseActionsCr pkeys cr
         theaction <- cr ^? crManipulation . manObject . inInventory . iselAction
         return $ theaction == NoInvSelAction
 
-pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Bool -> World -> World
+pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Int -> World -> World
 pressedMBEffectsTopInventory pkeys w
     | isDown SDL.ButtonLeft && isDown SDL.ButtonRight && inTopInv = useItem (you w) w
     | isDown SDL.ButtonLeft && inTopInv = doTopInvLeftClick (you w) w

src/Dodge/Data/Input.hs

@@ -20,7 +20,7 @@ data Input = Input
     { _mousePos :: Point2 -- in pixels, from the center of the screen
     , _mouseMoving :: Bool
     , _pressedKeys :: M.Map Scancode PressType
-    , _mouseButtons :: M.Map MouseButton Bool -- shortpress False, repeatpress True
+    , _mouseButtons :: M.Map MouseButton Int -- counts number of frames held down
     , _scrollAmount :: Int
     , _previousScrollAmount :: Int
     , _lLine :: (Point2, Point2)
@@ -28,7 +28,10 @@ data Input = Input
     , _lrLine :: (Point2, Point2)
     , _lSelect :: Point2
     , _rSelect :: Point2
-    , _clickMousePos :: Point2
+    , _clickMousePos :: Point2  -- is this in world or screen coords?
+    , _clickPos :: M.Map MouseButton Point2 -- updates when mouse button is pressed
+    , _heldPos :: M.Map MouseButton Point2 -- updates when mouse button is held
+            -- ideally, lags ONE FRAME BEHIND the stored mouse position
     , _textInput :: [Either TermSignal Char]
     , _scrollTestFloat :: Float
     , _scrollTestInt :: Int

src/Dodge/Default/World.hs

@@ -14,6 +14,8 @@ defaultInput :: Input
 defaultInput =
     Input
         { _clickMousePos = V2 0 0
+        , _clickPos = mempty
+        , _heldPos = mempty
         , _textInput = mempty
         , _pressedKeys = mempty
         , _mouseButtons = mempty

src/Dodge/Event/Input.hs

@@ -12,6 +12,7 @@ import Dodge.Data.Config
 import Dodge.Data.Input
 import LensHelp
 import SDL
+--import qualified Data.Map.Strict as M
 
 -- annoyingly, the text input event doesn't register backspace, so deletion has to be
 -- dealt with separately
@@ -55,7 +56,8 @@ handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y
 
 handleMouseButtonEvent :: MouseButtonEventData -> Input -> Input
 handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
-    Released -> pointtothebutton .~ Nothing
+    Released -> mouseButtons . at thebutton .~ Nothing
-    Pressed -> pointtothebutton ?~ False
+    Pressed -> mouseButtons . at thebutton ?~ 1 -- note that mouse button events are NOT repeating
   where
-    pointtothebutton = mouseButtons . at (mouseButtonEventButton mbev)
+--    pointtothebutton = mouseButtons . at thebutton
+    thebutton = mouseButtonEventButton mbev

src/Dodge/Menu.hs

@@ -231,6 +231,7 @@ listControls =
     , ("x", "EXAMINE ITEMS")
     , ("c|<esc>", "PAUSE AND DISPLAY MENU")
     , ("q|e", "ROTATE CAMERA")
+    , ("<F1>", "USE NORMAL CAMERA")
     , ("<F2>", "PAUSE AND FLOAT CAMERA")
     , ("<F3>", "PAUSE AND PAN CAMERA")
     , ("<F5>", "QUICKSAVE")

src/Dodge/TestString.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where
 
 import HelpNum
@@ -15,20 +16,22 @@ import Dodge.Data.Universe
 --import qualified Data.Map.Strict as M
 --import qualified IntMapHelp as IM
 testStringInit :: Universe -> [String]
-testStringInit u = [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . cwCam) 
+testStringInit u = [show $ u ^. uvWorld . input . mouseButtons
-        (u ^. uvWorld . cWorld . lWorld)
+    , show $ u ^. uvWorld . input . heldPos]
-        , show a
+--    [show $ length $ lightsToRender (u ^. uvConfig) (u ^. uvWorld . cWorld . cwCam) 
-        , show $ u ^. uvWorld . input . mousePos
+--        (u ^. uvWorld . cWorld . lWorld)
-        , show $ u ^. uvConfig . windowX
+--        , show a
-        , show $ u ^. uvConfig . windowY
+--        , show $ u ^. uvWorld . input . mousePos
-        , show $ u ^. uvWorld . input . scrollTestInt
+--        , show $ u ^. uvConfig . windowX
-        ]
+--        , show $ u ^. uvConfig . windowY
-  where
+--        , show $ u ^. uvWorld . input . scrollTestInt
-    w = u ^. uvWorld
+--        ]
-    a = fromMaybe 0 $ do 
+--  where
-        cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
+--    w = u ^. uvWorld
-        return . toClosestMultiple (pi/ 8) $ argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCam) -.- cpos)
+--    a = fromMaybe 0 $ do 
-            - w ^. cWorld . cwCam . camRot
+--        cpos <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
+--        return . toClosestMultiple (pi/ 8) $ argV (mouseWorldPos (w ^. input) (w ^. cWorld . cwCam) -.- cpos)
+--            - w ^. cWorld . cwCam . camRot
 
     --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
 --    [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections]

src/Dodge/Update.hs

@@ -105,11 +105,13 @@ gotoTerminal w = case _uvScreenLayers w of
     _ -> w & uvScreenLayers .:~ InputScreen mempty "Enter command"
 
 updateUniverseLast :: Universe -> Universe
-updateUniverseLast =
+updateUniverseLast u = u
-    over uvWorld (input . mouseButtons . each .~ True) -- to determine if the mouse button is held
+      & uvWorld . input . pressedKeys . each %~ f
-        . over uvWorld (input . pressedKeys . each %~ f)
+      & uvWorld . input . mouseMoving .~ False
-        . over uvWorld (input . mouseMoving .~ False)
+      & uvWorld . input . mouseButtons . each +~ 1
+      & uvWorld . input . heldPos %~ M.union (fmap (const  mp) (u ^. uvWorld . input . mouseButtons))
   where
+    mp = u ^. uvWorld . input . mousePos
     f LongPress = LongPress
     f _ = ShortPress
 
@@ -131,25 +133,28 @@ updateUniverseMid u = case _uvScreenLayers u of
 
 timeFlowUpdate :: Universe -> Universe
 timeFlowUpdate u = case u ^. uvWorld . timeFlow of
+    _ | debugcamera -> u
     NormalTimeFlow -> functionalUpdate u
     ScrollTimeFlow smoothing _ _ _ -> over uvWorld (doTimeScroll smoothing) u
     RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
     RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
     DeathTime{} -> u
     PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u
+  where
+    debugcamera = CamInGame /= (u ^. uvWorld . cWorld . cwCam . camControl)
 
 pauseTime :: Int -> World -> World
 pauseTime itmloc w
     | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow
     | otherwise = w & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge -~ 1
   where
-    justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just False
+    justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 1
     outofcharge = maybe True (== 0) charge
     charge = w ^? pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge
 
 doTimeScroll :: Int -> World -> World
 doTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of
-    Just False -> w & timeFlow .~ NormalTimeFlow
+    Just 1 -> w & timeFlow .~ NormalTimeFlow
     _ -> doTimeScroll' smoothing w
 
 doTimeScroll' :: Int -> World -> World
@@ -286,16 +291,16 @@ updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . cwCam)) w
 
 updateWorldSelect :: Camera -> Input -> Input
 updateWorldSelect cam inp = f . g $ case (inp ^? mouseButtons . ix ButtonLeft, inp ^? mouseButtons . ix ButtonRight) of
-    (Just False, Nothing) ->
+    (Just 1, Nothing) ->
         inp & lLine . _1 .~ mwp
             & lrLine . _1 .~ mwp
-    (Just True, Nothing) ->
+    (Just _, Nothing) ->
         inp & lLine . _2 .~ mwp
             & lrLine . _1 .~ mwp
-    (Nothing, Just False) ->
+    (Nothing, Just 1) ->
         inp & rLine . _1 .~ mwp
             & lrLine . _2 .~ mwp
-    (Nothing, Just True) ->
+    (Nothing, Just _) ->
         inp & rLine . _2 .~ mwp
             & lrLine . _2 .~ mwp
     _ -> inp

src/Dodge/Update/Camera.hs

@@ -5,6 +5,8 @@ module Dodge.Update.Camera (
     updateCamera,
 ) where
 
+import SDL (MouseButton (..))
+import Dodge.Base.Coordinate
 import Dodge.InputFocus
 import Bound
 import Dodge.Viewpoints
@@ -28,9 +30,32 @@ update where your avatar's view is from.  -}
 updateCamera :: Configuration -> World -> World
 updateCamera cfig w = case w ^. cWorld . cwCam . camControl of
     CamInGame -> updateInGameCamera cfig w
-    CamFloat -> w
+    CamFloat -> updateFloatingCamera cfig w
     CamPan -> w
 
+updateFloatingCamera :: Configuration -> World -> World
+updateFloatingCamera cfig w = w 
+    & updateBounds cfig
+    & cWorld . cwCam %~ setViewDistance cfig
+    & cWorld . cwCam %~ translateFloatingCamera theinput
+    & cWorld . cwCam %~ zoomFloatingCamera theinput
+  where
+    theinput = w ^. input
+
+translateFloatingCamera :: Input -> Camera -> Camera
+translateFloatingCamera theinput cam = fromMaybe cam $ do
+    presstime <- theinput ^. mouseButtons . at ButtonLeft
+    guard $ presstime > 1
+    hpos <- theinput ^? heldPos . ix ButtonLeft
+    let thetran = 
+            screenToWorldPos cam hpos
+            -.-
+            screenToWorldPos cam (theinput ^. mousePos) 
+    return $ cam & camCenter +~ thetran
+        & camViewFrom +~ thetran
+
+zoomFloatingCamera theinput cam = cam
+
 updateInGameCamera :: Configuration -> World -> World
 updateInGameCamera cfig w =
     w

src/Dodge/Update/Input/InGame.hs

@@ -61,12 +61,12 @@ updateUseInputInGame h u = case h of
   where
     w = u ^. uvWorld
     pkeys = u ^. uvWorld . input . pressedKeys
-    lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just False
+    lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just 1
 
 updatePressedButtonsCarte :: World -> World
 updatePressedButtonsCarte w = updatePressedButtonsCarte' (_mouseButtons (_input w)) w
 
-updatePressedButtonsCarte' :: M.Map MouseButton Bool -> World -> World
+updatePressedButtonsCarte' :: M.Map MouseButton Int -> World -> World
 updatePressedButtonsCarte' pkeys w
     | isDown ButtonRight =
         w
@@ -106,6 +106,7 @@ updateKeyInGame uv sc pt = case pt of
 
 updateInitialPressInGame :: Universe -> Scancode -> Universe
 updateInitialPressInGame uv sc = case sc of
+    ScancodeF1 -> useNormalCamera uv
     ScancodeF2 -> pauseAndFloatCam uv
     ScancodeF3 -> pauseAndPanCam uv
     ScancodeF5 -> doQuicksave uv
@@ -149,7 +150,7 @@ doRegexInput u i sss
         any
             ((== Just InitialPress) . (`M.lookup` pkeys))
             [ScancodeReturn, ScancodeSlash]
-    endmouse = fromMaybe False $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
+    endmouse = maybe False (==1) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
     backspacetonothing =
         sss ^? sssExtra . sssFilters . ix i . _Just == Just ""
             && ScancodeBackspace `M.lookup` pkeys == Just InitialPress

src/Dodge/Update/Input/ScreenLayer.hs

@@ -60,12 +60,12 @@ mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
 mouseClickOptionsList screen u = fromMaybe u $ do
     sl <- screen ^? scSelectionList
     Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
-        Just False -> fromMaybe u $ do
+        Just 1 -> fromMaybe u $ do
             i <- sl ^. slSelPos
             f <- sl ^? slItems . ix i . siPayload . _1
             return $ f u
         _ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
-            Just False -> fromMaybe u $ do
+            Just 1 -> fromMaybe u $ do
                 i <- sl ^. slSelPos
                 f <- sl ^? slItems . ix i . siPayload . _2
                 return $ f u