Implement floating camera

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