Improve scroll selection/inventory modification

2026-03-24 19:21:04 +00:00
parent 5b297643db
commit 8ff2f37af5
16 changed files with 532 additions and 432 deletions
@@ -1,4 +1,8 @@
-module Dodge.Placement.Instance.Button where
+module Dodge.Placement.Instance.Button (
+    putLitButOnPos,
+    extTrigLitPos,
+    putLitButOnPosExtTrig,
+) where

 import Color
 import Control.Lens
@@ -8,54 +12,54 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Dodge.LightSource
 import Dodge.Placement.Instance.LightSource
-import Dodge.PlacementSpot
+--import Dodge.PlacementSpot
 import Geometry
 import Shape

-triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp ->
-        Just $
-            pContID
-                ps
-                ( PutButton
-                    ( makeSwitch
-                        c1
-                        c2
-                        (SetTrigger True $ trigid tp)
-                        (SetTrigger False $ trigid tp)
-                    )
-                )
-                (const Nothing)
-  where
-    trigid tp = fromJust $ _plMID tp
+--triggerSwitchSPic :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPic c1 c2 ps = psPtCont ps (PutTrigger False) $
+--    \tp ->
+--        Just $
+--            pContID
+--                ps
+--                ( PutButton
+--                    ( makeSwitch
+--                        c1
+--                        c2
+--                        (SetTrigger True $ trigid tp)
+--                        (SetTrigger False $ trigid tp)
+--                    )
+--                )
+--                (const Nothing)
+--  where
+--    trigid tp = fromJust $ _plMID tp
+--
+--triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
+--triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
+--    \tp -> Just $
+--        pContID atFstLnkOut (PutLS thels) $
+--            \lsid ->
+--                Just $
+--                    pContID
+--                        ps
+--                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
+--                        (const Nothing)
+--  where
+--    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
+--    trigid tp = fromJust $ _plMID tp
+--    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
+--    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]

-triggerSwitchSPicLight :: Color -> Color -> PlacementSpot -> Placement
-triggerSwitchSPicLight c1 c2 ps = psPtCont ps (PutTrigger False) $
-    \tp -> Just $
-        pContID atFstLnkOut (PutLS thels) $
-            \lsid ->
-                Just $
-                    pContID
-                        ps
-                        (PutButton (makeSwitch c1 c2 (oneff lsid $ trigid tp) (offeff lsid $ trigid tp)))
-                        (const Nothing)
-  where
-    thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75
-    trigid tp = fromJust $ _plMID tp
-    oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid]
-    offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid]
-
-triggerSwitch :: Color -> PlacementSpot -> Placement
-triggerSwitch col ps = psPtCont ps (PutTrigger False) $
-    \tp ->
-        Just $
-            pContID
-                ps
-                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
-                (const Nothing)
-  where
-    trigid tp = fromJust $ _plMID tp
+--triggerSwitch :: Color -> PlacementSpot -> Placement
+--triggerSwitch col ps = psPtCont ps (PutTrigger False) $
+--    \tp ->
+--        Just $
+--            pContID
+--                ps
+--                (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) (SetTrigger False $ trigid tp)))
+--                (const Nothing)
+--  where
+--    trigid tp = fromJust $ _plMID tp

 putLitButOnPos :: Color -> PlacementSpot -> (Placement -> Maybe Placement) -> Placement
 putLitButOnPos col theps subpl =
@@ -45,7 +45,7 @@ mntLSOn shapeF ls wallp lsp@(V3 lx ly _) =
    ps0jPushPS (PutLabel "light") .
    ps0jPushPS (putShape $ shapeF wallp lsp)
    --ps0j (PutLabel "light") .
-    --ps0j (putShape . setCol $ shapeF wallp lsp)
+    --ps0j (putShape $ shapeF wallp lsp)
        . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
  where
    lsp' = lsp -.-.- V3 x y 1
@@ -96,38 +96,17 @@ aShape wallpos (V3 x y z) = girder (z + 2) 20 10 pout wallpos
    pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)

 vShape :: Point2 -> Point3 -> Shape
-vShape wallpos (V3 x y z) =
-    thinHighBar z wallposUp lxy
-        <> thinHighBar z wallposDown lxy
+vShape p (V3 x y z) = abar n <> abar (-n)
  where
+    abar a = thinHighBar z (p + a) lxy
    lxy = V2 x y
-    n = vNormal (wallpos -.- lxy)
-    wallposUp = wallpos +.+ n
-    wallposDown = wallpos -.- n
+    n = vNormal (p - lxy)

 mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement
 mntLS shp wallp lampp = mntLSOn shp defaultLS wallp lampp (const Nothing)
  where
    defaultLS = LS 0 $ LSParam 0 300 0.6

--mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing)
--  where
--    defaultLS = LS 0 $ LSParam 0 200 0.6
-
--mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement
--mntLSLampCol shp (V4 x y z _) wallp lampp =
--    mntLSOn
--        shp
--        Nothing
--        (defaultLS & lsParam . lsCol .~ col)
--        wallp
--        lampp
--        (const Nothing)
--  where
--    col = V3 x y z
--    defaultLS = LS 0 $ LSParam 0 200 0.6
-
 mntLSCond ::
    (Point2 -> Point3 -> Shape) ->
    --    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
@@ -92,7 +92,6 @@ placeSpotRoomRand ::
 placeSpotRoomRand rid i f plmnt w =
    let (ps, g) =
            runState
-                -- (_rmRandPSs (w ^?! genRooms . ix rid) !! i)
                (w ^?! genRooms . ix rid . rmRandPSs . ix i)
                $ w ^. gwWorld . randGen
     in placeSpot rid (w & gwWorld . randGen .~ g) (plmnt & plSpot .~ f ps)
@@ -143,11 +142,11 @@ placeSpotID rid ps pt w = case pt of
    PutChasm ps' qs ->
        ( 0
        , placeChasm
-            w
            rid
            ps'
            (map (map doShift) ps')
            (foldMap (loopPairs . map doShift) qs)
+            w
        )
    PutLabel{} -> (0, w)
  where
@@ -156,13 +155,12 @@ placeSpotID rid ps pt w = case pt of
    doShift = shiftPointBy (p, rot)
    pashift = compP2A (p, rot)

-placeChasm :: GenWorld -> Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld
-placeChasm gw rid ps shiftps cfs =
-    gw
-        & gwWorld . cWorld . chasms <>~ shiftps
-        & gwWorld . cWorld . cliffs <>~ cfs
-        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps)
-        & gwWorld %~ f
+placeChasm :: Int -> [[Point2]] -> [[Point2]] -> [(Point2, Point2)] -> GenWorld -> GenWorld
+placeChasm rid ps shiftps cfs =
+    (gwWorld . cWorld . chasms <>~ shiftps)
+        . (gwWorld . cWorld . cliffs <>~ cfs)
+        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
+        . (gwWorld %~ f)
  where
    -- f w = foldl' g w (loopPairs shiftps)
    f w = foldl' g w cfs
@@ -201,9 +199,14 @@ plMachine ::
 plMachine wallpoly mc mitm p rot gw =
    ( mcid
    , gw
-        & tolw . machines . at mcid ?~ themc
-        & gwWorld %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
-        & tolw %~ maybe id placeturretitm mitm
+        & tolw
+        . machines
+        . at mcid
+        ?~ themc
+        & gwWorld
+        %~ placeMachineWalls (_mcMaterial mc) wallpoly mcid wlid
+        & tolw
+        %~ maybe id placeturretitm mitm
    )
  where
    tolw = gwWorld . cWorld . lWorld
@@ -221,9 +224,13 @@ plMachine wallpoly mc mitm p rot gw =
 placeMachineWalls :: Material -> [Point2] -> Int -> Int -> World -> World
 placeMachineWalls mat poly mcid = insertStructureWalls MachinePart baseWall poly mcid
  where
-    baseWall = defaultMachineWall 
-        & wlStructure . wsMachine .~ mcid
-        & wlMaterial .~ mat
+    baseWall =
+        defaultMachineWall
+            & wlStructure
+            . wsMachine
+            .~ mcid
+            & wlMaterial
+            .~ mat

 mvLS :: Point2 -> Float -> LightSource -> LightSource
 mvLS x rot = lsParam . lsPos . _xy %~ ((+ x) . rotateV rot)