132 lines
3.7 KiB
Haskell
132 lines
3.7 KiB
Haskell
module Dodge.Placement.Instance.Wall
|
|
where
|
|
import Dodge.Data
|
|
import Color
|
|
import Geometry
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Default.Wall
|
|
|
|
import Data.List
|
|
import Control.Lens
|
|
singleBlock :: Point2 -> [Placement]
|
|
singleBlock a =
|
|
[sPS a 0
|
|
$ PutBlock [5,20,20] (greyN 0.5)
|
|
$ reverse
|
|
$ rectNSWE 10 (-10) (-10) 10
|
|
]
|
|
{-
|
|
Places a line of blocks between two points.
|
|
Width 9, also extends out from each point by 9.
|
|
-}
|
|
blockLine :: Point2 -> Point2 -> Placement
|
|
blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
|
|
|
|
{-
|
|
Places an breakable window between two points.
|
|
Width 8, also extends out from each point by 8.
|
|
-}
|
|
windowLine :: Point2 -> Point2 -> Placement
|
|
windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
|
|
{-
|
|
Places an unbreakable window between two points.
|
|
Width 7, also extends out from each point by 7.
|
|
-}
|
|
crystalLine :: Point2 -> Point2 -> Placement
|
|
crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
|
|
where
|
|
ps =
|
|
[ a +.+ left +.+ up
|
|
, (a +.+ left) -.- up
|
|
, (b -.- left) -.- up
|
|
, (b -.- left) +.+ up
|
|
]
|
|
left = 7 *.* normalizeV (a-.-b)
|
|
up = vNormal left
|
|
{- Places an unbreakable wall between two points.
|
|
Depth 15, does not extend wider than points.
|
|
-}
|
|
wallLine :: Point2 -> Point2 -> Placement
|
|
wallLine a b = sps0 $ PutWall ps defaultWall
|
|
where
|
|
ps = [ a +.+ up
|
|
, a -.- up
|
|
, b -.- up
|
|
, b +.+ up
|
|
]
|
|
left = 15 *.* normalizeV (a-.-b)
|
|
up = vNormal left
|
|
|
|
windowLineType :: Point2 -> Point2 -> PSType
|
|
windowLineType = PutLineBlock baseWindowPane 8 8
|
|
|
|
baseBlockPane :: Wall
|
|
baseBlockPane = defaultWall
|
|
{ _wlLine = (V2 0 0,V2 50 0)
|
|
, _wlID = 0
|
|
, _wlColor = greyN 0.5
|
|
, _wlSeen = False
|
|
, _wlOpacity = Opaque
|
|
, _wlDraw = True
|
|
, _wlFireThrough = True
|
|
}
|
|
baseWindowPane :: Wall
|
|
baseWindowPane = defaultWall
|
|
{ _wlLine = (V2 0 0,V2 50 0)
|
|
, _wlID = 0
|
|
, _wlColor = withAlpha 0.2 cyan
|
|
, _wlSeen = False
|
|
, _wlOpacity = SeeThrough
|
|
, _wlDraw = True
|
|
, _wlFireThrough = True
|
|
}
|
|
-- TODO find home for this
|
|
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -}
|
|
replacePutID
|
|
:: Int -- ^ The id of 'PutID' to be replaced
|
|
-> [PSType] -- ^ List of replacements
|
|
-> Room
|
|
-> Room
|
|
replacePutID i psts r =
|
|
r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
|
|
{- Partition a list by a predicate, apply a zip to those elements
|
|
that satisfy the predicate, concatenate
|
|
the new zipped list and the other (unchanged) half. -}
|
|
subZipWith
|
|
:: (a -> Bool) -- ^ Filter: elements to apply zip to
|
|
-> (a -> b -> a) -- ^ Combining function
|
|
-> [a] -- ^ List to be partitioned
|
|
-> [b] -- ^ Modifying list
|
|
-> [a]
|
|
subZipWith f g xs ys =
|
|
let (zs,ws) = partition f xs
|
|
in zipWith g zs ys ++ ws
|
|
|
|
isPutID :: Int -> Placement -> Bool
|
|
isPutID i ps = Just i == ps ^? plType . putID
|
|
|
|
putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
|
|
putBlockRect a x b y =
|
|
[ blockLine (V2 a b) (V2 a y)
|
|
, blockLine (V2 a y) (V2 x y)
|
|
, blockLine (V2 x y) (V2 x b)
|
|
, blockLine (V2 x b) (V2 a b)
|
|
]
|
|
putBlockV :: Float -> Float -> Float -> Float -> [Placement]
|
|
putBlockV a x b y =
|
|
[ blockLine (V2 a b) (V2 a y)
|
|
, blockLine (V2 x b) (V2 a b)
|
|
]
|
|
putBlockC :: Float -> Float -> Float -> Float -> [Placement]
|
|
putBlockC a x b y =
|
|
[ blockLine (V2 a b) (V2 a y)
|
|
, blockLine (V2 x b) (V2 a b)
|
|
, blockLine (V2 a y) (V2 x y)
|
|
]
|
|
putBlockN :: Float -> Float -> Float -> Float -> [Placement]
|
|
putBlockN a x b y =
|
|
[ blockLine (V2 a b) (V2 a y)
|
|
, blockLine (V2 x b) (V2 a b)
|
|
, blockLine (V2 x y) (V2 x b)
|
|
]
|