Refactor map, add location arrows

app/Main.hs

@@ -65,8 +65,8 @@ main = do
                       let lastFrameTicks = _frameTimer preData
                       renderFoldable (_renderData preData) 
                                      (picToLTree Nothing . setLayer 1 . setDepth (-1) 
-                                       . translate 0 (-0.8) . scale 0.0005 0.0005 
+                                       . translate (-0.5) (-0.8) . scale 0.0005 0.0005 
-                                       . text $ show (endTicks - lastFrameTicks))
+                                       . text $ "ms/frame " ++ show (endTicks - lastFrameTicks))
                       return $ preData & soundData  .~ newSoundData
                                        & frameTimer .~ endTicks
         )

src/Dodge/Base.hs

@@ -728,6 +728,26 @@ levLayer LabelLayer         = 80
 levLayer InvLayer           = 85
 levLayer MenuLayer          = 90
 
+worldPosToScreen :: World -> Point2 -> Point2
+worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
+  where
+    doTranslate p       =   p -.- _cameraPos w
+    doZoom p            =   _cameraZoom w *.* p
+    doRotate p          =   rotateV (0 - _cameraRot w) p
+    doWindowScale (x,y) =   ( x * 2 / _windowX w
+                            , y * 2 / _windowY w
+                            )
+
+cartePosToScreen :: World -> Point2 -> Point2
+cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
+  where
+    doTranslate p       =   p -.- _carteCenter w
+    doZoom p            =   _carteZoom w *.* p
+    doRotate p          =   rotateV (0 - _cameraRot w) p
+    doWindowScale (x,y) =   ( x * 2 / _windowX w
+                            , y * 2 / _windowY w
+                            )
+
 mouseWorldPos :: World -> Point2
 mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
 

src/Dodge/Data.hs

@@ -74,9 +74,12 @@ data World = World
     , _storedLevel          :: Maybe World
     , _menuState            :: MenuState
     , _worldState           :: M.Map WorldState Bool
-                , _windowX          :: Float
+    , _windowX              :: !Float
-                , _windowY          :: Float
+    , _windowY              :: !Float
-                , _mapDisplay       :: (Bool, Float)
+    , _carteDisplay         :: !Bool
+    , _carteCenter          :: !Point2
+    , _carteZoom            :: !Float
+    , _carteRot             :: !Float
     , _lightSources         :: !(IM.IntMap LightSource)
     , _tempLightSources     :: ![TempLightSource]
     , _closeActiveObjects   :: [Either FloorItem Button]

src/Dodge/Event.hs

@@ -56,8 +56,8 @@ handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos
 handlePressedMouseButton _ w = Just w
 
 wheelUpEvent :: World -> World
-wheelUpEvent w = case _mapDisplay w of
+wheelUpEvent w = case _carteDisplay w of
-    (True,z)        -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z))
+    True            -> w & carteZoom .~ min 0.5 (z+(0.1*z))
     _ | rbPressed   -> fromMaybe (closeObjScrollUp w) 
                             $ (yourItem w ^? itScrollUp) 
                                 <*> pure (_crInvSel (you w))
@@ -68,18 +68,21 @@ wheelUpEvent w = case _mapDisplay w of
     lbPressed = ButtonLeft `S.member` mbs
     rbPressed = ButtonRight `S.member` mbs
     mbs = _mouseButtons w
+    z = _carteZoom w
 wheelDownEvent :: World -> World
-wheelDownEvent w = case _mapDisplay w of
+wheelDownEvent w = case _carteDisplay w of
-    (True,z)        -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z))
+    True            -> w & carteZoom .~ max 0.05 (z-(0.1*z))
     _ | rbPressed   -> fromMaybe (closeObjScrollDown w)
                             $ (yourItem w ^? itScrollDown) 
                                 <*> pure (_crInvSel (you w))
                                 <*> pure w
       | lbPressed   -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
       | otherwise   -> downInvPos w
-  where lbPressed = ButtonLeft `S.member` mbs
+  where 
+    lbPressed = ButtonLeft `S.member` mbs
     rbPressed = ButtonRight `S.member` mbs
     mbs = _mouseButtons w
+    z = _carteZoom w
 
 upInvPos :: World -> World
 upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w

src/Dodge/Event/Keyboard.hs

@@ -47,8 +47,8 @@ testEvent w = w
 pauseGame :: World -> World
 pauseGame w = w {_menuState = PauseMenu}
 
-toggleMap w = w & mapDisplay . _1 %~ not
+toggleMap w = w & carteDisplay %~ not
-escapeMap w = w & mapDisplay . _1 .~ False
+escapeMap w = w & carteDisplay .~ False
 
 -- Basic key remapping for a dvorak key layout
 keyremap :: Keycode -> Keycode 

src/Dodge/Prototypes.hs

@@ -204,7 +204,6 @@ basicWorld = World
     , _pressPlates = IM.empty
     , _buttons = IM.empty
     , _soundQueue = []
---    , _loadedSounds = IM.empty
     , _sounds = M.empty
     , _corpses = IM.empty
     , _decorations = IM.empty
@@ -219,12 +218,17 @@ basicWorld = World
     , _pathInc = M.empty
     , _windowX = 800
     , _windowY = 840
-    , _mapDisplay = (False, 0.2)
+    , _carteDisplay = False
+    , _carteCenter = (0,0)
+    , _carteZoom = 0.5
+    , _carteRot  = 0
     , _lightSources = IM.empty
     , _tempLightSources = [youLight]
     , _closeActiveObjects = []
-    , _seenLocations        = IM.fromList [(0, (_crPos . you, "YOURPOS"))]
+    , _seenLocations        = IM.fromList 
---    , _remap = keyremapDefault
+        [(0, (_crPos . you, "CURRENT POSITION"))
+        ,(1, (const (0,0) , "START POSITION"))
+        ]
     }
 youLight = 
 --    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 

src/Dodge/Rendering.hs

@@ -26,8 +26,8 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 
 worldPictures :: World -> Picture
-worldPictures w
+worldPictures w = pictures $ concat 
-    = pictures $ concat [ IM.elems $ _decorations w 
+    [ IM.elems $ _decorations w 
     , map _ptPict  . IM.elems $ _projectiles w
     , map drawItem . IM.elems $ _floorItems w
     , map crDraw   . IM.elems $ _creatures w
@@ -36,33 +36,15 @@ worldPictures w
     , map (\pt -> _ptDraw pt pt) $ _particles' w
     , map drawWallFloor (wallFloorsToDraw w)
     , testPic w
-                        , mapOverlay w
     ]
 
 fixedCoordPictures :: World -> Picture
 fixedCoordPictures w = pictures
-             [ scaler $ hudDrawings w
+    [ hudDrawings w
     , scaler . onLayer MenuLayer $ menuScreen w
-             , setDepth (-1) $ closeObjectTexts w
     ]
-    where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
-
-mapOverlay :: World -> [Picture]
-mapOverlay w = case _mapDisplay w of
-    (True,mapZoom) -> (setLayer 1 . setDepth (-1) . color (withAlpha 0.5 black) 
-                                    . polygon $ screenPolygon w)
-                        :
-                        (map ( setLayer 1 . setDepth (-1) . doZoom ) 
-                        . mapMaybe mapWall 
-                        . IM.elems 
-                        $ _walls w
-                        )
   where 
-        doZoom = uncurry translate (_cameraPos w) 
+    scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
-                    . scale zoom zoom 
-                    . uncurry translate ((0,0) -.- _cameraPos w)
-        zoom = 2 * mapZoom / _cameraZoom w
-    _           -> []
 
 testPic :: World -> [Picture]
 testPic w = [blank]
@@ -78,17 +60,6 @@ clDraw :: Cloud -> Picture
 clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
 
 
-mapWall :: Wall -> Maybe Picture
-mapWall wl =
-    case _wlSeen wl of
-        False -> Nothing
-        True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-    where t = 5 *.* errorNormalizeV 68 (y -.- x)
-          n = vNormal t
-          n2 = 4 *.* n
-          (x:y:_) = _wlLine wl
-          c = _wlColor wl
-
 wallFloorsToDraw :: World -> [Wall]
 wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
     where onScreen wall = lineOnScreen w (_wlLine wall)

src/Dodge/Rendering/HUD.hs

@@ -14,38 +14,40 @@ import qualified Data.IntMap as IM
 import Control.Lens
 
 hudDrawings :: World -> Picture
-hudDrawings w = case _mapDisplay w of
+hudDrawings w = setLayer 1 . setDepth (-1) . pictures $
-    (True,_) -> drawLocations w
+    [ scaler . dShadCol white $ displayHP 0 w
-    _        -> drawInventory w
+    , scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
-
-drawInventory :: World -> Picture
-drawInventory w =
-    setLayer 1 $ (onLayer InvLayer) 
-                        $ pictures
-                          [ displayInv 0 w
-                          , dShadCol white $ displayHP 0 w
-                          , drawCursor (itCol (yourItem w)) w
-                          , translate (-390) 20 
-                                $ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
     ] 
-    where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
+    ++ selectionText
+  where
+    selectionText = if   _carteDisplay w
+                    then drawLocations w
+                    else drawInventory w
+    scaler = scale (2 / _windowX w) (2 / _windowY w)
 
-drawLocations w = displayListTopLeft locs w
+drawInventory :: World -> [Picture]
-    where locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
+drawInventory w = 
+    [ closeObjectTexts w
+    , scaler $ drawCursor (itCol (yourItem w)) w 
+    ]
+    ++ displayInv 0 w
+  where 
+    itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
+    scaler = scale (2 / _windowX w) (2 / _windowY w)
 
-displayListTopLeft :: [(String,Color)] -> World -> Picture
+displayListTopLeft :: [(String,Color)] -> World -> [Picture]
-displayListTopLeft scols w = pictures $ zipWith (translate (15-halfWidth w))
+displayListTopLeft scols w = 
+    map scaler $ zipWith 
+        (translate (15-halfWidth w))
         ( map (\x -> halfHeight w - (20 * (fromIntegral x+1)))    [0..] )
         ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
+  where
+    scaler = scale (2 / _windowX w) (2 / _windowY w)
 
-displayInv :: Int -> World -> Picture
+displayInv :: Int -> World -> [Picture]
 displayInv n w = displayListTopLeft scols w
-    where scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
+  where 
-
+    scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
---displayInv :: Int -> World -> Picture
---displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 
---                         (map (\x-> halfHeight w-(20*(fromIntegral x+1))) ns) $ map dItem' is
---     where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
 
 itemStringCol :: Item -> (String,Color)
 itemStringCol NoItem    = ("----", greyN 0.5)
@@ -55,6 +57,57 @@ dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"
 dItem' i = scale 0.1 0.1 $ dShadCol (_itInvColor i) t
     where t = text $ _itInvDisplay i i
 
+drawLocations :: World -> [Picture]
+drawLocations w = displayListTopLeft locs w
+    ++ zipWith bFunc (displayListEndCoords w locTexts) locPoss
+    ++ mapOverlay w
+  where
+    locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
+    locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w
+    zoom = _carteZoom w
+    locTexts = fst . unzip $ locs
+    bFunc (x,y) (z,w) = pictures 
+        --[ bezierQuad (withAlpha 0.2 white) (withAlpha 0.2 white) 0.01  0.01  (x,y) (0,y) (z,w)
+        --, bezierQuad (withAlpha 0.5 white) (withAlpha 0.5 white) 0.005 0.005 (x,y) (0,y) (z,w)
+        --, bezierQuad (withAlpha 0.5 white) (withAlpha 0.5 white) 0.002 0.002 (x,y) (0,y) (z,w)
+        [ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w)
+        , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
+        , bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w)
+        ] --cheapo antialiasing
+
+displayListCoords :: World -> [Point2]
+displayListCoords w = map (g . f) [1..]
+  where 
+    f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
+    g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
+
+displayListEndCoords :: World -> [String] -> [Point2]
+displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
+  where 
+    f :: Int -> Point2
+    f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
+    g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
+    h :: String -> Point2 -> Point2
+    h s (x,y) = (x + 9 * fromIntegral (length s), y)
+
+--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
+
+mapOverlay :: World -> [Picture]
+mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) : 
+            (mapMaybe (mapWall w) . IM.elems $ _walls w)
+
+mapWall :: World -> Wall -> Maybe Picture
+mapWall w wl =
+    if _wlSeen wl
+    then Just . color c . polygon $ map (cartePosToScreen w) [x,x +.+ n2,y +.+ n2, y]
+    else Nothing
+  where 
+    t = normalizeV (y -.- x)
+    n2 = 20 *.* vNormal t
+    (x:y:_) = (_wlLine wl)
+    c = _wlColor wl
+
+
 closeObjectTexts :: World -> Picture
 closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w)
                                 ++ maybeToList maybeLine
@@ -80,13 +133,7 @@ closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _cl
           xtran _ = 0
           objPos obj = case obj of Left flit -> _flItPos flit
                                    Right bt  -> _btPos bt
-          mayScreenPos = mayObj >>= (\theObj -> 
+          mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
-                                        Just (sc $ rotateV (0 - _cameraRot w) 
-                                                          $ _cameraZoom w *.* (objPos theObj 
-                                                                                 -.- _cameraPos w
-                                                                              )
-                                             )
-                                    )
           sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
           maybeLine = do 
                 itScreenPos <- mayScreenPos