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.LevelGen.Switch
import Dodge.Room.Data
import Dodge.Creature.Inanimate
import Picture
import Geometry

import Data.List
import Control.Lens
import qualified Data.IntMap.Strict as IM

putColorLamp :: Point3 -> PSType
putColorLamp col = PutCrit (colorLamp col 90)

putLamp :: PSType
putLamp = PutCrit (lamp 90)

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 = Placement PS
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutLineBlock baseBlockPane 9 9 a b
    } (const Nothing)

{-
Places an breakable window between two points.
Width 8, also extends out from each point by 8.
 -}
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = Placement PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutLineBlock baseWindowPane 8 8 a b
    } (const Nothing)

{-
Places an unbreakable window between two points.
Width 7, also extends out from each point by 7.
 -}
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = Placement PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutWall ps defaultCrystalWall
    } (const Nothing)
  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 = Placement PS 
    { _psPos    = V2 0 0
    , _psRot    = 0
    , _psType   = PutWall ps defaultWall
    } (const Nothing)
  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
    , _wlIsSeeThrough = False
    , _wlDraw = True
    }
baseWindowPane :: Wall
baseWindowPane = defaultWall
    { _wlLine = (V2 0 0,V2 50 0)
    , _wlID = 0
    , _wlColor = withAlpha 0.2 cyan
    , _wlSeen = False
    , _wlIsSeeThrough = True
    , _wlDraw = True
    }
{- 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 (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)
                    ]

switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
    $ \btid -> jsps0J (PutSingleDoor col (cond btid) dra drc 2)
    $          sps0   (PutSingleDoor col (cond btid) drb drc 2)
  where
    drc = 0.5 *.* (dra +.+ drb)
    cond btid w' = _btState (_buttons w' IM.! btid) == BtOn