diff --git a/package.yaml b/package.yaml index 44ba3ef19..7f62b581a 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ dependencies: - unordered-containers - bitwise-enum - graphviz +- template-haskell #- heap - sdl2 - sdl2-mixer diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index ec9742a1c..7668017b9 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -4,6 +4,7 @@ import Dodge.Particle.Flame import Dodge.Particle.TeslaArc import Dodge.Item.Location import Dodge.WorldEvent.Damage +--import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.HelperParticle import Dodge.Item.Weapon.LaserPath import Geometry @@ -50,12 +51,13 @@ teslaBeamCombine (p,(a,b,bm),(x,y,_)) w lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> Particle lasRayAt col dam phasev pos dir = LaserParticle - { _ptDraw = const blank + { _ptDraw = drawLaser , _ptUpdate = mvLaser phasev pos dir , _ptRange = 800 , _ptDamage = dam , _ptPhaseV = phasev , _ptColor = col + , _ptPoints = [] } mvLaser :: Float -- ^ Phase velocity, controls deflection through windows -> Point2 @@ -63,19 +65,24 @@ mvLaser :: Float -- ^ Phase velocity, controls deflection through windows -> World -> Particle -> (World, Maybe Particle) -mvLaser phasev pos dir w pt - = ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) pos xp thHit w - , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 } +mvLaser phasev sp dir w pt + = ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w + , Just pt {_ptPoints = sp:ps ,_ptUpdate = ptSimpleTime 0 } ) where dam = _ptDamage pt - xp = pos +.+ 800 *.* unitVectorAtAngle dir - (thHit, ps) = reflectLaserAlong phasev [] pos xp w + xp = sp +.+ 800 *.* unitVectorAtAngle dir +-- thHit' = thingHit sp xp w + (thHit, ps) = reflectLaserAlong phasev sp xp w + +drawLaser :: Particle -> Picture +drawLaser pt = setLayer BloomNoZWrite $ pictures + [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps + , setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps + ] + where col = _ptColor pt - pic = setLayer BloomNoZWrite $ pictures - [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 (pos:ps) - , setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 (pos:ps) - ] + ps = _ptPoints pt shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams) shootTeslaArc' ip pos dir w = diff --git a/src/Dodge/Combine/Combinations.hs b/src/Dodge/Combine/Combinations.hs index 8a1cbc57a..8f2fc306f 100644 --- a/src/Dodge/Combine/Combinations.hs +++ b/src/Dodge/Combine/Combinations.hs @@ -16,41 +16,38 @@ import LensHelp itemCombinations :: [([(IcAmount,ItemBaseType)],Item)] itemCombinations = - [ po [CRAFT PIPE, CRAFT HARDWARE] (bangStick 1) + [ po [CRAFT PIPE, CRAFT HARDWARE] (bangStick 1) , po [BANGSTICK 1, CRAFT TIN] pistol - , po [PISTOL, CRAFT SPRING, cr HARDWARE] autoPistol - , po [AUTOPISTOL, cr PLANK, cr HARDWARE] smg - , po [AUTOPISTOL, cr HARDWARE] machinePistol + , po [PISTOL, CRAFT SPRING] autoPistol + , po [AUTOPISTOL, cr PLANK] smg + , po [AUTOPISTOL, cr SPRING] machinePistol , po [BANGSTICK 1,cr CAN] revolver - , po [REVOLVER, cr SPRING, cr HARDWARE] $ revolverX 1 + , po [REVOLVER, cr SPRING] $ revolverX 1 - , po [cr TUBE,cr HARDWARE] bangCone + , po [cr CAN,cr HARDWARE] bangCone , po [BANGCONE,cr PLANK] blunderbuss - , po [BLUNDERBUSS,cr TUBE] bigBlunderbuss - , po [BIGBLUNDERBUSS,cr TUBE] biggerBlunderbuss - , po [BIGGERBLUNDERBUSS,cr TUBE] biggestBlunderbuss + , po [BLUNDERBUSS,cr DRUM] (grapeCannon 1) -- , po [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1 -- , po [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2 - , p [p 2 $ cr PIPE,o $ cr HARDWARE] (bangCaneX 1) - , p [p 2 $ cr PIPE,o $ BANGCANEX 1] (bangCaneX 2) - , po [BANGCANEX 1,cr TIN] rifle - , po [RIFLE,cr PLANK] repeater - , po [REPEATER,cr SPRING,cr HARDWARE] autoRifle - , po [REPEATER,cr SPRING,cr CAN] burstRifle - , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle - , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle - , po [cr MOTOR,BANGCANEX 3] $ miniGunX 3 - , po [cr MOTOR,BANGCANEX 4] $ miniGunX 4 - , po [cr MOTOR,BANGCANEX 5] $ miniGunX 5 - , po [cr MOTOR,BANGCANEX 6] $ miniGunX 6 +-- , po [cr PIPE, cr HARDWARE] (volleyGun 1) + , po [BANGSTICK 1,cr PLANK] rifle + , p [p 3 $ BANGSTICK 1] (volleyGun 3) + , po [RIFLE,cr TIN] repeater + , po [REPEATER,cr SPRING] autoRifle + , po [REPEATER,cr CAN] burstRifle +-- , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle +-- , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle + , po [cr MOTOR,VOLLEYGUN 3] $ miniGunX 3 + , po [cr MOTOR,VOLLEYGUN 4] $ miniGunX 4 + , po [cr MOTOR,VOLLEYGUN 5] $ miniGunX 5 + , po [cr MOTOR,VOLLEYGUN 6] $ miniGunX 6 - , p [p 3 $ cr PIPE,o $ cr HARDWARE] bangRod - , po [BANGROD,cr PLANK,cr HARDWARE] elephantGun - , po [ELEPHANTGUN,cr HARDWARE,cr PRISM] sniperRifle - , po [ELEPHANTGUN,cr HARDWARE,cr TIN] amr - , po [AMR,cr HARDWARE,cr SPRING] autoAmr - , po [BANGROD,cr PLATE,cr DRUM,cr MOTOR] machineGun +-- , po [BANGSTICK 1,cr TUBE] elephantGun + , po [AMR,cr PIPE] sniperRifle + , po [RIFLE,cr PIPE] amr + , po [AMR,cr SPRING] autoAmr + , po [AMR,cr MOTOR] machineGun , p [p 2 $ cr TUBE,o $ cr HARDWARE] launcher , p [p 2 $ cr TUBE,o LAUNCHER] (launcherX 2) @@ -86,12 +83,13 @@ itemCombinations = , p [p 2 $ cr PLATE] flatShield ] - ++ map (\i -> po [LASGUNWIDE i,cr TRANSFORMER,cr PRISM] $ lasWide (i+1)) [1..9] - ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [1..10] + ++ map (\i -> po [LASGUNWIDE i,cr TRANSFORMER,cr PRISM] $ lasWide (i+1)) [2..9] +-- ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [2..10] ++ map (\i -> po [cr PIPE,BANGSTICK i] $ bangStick (i+1)) [1..8] ++ map (\i -> po [REVOLVERX i,cr CAN] $ revolverX (i+1)) [1..5] - ++ map (\i -> p [o (BANGCANEX i),p 2 $ cr PIPE] $ bangCaneX (i+1)) [1..5] - ++ map (\i -> po [MINIGUNX i,BANGCANEX 1] $ miniGunX (i+1)) [3..15] + ++ map (\i -> po [VOLLEYGUN i,BANGSTICK 1] $ volleyGun (i+1)) [3..5] + ++ map (\i -> po [MINIGUNX i,BANGSTICK 1] $ miniGunX (i+1)) [3..15] + ++ map (\i -> po [GRAPECANNON i,cr DRUM] $ grapeCannon (i+1)) [1,2,3] ++ [ po (_iyBase (_itType it):mtype) $ it & itType . iyModules . ix modtype .~ m | (modtype,is,ms) <- moduleCombinations @@ -109,8 +107,8 @@ moduleCombinations = [ ( ModRifleMag , [repeater ,autoRifle - ,burstRifle - ,fastBurstRifle +-- ,burstRifle +-- ,fastBurstRifle ] , [amod [cr DRUM,cr HARDWARE] DRUMMAG ,amod [cr MOTOR,cr HARDWARE] BELTMAG @@ -185,19 +183,22 @@ batteryGuns = , lasSwing ] ++ [ lasWide i | i <- [1..10] - ] ++ - [ lasFocus i | i <- [1..10]] + ] +-- ++ +-- [ lasFocus i | i <- [1..10]] teleportableWeapons :: [Item] teleportableWeapons = bulletWeapons ++ batteryGuns ++ homingLaunchers bulletWeapons :: [Item] -bulletWeapons = [bangStick i | i <- [1..9] ] - ++ [bangCaneX i | i <- [1..6] ] +bulletWeapons + = [bangStick i | i <- [1..9] ] + ++ [volleyGun i | i <- [3..6] ] ++ [revolverX i | i <- [1..5] ] ++ [miniGunX i | i <- [3..16] ] - ++ [bangCane - ,pistol + ++ [grapeCannon i | i <- [1,2,3,4] ] + ++ + [pistol ,autoPistol ,smg ,machinePistol @@ -206,11 +207,14 @@ bulletWeapons = [bangStick i | i <- [1..9] ] ,repeater ,autoRifle ,burstRifle - ,fastBurstRifle - ,completeBurstRifle +-- ,fastBurstRifle +-- ,completeBurstRifle ,bangCone ,blunderbuss - ,bigBlunderbuss - ,biggerBlunderbuss - ,biggestBlunderbuss + ,machineGun + ,elephantGun + ,sniperRifle + ,amr + ,autoAmr + ,bangRod ] diff --git a/src/Dodge/Combine/Data.hs b/src/Dodge/Combine/Data.hs index 7c5bc38b4..b1b6006a8 100644 --- a/src/Dodge/Combine/Data.hs +++ b/src/Dodge/Combine/Data.hs @@ -72,31 +72,27 @@ data ItemBaseType | EFFGUN String | AUTOEFFGUN String -- Weapons - | BANGSTICK Int + | BANGSTICK {_xNum :: Int} | PISTOL | REVOLVER - | REVOLVERX Int + | REVOLVERX {_xNum :: Int} | MACHINEPISTOL | AUTOPISTOL | SMG | BANGCONE | BLUNDERBUSS - | BIGBLUNDERBUSS - | BIGGERBLUNDERBUSS - | BIGGESTBLUNDERBUSS --- | GRAPESHOTCANNON + | GRAPECANNON {_xNum :: Int} -- | GRENADELAUNCHER Int -- number of chambers that can be reloaded -- | MORTARCONE / HANDMORTAR - | BANGCANE -- | MINIGUN - | MINIGUNX Int - | BANGCANEX Int + | MINIGUNX {_xNum :: Int} + | VOLLEYGUN {_xNum :: Int} | RIFLE | REPEATER | AUTORIFLE | BURSTRIFLE - | FASTBURSTRIFLE - | COMPLETEBURSTRIFLE +-- | FASTBURSTRIFLE +-- | COMPLETEBURSTRIFLE | BANGROD | ELEPHANTGUN | AMR @@ -122,7 +118,7 @@ data ItemBaseType | SONICGUN | TRACTORGUN | LAUNCHER - | LAUNCHERX Int + | LAUNCHERX {_xNum :: Int} -- | TRACKINGLAUNCHER | REMOTELAUNCHER | POISONSPRAYER @@ -205,3 +201,4 @@ data ModuleSlot deriving (Eq,Ord,Show) makeLenses ''ItemType +makeLenses ''ItemBaseType diff --git a/src/Dodge/Combine/Graph.hs b/src/Dodge/Combine/Graph.hs new file mode 100644 index 000000000..c679d2d8b --- /dev/null +++ b/src/Dodge/Combine/Graph.hs @@ -0,0 +1,139 @@ +--{-# LANGUAGE TypeSynonymInstances #-} +--{-# LANGUAGE FlexibleInstances #-} +module Dodge.Combine.Graph where +import Dodge.Data hiding (East,West,North,South) +import Dodge.Combine.Combinations +import LensHelp +import GraphHelp + +import Data.Text (Text) +import Data.Text.Lazy (toStrict,pack) +import qualified Data.Graph.Inductive as FGL +import GraphVizHelp +import Data.GraphViz.Attributes.Complete +import Data.Bifunctor + +data CombClust + = CraftClust + | ItemClust + | JoinClust + deriving (Eq,Ord,Show,Enum,Bounded) + +newtype CombNode = CombNode {_unCombNode :: Either ItemBaseType [(IcAmount,ItemBaseType)]} + deriving (Eq,Ord,Show) + +instance Labellable CombNode where + toLabelValue (CombNode Right{}) = StrLabel (pack "") + toLabelValue (CombNode (Left ibt)) = StrLabel (pack $ show ibt) + +newtype CombEdge = CombEdge {_unCombEdge :: Int} + deriving (Eq,Ord,Show) +instance Labellable CombEdge where + toLabelValue (CombEdge 0) = StrLabel (pack "") + toLabelValue (CombEdge x) = StrLabel (pack $ show x) + +bulletCombinations :: [([(IcAmount,ItemBaseType)],Item)] +bulletCombinations = filter + ( (`elem` map totype bulletWeapons) + . totype + . snd + ) itemCombinations + where + totype = _iyBase . _itType + +maxShowX :: ItemBaseType -> Maybe Int +maxShowX bt = case bt of + BANGSTICK _ -> Just 2 + REVOLVERX _ -> Just 1 + VOLLEYGUN _ -> Just 3 + MINIGUNX _ -> Just 3 + GRAPECANNON _ -> Just 1 + LAUNCHERX _ -> Just 2 +-- LASGUNWIDE _ -> Just 2 +-- LASGUNFOCUS _ -> Just 2 + _ -> Nothing + +itemCombinationsEdges :: [(CombNode,CombNode,Int)] +itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) itemCombinations +--itemCombinationsEdges = concatMap (f . over _2 (_iyBase . _itType)) bulletCombinations + where + f (abts,bt) + | bt `elem` bts = [] + | any (not . belowNumX) bts = [] + | otherwise = (CombNode $ Right abts,CombNode $ Left bt,0) : map g abts + where + bts = map snd abts + g (am,bt') = (CombNode $ Left bt',CombNode $ Right abts,_toInt am) + +combinationsGraph :: FGL.Gr CombNode CombEdge +combinationsGraph = FGL.labnfilter (f . _unCombNode . snd) + . second CombEdge $ mkGraphFromEdges itemCombinationsEdges + where + f Right {} = True + f (Left (CRAFT _)) = False + f (Left bt) = case maxShowX bt of + Nothing -> True + Just i -> _xNum bt <= i + +belowNumX :: ItemBaseType -> Bool +belowNumX bt = case maxShowX bt of + Nothing -> True + Just i -> _xNum bt <= i + +toCombNodeLabel :: CombNode -> String +toCombNodeLabel (CombNode (Left ibt)) = show ibt +toCombNodeLabel (CombNode Right{}) = "" + +combinationsDotGraph :: Text +--combinationsDotGraph = toStrict . printDotGraph . graphToDot nonClusteredParams $ combinationsGraph +combinationsDotGraph = toStrict . printDotGraph . graphToDot myParams + $ combinationsGraph +-- $ first toCombNodeLabel combinationsGraph + +myParams :: GraphvizParams Int CombNode CombEdge CombClust CombNode +myParams = defaultParams -- {globalAttributes = [GraphAttrs [RankDir FromLeft]]} + & isDirectedL .~ True +-- & globalAttributesL .~ [GraphAttrs [RankDir FromLeft,Splines PolyLine]] + & globalAttributesL .~ [GraphAttrs [RankDir FromLeft]] + & clusterByL .~ clusterFunc + & isDotClusterL .~ (const False) + & clusterIDL .~ setClusterID + & fmtClusterL .~ clusterFormatting + & fmtEdgeL .~ edgeFormatting + & fmtNodeL .~ nodeFormatting + +setClusterID :: CombClust -> GraphID +setClusterID = Num . Int . fromEnum + +clusterFunc :: (Int,CombNode) -> NodeCluster CombClust (Int,CombNode) +clusterFunc n@(_,CombNode (Left bt)) = case bt of + CRAFT _ -> C CraftClust (N n) + _ -> C ItemClust (N n) +clusterFunc n = C JoinClust (N n) + +clusterFormatting :: CombClust -> [GlobalAttributes] +clusterFormatting cl = case cl of +-- CraftClust -> [GraphAttrs [Rank SameRank]] + _ -> [] + +edgeFormatting :: (Int,Int,CombEdge) -> Attributes +--edgeFormatting (_,_,CombEdge 0) = [] +-- [ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)]) +-- ,SameTail (pack "b") +-- ] +edgeFormatting (_,_,ce) = case _unCombEdge ce of + 0 -> [ xLabel ce + , TailPort (CompassPoint East) + ] + _ -> [ xLabel ce + , ArrowHead (AType [(ArrMod OpenArrow BothSides ,NoArrow)]) + , HeadPort (CompassPoint West) + ] + + +nodeFormatting :: (Int,CombNode) -> Attributes +nodeFormatting (_,CombNode Right {}) = [Shape PointShape] +nodeFormatting (_,CombNode cn@(Left bt)) = case bt of + --CRAFT _ -> [Shape DiamondShape,toLabel (CombNode cn)] + CRAFT _ -> [Color [WC (X11Color Green) Nothing],toLabel (CombNode cn)] + _ -> [Shape BoxShape,toLabel (CombNode cn)] diff --git a/src/Dodge/Combine/Trie.hs b/src/Dodge/Combine/Trie.hs new file mode 100644 index 000000000..55cfe514b --- /dev/null +++ b/src/Dodge/Combine/Trie.hs @@ -0,0 +1,19 @@ +module Dodge.Combine.Trie where +import Dodge.Combine.Combinations +import Dodge.Data +--import Dodge.Combine.Module +--import Dodge.Combine.Data +--import Multiset +import SimpleTrie + +import Data.Bifunctor +--import qualified Data.IntSet as IS +--import Data.Map.Merge.Strict +import Data.List (sort) + +combinationsTrie :: Trie (IcAmount,ItemBaseType) Item +{-# INLINE combinationsTrie #-} +combinationsTrie = foldr + (uncurry insertInTrie . first sort) + emptyTrie + itemCombinations diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 5d21e67e7..c250f5e52 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -97,7 +97,7 @@ multGunCrit :: Creature multGunCrit = defaultCreature { _crPict = basicCrPict -- , _crUpdate = stateUpdate (twitchMissAI 300 350) - , _crInv = IM.fromList [(0,bangCaneX 4),(1,medkit 100)] + , _crInv = IM.fromList [(0,volleyGun 4),(1,medkit 100)] , _crRad = 10 , _crHP = 300 , _crUpdate = defaultImpulsive [sentinelExtraWatchUpdate @@ -227,6 +227,20 @@ inventoryX c = case c of 'I' -> [ makeTypeCraft TELEPORTMODULE , makeTypeCraftNum 2 MICROCHIP ] + 'J' -> [ lasGun + , lasSwing + , lasDual + , lasWide 1 + , lasWide 2 + , lasWide 3 + , lasWide 4 + , lasWide 5 + , lasWidePulse + , lasFocus 1 + , lasFocus 2 + , lasFocus 3 + , lasFocus 6 + ] _ -> [] testInventory :: IM.IntMap Item diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 01891dc87..dafda0bcc 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -649,6 +649,7 @@ data Particle , _ptDamage :: Int , _ptColor :: Color , _ptPhaseV :: Float + , _ptPoints :: [Point2] } | LinearParticle { _ptDraw :: Particle -> Picture diff --git a/src/Dodge/Data/PathGraph.hs.orig b/src/Dodge/Data/PathGraph.hs.orig new file mode 100644 index 000000000..3bf0e61cb --- /dev/null +++ b/src/Dodge/Data/PathGraph.hs.orig @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.PathGraph where +import Geometry.Data +import Control.Lens +import Data.Graph.Inductive +import qualified Data.Set as Set +import Data.Map.Strict (Map) +data PathGraph = PathGraph + { _pgGraph :: Gr Point2 PathEdge + , _pgNodeMap :: Map Point2 Int + , _pgNodeCount :: Int + , _pgEdgeMap :: Map (V2 Point2) (Int,Int,PathEdge) + } +data PathEdge = PathEdge + {_peStart :: Point2 + ,_peEnd :: Point2 +<<<<<<< HEAD +======= + ,_peDist :: Float +>>>>>>> efficientRuntime + ,_peObstacles :: Set.Set EdgeObstacle + } + deriving (Eq,Ord,Show) +data EdgeObstacle + = BlockObstacle + | DoorObstacle + | AutoDoorObstacle + | WallObstacle + deriving (Eq,Ord,Show,Bounded,Enum) + +makeLenses ''PathGraph +<<<<<<< HEAD +======= +makeLenses ''PathEdge +>>>>>>> efficientRuntime diff --git a/src/Dodge/Default/Block.hs.orig b/src/Dodge/Default/Block.hs.orig new file mode 100644 index 000000000..c878ea277 --- /dev/null +++ b/src/Dodge/Default/Block.hs.orig @@ -0,0 +1,24 @@ +module Dodge.Default.Block where +import Dodge.Data +import Dodge.Block.Debris +import LensHelp + +defaultBlock :: Block +defaultBlock = Block + { _blID = 0 + , _blWallIDs = mempty + , _blHP = 1000 + , _blShadows = [] + , _blFootprint = [] + , _blPos = 0 + , _blDir = 0 + , _blDraw = const mempty + , _blDeath = makeBlockDebris + , _blObstructs = [] +<<<<<<< HEAD +======= + , _blPaths = [] +>>>>>>> efficientRuntime + } +defaultDirtBlock :: Block +defaultDirtBlock = defaultBlock & blHP .~ 50 diff --git a/src/Dodge/Default/World.hs.orig b/src/Dodge/Default/World.hs.orig new file mode 100644 index 000000000..651cf4275 --- /dev/null +++ b/src/Dodge/Default/World.hs.orig @@ -0,0 +1,140 @@ +module Dodge.Default.World where +import Dodge.Data +import Dodge.Zone.Size +import Dodge.Zone.Object +import Dodge.Base +import Geometry.Vector3D +import Geometry.Zone +--import Dodge.Config.KeyConfig +--import Dodge.Menu +--import Picture +import Geometry.Data +import Geometry.Polygon +--import Picture.Texture +--import Data.Preload + +import Control.Lens +import System.Random +import qualified Data.IntMap.Strict as IM +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Graph.Inductive.Graph hiding ((&)) +--import Data.Graph.Inductive.NodeMap +--import qualified Data.Vector.Fusion.Stream.Monadic as VS +defaultWorld :: World +defaultWorld = World + { _keys = S.empty + , _magnets = IM.empty + , _mouseButtons = mempty + , _cameraCenter = V2 0 0 + , _cameraRot = 0 + , _cameraZoom = 1 + , _itemZoom = 1 + , _defaultZoom = 1 + , _cameraViewFrom = V2 0 0 + , _viewDistance = 1000 + , _modifications = IM.empty + , _creatures = IM.empty + , _crZoning = Zoning IM.empty crZoneSize zoneOfCreature + , _creatureGroups = IM.empty + , _clouds = mempty + , _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos)) + , _gusts = IM.empty + , _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos) + , _itemPositions = IM.empty + , _props = IM.empty + , _instantParticles = [] + , _particles = [] + , _newBeams = WorldBeams [] [] [] [] + , _beams = WorldBeams [] [] [] [] + , _walls = IM.empty + , _wallDamages = IM.empty + , _blocks = IM.empty + , _machines = IM.empty + , _terminals = IM.empty + , _doors = IM.empty + , _coordinates = IM.empty + , _triggers = IM.empty + , _wlZoning = Zoning IM.empty wlZoneSize zoneOfWall + , _floorItems = IM.empty + , _floorTiles = [] + , _randGen = mkStdGen 2 + , _mousePos = V2 0 0 + , _testString = const . const [] + , _debugPicture = mempty + , _yourID = 0 + , _worldEvents = id + , _delayedEvents = [] + , _pressPlates = IM.empty + , _buttons = IM.empty + , _toPlaySounds = M.empty + , _playingSounds = M.empty + , _corpses = IM.empty + , _decorations = IM.empty + --, _savedWorlds = M.empty +-- , _menuLayers = [] + , _clickMousePos = V2 0 0 + , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty + , _pathGraphP = mempty +<<<<<<< HEAD + , _pnZoning = Zoning mempty pnZoneSize (zonePos snd) + , _peZoning = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q) +======= + , _pnZoning = Zoning mempty wlZoneSize (zonePos snd) + , _peZoning = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e)) +>>>>>>> efficientRuntime + , _hud = HUD + { _hudElement = DisplayInventory NoSubInventory + , _carteCenter = V2 0 0 + , _carteZoom = 0.5 + , _carteRot = 0 + } + , _lightSources = IM.empty + , _tempLightSources = [youLight] + , _closeObjects = [] + , _rbOptions = NoRightButtonOptions + , _seenLocations = IM.fromList + [(0, (_crPos . you, "CURRENT POSITION")) + ,(1, (const (V2 0 0) , "START POSITION")) + ] + , _selLocation = 0 + --, _keyConfig = defaultKeyConfigSDL +-- , _config = defaultConfig + , _sideEffects = return + , _shapes = mempty + , _distortions = [] + , _gameRooms = [] + , _roomClipping = [] + , _worldClock = 0 + , _worldBounds = defaultBounds + , _maybeWorld = Nothing' + , _rewindWorlds = [] + , _timeFlow = NormalTimeFlow + , _hammers = defaultWorldHammers + , _backspaceTimer = 0 + , _genParams = GenParams M.empty + , _genPlacements = IM.empty + , _genRooms = IM.empty + , _deathDelay = Nothing + , _testFloat = 0 + , _boundBox = square 100 + , _boundDist = (100,-100,100,-100) + , _lLine = (0,0) + , _rLine = (0,0) + , _lSelect = 0 + , _rSelect = 0 + } +defaultWorldHammers :: M.Map WorldHammer HammerPosition +defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound] +youLight :: TempLightSource +youLight = TLS + { _tlsParam = LSParam + {_lsPos = V3 0 0 0 + ,_lsRad = 300 + ,_lsCol = 0.1 + } + ,_tlsUpdate = \w _ -> Just (youLight & tlsParam . lsPos .~ f (_crPos $ you w)) + ,_tlsTime = 0 + } + where + f (V2 x y) = V3 x y 100 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index f6683000b..7a305cda0 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 $ roomCCrits 0 , AnRoom $ return airlock0 , AnRoom slowDoorRoom , AnRoom $ roomCCrits 10 diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index 0d583fdee..1edfc44e2 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -31,21 +31,17 @@ itemFromBase ibt = case ibt of SMG -> smg BANGCONE -> bangCone BLUNDERBUSS -> blunderbuss - BIGBLUNDERBUSS -> bigBlunderbuss - BIGGERBLUNDERBUSS -> biggerBlunderbuss - BIGGESTBLUNDERBUSS -> biggestBlunderbuss --- GRAPESHOTCANNON -> grapeShotCannon + GRAPECANNON i -> grapeCannon i --GRENADELAUNCHER Int -- number of chambers that can be reloaded -- --| MORTARCONE / HANDMORTAR - BANGCANE -> bangCane MINIGUNX i -> miniGunX i - BANGCANEX i -> bangCaneX i + VOLLEYGUN i -> volleyGun i RIFLE -> rifle REPEATER -> repeater AUTORIFLE -> autoRifle BURSTRIFLE -> burstRifle - FASTBURSTRIFLE -> fastBurstRifle - COMPLETEBURSTRIFLE -> completeBurstRifle +-- FASTBURSTRIFLE -> fastBurstRifle +-- COMPLETEBURSTRIFLE -> completeBurstRifle BANGROD -> bangRod ELEPHANTGUN -> elephantGun AMR -> amr @@ -175,22 +171,18 @@ baseToFamily ibt = case ibt of SMG -> HeldFamily BANGCONE -> HeldFamily BLUNDERBUSS -> HeldFamily - BIGBLUNDERBUSS -> HeldFamily - BIGGERBLUNDERBUSS -> HeldFamily - BIGGESTBLUNDERBUSS -> HeldFamily --- | GRAPESHOTCANNON -> HeldFamily + GRAPECANNON _ -> HeldFamily -- | GRENADELAUNCHER In-> HeldFamilyt -- number of chambers that can be reloaded -- | MORTARCONE / HANDM-> HeldFamilyORTAR - BANGCANE -> HeldFamily -- | MINIGUN -> HeldFamily MINIGUNX _ -> HeldFamily - BANGCANEX _ -> HeldFamily + VOLLEYGUN _ -> HeldFamily RIFLE -> HeldFamily REPEATER -> HeldFamily AUTORIFLE -> HeldFamily BURSTRIFLE -> HeldFamily - FASTBURSTRIFLE -> HeldFamily - COMPLETEBURSTRIFLE -> HeldFamily +-- FASTBURSTRIFLE -> HeldFamily +-- COMPLETEBURSTRIFLE -> HeldFamily BANGROD -> HeldFamily ELEPHANTGUN -> HeldFamily AMR -> HeldFamily diff --git a/src/Dodge/Item/Random.hs b/src/Dodge/Item/Random.hs index 226a96375..30d7ed36d 100644 --- a/src/Dodge/Item/Random.hs +++ b/src/Dodge/Item/Random.hs @@ -5,4 +5,4 @@ import Dodge.Item.Weapon.BulletGuns randBlockBreakWeapon :: RandomGen g => State g Item -randBlockBreakWeapon = takeOne [bangStick 1,bangCane] +randBlockBreakWeapon = takeOne [bangStick 1] diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 7db131418..4f1c71c52 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -433,7 +433,7 @@ basicBeamAt itid w col dam phasev pos dir = Beam , _bmType = BeamCombine $ const id } where - (_,ps) = reflectLaserAlong phasev [] pos (pos +.+ 800 *.* unitVectorAtAngle dir) w + (_,ps) = reflectLaserAlong phasev pos (pos +.+ 800 *.* unitVectorAtAngle dir) w dualRayAt :: BeamType -> Int -> World -> Color -> Int -> Float -> Point2 -> Float -> Beam dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev pos dir diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Weapon/BulletGun/Cane.hs index 51c235b51..de65ea1e9 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Cane.hs @@ -1,12 +1,11 @@ module Dodge.Item.Weapon.BulletGun.Cane - ( bangCane - , bangCaneX + ( volleyGun , repeater , rifle , autoRifle , burstRifle - , completeBurstRifle - , fastBurstRifle +-- , completeBurstRifle +-- , fastBurstRifle , miniGunX ) where --import Dodge.Particle.Bullet.HitEffect @@ -31,14 +30,8 @@ import Shape import Sound.Data import LensHelp ---import qualified Data.Map.Strict as M ---import qualified Data.Sequence as Seq ---import Control.Lens ---import Control.Monad.State ---import System.Random - -bangCane :: Item -bangCane = defaultBulletWeapon +defaultBangCane :: Item +defaultBangCane = defaultBulletWeapon { _itParams = BulletShooter { _muzVel = 0.8 , _rifling = 0.9 @@ -72,11 +65,11 @@ bangCane = defaultBulletWeapon <> makeSingleClipAt (V3 5 0 3) it } } & itUse . useAim . aimStance .~ OneHand - & itType . iyBase .~ BANGCANE + & itType . iyBase .~ error "undefined bangCane baseitemtype" & itConsumption . laMax .~ 1 & itConsumption . laCycle .~ [loadPartialInsert 10 1] -bangCaneX :: Int -> Item -bangCaneX i = defaultBulletWeapon +volleyGun :: Int -> Item +volleyGun i = defaultBulletWeapon & itUse .~ ruseAmmoParamsRate 6 upHammer [ ammoHammerCheck , useTimeCheck @@ -123,7 +116,7 @@ bangCaneX i = defaultBulletWeapon ,_brlInaccuracy = 0.1 } & itParams . torqueAfter .~ 0.48 + 0.2 * fromIntegral i - & itType . iyBase .~ BANGCANEX i + & itType . iyBase .~ VOLLEYGUN i caneStickSoundChoice :: Item -> SoundID caneStickSoundChoice it | _laLoaded (_itConsumption it) < 2 = tap3S @@ -136,7 +129,7 @@ caneClipX i it = case it ^? itConsumption . laLoaded of [0..la-1] _ -> mempty rifle :: Item -rifle = bangCane +rifle = defaultBangCane { _itDimension = ItemDimension { _dimRad = 8 , _dimCenter = V3 5 0 0 @@ -195,41 +188,41 @@ burstRifle = repeater , withMuzFlareI , withRecoil ] -fastBurstRifle :: Item -fastBurstRifle = repeater - & itType . iyBase .~ FASTBURSTRIFLE - & itParams . gunBarrels . brlInaccuracy .~ 0.06 - & itUse . useDelay . rateMax .~ 18 - & itUse . useMods .~ - [ ammoHammerCheck - , useTimeCheck - , sideEffectOnFrame 9 (torqueSideEffect 0.4) - , lockInvFor 9 - , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8]) f it - , withSoundStart tap3S - , useAmmoAmount 1 - , applyInaccuracy - , withMuzFlareI - , withRecoil - ] -completeBurstRifle :: Item -completeBurstRifle = repeater - & itType . iyBase .~ COMPLETEBURSTRIFLE - & itType . iyModules . at ModRifleMag .~ Nothing - & itParams . gunBarrels . brlInaccuracy .~ 0.1 - & itUse . useDelay . rateMax .~ 28 - & itUse . useMods .~ - [ ammoHammerCheck - , useTimeCheck - , sideEffectOnFrame 15 (torqueSideEffect 0.8) - , lockInvFor 15 - , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [1..14]) f it - , withSoundStart tap3S - , useAmmoAmount 1 - , applyInaccuracy - , withMuzFlareI - , withRecoil - ] +--fastBurstRifle :: Item +--fastBurstRifle = repeater +-- & itType . iyBase .~ FASTBURSTRIFLE +-- & itParams . gunBarrels . brlInaccuracy .~ 0.06 +-- & itUse . useDelay . rateMax .~ 18 +-- & itUse . useMods .~ +-- [ ammoHammerCheck +-- , useTimeCheck +-- , sideEffectOnFrame 9 (torqueSideEffect 0.4) +-- , lockInvFor 9 +-- , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8]) f it +-- , withSoundStart tap3S +-- , useAmmoAmount 1 +-- , applyInaccuracy +-- , withMuzFlareI +-- , withRecoil +-- ] +--completeBurstRifle :: Item +--completeBurstRifle = repeater +-- & itType . iyBase .~ COMPLETEBURSTRIFLE +-- & itType . iyModules . at ModRifleMag .~ Nothing +-- & itParams . gunBarrels . brlInaccuracy .~ 0.1 +-- & itUse . useDelay . rateMax .~ 28 +-- & itUse . useMods .~ +-- [ ammoHammerCheck +-- , useTimeCheck +-- , sideEffectOnFrame 15 (torqueSideEffect 0.8) +-- , lockInvFor 15 +-- , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [1..14]) f it +-- , withSoundStart tap3S +-- , useAmmoAmount 1 +-- , applyInaccuracy +-- , withMuzFlareI +-- , withRecoil +-- ] miniGunUse :: Int -> ItemUse miniGunUse i = ruseInstant (useAmmoParams $ Just 1) NoHammer $ [ ammoCheckI diff --git a/src/Dodge/Item/Weapon/BulletGuns.hs b/src/Dodge/Item/Weapon/BulletGuns.hs index 6107c1984..3781caaa4 100644 --- a/src/Dodge/Item/Weapon/BulletGuns.hs +++ b/src/Dodge/Item/Weapon/BulletGuns.hs @@ -1,9 +1,7 @@ module Dodge.Item.Weapon.BulletGuns ( bangCone , blunderbuss - , bigBlunderbuss - , biggerBlunderbuss - , biggestBlunderbuss + , grapeCannon , grenadeLauncher , autogunSpread , autoGun @@ -164,30 +162,14 @@ blunderbuss = bangCone & itUse . useAim . aimStance .~ TwoHandTwist & itUse . useAim . aimWeight .~ 6 & itType . iyBase .~ BLUNDERBUSS -bigBlunderbuss :: Item -bigBlunderbuss = blunderbuss - & itType . iyBase .~ BIGBLUNDERBUSS - & itConsumption . laMax .~ 50 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 40 , loadPrime 5] - & itParams . recoil .~ 200 - & itParams . torqueAfter .~ 0.3 - & itParams . randomOffset .~ 16 -biggerBlunderbuss :: Item -biggerBlunderbuss = bigBlunderbuss - & itType . iyBase .~ BIGGERBLUNDERBUSS - & itConsumption . laMax .~ 75 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 50 , loadPrime 5] - & itParams . recoil .~ 250 - & itParams . torqueAfter .~ 0.5 - & itParams . randomOffset .~ 20 -biggestBlunderbuss :: Item -biggestBlunderbuss = biggerBlunderbuss - & itType . iyBase .~ BIGGESTBLUNDERBUSS - & itConsumption . laMax .~ 100 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 60 , loadPrime 5] - & itParams . recoil .~ 300 - & itParams . torqueAfter .~ 0.7 - & itParams . randomOffset .~ 24 +grapeCannon :: Int -> Item +grapeCannon i = blunderbuss + & itType . iyBase .~ GRAPECANNON i + & itConsumption . laMax .~ 25 + 25 * i + & itConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10) , loadPrime 5] + & itParams . recoil .~ (150 + fromIntegral i * 50) + & itParams . torqueAfter .~ (0.1 + 0.2 * fromIntegral i) + & itParams . randomOffset .~ (12 + 4 * fromIntegral i) grenadeLauncher :: Int -> Item grenadeLauncher _ = bangCone diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index 1c4c36ac7..0a95db6fc 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -195,7 +195,7 @@ targetLaserUpdate _ cr w t & tgActive .~ False ) where - (mp, ps) = reflectLaserAlong 0.2 [] sp ep w + (mp, ps) = reflectLaserAlong 0.2 sp ep w sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr) ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp) addLaserPic = instantParticles .:~ Particle diff --git a/src/Dodge/Item/Weapon/LaserPath.hs b/src/Dodge/Item/Weapon/LaserPath.hs index 6ca136ebd..e46715cd8 100644 --- a/src/Dodge/Item/Weapon/LaserPath.hs +++ b/src/Dodge/Item/Weapon/LaserPath.hs @@ -11,27 +11,29 @@ import Geometry --import Data.List import Data.Bifunctor import Data.Tuple -import Streaming -import qualified Streaming.Prelude as S +--import Streaming +--import qualified Streaming.Prelude as S -- not sure why we need to keep a list of seen walls, but seems to loop -- infinitely when removed -- this needs to be tested with both reflections and refractions -reflectLaserAlong :: Float -> [Wall] -> Point2 -> Point2 -> World +-- the distance of the laser should be limited +reflectLaserAlong :: Float -> Point2 -> Point2 -> World -> (Maybe (Point2,Either Creature Wall),[Point2]) -reflectLaserAlong phasev seenWl sp ep w = case runIdentity . S.head_ . S.dropWhile (notseen seenWl) - $ thingsHitExceptCr Nothing sp ep w of +reflectLaserAlong phasev sp ep w = case thingHit sp ep w of Just (p,Right wl) - | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p - (p +.+ 800 *.* unitVectorAtAngle (reflDirWall sp p wl)) w - | wlIsSeeThrough wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p - (refract sp ep wl p) w + | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev + (p +.+ unitVectorAtAngle (reflDirWall sp p wl)) + (p +.+ (dist p ep) *.* unitVectorAtAngle (reflDirWall sp p wl)) + w + | wlIsSeeThrough wl && _wlSeen wl -> second (p:) $ reflectLaserAlong phasev + (p +.+ normalizeV (refract sp ep wl p)) + (refract sp ep wl p) + w | otherwise -> (Just (p,Right wl), [p]) Just (p,obj) -> (Just (p,obj), [p]) Nothing -> (Nothing, [ep]) where - notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws - notseen _ _ = True refract x y wl p | isEntering = p +.+ rotateV angleRef (normalDist wlNormal) | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal') diff --git a/src/Dodge/Layout.hs.orig b/src/Dodge/Layout.hs.orig new file mode 100644 index 000000000..66cd5fa4e --- /dev/null +++ b/src/Dodge/Layout.hs.orig @@ -0,0 +1,267 @@ +--{-# LANGUAGE TupleSections #-} +module Dodge.Layout + ( generateLevelFromRoomList + ) where +import Data.Tile +import Dodge.Data +import Dodge.Path +import Dodge.Zone.Update +import Dodge.ShiftPoint +import Dodge.Placement.PlaceSpot +--import Dodge.LevelGen.Data +import Dodge.LevelGen.StaticWalls +import Dodge.LevelGen.LevelStructure +import Dodge.Wall.Zone +import Dodge.GameRoom +import Dodge.Default.Wall +import Dodge.Room.Link +import Dodge.Randify +import Geometry +--import Geometry.ConvexPoly +import qualified IntMapHelp as IM +import Tile +import RandomHelp + +import Data.Graph.Inductive (labNodes,labEdges) +import Data.List (nubBy) +import Data.Traversable +import Control.Lens +import Data.Foldable +import qualified Control.Foldl as L +import Data.Maybe +import Data.Function + +generateLevelFromRoomList :: IM.IntMap Room -> World -> World +generateLevelFromRoomList gr' w = initWallZoning + . randomCompass + . setupWorldBounds + . doAfterPlacements + . doInPlacements + . doOutPlacements + . doIndividualPlacements + . setFloors + . worldToGenWorld rs' + $ w { _walls = wallsFromRooms rs + , _gameRooms = gameRoomsFromRooms (IM.elems rs') + , _pathGraph = path + , _pathGraphP = pairPath + } + & pnZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) +<<<<<<< HEAD + (labNodes (_pgGraph path))) + & peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) + (labEdges (_pgGraph path))) + where + path = pairsToGraph pairPath +======= + (labNodes path)) + & peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) + (labEdges path)) + where + (_,path) = pairsToGraph pairPath +>>>>>>> efficientRuntime + pairPath = foldMap _rmPath rs + rs = map doRoomShift $ IM.elems rs' + rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w + +randomCompass :: World -> World +randomCompass w = w & cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w) + +putFloorTiles :: World -> World +putFloorTiles gw = gw & floorTiles .~ floorsFromGenWorld gw + +setFloors :: World -> World +setFloors = putFloorTiles . setTiles + +-- note the order of traversal of the rooms is important +-- hence the reverse +-- this is not ideal: should do this in some more sensible way +setTiles :: World -> World +setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw + +setTile :: Room -> World -> World +setTile r gw = case _rmFloor r of + Tiled {} -> gw + InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly] + where + t = case _rmMParent r of + Nothing -> Tile poly (V2 0 0) (V2 1 0) 16 + Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid + poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat $ _rmPolys r + +shuffleRoomPos :: RandomGen g => Room -> State g Room +shuffleRoomPos rm = do + newPos <- shuffle $ _rmPos rm + return $ rm & rmPos .~ newPos + +doAfterPlacements :: World -> World +doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw) + +doAfterPlacement :: [(Placement,Int)] -> World -> World +doAfterPlacement pmntis gw = gRandify gw $ do + (pmnt,i) <- takeOne pmntis + let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt + return $ newgw & genRooms . ix i .~ rm + +doInPlacements :: ( IM.IntMap [Placement],World) -> World +doInPlacements (im,w) = + let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w) + in gw & genRooms .~ rms + +doRoomInPlacements :: IM.IntMap [Placement] -> World -> Room -> (World, Room) +doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm + where + f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i) + +doOutPlacements :: World -> ( IM.IntMap [Placement], World) +doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w) + in (pmnts,gw & genRooms .~ rms) + +doRoomOutPlacements :: (IM.IntMap [Placement], World) + -> Room + -> ( (IM.IntMap [Placement], World) , Room ) +doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r + where + f (OutPlacement pl i) ( (im,w) , rm ) = + let ((neww,newrm),plmnts) = placeSpot (w,rm) pl + in ((IM.insert i plmnts im, neww) , newrm ) + +doIndividualPlacements :: World -> World +doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw) + in gw' & genRooms .~ rms + +doRoomPlacements :: World -> Room -> (World, Room) +doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm + +setupWorldBounds :: World -> World +setupWorldBounds w = w & worldBounds %~ + ( (bdMinX .~ f minx) + . (bdMaxX .~ f maxx) + . (bdMinY .~ f miny) + . (bdMaxY .~ f maxy) + ) + where + f = fromMaybe 0 + ps = IM.map (fst . _wlLine) $ _walls w + (minx,maxx,miny,maxy) = L.fold ((,,,) + <$> L.premap fstV2 L.minimum + <*> L.premap fstV2 L.maximum + <*> L.premap sndV2 L.minimum + <*> L.premap sndV2 L.maximum + ) ps + +--polyhedrasToEdges :: [Polyhedra] -> [Point3] +--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges + +initWallZoning :: World -> World +initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w) + +--makePath :: Tree Room -> [(Point2,Point2)] +--makePath = concatMap _rmPath . flatten + +wallsFromRooms :: [Room] -> IM.IntMap Wall +wallsFromRooms = -- divideWalls . + IM.fromAscList + . zipWith f [0..] + . removeInverseWalls + . foldl' (flip cutWalls) [] + . concatMap _rmPolys + where + f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i}) + +-- TODO sort out shifting before or after etc +gameRoomsFromRooms :: [Room] -> [GameRoom] +gameRoomsFromRooms = fmap gameRoomFromRoom + +gameRoomFromRoom :: Room -> GameRoom +gameRoomFromRoom rm = GameRoom + { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) + ++ mapMaybe filterUnusedLinks (_rmPos rm) + , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm) + , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints + . concat $ _rmBound rm ++ _rmPolys rm + , _grDir = getDir $ _rmPos rm + , _grLinkDirs = mapMaybe undir $ _rmPos rm + , _grName = _rmName rm + } + where + doshift = shiftPointBy (_rmShift rm) + doubleShift p a = map doshift + [p +.+ 10 *.* unitVectorAtAngle a + ,p -.- 10 *.* unitVectorAtAngle a + ] + filterUnusedLinks rp = case _rpLinkStatus rp of + UnusedLink{} -> Just $ _rpPos rp + _ -> Nothing + filterUsedLinks rp = case _rpLinkStatus rp of + UsedOutLink{} -> doubleShift (_rpPos rp) (_rpDir rp) + UsedInLink{} -> doubleShift (_rpPos rp) (_rpDir rp) + _ -> [] + undir rp = case _rpLinkStatus rp of + UsedOutLink{} -> ma + UsedInLink{} -> ma + _ -> Nothing + where + ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm) + closePoints x y = roundPoint2 x == roundPoint2 y + getDir (rp:xs) = case _rpLinkStatus rp of + UsedInLink {} -> _rpDir rp + snd (_rmShift rm) + _ -> getDir xs + getDir _ = 0 -- fallback + +floorsFromRooms :: [Room] -> [(Point3,Point3)] +floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift) + +floorsFromGenWorld :: World -> [(Point3,Point3)] +floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms + +getTiles :: Floor -> [Tile] +getTiles fl = case fl of + Tiled xs -> xs + _ -> error "tiles not correctly set for some room" + +--divideWall :: Wall -> [Wall] +--divideWall wl +-- = let (a,b) = _wlLine wl +-- ps = divideLine (zoneSize * 2) a b +-- in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps) + +--divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall +--divideWallIn wl wls = +-- let (wl':newWls) = divideWall wl +-- k = IM.newKey wls +-- newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls +-- in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls') +-- +--divideWalls :: IM.IntMap Wall -> IM.IntMap Wall +--divideWalls wls = foldl' (flip divideWallIn) wls wls + +--insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a) +--insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj +-- where f _ = IM.insert y obj + +--shiftRoomTree :: Tree Room -> Tree Room +--shiftRoomTree (Node t []) = Node t [] +--shiftRoomTree (Node t ts) = Node t +-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) +-- (_rmLinks t) +-- ts + +--shiftRoomTreeConstruction :: Tree Room -> [Tree Room] +--shiftRoomTreeConstruction (Node t []) = [Node t []] +--shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $ +-- zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f)) +-- (_rmLinks t) +-- ts +-- where +-- f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r +-- where +-- (p,a) = last $ _rmLinks r + +--addTile :: Float -> Room -> Room +--addTile z r +-- | not (null (_rmFloor r)) || null rp = r +-- | otherwise = r & rmFloor .~ [makeTileFromPoly poly z] +-- where +-- rp = _rmPolys r +-- poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index fd1e3e591..d19ef4027 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -24,10 +24,11 @@ import qualified Data.Text.IO as TIO generateWorldFromSeed :: Int -> IO World generateWorldFromSeed i = do createDirectoryIfMissing True "log" + createDirectoryIfMissing True "graph" writeFile "log/attemptedSeeds" "" writeFile "log/treeCluster" "" writeFile "log/aGeneratedRoomLayout" "" - TIO.writeFile "log/itemCombinations.gv" combinationsDotGraph + generateGraphs (roomList,bounds) <- layoutLevelFromSeed 0 i return $ saveLevelStartSlot $ postGenerationProcessing @@ -37,6 +38,9 @@ generateWorldFromSeed i = do postGenerationProcessing :: World -> World postGenerationProcessing w = foldl' assignPushDoors w (_doors w) +generateGraphs :: IO () +generateGraphs = TIO.writeFile "graph/itemCombinations.gv" combinationsDotGraph + assignPushDoors :: World -> Door -> World assignPushDoors w dr = case dr ^?! drPushedBy of PushedBy i -> w & doors . ix i . drPushes ?~ _drID dr diff --git a/src/Dodge/Path.hs.orig b/src/Dodge/Path.hs.orig new file mode 100644 index 000000000..3357d59e8 --- /dev/null +++ b/src/Dodge/Path.hs.orig @@ -0,0 +1,250 @@ +--{-# LANGUAGE TupleSections #-} +module Dodge.Path + ( pointTowardsImpulse + , makePathBetween + , makePathBetweenPs +<<<<<<< HEAD + , pairsToGraph + , walkableNodeNear + , nodesNearL + , getNodePos + , addObstacleCrossing' +======= +-- , removePathsCrossing + , obstructPathsCrossing + , pairsToGraph + , getNodePos + , walkableNodeNear +>>>>>>> efficientRuntime + ) where +import Dodge.Data +import Dodge.Base.Collide +import Dodge.Zone +import Geometry.Data +import Geometry + +import Control.Lens +import Data.Maybe +import Data.List +--import qualified Data.IntMap.Strict as IM +import Data.Graph.Inductive hiding ((&)) +import Data.Set (Set) +import qualified Data.Set as Set +<<<<<<< HEAD +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +======= +import qualified Data.Map.Strict as M +import Data.Map.Strict (Map) +import StreamingHelp +>>>>>>> efficientRuntime +import qualified Streaming.Prelude as S +import StreamingHelp +--import Data.Graph.Inductive.PatriciaTree +--import Data.Graph.Inductive.Graph hiding ((&)) + +getNodePos :: Int -> World -> Maybe Point2 +<<<<<<< HEAD +getNodePos i w = _pgGraph (_pathGraph w) `lab` i + +makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] +makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) + (na,_) <- walkableNodeNear a w + (nb,_) <- walkableNodeNear b w + sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w) + where + noobstacle (_,_,PathEdge _ _ s) = null s + +pathDist :: PathEdge -> Float +pathDist pe = dist (_peStart pe) (_peEnd pe) + +walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2) +{-# INLINE walkableNodeNear #-} +walkableNodeNear p w = minStreamOn (dist p . snd) + . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w + +nodesNear :: Point2 -> World -> StreamOf (Int,Point2) +{-# INLINE nodesNear #-} +nodesNear = aroundPoint _pnZoning + +nodesNearL :: Point2 -> World -> [(Int,Point2)] +nodesNearL p = runIdentity . S.toList_ . nodesNear p +======= +getNodePos i w = _pathGraph w `lab` i + +makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] +makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) + na <- walkableNodeNear w a + nb <- walkableNodeNear w b + sp na nb (second _peDist (_pathGraph w)) + where + --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w) +-- nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w +-- walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p + +walkableNodeNear :: World -> Point2 -> Maybe Int +{-# INLINE walkableNodeNear #-} +walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear + where + --nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w + nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w +>>>>>>> efficientRuntime + +makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] +makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w + +pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 +pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w + +------ continues a walk from a list of points, without repetitions +------ supposes that the list is non-empty +--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] +--randomGraphWalk (n:ns) g = do +-- next' <- randomGraphStepRestricted n ns g +-- case next' of +-- Nothing -> return (n:ns) +-- Just n' -> randomGraphWalk (n':n:ns) g +--randomGraphWalk _ _ = error "Trying to walk in an empty list" +-- +--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 +--randomPointXStepsFrom i p w = +-- let g = _pathGraph w +-- ns = labNodes g +-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns +-- in case mp of +-- Nothing -> p +-- Just (n,_) -> fromJust +-- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) +-- +--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] +--randomPointsXStepsFrom i p w = +-- let g = _pathGraph w +-- ns = labNodes g +-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns +-- in case mp of +-- Nothing -> [p] +-- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) +-- +--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) +--randomGraphStep n g = +-- do let ns = neighbors g n +-- i <- state $ randomR (0,length ns - 1) +-- case ns of [] -> return Nothing +-- _ -> return $ Just $ ns !! i +--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) +--randomGraphStepRestricted n notns g = do +-- let ns = neighbors g n \\ notns +-- i <- state $ randomR (0,length ns - 1) +-- case ns of +-- [] -> return Nothing +-- _ -> return $ Just $ ns !! i +-- +<<<<<<< HEAD + +pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph +pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap + where + (gr,nodemap,ncount) = insertNodes pairset + (gr',edgemap) = insertEdges toPathEdge gr nodemap pairset + +toPathEdge :: Point2 -> Point2 -> PathEdge +toPathEdge sp' ep = PathEdge sp' ep mempty + +insertEdges :: (Point2 -> Point2 -> b) + -> Gr Point2 b -> Map Point2 Int + -> Set (Point2,Point2) + -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b)) +insertEdges efunc gr nm = runIdentity . S.fold_ (insertEdge efunc nm) (gr,mempty) id . S.each + +insertEdge :: Ord a => (a -> a -> c) -> Map a Int -> (Gr b c,Map (V2 a) (Int,Int,c)) + -> (a,a) + -> (Gr b c,Map (V2 a) (Int,Int,c)) +insertEdge efunc nm (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr' + , M.insert (V2 a b) (f a,f b,efunc a b) em) + where + f x = nm M.! x + +insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int) +insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream + where + nodestream :: StreamOf Point2 + nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset + getnode strm (x,y) = Set.insert x $ Set.insert y strm + insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int) + insertnode (gr,nm,i) n = case M.lookup n nm of + Nothing -> (insNode (j,n) gr, M.insert n j nm, j) + Just _ -> (gr,nm,i) + where + j = i + 1 + +--pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b +--pairsToGraph f pairs = undir +-- $ run_ Data.Graph.Inductive.empty +-- $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs') +-- where +-- nodes' = Set.map fst pairs `Set.union` Set.map snd pairs +-- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs + +addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 + -> Gr Point2 PathEdge + -> Gr Point2 PathEdge +addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths + where + updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs)) + $ delEdge (xi,yi) gr' + paths = S.filter f $ nearSeg _peZoning a b w + f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b + +addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 + -> World + -> World +addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b +======= +pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge) +pairsToGraph pairs = addEdges nodemap gr $ S.each pairs + where + (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs) +-- let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs +-- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs +-- in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs') + +addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge) +addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id + where + f (nodemap,i,gr) p = case nodemap M.!? p of + Just _ -> (nodemap,i,gr) + Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr) +addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) + -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge) +addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id + where + f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap + , insEdge theedge gr' + ) + where + theedge = (g a,g b,PathEdge a b (dist a b) mempty) + g a = nodemap M.! a + +obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)]) +obstructPathsCrossing sp ep w = + ( w & pathGraph %~ updateedges + , runIdentity $ S.toList_ edges + ) + where + edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w + edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe) + updateedges gr = runIdentity $ S.fold_ updateedge gr id edges + updateedge gr (x,y,pe) + = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr + +removePathsCrossing :: Point2 -> Point2 -> World -> World +removePathsCrossing a b w = w +-- & pathGraph .~ newGraph +-- & pathGraphP .~ pg' +-- & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) +-- (labNodes newGraph) +-- where +-- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w +-- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp] +-- newGraph = pairsToGraph pg' +>>>>>>> efficientRuntime diff --git a/src/Dodge/Placement/PlaceSpot.hs.orig b/src/Dodge/Placement/PlaceSpot.hs.orig new file mode 100644 index 000000000..7537c2419 --- /dev/null +++ b/src/Dodge/Placement/PlaceSpot.hs.orig @@ -0,0 +1,203 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +-- | deals with placement of objects within the world +-- after they have had their coordinates set by the layout +module Dodge.Placement.PlaceSpot + ( placeSpot + ) where +import Dodge.Placement.Shift +import Dodge.Data +import Dodge.Path +import Dodge.Placement.PlaceSpot.Block +import Dodge.Placement.PlaceSpot.TriggerDoor +import Dodge.Default.Wall +import Dodge.ShiftPoint +import Dodge.Base.NewID +import Geometry +import qualified IntMapHelp as IM +import Color + +import Data.Foldable +import Data.Maybe +import System.Random +import Control.Monad.State +import Control.Lens +import qualified Data.IntSet as IS +import Data.Bifunctor + +-- when placing a placement, we update the world and the room and assign an id +-- to the placement +placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] ) +placeSpot (w,rm) plmnt = case plmnt of + Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w + Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback + Placement{} -> placePlainPSSpot w rm plmnt shift + PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) + RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm + PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), []) + where + shift = _rmShift rm + +placePickOne :: Int -> Placement -> Room -> World -> World +placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))] + +placeRandomPlacement :: State StdGen Placement -> World -> Room -> ((World,Room),[Placement]) +placeRandomPlacement rplmnt w rm = placeSpot (w & randGen .~ g,rm) plmnt' + where + (plmnt', g) = runState rplmnt (_randGen w) + +placePlainPSSpot :: World -> Room -> Placement -> DPoint2 -> ((World,Room),[Placement]) +placePlainPSSpot w rm plmnt shift = + let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w + newplmnt = plmnt & plMID ?~ i + in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt) + where + recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl + in (wr,newplmnt:newplmnts) + +-- this should be tidied up +placeSpotUsingLink :: World + -> Room + -> Placement + -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) + -> (RoomPos -> Room -> Room) + -> Maybe Placement + -> ((World, Room), [Placement]) +placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of + Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) + Nothing -> case fallback of + Nothing -> ((w,rm),[plmnt]) + Just plmnt' -> placeSpot (w,rm) plmnt' + where + searchedPoss [] = Nothing + searchedPoss (pos:poss) = case extract pos rm of + Nothing -> second (pos:) <$> searchedPoss poss + Just (ps,rmpos) -> Just ( ps,rmpos:poss) + +placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) + -> Placement -> World -> ((World,Room),[Placement]) +placeSpotRoomRand rm i f plmnt w = + let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w + in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps) + +-- the Int here is some id that is assigned when the placement is placed +placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) +placeSpotID ps pt w = case pt of + PutTrigger cnd -> plNewID triggers cnd w + PutMod mdi -> plNewUpID modifications mdID mdi w + PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w + PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w + 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 + RandPS rgn -> evaluateRandPS rgn ps w + PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w + PutCoord cp -> plNewID coordinates (doShift cp) w + PutSlideDr wl dr off a b + -> plSlideDoor wl dr off (doShift a) (doShift b) w + PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) + wl w + PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w + PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) + PutNothing -> (0,w) + PutID i -> (i, w) + PutWorldUpdate f -> (0, w & f ps) + PutUsingGenParams f -> let (w',pt') = f w + in placeSpotID ps pt' w' + where + p@(V2 px py) = _psPos ps + p' = V3 px py 0 + rot = _psRot ps + doShift = shiftPointBy (p,rot) + +evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) +evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) + where + (evaluatedType, g) = runState rgen (_randGen w) + +placeWallPoly :: [Point2] -> Wall -> World -> World +<<<<<<< HEAD +--placeWallPoly ps wl = over walls (placeWalls ps wl) +placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) + where + rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) w $ loopPairs ps +======= +placeWallPoly ps wl = -- rmCrossPaths . + over walls (placeWalls ps wl) +-- where +-- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps +>>>>>>> efficientRuntime + +placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall +placeWalls qs wl wls = foldl' (addPane wl) wls pairs + where + (p:ps) = orderPolygon qs + pairs = zip (ps ++ [p]) (p:ps) + +addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall +addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls + where + wlid = IM.newKey wls + +---- | place an new object into an intmap and update its id +--plNewUpID :: ALens' World (IM.IntMap a) +-- -> ALens' a Int +-- -> a +-- -> World +-- -> (Int,World) +--plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) +-- where +-- i = IM.newKey $ w ^# l + +mvProp :: Point2 -> Float -> Prop -> Prop +mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a )) + +mvButton :: Point2 -> Float -> Button -> Button +mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) + +{- Creates a floor item at a given point.-} +createFlIt :: Point2 -> Float -> Item -> FloorItem +createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm } + +mvPP :: Point2 -> Float -> PressPlate -> PressPlate +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 + & walls %~ placeMachineWalls color wallpoly mcid wlid + ) + where + color = _mcColor mc + w' = gw + mcid = IM.newKey $ _machines w' + wlid = IM.newKey $ _walls w' + wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] + --addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) + addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) + +-- TODO correctly remove/shift pathfinding lines (removePathsCrossing) +placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall +placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly + where + f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} + baseWall = defaultMachineWall + & wlColor .~ col + & wlStructure . wsMachine .~ mcid + & wlTouchThrough .~ True + +mvLS :: Point3 -> Float -> LightSource -> LightSource +mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos + & lsDir .~ rot + where + startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs.orig b/src/Dodge/Placement/PlaceSpot/Block.hs.orig new file mode 100644 index 000000000..aec26323e --- /dev/null +++ b/src/Dodge/Placement/PlaceSpot/Block.hs.orig @@ -0,0 +1,126 @@ +{- | Creation, update and destruction of destructible walls. -} +module Dodge.Placement.PlaceSpot.Block + ( plBlock + , plLineBlock + ) + where +import Dodge.Data +import Dodge.Path +import Dodge.Block.Debris +--import Dodge.LevelGen.LevelStructure +import Dodge.Base +--import Dodge.Zone +import Geometry +import qualified IntMapHelp as IM + +import Control.Lens +import qualified Data.IntSet as IS + +plBlock + :: [Point2] -- ^ Block polygon + -> Block + -> Wall -- ^ Base Pane + -> World + -> (Int,World) +plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" +plBlock (p:ps) bl wl w = (,) blid $ w +<<<<<<< HEAD + & flip (foldr insertWall) wls +======= +>>>>>>> efficientRuntime + & blocks . at blid ?~ bl + { _blID = blid + , _blWallIDs = IS.fromList is + , _blShadows = [] + , _blFootprint = p:ps + } +<<<<<<< HEAD +======= + & insertWalls blid wls +>>>>>>> efficientRuntime + where + blid = IM.newKey $ _blocks w + lns = zip (p:ps) (ps ++ [p]) + i = IM.newKey $ _walls w + is = [i.. i + length lns-1] + wls = zipWith + (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) + is + lns + +{- | Splits a line into many four cornered blocks. -} +plLineBlock + :: Wall -- ^ Base pane + -> Float + -> Point2 -- ^ Start point (symmetric) + -> Point2 -- ^ End point (symmetric) + -> World + -> (Int, World) +plLineBlock basePane blwidth a b gw = ( 0 +<<<<<<< HEAD + , foldr insertWall (insertBlocks gw) listWalls +======= +-- , foldr insertWall (insertBlocks gw) listWalls + , insertBlocks gw +>>>>>>> efficientRuntime + ) + where + depth = blwidth + psOnLine = divideLineOddNumPoints blwidth a b + halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) + blockCenPs = snd $ evenOddSplit psOnLine + numBlocks = length blockCenPs + is = [0.. numBlocks - 1] + cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block + cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints + linesAt p = loopPairs $ cornersAt p + wlid = IM.newKey $ _walls gw + blid = IM.newKey $ _blocks gw + insertBlock (i,p) = + insertWalls (i + blid) (makeWallAt p i) + . (over blocks $ IM.insert (i+blid) Block + { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i + , _blHP = 1000, _blShadows = shadowsAt i + , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning + , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) + , _blObstructs = [] +<<<<<<< HEAD +======= + , _blPaths = [] +>>>>>>> efficientRuntime + , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris} + ) + insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs + ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] + visibilityAt i + | i == 0 = [False,True,True ,True] + | i == numBlocks - 1 = [True ,True,False,True] + | otherwise = [False,True,False,True] + shadowsAt i + | i == 0 = ksAtI 1 + | i == numBlocks - 1 = ksAtI $ numBlocks - 2 + | otherwise = ksAtI (i-1) ++ ksAtI (i+1) + makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) + makePane i visStatus k ps = basePane + {_wlID = k + ,_wlStructure = BlockPart $ i + blid + ,_wlLine = ps + ,_wlDraw = visStatus + } + listWalls = concat $ zipWith makeWallAt blockCenPs is + +<<<<<<< HEAD +insertWall :: Wall -> World -> World +insertWall wl = (walls . at (_wlID wl) ?~ wl) + . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl) +======= +-- | Must be done after inserting the block +insertWalls :: Int -> [Wall] -> World -> World +insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths + where + (w',paths) = mapAccumR (flip insertWall) w wls + +insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)]) +insertWall wl = uncurry obstructPathsCrossing (_wlLine wl) + . (walls . at (_wlID wl) ?~ wl) +>>>>>>> efficientRuntime diff --git a/src/Dodge/Placement/Random.hs b/src/Dodge/Placement/Random.hs index 9b5532e55..dbdd9a993 100644 --- a/src/Dodge/Placement/Random.hs +++ b/src/Dodge/Placement/Random.hs @@ -8,6 +8,6 @@ randFirstWeapon :: State StdGen Item randFirstWeapon = takeOne $ replicate 10 pistol ++ replicate 5 (bangStick 4) - ++ replicate 5 (bangCaneX 3) + ++ replicate 5 (volleyGun 3) ++ replicate 5 bangCone ++ [lasGun] diff --git a/src/Dodge/Render/ShapePicture.hs.orig b/src/Dodge/Render/ShapePicture.hs.orig new file mode 100644 index 000000000..87d34833c --- /dev/null +++ b/src/Dodge/Render/ShapePicture.hs.orig @@ -0,0 +1,392 @@ +module Dodge.Render.ShapePicture + ( worldSPic + ) where +import Dodge.Creature.Picture.Awareness +import Dodge.ShortShow +import Dodge.Config.Data +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 +import Dodge.Graph +import Dodge.GameRoom +import Dodge.Update.Camera +import Dodge.Item.Draw +import Dodge.Render.List +import Dodge.Path +--import Dodge.Zone +import Geometry +import Geometry.Zone +import ShapePicture +import Picture +import Sound.Data +import Geometry.ConvexPoly +--import Dodge.Base.Collide + +--import Data.Foldable +import qualified Data.IntMap.Strict as IM -- Lazy? +import qualified Data.Map.Strict as M +--import qualified Data.Set as Set +import Control.Lens +import Data.Maybe +import qualified Streaming.Prelude as S +import qualified Data.Graph.Inductive as FGL +import qualified Data.Set as Set + +-- TODO only filter out shapes outside the range of the furthest shown light source +worldSPic :: Configuration -> World -> SPic +worldSPic 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 (dbArg _cpPict) (filtOn _cpPos _corpses) + <> foldMap (dbArg _crPict) (filtOn _crPos _creatures) + <> foldMap floorItemSPic (filtOn _flItPos _floorItems) + <> foldMap btSPic (filtOn _btPos _buttons) + <> foldMap mcSPic (filtOn _mcPos _machines) + <> anyTargeting cfig w + where + filtOn f g = IM.filter (pointIsClose . f) (g w) + pointIsClose = cullPoint cfig w + +anyTargeting :: Configuration -> World -> SPic +anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr) + where + cr = you w + f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw) + +shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic +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) + | otherwise = dist (_cameraCenter w) p < _viewDistance w + +-- TODO filter out pictures not in the frame +extraPics :: Configuration -> World -> Picture +extraPics cfig w = pictures (_decorations w) + <> concatMapPic (dbArg _ptDraw) (_particles w) + <> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w) + <> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w) + <> concatMapPic (dbArg _lsPict) (_lightSources w) + <> testPic cfig w + <> _debugPicture w +-- <> runIdentity (S.foldMap_ clDraw (_clouds w)) + <> concatMapPic clDraw (_clouds w ) + <> concatMapPic ppDraw (_pressPlates w ) + <> viewClipBounds cfig w +<<<<<<< HEAD + <> debugDraw cfig w +======= +-- <> debugDraw cfig w +>>>>>>> efficientRuntime + +debugDraw :: Configuration -> World -> Picture +debugDraw cfig w = pic + <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) + where + (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig) + f (Left s) = ([s],mempty) + f (Right pic') = (mempty,pic') + +debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture +debugDraw' cfig w bl = case bl of + Noclip -> Left "Noclip" + Remove_LOS -> Left "No line of sight" + Cull_more_lights -> Left "Cull more lights" + Close_shape_culling -> Left "Close shape culling" + Bound_box_screen -> Left "bound box screen, this should be moved" + Show_ms_frame -> Right mempty + View_boundaries -> Right $ viewBoundaries w + Show_bound_box -> Right $ drawBoundingBox w + Show_wall_search_rays -> Right $ drawWallSearchRays w + Show_dda_test -> Right $ drawDDATest w + Show_far_wall_detect -> Right $ drawFarWallDetect w + Show_select -> Right $ drawWorldSelect w + Inspect_wall -> Right $ drawInspectWalls w + Cr_awareness -> Right $ drawCreatureDisplayTexts w + Show_sound -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> Right $ drawCrInfo cfig w + Mouse_position -> Right $ drawMousePosition cfig w + Walls_info -> Right $ drawWlIDs cfig w + Pathing -> Right $ drawPathing cfig w + Show_nodes_near_select -> Right $ drawNodesNearSelect w + Show_path_between -> Right $ drawPathBetween w + +drawCreatureDisplayTexts :: World -> Picture +drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w) + +drawPathBetween :: World -> Picture +drawPathBetween w = setLayer DebugLayer + $ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist) +<<<<<<< HEAD + <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0) + <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just) +======= + <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp) + <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep) +>>>>>>> efficientRuntime + where + nodepos = (`getNodePos` w) + nodelist = makePathBetween sp ep w + sp = _lSelect w + ep = _rSelect w + +drawNodesNearSelect :: World -> Picture +drawNodesNearSelect w = setLayer DebugLayer $ + runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp)) +<<<<<<< HEAD + <> color red (foldMap (drawCross . snd) $ nodesNearL sp w) + <> color green (drawCross sp) + <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w) +======= +-- <> color red (foldMap (drawCross . snd) $ nodesNearL sp w) + <> color green (drawCross sp) +-- <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w) +>>>>>>> efficientRuntime + where + sp = _lSelect w + +drawInspectWalls :: World -> Picture +drawInspectWalls w = foldMap (drawInspectWall w) + $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) + $ IM.elems $ _walls w + where + (a,b) = _lLine w + +drawInspectWall :: World -> Wall -> Picture +drawInspectWall _ wl = setLayer DebugLayer $ + color rose (thickLine 3 [a,b]) + <> foldMap (drawZone wlZoneSize) + (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl) -- this won't work if wlZoneSize is not consistent + 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]) + <> color magenta (line [c,d]) + where + (a,b) = _lLine w + (c,d) = _rLine w + +drawFarWallDetect :: World -> Picture +drawFarWallDetect w = setLayer DebugLayer + . color yellow + . concatMap (\q -> line + [ p + , fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg 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') + <> runIdentity (S.foldMap_ drawCross qs) + <> color blue (runIdentity (S.foldMap_ drawCross qs')) + <> setLayer DebugLayer (color yellow (line [cvf,mwp])) + where + cvf = _cameraViewFrom w + mwp = mouseWorldPos w + ps = ddaStreamX 50 cvf mwp + ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w) + qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w) + qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w) + +drawCross :: Point2 -> Picture +drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5 + +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 $ 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)] + +drawZone' :: Float -> V2 Int -> Picture +drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p]) + where + (p:ps) = zipWith (+.+) (map (2*.*) innerSquare) $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)] + +innerSquare :: [Point2] +innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)] + +drawWallSearchRays :: World -> Picture +drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w + where + f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) + <> line [_cameraViewFrom w, p] + +testPic :: Configuration -> World -> Picture +testPic _ _ = mempty + +drawBoundingBox :: World -> Picture +drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x] + where + (x:xs) = _boundBox w + +clDraw :: Cloud -> Picture +clDraw c = translate3 (_clPos c) (_clPict c c) +ppDraw :: PressPlate -> Picture +ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) + +floorItemSPic :: FloorItem -> SPic +floorItemSPic flit = uncurryV translateSPf (_flItPos flit) + $ rotateSP (_flItRot flit) (itSPic (_flIt flit)) + +btSPic :: Button -> SPic +btSPic bt = uncurryV translateSPf (_btPos bt) + $ rotateSP (_btRot bt) (_btPict bt bt) +mcSPic :: Machine -> SPic +mcSPic bt = uncurryV translateSPf (_mcPos bt) + $ rotateSP (_mcDir bt) (_mcDraw bt bt) + +soundPic :: Configuration -> World -> Sound -> Picture +soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w + where + p = _soundPos s + thePic + = rotate (_cameraRot w) + . scale theScale theScale + . centerText + . soundToOnomato + $ _soundChunkID s + theScale = 0.15 * f (_soundVolume s * 0.0001) + f x = 1 - 0.5 * (1 - x) + +drawMousePosition :: Configuration -> World -> Picture +drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ shortPoint2 mwp + where + p = worldPosToScreen w mwp + mwp = mouseWorldPos w + +drawWlIDs :: Configuration -> World -> Picture +drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) + where + f wl + | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test" + | otherwise = winScale cfig + . uncurryV translate p + . scale 0.1 0.1 + . text + $ show $ _wlID wl + where + p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl) + +edgeToPic :: [Point2] -> PathEdge -> Picture +edgeToPic poly pe + | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty + | null $ _peObstacles pe + = anarrow green + | hasobstacle BlockObstacle + = anarrow red + | hasobstacle AutoDoorObstacle = anarrow yellow + | otherwise = anarrow cyan + where + hasobstacle = (`Set.member` _peObstacles pe) + anarrow col = color col $ arrow sp ep + sp = _peStart pe + ep = _peEnd pe + +drawPathing :: Configuration -> World -> Picture +drawPathing cfig w = setLayer DebugLayer + $ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr) + <> concatMap dispInc (graphToIncidence gr) + where + dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n + gr = _pgGraph $ _pathGraph w + +crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String]) +crDisplayInfo cfig w cr +-- | _crID cr == 0 = Nothing + | crOnScreen = Just (_crPos cr, catMaybes +-- [fmap show $ ap ^? crGoal + [ fmap show $ cr ^? crHP + , fmap show $ ap ^? crStrategy + , fmap show $ cr ^? crPos + , fmap show $ cr ^? crPerception . cpVigilance +-- , fmap show $ cr ^? crOldPos + , fmap show $ ap ^? crAction + , fmap show $ ap ^? crImpulse + ] + ) + | otherwise = Nothing + where + ap = _crActionPlan cr + crOnScreen = pointOnScreen cfig w $ _crPos cr + +drawCrInfo :: Configuration -> World -> Picture +drawCrInfo cfig w = setLayer FixedCoordLayer + $ renderInfoListsAt (2*hw - 400) 0 cfig w + $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w + where + hw = halfWidth cfig + +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) + +viewClipBounds :: Configuration -> World -> Picture +viewClipBounds cfig w + | _debug_view_clip_bounds cfig == AllRoomClipBoundaries + = setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w) + | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries + = setLayer DebugLayer $ f (_roomClipping w) + | otherwise = [] + where + f (x:xs) = g x xs <> f xs + f [] = mempty + g x (y:ys) | convexPolysOverlap x y = color green (polygonWire $ _cpPoints x) + <> color yellow (polygonWire $ _cpPoints y) + <> g x ys + | otherwise = g x ys + g _ [] = mempty + +--wallFloorsToDraw :: World -> [Wall] +--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w +-- where +-- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall +-- isVisible wl +-- | wl ^? wlDraw == Just False = False +-- | otherwise = onScreen wl +-- +--lineOnScreen :: World -> Point2 -> Point2 -> Bool +--lineOnScreen w p1 p2 = pointInPolygon p1 sp +-- || pointInPolygon p2 sp +-- || any (isJust . uncurry (intersectSegSeg p1 p2)) sps +-- where +-- sp = screenPolygon w +-- sps = zip sp (tail sp ++ [head sp]) +-- +--drawWallFloor :: Wall -> Picture +--drawWallFloor wl = if _wlOpacity wl == SeeThrough +-- then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] +-- else blank +-- where +-- (x,y) = _wlLine wl +-- c = _wlColor wl +-- n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x) +-- +--errorNormalizeVDR :: Point2 -> Point2 +--errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering" +--errorNormalizeVDR p = normalizeV p diff --git a/src/GraphHelp.hs b/src/GraphHelp.hs new file mode 100644 index 000000000..a2c5816fd --- /dev/null +++ b/src/GraphHelp.hs @@ -0,0 +1,8 @@ +module GraphHelp where +import Data.Graph.Inductive + +mkGraphFromEdges :: Ord a => [(a,a,b)] -> Gr a b +mkGraphFromEdges es = insMapEdges nm es gr + where + (gr,nm,_) = insMapNodes new ns empty + ns = concatMap (\(x,y,_) -> [x,y]) es diff --git a/src/GraphVizHelp.hs b/src/GraphVizHelp.hs new file mode 100644 index 000000000..d980834b6 --- /dev/null +++ b/src/GraphVizHelp.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module GraphVizHelp + ( module GraphVizHelp + , module Data.GraphViz + ) where +import Data.GraphViz +import ThirdPartyLens + +mkCustomLenses ''GraphvizParams diff --git a/src/ThirdPartyLens.hs b/src/ThirdPartyLens.hs new file mode 100644 index 000000000..d9e208a0e --- /dev/null +++ b/src/ThirdPartyLens.hs @@ -0,0 +1,12 @@ +-- https://dev.to/piq9117/haskell-generating-lenses-for-third-party-libraries-1oik +module ThirdPartyLens where +import Language.Haskell.TH +import Control.Lens.Operators +import Control.Lens.TH + +mkCustomLenses :: Name -> DecsQ +mkCustomLenses = makeLensesWith + $ lensRules + & lensField + .~ (\_ _ name -> [TopName ( mkName $ nameBase name ++ "L" )]) -- you can append whatever suits your code base here, I chose to append "L" +