Add source files, commit before reverting pictures to lists
This commit is contained in:
@@ -0,0 +1,756 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Dodge.LevelGen where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Prototypes
|
||||
import Dodge.Block
|
||||
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import System.Random
|
||||
--import Graphics.Gloss
|
||||
--import Graphics.Gloss.Geometry.Line
|
||||
--import Graphics.Gloss.Geometry.Angle
|
||||
--import Graphics.Gloss.Data.Vector
|
||||
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
|
||||
|
||||
import Data.Graph.Inductive
|
||||
import Data.Graph.Inductive.NodeMap
|
||||
import Data.Tree
|
||||
-- }}}
|
||||
|
||||
inSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
|
||||
where p1' = p1 +.+ normalizeV (p1 -.- p2)
|
||||
p2' = p2 +.+ normalizeV (p2 -.- p1)
|
||||
a1' = a1 +.+ normalizeV (a1 -.- a2)
|
||||
a2' = a2 +.+ normalizeV (a2 -.- a1)
|
||||
|
||||
--
|
||||
|
||||
|
||||
--supposes that the quadrilateral points are given in anticlockwise order
|
||||
-- cutOutQuad :: Point -> Point -> Point -> Point -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
-- cutOutQuad p1 p2 p3 p4 walls = cutLine p4 p1 . cutLine p3 p4 . cutLine p2 p3 . cutLine p1 p2 $ walls
|
||||
|
||||
collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
collidePointAllWalls p1 p2 walls = IM.filter f walls
|
||||
where f wall
|
||||
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
|
||||
of Nothing -> False
|
||||
_ -> True
|
||||
|
||||
-- returns walls that collide with lines, and the point of collision
|
||||
|
||||
collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
|
||||
collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
|
||||
where f wall
|
||||
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
|
||||
of Nothing -> Nothing
|
||||
Just p -> Just (wall,p)
|
||||
|
||||
collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
|
||||
collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
|
||||
where f wall
|
||||
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
|
||||
of Nothing -> Nothing
|
||||
Just p -> Just (wall,[p])
|
||||
|
||||
collidePolygonWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
|
||||
collidePolygonWalls (p:ps) walls
|
||||
= IM.unionsWith f (fmap g (zip (p:ps) (ps ++ [p])))
|
||||
-- = fmap ($ walls) $ zipWith collidePointAllWallsPoints' (init ps) (tail ps)
|
||||
--where f (x,xs) (_,ys) = (x,xs++ys)
|
||||
where f (x,xs) (_,ys) = (x,xs++ys)
|
||||
g (p1,p2) = collidePointAllWallsPoints' p1 p2 walls
|
||||
|
||||
-- -- assumes that walls meet in corners
|
||||
-- there appears to be an issue when one wall point is inside and the other exactly on the polygon
|
||||
-- this is probably an issue with collidePolygonwalls
|
||||
existingWallChanges :: [Point2] -> (Wall,[Point2]) -> [Wall]
|
||||
existingWallChanges poly (wall,ps) = catMaybes [w1,w2]
|
||||
where wp1 = _wlLine wall !! 0
|
||||
wp2 = _wlLine wall !! 1
|
||||
c1 = head $ sortBy (compare `on` dist wp1) ps
|
||||
c2 = head $ sortBy (compare `on` dist wp2) ps
|
||||
--c1 = last ps
|
||||
--c2 = last ps
|
||||
w1 = if errorPointInPolygon 5 wp1 poly || wp1 == c1
|
||||
then Nothing
|
||||
else Just $ wall {_wlLine = [ wp1, c1 ] }
|
||||
w2 = if errorPointInPolygon 6 wp2 poly || wp2 == c2
|
||||
then Nothing
|
||||
else Just $ wall {_wlLine = [ c2, wp2 ] }
|
||||
|
||||
|
||||
removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
removeWallsInPolygon ps walls = IM.filter (not . cond) walls
|
||||
-- where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
|
||||
-- && pointInsidePolygon (_wlLine wall !! 1) ps
|
||||
where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
|
||||
&& pointInsidePolygon (_wlLine wall !! 1) ps
|
||||
|
||||
pointInsidePolygon :: Point2 -> [Point2] -> Bool
|
||||
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|
||||
|| any (\l -> uncurry isOnLine l p) pairs
|
||||
where pairs = zip (x:xs) (xs ++ [x])
|
||||
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
|
||||
-.- p
|
||||
|
||||
|
||||
-- ok, now to find out which new walls need to be drawn
|
||||
drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
drawCutWall (p1,p2) walls =
|
||||
case maybeW of Just w -> if errorIsLHS 200 (_wlLine w !! 0) (_wlLine w !! 1) p3
|
||||
then walls
|
||||
else IM.insert k newWall walls
|
||||
Nothing -> IM.insert k newWall walls
|
||||
where p3 = 0.5 *.* (p1 +.+ p2)
|
||||
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
||||
maybeW = wallOnLine p3 p4 walls
|
||||
k = case IM.lookupMax walls
|
||||
of Nothing -> 0
|
||||
Just (j,_) -> j + 1
|
||||
newWall = basicWall {_wlLine = [p1,p2], _wlID = k}
|
||||
|
||||
|
||||
drawCutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
drawCutWalls (q:qs) walls = foldr drawCutWall walls (zip (q:qs) (qs++[q]))
|
||||
-- where (q:qs) = reverse $ orderPolygon
|
||||
-- -- $ intersectPolygonWalls ps walls
|
||||
-- $ maybeToList $ intersectSegSeg (20,0) (100,900) (-200,400) (200,400)
|
||||
-- -- $ (++) ps $ nub $ concat $ IM.elems $ fmap snd $ collidePolygonWalls ps walls
|
||||
|
||||
-- I have no idea why collidePolygonWalls is sometimes dropping an intersection
|
||||
-- point between the walls and the polygon
|
||||
-- Trying a workaround
|
||||
intersectPolygonWalls :: [Point2] -> IM.IntMap Wall -> [Point2]
|
||||
intersectPolygonWalls ps walls = nub $ concat $ IM.elems $ IM.map (intersectSegsWall ps) walls
|
||||
--intersectPolygonWalls (p:ps) walls = nub $ concat [intersectSegWalls s1 s2 walls | (s1,s2) <- segs]
|
||||
-- where segs = zip (p:ps) (ps ++ [p])
|
||||
|
||||
intersectSegWalls s1 s2 ws = concatMap (intersectSegWall s1 s2) $ IM.elems ws
|
||||
|
||||
intersectSegsWall (p:ps) wall = concat [intersectSegWall s1 s2 wall | (s1,s2) <- zip (p:ps) (ps++[p])]
|
||||
|
||||
-- finds intersection, or any segment points contained in the wall
|
||||
intersectSegWall s1 s2 w = catMaybes [myIntersectSegSeg s1 s2 w1 w2
|
||||
-- ,intersectSegPoint w1 w2 s1
|
||||
-- ,intersectSegPoint w1 w2 s2
|
||||
]
|
||||
where w1 = _wlLine w !! 0
|
||||
w2 = _wlLine w !! 1
|
||||
|
||||
intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing
|
||||
|
||||
-- new procedure: line by line
|
||||
-- then remove all walls inside the polygon
|
||||
|
||||
-- abuses the list nature of wlLine
|
||||
cutWall1 :: Point2 -> Point2 -> Wall -> Wall
|
||||
cutWall1 p1 p2 wall = case maybeCP of
|
||||
Nothing -> wall
|
||||
Just cp -> wall {_wlLine = [cp,w0,w1]}
|
||||
where wl = _wlLine wall
|
||||
w0 = wl !! 0
|
||||
w1 = wl !! 1
|
||||
w0' = w0 +.+ normalizeV (w0 -.- w1)
|
||||
w1' = w1 +.+ normalizeV (w1 -.- w0)
|
||||
p1' = p1 +.+ normalizeV (p1 -.- p2)
|
||||
p2' = p2 +.+ normalizeV (p2 -.- p1)
|
||||
pT = p1' +.+ vNormal (normalizeV (p1 -.- p2))
|
||||
pB = p1' -.- vNormal (normalizeV (p1 -.- p2))
|
||||
--maybeCP = intersectSegSeg p1' p2' w0' w1'-- <|> intersectSegSeg w0 w1 pT pB
|
||||
--maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
|
||||
maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
|
||||
--maybeCP = intersectSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
|
||||
cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws
|
||||
where splitAndAdd w ws
|
||||
= case _wlLine w of
|
||||
(cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
|
||||
,_wlID = newKey ws})
|
||||
$ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
|
||||
(x:y:[]) -> ws
|
||||
|
||||
cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
|
||||
cutWallsPoints p1 p2 ws = map head $ filter (\xs -> length xs > 2)
|
||||
$ IM.elems $ IM.map (_wlLine . cutWall1 p1 p2) ws
|
||||
|
||||
cutWallsProcess :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
|
||||
cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
|
||||
where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws', cutWalls1 p1 p2 ws')
|
||||
|
||||
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $
|
||||
drawCutWalls rs $ IM.filter (not.wallIsZeroLength)
|
||||
$ removeWallsInPolygon ps -- cwals
|
||||
(fuseWallsWith zs cwals)
|
||||
where (zs,cwals) = cutWallsProcess ps walls
|
||||
ps = orderPolygon qs
|
||||
--ps = orderPolygon $ map perturbToWallPoints qs
|
||||
rs = orderPolygon $ nub $ zs ++ qs
|
||||
-- perturbToWallPoints p = fromMaybe p $ find (\p1 -> dist p p1 < 1) wps
|
||||
|
||||
|
||||
fusePoint :: [Point2] -> Point2 -> Maybe Point2
|
||||
fusePoint ps p = find (\q -> dist p q < 5) ps
|
||||
|
||||
pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
|
||||
pointIfNotClose ps p = case fusePoint ps p of
|
||||
Nothing -> Just p
|
||||
_ -> Nothing
|
||||
|
||||
fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
|
||||
fuseWall (ps, w) = (qs, w {_wlLine = newLine})
|
||||
where wp0 = _wlLine w !! 0
|
||||
wp0' = fromMaybe wp0 $ fusePoint ps wp0
|
||||
ps0 = maybeToList (pointIfNotClose ps wp0) ++ ps
|
||||
wp1 = _wlLine w !! 1
|
||||
wp1' = fromMaybe wp1 $ fusePoint ps0 wp1
|
||||
newLine = [wp0',wp1']
|
||||
qs = catMaybes [pointIfNotClose ps wp0, pointIfNotClose ps0 wp1] ++ ps
|
||||
|
||||
fuseWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws
|
||||
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
|
||||
in (qs, IM.insert (_wlID w') w' ws)
|
||||
fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
|
||||
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
|
||||
in (qs, IM.insert (_wlID w') w' ws)
|
||||
|
||||
wallIsZeroLength w = l !! 0 == l !! 1
|
||||
where l = _wlLine w
|
||||
|
||||
treeTrunk :: [a] -> Tree a -> Tree a
|
||||
treeTrunk [] t = t
|
||||
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
|
||||
|
||||
applyToRoot :: (a -> a) -> Tree a -> Tree a
|
||||
applyToRoot f (Node x xs) = Node (f x) xs
|
||||
|
||||
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 = 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
|
||||
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
|
||||
|
||||
pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
|
||||
pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
|
||||
pairs' = map (\(x,y)->(x,y,f x y)) pairs
|
||||
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
|
||||
|
||||
makeButton :: Color -> (World -> World) -> Button
|
||||
makeButton c eff = Button
|
||||
{ _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
|
||||
, _btPos = (0,0)
|
||||
, _btRot = 0
|
||||
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
|
||||
-- . set (buttons . ix (_btID b) . btPict)
|
||||
-- (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
-- . set (buttons . ix (_btID b) . btState) BtNoLabel
|
||||
-- . set (buttons . ix (_btID b) . btEvent) (\b -> return)
|
||||
. soundOnce 1 $ w
|
||||
, _btID = 0
|
||||
, _btText = "Button"
|
||||
--, _btText = "Button"
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
|
||||
onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
|
||||
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
|
||||
makeSwitch c effOn effOff = Button
|
||||
{ _btPict = offPict
|
||||
, _btPos = (0,0)
|
||||
, _btRot = 0
|
||||
, _btEvent = flipSwitch
|
||||
, _btID = 0
|
||||
, _btText = "Switch"
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
flipSwitch b w = switchEffect b . soundOnce 1 $ w
|
||||
switchEffect b = case _btState b of
|
||||
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
|
||||
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
|
||||
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
|
||||
polygon $ rectNSEW (-2) (-5) (-10) (10)
|
||||
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
|
||||
]
|
||||
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
|
||||
polygon $ rectNSEW (-2) (-5) (-10) (10)
|
||||
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
|
||||
]
|
||||
turnOn :: Button -> Button
|
||||
turnOn bt = bt {_btState = BtOn, _btPict = onPict}
|
||||
turnOff :: Button -> Button
|
||||
turnOff bt = bt {_btState = BtOff, _btPict = offPict}
|
||||
|
||||
|
||||
|
||||
-- probably don't have to rebuild the entire graph, oh well
|
||||
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
|
||||
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where bid = newKey $ _buttons w
|
||||
cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
|
||||
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
|
||||
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
|
||||
$ _pathGraph' w
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
eff w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
|
||||
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
|
||||
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
$ set pathGraph newGraph
|
||||
$ set pathGraph' newGraphPairs
|
||||
$ addTriggerDoor c cond a b w
|
||||
where bid = newKey $ _buttons w
|
||||
cond w = BtOn == (_btState $ _buttons w IM.! bid)
|
||||
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
|
||||
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
|
||||
$ _pathGraph' w
|
||||
newGraph = pairsToGraph dist newGraphPairs
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
openDoor w' = over pathGraph' (removedPairs ++)
|
||||
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
|
||||
f (x,y) = (x,y,dist x y)
|
||||
closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
|
||||
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
|
||||
|
||||
addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
|
||||
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
|
||||
|
||||
triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
|
||||
where i = newKey wls
|
||||
is = [i..]
|
||||
|
||||
mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
|
||||
xs
|
||||
[ [pld,hwd]
|
||||
, [hwd,hwu]
|
||||
, [hwu,plu]
|
||||
, [plu,pld]
|
||||
, [pru,hwu]
|
||||
, [hwu,hwd]
|
||||
, [hwd,prd]
|
||||
, [prd,pru]
|
||||
]
|
||||
[ [plld,pld]
|
||||
, [pld,plu]
|
||||
, [plu,pllu]
|
||||
, [pllu,plld]
|
||||
, [prru,pru]
|
||||
, [pru,prd]
|
||||
, [prd,prrd]
|
||||
, [prrd,prru]
|
||||
]
|
||||
where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
perp = 20 *.* normalizeV (pl -.- pr)
|
||||
--perp = pl -.- hw
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
pru = pr +.+ norm
|
||||
prd = pr -.- norm
|
||||
hwu = hw +.+ norm
|
||||
hwd = hw -.- norm
|
||||
pllu = plu +.+ perp
|
||||
plld = pld +.+ perp
|
||||
prru = pru -.- perp
|
||||
prrd = prd -.- perp
|
||||
addSound (x:xs) = f x : xs
|
||||
f wl = over doorMech g wl
|
||||
g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
|
||||
$ dm w
|
||||
| otherwise = dm w
|
||||
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
||||
|
||||
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
|
||||
triggerDoorPane c cond n [a,b] [a',b'] = Door
|
||||
{ _wlLine = [a,b]
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
, _wlColor = c
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
-- , _doorLine = [a,b,a',b']
|
||||
}
|
||||
where
|
||||
dm w | cond w = flip (foldr changeZonedWall) zoneps
|
||||
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
|
||||
| otherwise = flip (foldr changeZonedWall') zoneps
|
||||
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
|
||||
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
openDoor :: Wall -> Wall
|
||||
openDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]}
|
||||
closeDoor :: Wall -> Wall
|
||||
closeDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]}
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
|
||||
addAutoDoor :: Point2 -> Point2 -> World -> World
|
||||
addAutoDoor a b = over walls (autoDoorAt a b)
|
||||
|
||||
removePathsCrossing :: Point2 -> Point2 -> World -> World
|
||||
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
|
||||
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
||||
w
|
||||
where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
newGraph = pairsToGraph dist pg'
|
||||
|
||||
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
|
||||
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
|
||||
where pairs = zip (p:ps) (ps ++ [p])
|
||||
wWithBlock = addBlock (p:ps) i c b is w
|
||||
|
||||
putWindowBlock :: Point2 -> Point2 -> World -> World
|
||||
--putWindowBlock a b w = foldr makeBlockAt w $ zip ps ns
|
||||
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 = Block
|
||||
{ _wlLine = [bl,tl]
|
||||
, _wlID = k0
|
||||
, _wlColor = winCol
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _blIDs = ksAtN i
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = True
|
||||
--, _blVisible = False
|
||||
, _blVisible = isLeftmost
|
||||
, _blShadows = shadows
|
||||
, _blDegrades = degradeHP
|
||||
}
|
||||
t = Block
|
||||
{ _wlLine = [tl,tr]
|
||||
, _wlID = k1
|
||||
, _wlColor = winCol
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _blIDs = ksAtN i
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = True
|
||||
, _blVisible = seen
|
||||
, _blShadows = shadows
|
||||
, _blDegrades = degradeHP
|
||||
}
|
||||
r = Block
|
||||
{ _wlLine = [tr,br]
|
||||
, _wlID = k2
|
||||
, _wlColor = winCol
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _blIDs = ksAtN i
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = True
|
||||
--, _blVisible = False
|
||||
, _blVisible = isRightmost
|
||||
, _blShadows = shadows
|
||||
, _blDegrades = degradeHP
|
||||
}
|
||||
b = Block
|
||||
{ _wlLine = [br,bl]
|
||||
, _wlID = k3
|
||||
, _wlColor = winCol
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _blIDs = ksAtN i
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = True
|
||||
, _blVisible = seen
|
||||
, _blShadows = shadows
|
||||
, _blDegrades = degradeHP
|
||||
}
|
||||
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
|
||||
in over walls f w
|
||||
|
||||
autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
|
||||
where i = newKey wls
|
||||
is = [i..]
|
||||
|
||||
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
|
||||
xs
|
||||
[ [pld,hwd]
|
||||
, [hwd,hwu]
|
||||
, [hwu,plu]
|
||||
, [pru,hwu]
|
||||
, [hwu,hwd]
|
||||
, [hwd,prd]
|
||||
]
|
||||
[ [plld,pld]
|
||||
, [pld,plu]
|
||||
, [plu,pllu]
|
||||
, [prru,pru]
|
||||
, [pru,prd]
|
||||
, [prd,prrd]
|
||||
]
|
||||
where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
perp = 20 *.* normalizeV (pl -.- pr)
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
pru = pr +.+ norm
|
||||
prd = pr -.- norm
|
||||
hwu = hw +.+ norm
|
||||
hwd = hw -.- norm
|
||||
pllu = plu +.+ perp
|
||||
plld = pld +.+ perp
|
||||
prru = pru -.- perp
|
||||
prrd = prd -.- perp
|
||||
addSound (x:xs) = f x : xs
|
||||
f wl = over doorMech g wl
|
||||
g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
|
||||
$ dm w
|
||||
| otherwise = dm w
|
||||
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
||||
|
||||
mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
|
||||
mvPointTowardAtSpeed speed !ep !p
|
||||
| dist p ep < speed = ep
|
||||
| otherwise = p +.+ speed *.* normalizeV (ep -.- p)
|
||||
|
||||
mvPointToward :: Point2 -> Point2 -> Point2
|
||||
mvPointToward ep p | dist p ep < 1 = ep
|
||||
| otherwise = p +.+ normalizeV (ep -.- p)
|
||||
|
||||
drawAutoDoor :: Wall -> Drawing
|
||||
drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2]
|
||||
$ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
|
||||
,color (dark c) $ line [x,y]
|
||||
]
|
||||
where
|
||||
(x:y:_) = _wlLine wl
|
||||
c = _wlColor wl
|
||||
nm = errorNormalizeV 543 (y -.- x)
|
||||
t = 5 *.* nm
|
||||
n = vNormal t
|
||||
n2 = 3 *.* n
|
||||
layer2 | _wlIsSeeThrough wl = 0
|
||||
| isJust $ wl ^? doorMech = 1
|
||||
| otherwise = 2
|
||||
|
||||
autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
|
||||
autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
|
||||
{ _wlLine = [a,b]
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
, _wlColor = dim $ yellow
|
||||
, _wlDraw = Just drawAutoDoor
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
-- , _doorLine = [a,b,a',b']
|
||||
}
|
||||
where
|
||||
dm w | crsNearLine 40 trigL w
|
||||
= flip (foldr changeZonedWall) zoneps
|
||||
$ over walls (IM.adjust openDoor n) w
|
||||
| otherwise = flip (foldr changeZonedWall') zoneps
|
||||
$ over walls (IM.adjust closeDoor n) w
|
||||
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
|
||||
openDoor :: Wall -> Wall
|
||||
openDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]}
|
||||
closeDoor :: Wall -> Wall
|
||||
closeDoor wl = case _wlLine wl of
|
||||
((!pa):(!pb):_) -> wl {_wlLine = [mvP a pa, mvP b pb]}
|
||||
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
|
||||
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
|
||||
|
||||
-- Left elements get new children, Right elements inherit the children from the
|
||||
-- mapped over node
|
||||
expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
|
||||
expandTreeBy f (Node x []) = fmap removeEither (f x)
|
||||
where removeEither (Left y) = y
|
||||
removeEither (Right y) = y
|
||||
expandTreeBy f (Node x xs) = appendAndRemove $ f x
|
||||
where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
|
||||
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
|
||||
|
||||
expandTreeRand :: RandomGen g =>
|
||||
(a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
|
||||
expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
|
||||
where removeEither (Left y) = y
|
||||
removeEither (Right y) = y
|
||||
expandTreeRand f (Node x xs) = do
|
||||
root <- f x
|
||||
branches <- sequence $ map (expandTreeRand f) xs
|
||||
return (appendAndRemove branches root)
|
||||
where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
|
||||
appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
|
||||
appendAndRemove bran (Node (Right y) _) = Node y bran
|
||||
|
||||
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 (radToDeg rot) dec)
|
||||
decs
|
||||
|
||||
|
||||
Reference in New Issue
Block a user