loop/src/Dodge/Placement/Instance/Wall.hs

module Dodge.Placement.Instance.Wall where

import Color
import Control.Lens
import Data.List
import Dodge.Data.GenWorld
import Dodge.Default.Block
import Dodge.Default.Wall
import Dodge.LevelGen.PlacementHelper
import Dodge.Placement.Instance.Block
import Geometry

heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
heightWallPS spot h ps = psPtPl 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
        , _wlColor = dark $ dark orange
        --, _wlOpacity = Opaque 10
        , _wlOpacity = Opaque 17
        , _wlUnshadowed = True
        , _wlFireThrough = False
        , _wlPenetrable = True
        }

-- TODO find home for this
{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
replacePutID ::
    -- | The id of 'PutID' to be replaced
    Int ->
    -- | List of replacements
    [PSType] ->
    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 ::
    -- | Filter: elements to apply zip to
    (a -> Bool) ->
    -- | Combining function
    (a -> b -> a) ->
    -- | List to be partitioned
    [a] ->
    -- | Modifying list
    [b] ->
    [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)
    ]