Add various capabilities for generating graphs, fixes to lasgun
This commit is contained in:
+17
-10
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
]
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)]
|
||||
@@ -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
|
||||
+15
-1
@@ -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
|
||||
|
||||
@@ -649,6 +649,7 @@ data Particle
|
||||
, _ptDamage :: Int
|
||||
, _ptColor :: Color
|
||||
, _ptPhaseV :: Float
|
||||
, _ptPoints :: [Point2]
|
||||
}
|
||||
| LinearParticle
|
||||
{ _ptDraw :: Particle -> Picture
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
+8
-16
@@ -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
|
||||
|
||||
@@ -5,4 +5,4 @@ import Dodge.Item.Weapon.BulletGuns
|
||||
|
||||
|
||||
randBlockBreakWeapon :: RandomGen g => State g Item
|
||||
randBlockBreakWeapon = takeOne [bangStick 1,bangCane]
|
||||
randBlockBreakWeapon = takeOne [bangStick 1]
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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')
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
@@ -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)
|
||||
@@ -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
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -0,0 +1,9 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module GraphVizHelp
|
||||
( module GraphVizHelp
|
||||
, module Data.GraphViz
|
||||
) where
|
||||
import Data.GraphViz
|
||||
import ThirdPartyLens
|
||||
|
||||
mkCustomLenses ''GraphvizParams
|
||||
@@ -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"
|
||||
|
||||
Reference in New Issue
Block a user