Move towards serializing saves/loads faster

2022-08-19 11:12:43 +01:00
parent c74d3b04bf
commit 9df0fa8692
38 changed files with 542 additions and 384 deletions
@@ -6,6 +6,7 @@ import Data.Maybe
 import Dodge.Data.Universe
 import Geometry
 import qualified IntMapHelp as IM
+import Control.Lens

 lightsToRender :: Configuration -> World -> [(Point3, Float, Point3)]
 lightsToRender cfig w =
@@ -14,8 +15,8 @@ lightsToRender cfig w =
  where
    getLS = getlsparam . _lsParam
    getTLS = getlsparam . _tlsParam
-    cbox = _boundBox (_cWorld w)
-    cpos = _cameraCenter (_cWorld w)
+    cbox = w ^. cWorld . cwCam . cwcBoundBox
+    cpos = w ^. cWorld . cwCam . cwcCenter
    getlsparam ls
        | not (pointInPolygon lpos cbox) && extraculltest = Nothing
        | otherwise = Just (_lsPos ls, rad ^ (2 :: Int), _lsCol ls)
@@ -59,6 +59,29 @@ listCursorNESW = listCursorChooseBorder [True, True, True, True]
 listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture
 listCursorNSW = listCursorChooseBorder [True, False, True, True]

+fillScreenText :: Configuration -> String -> Picture
+fillScreenText cfig str =
+    winScale cfig
+        . scale wscale hscale
+        . centerText
+        $ str
+  where
+    wscale = hw*0.02/fromIntegral (length str)
+    hscale = hh*0.01
+    hw = halfWidth cfig
+    hh = halfHeight cfig
+
+
+fillWidthText :: Configuration -> String -> Picture
+fillWidthText cfig str =
+    winScale cfig
+        . scale thescale thescale
+        . centerText
+        $ str
+  where
+    thescale = hw*0.02/fromIntegral (length str)
+    hw = halfWidth cfig
+
 listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture
 listTextPictureAt xoff yoff cfig yint =
    winScale cfig
@@ -64,7 +64,7 @@ drawOptions u title ops off footer =
        , drawFooterText cfig red footer
        ]
            ++ zipWith
-                (\s vpos -> placeString (- hw + 50) vpos 0.2 s)
+                (\s vpos -> placeColorString (- hw + 50) vpos 0.2 s)
                ops''
                [hh -100, hh -150 ..]
  where
@@ -77,7 +77,7 @@ drawOptions u title ops off footer =
        x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops)
        _ -> visibleops
    ops'' = case availableMenuLines cfig of
-        x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ ["SPACE: MORE OPTIONS"]
+        x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ [(white,"SPACE: MORE OPTIONS")]
        _ -> map (menuOptionToString u maxOptionLength) ops'
    visibleops = filter notInvisible ops
    notInvisible InvisibleToggle{} = False
@@ -88,8 +88,8 @@ drawOptions u title ops off footer =

 optionValueOffset :: Universe -> MenuOption -> Int
 optionValueOffset u mo = case _moString mo u of
-    Left _ -> 0
-    Right (s, _) -> length s
+    MODStringOption s _ -> length s
+    _ -> 0

 darkenBackground :: Configuration -> Picture
 darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox
@@ -111,18 +111,32 @@ placeString ::
    Picture
 placeString x y sc = color white . translate x y . scale sc sc . text

+placeColorString ::
+    -- | x distance from center
+    Float ->
+    -- | y distance from center
+    Float ->
+    -- | scale
+    Float ->
+    (Color,String) ->
+    Picture
+placeColorString x y sc (col,str) = color col . translate x y . scale sc sc . text $ str
+
 drawFooterText :: Configuration -> Color -> String -> Picture
 drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1
  where
    hh = halfHeight cfig
    hw = halfWidth cfig

-menuOptionToString :: Universe -> Int -> MenuOption -> String
-menuOptionToString w padAmount mo = theKeys ++ optionText
+menuOptionToString :: Universe -> Int -> MenuOption -> (Color,String)
+menuOptionToString w padAmount mo = (thecol,theKeys ++ optionText)
  where
+    thecol = case _moString mo w of
+        MODBlockedString {} -> greyN 0.5
+        _ -> white
    optionText = case _moString mo w of
-        Left s -> s
-        Right (s, t) -> rightPad padAmount '.' s ++ t
+        MODStringOption s t -> rightPad padAmount '.' s ++ t
+        x -> _modString x
    theKeys = case mo of
        Toggle{_moKey = k} -> stc k : ":"
        Toggle2{_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":"
@@ -0,0 +1,14 @@
+module Dodge.Render.Outline
+    where
+import Picture
+
+hackOutline :: Color -> Float -> Picture -> Picture
+hackOutline col x pic = pictures 
+    (map (color col)
+    [ translate x 0 pic
+    , translate (-x) 0 pic
+    , translate 0 x pic
+    , translate 0 (-x) pic
+    ]
+    ) <> pic
+
@@ -2,6 +2,7 @@ module Dodge.Render.Picture (
    fixedCoordPictures,
 ) where

+import Control.Lens
 import Dodge.Base.WinScale
 import Dodge.Base.Window
 import Dodge.Data.Universe
@@ -10,7 +11,6 @@ import Dodge.Render.List
 import Dodge.Render.MenuScreen
 import Geometry
 import Picture
-import Control.Lens

 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
@@ -27,16 +27,18 @@ fixedCoordPictures u =

 drawConcurrentMessage :: Universe -> Picture
 drawConcurrentMessage u = case u ^. uvConcEffects of
-    BlockingConcEffect str -> listPicturesAt
-        (halfWidth cfig)
-        (halfHeight cfig)
-        cfig
-        [text str]
-    BackgroundConcEffect str -> listPicturesAt
-        (halfWidth cfig)
-        (_windowY cfig - 50)
-        cfig
-        [text str]
+    BlockingConcEffect str -> fillWidthText cfig str
+    --listPicturesAt
+    --(halfWidth cfig)
+    --(halfHeight cfig)
+    --cfig
+    --[centerText str]
+    BackgroundConcEffect str ->
+        listPicturesAt
+            (halfWidth cfig)
+            (_windowY cfig - 50)
+            cfig
+            [centerText str]
    _ -> mempty
  where
    cfig = _uvConfig u
@@ -118,8 +118,8 @@ shiftDraw' fpos fdir fdraw x =

 cullPoint :: Configuration -> World -> Point2 -> Bool
 cullPoint cfig w p
-    | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox (_cWorld w))
-    | otherwise = dist (_cameraCenter (_cWorld w)) p < _viewDistance (_cWorld w)
+    | debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . cwCam . cwcBoundBox)
+    | otherwise = dist (w ^. cWorld . cwCam . cwcCenter) p < (w ^. cWorld . cwCam . cwcViewDistance)

 extraPics :: Configuration -> World -> Picture
 extraPics cfig w =
@@ -277,7 +277,7 @@ drawFarWallDetect w =
            )
        $ runIdentity $ S.toList_ $ streamViewpoints p w
  where
-    p = _cameraViewFrom (_cWorld w)
+    p = w ^. cWorld . cwCam . cwcViewFrom

 drawDDATest :: World -> Picture
 drawDDATest w =
@@ -288,7 +288,7 @@ drawDDATest w =
        --        <> color blue (runIdentity (S.foldMap_ drawCross qs'))
        <> setLayer DebugLayer (color yellow (line [cvf, mwp]))
  where
-    cvf = _cameraViewFrom (_cWorld w)
+    cvf = w ^. cWorld . cwCam . cwcViewFrom
    mwp = mouseWorldPos w
    --ps = ddaStreamX 50 cvf mwp
    ps = zoneOfSeg' 50 cvf mwp
@@ -315,15 +315,23 @@ drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
        setLayer DebugLayer $
            color yellow $
                uncurryV translate p (circle 5)
-                    <> line [_cameraViewFrom (_cWorld w), p]
+                    <> line [w ^. cWorld . cwCam . cwcViewFrom , p]

 testPic :: Configuration -> World -> Picture
 testPic _ _ = mempty
+--testPic cfig _ = setLayer FixedCoordLayer $ listPicturesAt 100 100 cfig $ map centerText
+--    ["A"
+--    ,"AA"
+--    ,"AAA"
+--    ,"AAAA"
+--    ,"AAAAA"
+--    ,"AAAAAA"
+--    ]

 drawBoundingBox :: World -> Picture
 drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
  where
-    (x : xs) = _boundBox (_cWorld w)
+    (x : xs) = w ^. cWorld . cwCam . cwcBoundBox

 clDraw :: Cloud -> Picture
 clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
@@ -351,7 +359,7 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
  where
    p = _soundPos s
    thePic =
-        rotate (_cameraRot (_cWorld w))
+        rotate (w ^. cWorld . cwCam . cwcRot)
            . scale theScale theScale
            . centerText
            . soundToOnomato