153 lines
4.3 KiB
Haskell
153 lines
4.3 KiB
Haskell
module Dodge.Placement.Instance.Wall
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Placement.Instance.Block
|
|
import Dodge.Default.Block
|
|
--import Dodge.Block.Debris
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Default.Wall
|
|
import Geometry
|
|
import Color
|
|
|
|
import Data.List
|
|
import Control.Lens
|
|
|
|
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
|
|
heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps
|
|
|
|
invisibleWall :: [Point2] -> Placement
|
|
invisibleWall ps = sps0 $ PutWall ps $ defaultWall
|
|
{ _wlOpacity = SeeAbove
|
|
, _wlUnshadowed = False
|
|
, _wlHeight = 0
|
|
, _wlTouchThrough = True
|
|
}
|
|
|
|
midWall :: [Point2] -> Placement
|
|
midWall = heightWallPS (PS 0 0) 50
|
|
|
|
singleBlock :: Point2 -> [Placement]
|
|
singleBlock a =
|
|
[sPS a 0
|
|
$ PutBlock defaultBlock baseBlockPane
|
|
$ reverse
|
|
$ square 10
|
|
]
|
|
{-
|
|
Places a line of blocks between two points.
|
|
-}
|
|
blockLine :: Point2 -> Point2 -> Placement
|
|
blockLine a b = sps0 $ PutLineBlock baseBlockPane 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 defaultWindow 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 $ PutLineBlock defaultCrystalWall 7 a b
|
|
--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 defaultWindow 8
|
|
|
|
baseBlockPane :: Wall
|
|
baseBlockPane = defaultWall
|
|
{ _wlLine = (V2 0 0,V2 50 0)
|
|
, _wlID = 0
|
|
, _wlColor = greyN 0.5
|
|
, _wlSeen = False
|
|
, _wlOpacity = Opaque
|
|
, _wlUnshadowed = True
|
|
, _wlFireThrough = True
|
|
, _wlPenetrable = 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 -> Placement
|
|
putBlockRect' w h = ps0jPushPS (aline tl tr)
|
|
$ ps0jPushPS (aline tr br)
|
|
$ ps0jPushPS (aline br bl)
|
|
$ sps0 (aline bl tl)
|
|
where
|
|
tl = V2 (-w) h
|
|
tr = V2 w h
|
|
br = V2 w (-h)
|
|
bl = V2 (-w) (-h)
|
|
aline = PutLineBlock baseBlockPane 9
|
|
|
|
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)
|
|
]
|