loop/src/Dodge/Room/Placement.hs

-- | Module defining helper placements for rooms.
module Dodge.Room.Placement
  where
import Dodge.Data
import Dodge.Default.Wall
import Dodge.LevelGen.Data
import Dodge.Room.Data
import Dodge.Creature.Inanimate
import Picture
import Geometry

import Data.List
import Control.Lens

putLamp :: PSType
putLamp = PutCrit lamp

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 = SinglePlacement $ PS
    { _psPos    = (0,0)
    , _psRot    = 0
    , _psType   = 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 = SinglePlacement $ PS 
    { _psPos    = (0,0)
    , _psRot    = 0
    , _psType   = 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 = SinglePlacement $ PS 
    { _psPos    = (0,0)
    , _psRot    = 0
    , _psType   = 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 = SinglePlacement $ PS 
    { _psPos    = (0,0)
    , _psRot    = 0
    , _psType   = 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 = Block
    { _wlLine = ((0,0),(50,0))
    , _wlID = 0
    , _wlColor = greyN 0.5
    , _wlSeen = False
    , _blIDs = []
    , _blHP = 5
    , _wlIsSeeThrough = False
    , _blVisible = True
    , _blShadows = []
    , _blDegrades = [20,20]
    }
baseWindowPane :: Wall
baseWindowPane = Block
    { _wlLine = ((0,0),(50,0))
    , _wlID = 0
    , _wlColor = withAlpha 0.2 cyan
    , _wlSeen = False
    , _blIDs = []
    , _blHP = 1
    , _wlIsSeeThrough = True
    , _blVisible = True
    , _blShadows = []
    , _blDegrades = [5,5]
    }
{- 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 & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & placementSpot . psType .~ 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 partition
    -> [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 ^? placementSpot . psType . putID

putBlockRect
    :: Float
    -> Float
    -> Float
    -> Float
    -> [Placement]
putBlockRect a x b y =  [ blockLine (a,b) (a,y)
                        , blockLine (a,y) (x,y)
                        , blockLine (x,y) (x,b)
                        , blockLine (x,b) (a,b)
                        ]
putBlockV
    :: Float
    -> Float
    -> Float
    -> Float
    -> [Placement]
putBlockV a x b y = [ blockLine (a,b) (a,y)
                    , blockLine (x,b) (a,b)
                    ]
putBlockC
    :: Float
    -> Float
    -> Float
    -> Float
    -> [Placement]
putBlockC a x b y = [ blockLine (a,b) (a,y)
                    , blockLine (x,b) (a,b)
                    , blockLine (a,y) (x,y)
                    ]
putBlockN
    :: Float
    -> Float
    -> Float
    -> Float
    -> [Placement]
putBlockN a x b y = [ blockLine (a,b) (a,y)
                    , blockLine (x,b) (a,b)
                    , blockLine (x,y) (x,b)
                    ]