230 lines
9.1 KiB
Haskell
230 lines
9.1 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
module Dodge.LevelGen
|
|
( module Dodge.LevelGen
|
|
, cutWalls
|
|
, createInnerWalls
|
|
, checkWalls
|
|
, nubWalls
|
|
, pairsToGraph
|
|
, makeButton
|
|
, makeSwitch
|
|
)
|
|
where
|
|
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
|
|
import Dodge.LevelGen.Block
|
|
import Dodge.LevelGen.Pathing
|
|
import Dodge.LevelGen.StaticWalls
|
|
import Dodge.LevelGen.AutoDoor
|
|
import Dodge.LevelGen.TriggerDoor
|
|
import Dodge.LevelGen.Switch
|
|
|
|
import Geometry
|
|
import Picture
|
|
|
|
import System.Random
|
|
|
|
import Control.Monad.State
|
|
import Data.List
|
|
import Data.Function
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Set as S
|
|
import qualified Data.Map as M
|
|
|
|
-- deals with placement of objects within the world
|
|
|
|
placeSpots :: [PlacementSpot] -> World -> World
|
|
placeSpots pss w = foldr placeSpot w basicPlacements
|
|
where (collectivePlacements,basicPlacements) = partition typeIsCollective pss
|
|
typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True
|
|
_ -> False
|
|
typeIsCollective _ = False
|
|
|
|
groupedPlacements = groupBy ((==) `on` _collectiveID . _psType)
|
|
$ sortBy (compare `on` _collectiveID . _psType) collectivePlacements
|
|
|
|
placeSpot :: PlacementSpot -> World -> World
|
|
placeSpot ps w = case ps of
|
|
PS {_psPos = p, _psRot = rot, _psType = PutButton bt}
|
|
-> placeBt bt p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutFlIt fi}
|
|
-> placeFlIt fi p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutCrit cr}
|
|
-> placeCr cr p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec}
|
|
-> placeLS ls dec p rot w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp}
|
|
-> placePressPlate pp p rot w
|
|
PS {_psType = RandPS rgen}
|
|
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
|
|
where (evaluatedType, g) = runState rgen (_randGen w)
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b}
|
|
-> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
|
|
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps}
|
|
-> putBlock(map (shiftPointBy (p,rot)) ps) hp col False hps w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutBlockWall (hp:hps) col ps}
|
|
-> putBlockWallPart (map (shiftPointBy (p,rot)) ps) hp col False hps w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b}
|
|
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b}
|
|
-> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
|
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutWindowBlock a b}
|
|
-> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
|
|
|
PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
|
|
-> rmCrossPaths $ over walls (addWindow (q:qs) c) w
|
|
-- where (q:qs) = translateS p $ rotateS rot ps
|
|
where (q:qs) = map (shiftPointBy (p,rot)) ps
|
|
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
|
|
|
|
_ -> w
|
|
|
|
class Shiftable a where
|
|
translateS :: Point2 -> a -> a
|
|
rotateS :: Float -> a -> a
|
|
|
|
instance {-# OVERLAPPING #-} Shiftable Point2 where
|
|
translateS = (+.+)
|
|
rotateS = rotateV
|
|
|
|
instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
|
|
translateS p (x,y) = (translateS p x,translateS p y)
|
|
rotateS r (x,y) = ( rotateS r x, rotateS r y)
|
|
|
|
instance (Shiftable a) => Shiftable [a] where
|
|
translateS p x = map (translateS p) x
|
|
rotateS r x = map (rotateS r) x
|
|
|
|
instance Shiftable RoomLink where
|
|
translateS q (RL p r) = RL (p +.+ q) r
|
|
rotateS s (RL p r) = RL (rotateV s p) (r+s)
|
|
|
|
instance Shiftable PlacementSpot where
|
|
translateS p' (PS p r x) = PS (p +.+ p') r x
|
|
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
|
|
|
|
putWindowBlock :: Point2 -> Point2 -> World -> World
|
|
putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
|
|
where d = dist a b
|
|
rot = argV (b -.- a)
|
|
numPoints' = floor (d / 20)
|
|
numPoints = numPoints'*2
|
|
ns = take (numPoints+1) [0..]
|
|
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
|
|
$ map fromIntegral ns
|
|
k = newKey $ _walls w
|
|
ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
|
|
bSide = d / (fromIntegral numPoints)
|
|
ds = [(-bSide,-10),(-bSide,10),(bSide,10),(bSide,-10)]
|
|
polyAtP p = map ((+.+) p . rotateV rot) ds
|
|
hp = 1
|
|
degradeHP = [5,5]
|
|
winCol = withAlpha 0.5 cyan
|
|
makeBlockAt :: (Point2,Int) -> World -> World
|
|
makeBlockAt (p,i) w =
|
|
let (k0:k1:k2:k3:_) = ksAtN i
|
|
(bl:tl:tr:br:_) = polyAtP p
|
|
shadows | i == 0 = ksAtN 1
|
|
| i == numPoints - 1 = ksAtN $ numPoints - 2
|
|
| otherwise = ksAtN (i-1) ++ ksAtN (i+1)
|
|
seen | even i = True
|
|
| otherwise = False
|
|
isLeftmost | i == 0 = True
|
|
| otherwise = False
|
|
isRightmost | i == numPoints = True
|
|
| otherwise = False
|
|
l = baseBlock
|
|
{ _wlLine = [bl,tl]
|
|
, _wlID = k0
|
|
, _blVisible = isLeftmost
|
|
}
|
|
t = baseBlock
|
|
{ _wlLine = [tl,tr]
|
|
, _wlID = k1
|
|
, _blVisible = seen
|
|
}
|
|
r = baseBlock
|
|
{ _wlLine = [tr,br]
|
|
, _wlID = k2
|
|
, _blVisible = isRightmost
|
|
}
|
|
b = baseBlock
|
|
{ _wlLine = [br,bl]
|
|
, _wlID = k3
|
|
, _blVisible = seen
|
|
}
|
|
baseBlock = Block
|
|
{ _wlLine = []
|
|
, _wlID = 0
|
|
, _wlColor = winCol
|
|
, _wlDraw = Nothing
|
|
, _wlSeen = False
|
|
, _blIDs = ksAtN i
|
|
, _blHP = hp
|
|
, _wlIsSeeThrough = True
|
|
, _blVisible = seen
|
|
, _blShadows = shadows
|
|
, _blDegrades = degradeHP
|
|
, _wlCastShadow = False
|
|
}
|
|
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
|
|
in over walls f w
|
|
|
|
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
|
|
|
addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
|
|
addWindow qs c wls = foldr (addPane c) wls pairs
|
|
where (p:ps) = orderPolygon qs
|
|
pairs = zip (ps ++ [p]) (p:ps)
|
|
addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
|
addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
|
|
, _wlID = newKey wls
|
|
, _wlColor = c
|
|
, _wlDraw = Nothing
|
|
, _wlSeen = False
|
|
, _wlIsSeeThrough = True
|
|
}
|
|
) wls
|
|
|
|
|
|
placeBt bt p rot w = over buttons addBT w
|
|
where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
|
|
placeFlIt fi p rot w = over floorItems addFI w
|
|
where addFI fis = IM.insert (newKey fis) (fi {_flItPos = p, _flItRot = rot, _flItID = newKey fis}) fis
|
|
placePressPlate pp p rot w = over pressPlates addPP w
|
|
where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
|
|
|
|
placeCr :: Creature -> Point2 -> Float -> World -> World
|
|
placeCr crF p rot w = over creatures addCr w
|
|
where addCr crs = IM.insert (newKey crs)
|
|
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
|
|
crs
|
|
|
|
placeLS :: LightSource -> Drawing -> Point2 -> Float -> World -> World
|
|
placeLS ls dec p rot w = over lightSources addLS
|
|
$ over decorations addDec w
|
|
where addLS lss = IM.insert (newKey lss)
|
|
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
|
|
lss
|
|
addDec decs = IM.insert (newKey decs)
|
|
(uncurry translate p $ rotate (0 - rot) dec)
|
|
decs
|
|
|
|
|