diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 360d92a11..04d628850 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -33,7 +33,7 @@ generateLevelFromRoomList gr' w . placeWires . doPartialPlacements . doExtendedPlacements - . flip (mapAccumR doRoomPlacements) rs + . flip (mapAccumR doRoomPlacements) rs' $ w { _walls = wallsFromRooms rs , _floorTiles = floorsFromRooms rs , _gameRooms = gameRoomsFromRooms rs @@ -43,9 +43,9 @@ generateLevelFromRoomList gr' w where path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs - rs = zipWith addTile zs gr zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w - gr = map doRoomShift gr' + rs = map doRoomShift rs' + rs' = zipWith addTile zs gr' placeWires :: (World,[Room])-> World placeWires (w,rms) = foldr placeRoomWires w rms diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 146d1a702..82a6fe574 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -16,11 +16,10 @@ import Data.List (delete) import Data.Bifunctor import Control.Lens hiding (Empty, (<|) , (|>)) -positionRooms :: Tree RoomInt -> IO (Maybe [Room]) -positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty - type RoomInt = (Room,Int) +positionRooms :: Tree RoomInt -> IO (Maybe [Room]) +positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty posRms :: [ConvexPoly] -> RoomInt @@ -50,8 +49,8 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) , i) - shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t - shiftedt'@(Node (r'',_) _) = applyToRoot (first $ shiftRoomShiftToLink l) t + (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t + shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l) t lnkEff :: (Point2,Float) -> Room -> Room lnkEff x rm = case _rmLinkEff rm of diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 721574c1b..373333950 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -49,11 +49,6 @@ placeSpot (w,rm) plmnt = case plmnt of where shift = _rmShift rm -invShiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot -invShiftPSBy (pos,rot) (PS p r) = PS (invShiftPointBy (pos,rot) p) (r - rot) -invShiftPSBy _ ps = ps - - -- this should be tidied up placeSpotUsingLink :: World -> Room -> Placement -> (RoomPos -> Maybe PlacementSpot) @@ -67,7 +62,7 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r Just plmnt' -> placeSpot (w,rm) plmnt' where searchedPoss [] = error "no correct pos type for lnk placement" - searchedPoss (pos:poss) = case extract (invShiftPosBy (_rmShift rm) pos) of + searchedPoss (pos:poss) = case extract pos of Nothing -> second (pos:) <$> searchedPoss poss Just ps -> Just ( ps,pos, poss) @@ -135,17 +130,6 @@ shiftPointBy (pos,rot) p = pos +.+ rotateV rot p invShiftPointBy :: (Point2,Float) -> Point2 -> Point2 invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1 -invShiftPosBy :: (Point2,Float) -> RoomPos -> RoomPos -invShiftPosBy s rp = case rp of - OutLink i p a -> uncurry (OutLink i) $ invShiftLinkBy s (p,a) - InLink p a -> uncurry (InLink) $ invShiftLinkBy s (p,a) - UnusedLink p a -> uncurry (UnusedLink) $ invShiftLinkBy s (p,a) - PosPl p a -> uncurry (PosPl) $ invShiftLinkBy s (p,a) - LabPos i rp' -> LabPos i $ invShiftPosBy s rp' - -invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) -invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) - shiftPoint3By :: (Point2,Float) -> Point3 -> Point3 shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y) diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index ac385cb07..600e89a71 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -8,15 +8,11 @@ import Dodge.LevelGen.Data import Dodge.Default import Dodge.LevelGen.Switch import Dodge.Placements.LightSource -import Dodge.Placements.Spot import Data.Maybe import Control.Lens externalButton :: Color -> PlacementSpot -> Placement ---externalButton col ps = pContID ps (PutTrigger (const False)) --- $ \trigid -> Just $ pContID ps (PutButton (makeSwitch col col (oneff trigid) (offeff trigid))) --- (const Nothing) externalButton col ps = plCont ps (PutTrigger (const False)) $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) (const Nothing) @@ -38,7 +34,7 @@ putLitButtonID col p a subpl = mntLSOn aShape (Just col) ls p'' (addZ 40 p') putLitButOnPos :: Color -> (RoomPos -> Maybe PlacementSpot) -> (Int -> Maybe Placement) -> Placement putLitButOnPos col f subpl - = updatePSToLevel 1 (const thePS) $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) + = plSpot .~ thePS $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $ \plmnt -> let lsid = fromJust $ _plMID plmnt in jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = V2 0 (-1), _btRot = pi}) subpl <&> plSpot .~ _plSpot plmnt diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs index 480dcf46b..25b36c680 100644 --- a/src/Dodge/Placements/LightSource.hs +++ b/src/Dodge/Placements/LightSource.hs @@ -3,7 +3,6 @@ import Dodge.Data import Dodge.LightSources.Lamp import Dodge.LevelGen.Data import Dodge.Room.Foreground -import Dodge.Placements.Spot import Geometry import Geometry.Vector3D import Dodge.Creature.Inanimate @@ -13,6 +12,8 @@ import Dodge.RandomHelp import Color import Shape +import Control.Lens + -- | mount a light source on a shape mntLSOn :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape @@ -80,8 +81,9 @@ mntLS :: (Point2 -> Point3 -> Shape) -> Point2 -> Point3 -> Placement mntLS shp wallp lampp = mntLSOn shp Nothing defaultLS wallp lampp (const Nothing) mntLSCond :: (Point2 -> Point3 -> Shape) -> (RoomPos -> Maybe PlacementSpot) -> Placement -mntLSCond shp shift = updatePSToLevel 2 (const $ PSLnk shift (const id) Nothing) - $ mntLS shp 0 (V3 0 (-40) 90) +mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ + mntLS shp 0 (V3 0 (-40) 90) + & plSpot .~ PSLnk shift (const id) Nothing -- note that this perhaps pushes the vshape light out too far mntLight :: Point2 -> Point2 -> Placement diff --git a/src/Dodge/Placements/Spot.hs b/src/Dodge/Placements/Spot.hs deleted file mode 100644 index 822172f2f..000000000 --- a/src/Dodge/Placements/Spot.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Dodge.Placements.Spot - ( setPS - , setLocalPS - , updatePS - , updatePSToLevel - ) where -import Dodge.LevelGen.Data - -setPS :: PlacementSpot -> Placement -> Placement -setPS = updatePS . const - --- TODO remove this, use previous placement spots in continued placements --- instead -updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement -updatePSToLevel 0 _ plmnt = plmnt -updatePSToLevel i f plmnt = case plmnt of - PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl) - Placement ps pt mi pl -> Placement (f ps) pt mi (fmap (fmap (updatePSToLevel (i-1) f)) pl) - RandomPlacement rplmnt -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt - -setLocalPS :: PlacementSpot -> Placement -> Placement -setLocalPS ps (Placement _ pt mi f) = Placement ps pt mi f -setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) rplmnt) -setLocalPS _ plmnt = plmnt - -updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement -updatePS f pl' = case pl' of - Placement ps pt mi ipl -> Placement (f ps) pt mi $ (fmap . fmap $ updatePS f) ipl - PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePS f) pl) - RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl) diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 0f704500a..d6d35b1c4 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -28,7 +28,7 @@ startRoom = do h <- state $ randomR (200,400) let plmnts = [ sPS (V2 0 0) 0 $ PutForeground $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2)) - , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70) + --, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70) , tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120