diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index bee14747c..09cef2ffa 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -41,6 +41,9 @@ data DebugBool | Bound_box_screen | Show_wall_search_rays | Show_dda_test + | Show_far_wall_detect + | Show_select + | Inspect_wall deriving (Generic, Eq,Ord,Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes deriving (Generic, Show, Eq, Ord, Enum, Bounded) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index a788622d2..26684284d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -169,9 +169,9 @@ data World = World , _genRooms :: IM.IntMap Room , _deathDelay :: Maybe Int , _testFloat :: Float + , _wSelect :: (Point2,Point2) } - newtype GenParams = GenParams { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape) } @@ -1405,6 +1405,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutDoor Color (World -> Bool) [(Point2,Point2)] | RandPS (State StdGen PSType) | PutShape Shape + | PutForeground ForegroundShape | PutWorldUpdate (PlacementSpot -> World -> World) | PutNothing | PutUsingGenParams (World -> (World,PSType)) diff --git a/src/Dodge/Data/ForegroundShape.hs b/src/Dodge/Data/ForegroundShape.hs index 74c2527eb..622e82eca 100644 --- a/src/Dodge/Data/ForegroundShape.hs +++ b/src/Dodge/Data/ForegroundShape.hs @@ -9,7 +9,7 @@ data ForegroundShape = ForegroundShape { _fsID :: Int , _fsPos :: Point2 , _fsDir :: Float - , _fsRad :: Float + , _fsRad :: Float -- This should probably be a bounding box , _fsSPic :: SPic } deriving (Eq,Show,Ord) diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 484eca525..81bb3400d 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -110,6 +110,7 @@ defaultWorld = World , _testFloat = 0 , _boundBox = square 100 , _boundDist = (100,-100,100,-100) + , _wSelect = (0,0) } youLight :: TempLightSource youLight = TLS diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 83078b91a..68b265e86 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -41,10 +41,10 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom - , AnRoom slowDoorRoom - , AnRoom $ roomCCrits 10 - , AnTree firstBreather - , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward +-- , AnRoom slowDoorRoom +-- , AnRoom $ roomCCrits 10 +-- , AnTree firstBreather +-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward ] extraAnoList :: [Annotation] diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 39e41c9e5..bc9c5530e 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -41,6 +41,6 @@ initialWorld = defaultWorld } testStringInit :: Configuration -> World -> [String] -testStringInit _ _ = mempty +testStringInit _ w = [show $ _boundDist w] --testStringInit = map (show . _drStatus) . IM.elems . _doors --testStringInit = const . const [] diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 14cd85230..33e93f1b0 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -96,6 +96,7 @@ placeSpotID ps pt w = case pt of PutTerminal tm -> plNewUpID terminals tmID tm w PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w + PutForeground fs -> plNewUpID shapes fsID (mvFS p rot fs) w PutMachine pps mc -> plMachine (map doShift pps) mc p rot w PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w @@ -172,6 +173,9 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot} mvCr :: Point2 -> Float -> Creature -> Creature mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} +mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape +mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a )) + plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World) plMachine wallpoly mc p rot gw = (mcid , gw & machines %~ addMc diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index e3883d4cc..7732851ff 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -7,6 +7,7 @@ import Dodge.Render.InfoBox import Dodge.Debug.Picture import Dodge.Picture.SizeInvariant import Dodge.Data +import Dodge.Zone import Dodge.Base --import Dodge.Base.Window import Dodge.SoundLogic.LoadSound @@ -14,6 +15,7 @@ import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera import Dodge.Item.Draw +import Dodge.Wall.Zone --import Dodge.Zone import Geometry import Geometry.Zone @@ -34,9 +36,11 @@ import qualified Streaming.Prelude as S worldSPic :: Configuration -> World -> SPic worldSPic cfig w = (extraShapes w, extraPics cfig w) + --(mempty, extraPics cfig w) <> foldMap (dbArg _prDraw) (filtOn _prPos _props) <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks) <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes) +-- <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w) <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses) <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures) <> foldMap floorItemSPic (filtOn _flItPos _floorItems) @@ -51,7 +55,6 @@ shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x) . rotateSP (fdir x) $ fdraw x x - cullPoint :: Configuration -> World -> Point2 -> Bool cullPoint cfig w p | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w) @@ -72,20 +75,55 @@ extraPics cfig w = pictures (_decorations w) <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) <> soundPics cfig w - <> viewBoundaries cfig w <> viewClipBounds cfig w <> drawMousePosition cfig w <> drawWallIDs cfig w <> drawPathing cfig w <> drawCrInfo cfig w + <> cfigdraw View_boundaries (const viewBoundaries) <> cfigdraw Show_bound_box (const drawBoundingBox) <> cfigdraw Show_wall_search_rays (const drawWallSearchRays) <> cfigdraw Show_dda_test (const drawDDATest) + <> cfigdraw Show_far_wall_detect (const drawFarWallDetect) + <> cfigdraw Show_select (const drawWorldSelect) + <> cfigdraw Inspect_wall (const drawInspectWalls) where cfigdraw boption draw | debugOn boption cfig = draw cfig w | otherwise = mempty +drawInspectWalls :: World -> Picture +drawInspectWalls w = foldMap (drawInspectWall w) + $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) + $ IM.elems $ _walls w + where + (a,b) = _wSelect w + +drawInspectWall :: World -> Wall -> Picture +drawInspectWall _ wl = setLayer DebugLayer $ + color rose (thickLine 3 [a,b]) + <> foldMap (drawZone zoneSize) + (runIdentity $ S.toList_ $ zoneOfWall wl) + where + (a,b) = _wlLine wl +-- $ line [a,b] +-- where +-- (a,b) = _wSelect w + +drawWorldSelect :: World -> Picture +drawWorldSelect w = setLayer DebugLayer . color cyan + $ line [a,b] + where + (a,b) = _wSelect w + +drawFarWallDetect :: World -> Picture +drawFarWallDetect w = setLayer DebugLayer . color yellow + . concatMap (\q -> line [p,q]) + . map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w) + $ runIdentity $ S.toList_ $ streamViewpoints p w + where + p = _cameraViewFrom w + drawDDATest :: World -> Picture drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps) <> runIdentity (S.foldMap_ (drawZone' 50) ps') @@ -107,7 +145,7 @@ crossPic :: Float -> Picture crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)] drawZone :: Float -> V2 Int -> Picture -drawZone s (V2 x y) = setLayer DebugLayer . color orange $ line (p:ps ++ [p]) +drawZone s (V2 x y) = setLayer DebugLayer . color orange $ thickLine 2 (p:ps ++ [p]) where (p:ps) = zipWith (+.+) innerSquare $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)] @@ -235,12 +273,9 @@ drawCrInfo cfig w where hw = halfWidth cfig -viewBoundaries :: Configuration -> World -> Picture -viewBoundaries cfig w - | debugOn View_boundaries cfig - = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs) - <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w) - | otherwise = [] +viewBoundaries :: World -> Picture +viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs) + <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w) where p = _crPos $ you w grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index de02ff095..ef47bf87b 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -5,8 +5,12 @@ import Geometry import Shape import Quaternion +import Dodge.Data.ForegroundShape +import Dodge.Default.Foreground import Data.List import Data.Maybe +import Control.Lens +import ShapePicture highDiagonalMesh :: Point2 @@ -111,6 +115,25 @@ girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n) where n = csize *.* vNormal (normalizeV (x -.- y)) +girderV' + :: Float -- ^ "cap" size + -> Float -- ^ height + -> Float -- ^ distance between cross bars + -> Float -- ^ width + -> Point2 -> Point2 -> ForegroundShape +girderV' csize h d w x y = defaultForeground + & fsPos .~ m + & fsRad .~ dist m x' + & fsSPic .~ noPic sh + where + m = midPoint x y + x' = x - m + y' = y - m + sh = thinHighBar h (x' -.- n) (x' +.+ n) + <> thinHighBar h (y' -.- n) (y' +.+ n) + <> girderV h d w x' y' + n = csize *.* vNormal (normalizeV (x' -.- y')) + girderV :: Float -- ^ height -> Float -- ^ distance between cross bars diff --git a/src/Dodge/Room/Modify/Girder.hs b/src/Dodge/Room/Modify/Girder.hs index 2eae8194b..cf40ac15e 100644 --- a/src/Dodge/Room/Modify/Girder.hs +++ b/src/Dodge/Room/Modify/Girder.hs @@ -151,13 +151,13 @@ addGirderLights rm = do midw = wiToFloat rm midi extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis extragirders = mapMaybe (\(i,hi) -> case i of - x | x < 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) + x | x < 0 -> Just $ girderV' 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) (V2 0 (hiToFloat rm hi)) - x | x > 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) + x | x > 0 -> Just $ girderV' 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) (V2 w (hiToFloat rm hi)) _ -> Nothing ) extragirderpos return $ rm & rmPmnts .++~ - (sps0 (PutShape $ colorSH black $ girderVCapLR 20 96 20 10 (V2 midw 0) (V2 midw h)) + (sps0 (PutForeground $ girderV' 20 96 20 10 (V2 midw 0) (V2 midw h)) : map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps - ) ++ map (sps0 . PutShape . colorSH black) extragirders + ) ++ map (sps0 . PutForeground) extragirders diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6f5b01337..25ca332a6 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -35,6 +35,7 @@ import Control.Applicative --import Data.Monoid --import System.Random import qualified Streaming.Prelude as S +import SDL --import Streaming {- For most menus the only way to change the world is using event handling. -} @@ -57,6 +58,7 @@ functionalUpdate cfig w = checkEndGame -- . updateRandGen . (mouseButtons . each .~ True) -- to determine if the mouse button is held . (worldClock +~ 1) + . updateWorldSelect . doRewind . (doubleMouseHammer %~ moveHammerUp) . updateDistortions @@ -100,6 +102,11 @@ functionalUpdate cfig w = checkEndGame where (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl +updateWorldSelect :: World -> World +updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of + Nothing -> w + Just False -> w & wSelect . _1 .~ mouseWorldPos w + Just True -> w & wSelect . _2 .~ mouseWorldPos w mcChooseUpdate :: Machine -> Machine -> World -> World mcChooseUpdate mc mc' diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 3ade6e5d8..04933340e 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -4,7 +4,7 @@ and the position that the character sees from: '_cameraViewFrom'. -} module Dodge.Update.Camera ( updateCamera , farWallPoints --- , streamViewpoints + , streamViewpoints , farWallDistDirection ) where import Dodge.Data diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs index 3ecf63b29..12434bd1c 100644 --- a/src/Dodge/Wall/Zone.hs +++ b/src/Dodge/Wall/Zone.hs @@ -6,19 +6,26 @@ import Dodge.Zone import Dodge.Base import Control.Lens -import Data.Foldable +--import Data.Foldable +import Streaming +import qualified Streaming.Prelude as S -zoneOfWall :: Wall -> [(Int,Int)] -zoneOfWall wl - | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ] - | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline - where - wlline = _wlLine wl +zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity () +zoneOfWall = uncurry zoneOfLineStream . _wlLine +-- | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ] +-- | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline +-- where +-- wlline = _wlLine wl insertWallInZones :: Wall -> World -> World insertWallInZones wl = wallsZone . znObjects - %~ flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl) + %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl))) + where + doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns deleteWallFromZones :: Wall -> World -> World deleteWallFromZones wl = wallsZone . znObjects - %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl) + %~ (runIdentity . (\wlzns -> S.fold_ dodelete wlzns id (zoneOfWall wl))) + where + dodelete wlzns (V2 x y) = deleteIMInZone x y (_wlID wl) wlzns +-- %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl) diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 867096f56..65004316b 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -13,6 +13,7 @@ module Dodge.Zone , zoneAroundPoint , floorHun , zoneOfLine + , zoneOfLineStream , wallsDoubleScreen , cloudZoneOfPoint , cloudsNearPoint @@ -86,6 +87,7 @@ zoneOfLine (V2 aa ab) (V2 ba bb) --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]] zoneOfLineStream :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity () +--zoneOfLineStream = ddaSqStream zoneSize zoneOfLineStream = ddaStream zoneSize zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index 523875189..4903523ac 100644 --- a/src/Geometry/Zone.hs +++ b/src/Geometry/Zone.hs @@ -3,7 +3,7 @@ module Geometry.Zone ( ddaExt , ddaExt' , ddaSq --- , ddaSqStream + , ddaSqStream , ddaStream , ddaStreamX , ddaStreamY @@ -144,6 +144,17 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey) [y1 .. y2] | otherwise = zip (map (divTo s) [y2x,y2x+xdy..]) [y2-1 .. y1-1] +ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity () +ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey] + where + V2 sx sy = sizeZoneOfPoint' s sp + V2 ex ey = sizeZoneOfPoint' s ep + +makeInterval :: Int -> Int -> [Int] +makeInterval x y + | x < y = [x-1..y+1] + | otherwise = [y-1..x+1] + ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity () ddaStream s sp ep = S.map (sizeZoneOfPoint' s) $ S.yield sp @@ -160,11 +171,11 @@ xIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity () {-# INLINE xIntercepts #-} xIntercepts s (V2 sx sy) (V2 ex ey) | xdx == 0 = mempty - | xdx > 0 = S.each $ zipWith V2 [sx',sx'+xdx*50..ex] [sy',sy'+ydx*50..ey] - | otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] [sy',sy'+ydx*50..ey] + | xdx > 0 = S.each $ zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey) + | otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey) where xdx = signum (ex - sx) - ydx = (ey - sy) / abs (ex - sx) + ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero sy' = sy + ydx * abs (sx - sx') sx' | xdx < 0 = sx - modTo s sx