diff --git a/src/Bound.hs b/src/Bound.hs new file mode 100644 index 000000000..9462e284d --- /dev/null +++ b/src/Bound.hs @@ -0,0 +1,17 @@ +module Bound where +import Geometry + +import Control.Lens +import Streaming +import qualified Streaming.Prelude as S +import qualified Control.Foldl as L + +boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float) +boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) + <$> L.premap (^?! _2) L.maximum + <*> L.premap (^?! _2) L.minimum + <*> L.premap (^?! _1) L.maximum + <*> L.premap (^?! _1) L.minimum + ) + where + f (mn,ms,me,mw) = (,,,) <$> mn <*> ms <*> me <*> mw diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 097d8cb5e..c9dae8fdf 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -96,6 +96,7 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep . S.filter t . wallsAlongLine sp ep +-- this hopefully also nub the stream in most cases --orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ()) sortStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity () {-# INLINE sortStreamOn #-} diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 26684284d..0c35ef4cd 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -13,6 +13,7 @@ module Dodge.Data , module Dodge.Data.LoadAction , module Dodge.Data.ForegroundShape , module Dodge.Data.Wall + , module Dodge.Data.Bounds , module Dodge.Combine.Data , module Dodge.Distortion.Data , module Dodge.Data.DamageType @@ -35,6 +36,7 @@ import Dodge.Data.ForegroundShape import Dodge.Data.LoadAction import Dodge.Data.Material import Dodge.Data.Wall +import Dodge.Data.Bounds import Dodge.RoomCluster.Data import Dodge.Data.ItemAmount import Dodge.ShortShow @@ -51,7 +53,6 @@ import Dodge.Config.Data import Dodge.Config.KeyConfig import Dodge.Item.Attachment.Data import Dodge.Item.Data -import Dodge.Bounds import Data.Preload import Picture.Data import ShapePicture diff --git a/src/Dodge/Bounds.hs b/src/Dodge/Data/Bounds.hs similarity index 92% rename from src/Dodge/Bounds.hs rename to src/Dodge/Data/Bounds.hs index 9fd32b850..775d4168f 100644 --- a/src/Dodge/Bounds.hs +++ b/src/Dodge/Data/Bounds.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Bounds +module Dodge.Data.Bounds where import Control.Lens diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 81bb3400d..b4f54030f 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -2,7 +2,6 @@ module Dodge.Default.World where import Dodge.Data import Dodge.Base --import Dodge.Config.KeyConfig -import Dodge.Bounds --import Dodge.Menu --import Picture import Geometry.Data diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 68b265e86..c90308745 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -41,6 +41,7 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom + , AnRoom $ return airlock0 -- , AnRoom slowDoorRoom -- , AnRoom $ roomCCrits 10 -- , AnTree firstBreather diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index dcddd9100..346ac8799 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -13,7 +13,6 @@ import Dodge.LevelGen.LevelStructure import Dodge.Room.Foreground import Dodge.Wall.Zone import Dodge.GameRoom -import Dodge.Bounds import Dodge.Default.Wall import Dodge.Room.Link import Dodge.Randify diff --git a/src/Dodge/Placement/Instance/Block.hs b/src/Dodge/Placement/Instance/Block.hs new file mode 100644 index 000000000..08ef22540 --- /dev/null +++ b/src/Dodge/Placement/Instance/Block.hs @@ -0,0 +1,23 @@ +module Dodge.Placement.Instance.Block where +import Dodge.Data +import Geometry +import Color +import LensHelp +import ShapePicture +import Shape +import Dodge.Default.Wall +import Dodge.Default.Block + +lowBlock :: Material -> Color -> Float -> [Point2] -> PSType +lowBlock mat col h ps = PutBlock bl wl $ reverse ps + where + bl = defaultBlock + & blDraw .~ const (noPic $ colorSH col (upperPrismPoly h $ reverse ps)) + & blDeath .~ const id + wl = defaultWall + & wlDraw .~ False + & wlColor .~ col + & wlRotateTo .~ False + & wlOpacity .~ SeeAbove + & wlMaterial .~ mat + & wlHeight .~ h diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index c9e51ea96..7f46a884b 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -1,6 +1,7 @@ module Dodge.Placement.Instance.Wall where import Dodge.Data +import Dodge.Placement.Instance.Block import Dodge.Default.Block --import Dodge.Block.Debris import Dodge.LevelGen.Data @@ -14,26 +15,7 @@ import Data.List import Control.Lens heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement -heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps) - $ sps spot $ PutWall ps theWall - where - col = _wlColor defaultWall - theWall = defaultWall - { _wlOpacity = SeeAbove - , _wlDraw = False - , _wlHeight = h - } - -heightWall :: Float -> [Point2] -> Placement -heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps) - $ sps0 $ PutWall ps theWall - where - col = _wlColor defaultWall - theWall = defaultWall - { _wlOpacity = SeeAbove - , _wlDraw = False - , _wlHeight = h - } +heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps invisibleWall :: [Point2] -> Placement invisibleWall ps = sps0 $ PutWall ps $ defaultWall diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 24f346cf5..568222953 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -31,7 +31,7 @@ airlock0 = defaultRoom $ \_ _ -> Just $ putDoubleDoor thewall (cond' btid) (V2 0 80) (V2 40 80) 2 , invisibleWall $ rectNSWE 60 40 (-40) (-30) ,spanLightI (V2 (-2) 30) (V2 (-2) 70) - ,sps0 $ PutShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) + ,sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) ] , _rmBound = [rectNSWE 75 15 0 40,switchcut] } diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index ef47bf87b..4484c327b 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -1,11 +1,12 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Foreground where +import Dodge.Data import Picture import Geometry import Shape import Quaternion -import Dodge.Data.ForegroundShape +--import Dodge.Data.ForegroundShape import Dodge.Default.Foreground import Data.List import Data.Maybe @@ -115,6 +116,24 @@ girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n) where n = csize *.* vNormal (normalizeV (x -.- y)) +putShape :: Shape -> PSType +putShape sh = PutForeground $ defaultForeground + & fsPos .~ m + & fsRad .~ radBounds bnds + & fsSPic .~ noPic (uncurryV translateSHf (-m) $ sh) + where + bnds = shapeBounds sh + m = midBounds bnds + +shapeBounds :: Shape -> (Float,Float,Float,Float) +shapeBounds sh = undefined + +midBounds :: (Float,Float,Float,Float) -> Point2 +midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2) + +radBounds :: (Float, Float,Float,Float) -> Float +radBounds (n,s,e,w) = max (n-s) (e-w) / 2 + girderV' :: Float -- ^ "cap" size -> Float -- ^ height @@ -123,7 +142,7 @@ girderV' -> Point2 -> Point2 -> ForegroundShape girderV' csize h d w x y = defaultForeground & fsPos .~ m - & fsRad .~ dist m x' + & fsRad .~ dist m x & fsSPic .~ noPic sh where m = midPoint x y diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 85c539294..5cb8177c4 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -10,24 +10,15 @@ import Dodge.Room.Door import Dodge.Room.Corridor import Dodge.Room.Link import Dodge.Room.Ngon ---import Dodge.Room.Procedural -import Dodge.Room.Foreground ---import Dodge.Room.RoadBlock +--import Dodge.Room.Foreground +import Dodge.Wire import Dodge.Placement.Instance import Dodge.Placement.Instance.Analyser import Dodge.Default.Room import Dodge.Item.Consumable ---import Dodge.Machine ---import Dodge.Item.Weapon.Utility ---import Dodge.LevelGen.Data ---import Geometry.Data import Geometry ---import Padding -import Color -import Shape import LensHelp import RandomHelp ---import Dodge.SoundLogic import qualified Data.Set as S import Data.Maybe @@ -39,15 +30,15 @@ cenLasTur = roomNgon 8 200 & rmPmnts .~ , mntLightLnkCond $ rprBool $ const . isInLnk ] where - covershape = reverse $ rectNSWE 10 (-10) (-20) 20 + covershape = rectNSWE 10 (-10) (-20) 20 lightSensInsideDoor :: Int -> Room -> Room lightSensInsideDoor outplid rm = rm - & rmPmnts .:~ psPt atFstLnkOut - (PutShape $ colorSH yellow $ - thinHighBar 0 (V2 20 (-1)) (V2 20 (-100)) - <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100)) - <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) + & rmPmnts .++~ + [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100))) + , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))) + , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80) + ] & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 10 (atFstLnkOutShiftInward 100)) outplid] lasSensLightAboveDoor :: Float -> PlacementSpot -> Placement @@ -61,14 +52,13 @@ lasSensLightAboveDoor wth ps = extTrigLitPos lightSensByDoor :: Int -> Room -> Room lightSensByDoor outplid rm = rm & rmPmnts .++~ - [ psPt atFstLnkOut $ PutShape $ colorSH yellow - $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80) + [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape , heightWallPS (atFstLnkOutShiftInward 100) 30 covershape ] & rmOutPmnt .~ [OutPlacement (lasSensLightAboveDoor 20 (atFstLnkOutShiftBy sensorshift)) outplid] where - covershape = reverse $ rectNSWE 10 (-10) (-20) 20 + covershape = rectNSWE 10 (-10) (-20) 20 sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a) keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String) @@ -90,8 +80,7 @@ healthAnalyserByDoor = analyserByDoor (RequireHealth 1100) analyserByDoor :: ProximityRequirement -> Int -> Room -> Room analyserByDoor proxreq outplid rm = rm & rmPmnts .++~ - [ psPt atFstLnkOut $ PutShape $ colorSH yellow - $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80) + [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 ] & rmOutPmnt .~ [OutPlacement diff --git a/src/Dodge/Room/SensorDoor.hs b/src/Dodge/Room/SensorDoor.hs index 977e51e2e..92bb03117 100644 --- a/src/Dodge/Room/SensorDoor.hs +++ b/src/Dodge/Room/SensorDoor.hs @@ -8,6 +8,7 @@ import Dodge.Placement.Instance.Terminal import Dodge.Terminal import Dodge.Data import Dodge.Tree +import Dodge.Wire --import Dodge.RoomLink import Dodge.Room.Door import Dodge.Room.Ngon @@ -80,11 +81,9 @@ sensInsideDoor :: DamageType -> Int -> Room -> Room sensInsideDoor senseType outplid rm = rm & rmName .++~ take 4 (show senseType) & rmPmnts .++~ - [ psPt atFstLnkOut - (PutShape $ colorSH yellow $ - thinHighBar 0 (V2 20 (-1)) (V2 20 (-100)) - <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100)) - <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) + [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100)) + , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)) + , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80 , putTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand) & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10) ] diff --git a/src/Dodge/Wire.hs b/src/Dodge/Wire.hs index 3452e67d6..e14e8bda9 100644 --- a/src/Dodge/Wire.hs +++ b/src/Dodge/Wire.hs @@ -1,10 +1,30 @@ module Dodge.Wire where --import Dodge.LevelGen.Data +import Dodge.Default.Foreground import Dodge.Data import Geometry +import LensHelp +import ShapePicture +import Shape +import Color +import Dodge.Room.Foreground import qualified Data.IntMap.Strict as IM -import Control.Lens + +floorWire :: Point2 -> Point2 -> ForegroundShape +floorWire a b = defaultForeground + & fsPos .~ m + & fsRad .~ dist m a + & fsSPic .~ noPic (colorSH yellow $ thinHighBar 0 a' b') + where + m = midPoint a b + a' = a - m + b' = b - m +verticalWire :: Point2 -> Float -> Float -> ForegroundShape +verticalWire p h1 h2 = defaultForeground + & fsPos .~ p + & fsRad .~ 2 + & fsSPic .~ noPic (colorSH yellow $ barPP 1.5 (V3 0 0 h1) (V3 0 0 h2)) putWireEnd :: Int -> (Point2,Float) -> Float -> Room -> Room putWireEnd i (p,a) h = rmEndWires %~ IM.insert i (WallWire p a h)