Add boss room, tweak launchers

src/Dodge/Creature.hs

@@ -261,8 +261,7 @@ Items you start with.
  -}
 startInventory = IM.fromList (zip [0..20] 
     (
-    [ 
+    [launcher
-    --[pistol
     --,blinkGun
     --,spawnGun lamp
     --,poisonSprayer

src/Dodge/Creature/State.hs

@@ -0,0 +1,247 @@
+module Dodge.Creature.State where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+import Dodge.RandomHelp
+import Dodge.WorldEvent
+import Dodge.WallCreatureCollisions
+import Dodge.CreatureAction
+import Geometry
+import Picture
+
+import Data.List
+import Data.Char
+import Data.Maybe
+import Data.Function
+import Data.Graph.Inductive.Graph
+import Data.Graph.Inductive.PatriciaTree
+import Data.Graph.Inductive.Query.SP
+import Codec.BMP
+import qualified Data.ByteString as B
+import Control.Lens
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad
+import qualified SDL as SDL
+import qualified SDL.Mixer as Mix
+import System.Random
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import Foreign.ForeignPtr
+import Control.Concurrent
+  
+type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
+
+-- | The movement is updated before the ai in order to correctly set the oldpos.
+-- the whole of this update cycle could do with a rethink, it is becoming
+-- convoluted
+stateUpdate :: CRUpdate -> CRUpdate
+stateUpdate u w (f,g) cr = let (cr', g'') = updateMovement g cr 
+                           in case u w (f,g'') cr' of
+        ((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . dropifdead . f'
+                                 , g')
+                               , fmap (updateReloadCounter . reducePastDamage . doDamage) 
+                                      $ crOrCorpse =<< maybeCr
+                               )
+    where   
+        crOrCorpse cr | cr ^. crHP > 0 = Just cr
+                      | otherwise      = Nothing
+        dropifdead | cr ^.crHP > 0 = id
+                   | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) 
+                                    . over decorations addCorpse 
+                                    . insertIt
+        crBeforeDeath = colCrWall w $ cr
+        addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) 
+                                 $ rotate (_crDir cr)
+                                 (_crCorpse cr)
+        maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
+        insertIt = case maybeIt of 
+--                      Just it -> createItemAt (offset +.+ _crPos crBeforeDeath) 
+                      Just it -> createItemAt (offset +.+ _crOldPos cr) 
+                                              (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
+                      Nothing -> id
+        offset = _crRad cr *.* unitVectorAtAngle rot
+        (rot,_) = randomR (-pi,pi) g
+
+setOldPos :: Creature -> Creature
+setOldPos cr = set crOldPos (_crPos cr) cr
+
+{- 
+Given a creature and a velocity, applies friction to that creature and evaluates a 
+velocity to carry across frames.
+-}
+crFriction :: Creature -> Point2 -> Point2
+crFriction cr vel = (0,0)
+
+doDamage :: Creature -> Creature
+doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) 
+                                            damagedCr
+    where dams = _crDamage $ _crState cr
+          startHP = _crHP cr
+          damagedCr = snd $ (_crApplyDamage (_crState cr)) dams cr
+          afterHP = _crHP damagedCr
+          hpLost = startHP - afterHP  -- note this can be negative 
+
+sumDamage :: Creature -> DamageType -> Int -> Int
+sumDamage cr dm x = x + _dmAmount dm
+
+reducePastDamage :: Creature -> Creature
+reducePastDamage = over (crState . crPastDamage) rdpdam
+    where rdpdam x  | x > 500 = x - 55
+                    | x > 200 = x - 25
+                    | x > 20  = x - 5
+                    | x > 0   = x - 1
+                    | otherwise = 0
+
+movementSideEff :: Creature -> World -> World
+movementSideEff cr w
+    | hasJetPack 
+        = case cr ^? crState . stance . carriage of
+            Just (Boosting v) 
+                -> makeFlameletTimed 
+                            (oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi))
+                            (momentum +.+ 1 *.* rotateV randDir (vInverse v)) 
+                            Nothing
+                            1
+                            20
+                    $ set randGen g
+                        w
+            _   -> w
+    | otherwise = case cr ^? crState . stance . carriage of
+                    Just (Walking x y) -> takeStep x y w
+                    _ -> w
+        where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
+              oldPos = _crOldPos cr
+              momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
+              momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
+                         | otherwise          = momentum'
+              momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
+              (randDir,g) = randomR (-0.5,0.5) $ _randGen w
+              (randAng,_) = randomR (0,2*pi) $ _randGen w
+
+              (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
+              (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
+
+              crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
+              takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
+                           | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0  
+                           | otherwise = id
+              footor = [FootstepSound 0,FootstepSound 1]
+
+invSideEff :: Creature -> World -> World
+invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
+    where f i it w' = case it ^? itEffect . itInvEffect of
+                            Nothing -> w'
+                            Just g  -> g cr i w'
+
+weaponReloadSounds :: Creature -> World -> World
+weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
+                              Just (Weapon {_wpReloadState = 0})
+                                 -> w
+                              Just (Weapon {_wpReloadState = 1})
+                                 -> stopSoundFrom (CrReloadSound cid) w
+                              Just (Weapon {})
+                                 -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
+                              _
+                                 -> w
+      where cid = _crID cr
+
+updateMovement :: StdGen -> Creature -> (Creature, StdGen)
+updateMovement g cr 
+    | isFrictionless cr 
+        = (over crPos (+.+ momentum) $ setOldPos cr, g')
+    | otherwise 
+        = case cr ^? crState . stance . carriage of
+            Just (Walking x y) 
+                -> (set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0)
+                    $ setOldPos
+                    cr, g)
+            _  -> (set (crState . stance . carriage) (Walking 0 0)
+                    $ setOldPos
+                    cr, g)
+  where
+    momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr)
+    momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum'
+               | otherwise          = momentum'
+    momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
+    (randAng,g') = randomR (0,2*pi) g
+
+isFrictionless :: Creature -> Bool
+isFrictionless cr = case cr ^? crState . stance . carriage of
+    Just (Boosting _) -> True
+    Just (Floating)   -> True
+    _                 -> False
+
+updateReloadCounter :: Creature -> Creature
+updateReloadCounter cr = over (crInv . ix iSel . wpFireState) decreaseToZero
+                            . over (crInv . ix iSel . wpReloadState) decreaseToZero
+                            $ cr
+     where iSel = _crInvSel cr 
+
+decreaseToZero :: Int -> Int
+decreaseToZero x | x > 0     = x - 1
+                 | otherwise = 0
+
+
+--comb :: (StdGen -> Creature -> World -> World) -> (StdGen -> Creature -> Maybe Creature)
+--            -> CRUpdate
+--comb 
+
+onDeath :: (Creature -> World -> World) -> CRUpdate -> CRUpdate
+onDeath h u w (f,g) cr 
+    | _crHP cr > 0 = u w (f,g) cr
+    | otherwise    = ( ( h cr . f, g ) , Nothing )
+
+updateBarrel :: 
+    World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
+updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr)
+                        | otherwise   = ((f, g), Nothing)
+    where damages = _crDamage $ _crState cr
+          newCr = Just $ doDamage cr
+
+-- it is easy to leave off the "f" here 
+-- should find some better way of doing all this that is less prone to error
+updateExpBarrel :: 
+    World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
+updateExpBarrel w (f,g) cr 
+    | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr)
+    | otherwise   = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
+    where damages = _crDamage $ _crState cr
+          pierceSparks :: [World -> World]
+          pierceSparks 
+            = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) 
+                                                (Just $ _crID cr))
+                                  poss as colids times
+          as =  randomRs (-0.7,0.7) $ g
+          colids = randomRs (0,11) $ g
+          times = randomRs (2,5) $ g
+          (g',_) = split g
+          poss = _piercedPoints $ _crSpState $ _crState cr
+          --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
+          newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
+          perforate :: DamageType -> Creature -> Creature
+          perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
+                                                            ((:) $ int -.- _crPos cr) cr
+          perforate _ cr = cr
+          applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints 
+                                                             $ _crSpState $ _crState cr)) 
+                                         cr
+          hiss | poss == [] = id
+               | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
+          stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
+
+damToExpBarrel :: [DamageType] -> Creature -> Creature
+damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
+    where (pierceDam,otherDam) = partition isPierce ds
+          isPierce (Piercing {}) = True
+          isPierce _             = False
+
+damToExpBarrel' :: DamageType -> Creature -> Creature
+damToExpBarrel' (Piercing amount sp int ep) cr 
+    = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) 
+        $ over crHP (\hp -> hp - div amount 200) cr
+damToExpBarrel' (PoisonDam {}) cr = cr
+damToExpBarrel' (SparkDam {})  cr = cr
+damToExpBarrel' (PushDam {_dmPushBack = v})   cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
+damToExpBarrel' dt             cr = cr Control.Lens.& crHP -~ _dmAmount dt

src/Dodge/Floor.hs

@@ -36,6 +36,9 @@ roomTreex = do
     let t' = padCorridors struct
         t = treeTrunk 
                 [[StartRoom]
+                ,[Corridor]
+                ,[BossAno launcherCrit]
+                ,[Corridor]
                 ,[OrAno [[DoorAno]
                         ,[Corridor]
                         ,[DoorNumAno 0,AirlockAno]] 

src/Dodge/Item/Weapon.hs

@@ -334,17 +334,17 @@ launcher = defaultGun
     }
 flameLauncher = launcher
     { _itName = "FLROCKO"
-    , _wpFire = shoot $ aRocket' makeFlameShellAt
+    , _wpFire = shoot . aRocket' $ makeShellAt makeFlameExplosionAt
     }
 
 poisonLauncher = launcher 
     { _itName = "POISROCK"
-    , _wpFire = shoot $ aRocket' makePoisonShellAt
+    , _wpFire = shoot . aRocket' $ makeShellAt makePoisonExplosionAt
     }
 
 teslaLauncher = launcher 
     { _itName = "TESLROCK"
-    , _wpFire = shoot $ aRocket' makeTeslaShellAt
+    , _wpFire = shoot . aRocket' $ makeShellAt makeTeslaExplosionAt
     }
 
 bezierGun = defaultAutoGun
@@ -712,7 +712,7 @@ aTractorBeam col cid w
           dir = _crDir cr
           itRef = _crInvSel cr
 
--- |The aRocket' function allows us to define the shell to be used
+-- | The aRocket' function allows us to define the shell to be used
 aRocket' :: (Int -> Int -> Point2 -> Float -> Projectile) -> Int -> World -> World
 aRocket' shell cid w
         = soundOnce (fromIntegral launcherSound)
@@ -723,70 +723,36 @@ aRocket' shell cid w
           dir = _crDir cr
 
 aRocket :: Int -> World -> World
-aRocket = aRocket' makeShellAt
+aRocket = aRocket' (makeShellAt shellExplosionAt)
---        = soundOnce (fromIntegral launcherSound)
---            $ over projectiles (IM.insert i (makeShellAt i cid pos dir)) w
---    where i = newProjectileKey w
---          cr  = (_creatures w IM.! cid)
---          pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
---          dir = _crDir cr
 
-makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile
+makeShellAt 
-makeShellAt i cid pos dir = Shell
+    :: (Point2 -> World -> World) -- ^ Payload
+    -> Int      -- ^ Projectile id
+    -> Int      -- ^ Creature id
+    -> Point2   -- ^ Start position
+    -> Float    -- ^ Direction
+    -> Projectile
+makeShellAt pl i cid pos dir = Shell
     { _pjPos = pos
     , _pjStartPos = pos
     , _pjVel = rotateV dir (1,0)
     , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
     , _pjID = i
-    , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
+    , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (3,0))
-    , _pjPayload = shellExplosionAt
+    , _pjPayload = pl
-    }
-
-makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile
-makeFlameShellAt i cid pos dir = Shell
-    { _pjPos = pos
-    , _pjStartPos = pos
-    , _pjVel = rotateV dir (1,0)
-    , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
-    , _pjID = i
-    , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
-    , _pjPayload = makeFlameExplosionAt
-    }
-
-makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile
-makePoisonShellAt i cid pos dir = Shell
-    { _pjPos = pos
-    , _pjStartPos = pos
-    , _pjVel = rotateV dir (1,0)
-    , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
-    , _pjID = i
-    , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
-    , _pjPayload = makePoisonExplosionAt
-    }
-
-makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile
-makeTeslaShellAt i cid pos dir = Shell
-    { _pjPos = pos
-    , _pjStartPos = pos
-    , _pjVel = rotateV dir (1,0)
-    , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
-    , _pjID = i
-    , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
-    , _pjPayload = makeTeslaExplosionAt
     }
 
 moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World
 moveShell time i cid rot accel w 
     | time > 40 = if circOnSomeWall oldPos 4 w
-        then projectileExplosion oldPos $ over projectiles (IM.delete i) w
+        then doExplode
         else over (projectiles . ix i . pjPos) (+.+ vel)
                         $ set (projectiles . ix i . pjPict) piclow
                         $ set (projectiles . ix i . pjUpdate) 
                                   (moveShell (time-1) i cid rot (rotateV rot accel))
                           w
     | time == 35 = case thingHit of
-        Just p  -> projectileExplosion oldPos
+        Just p  -> doExplode
-                     $ over projectiles (IM.delete i) w
         Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
                    $ set (projectiles . ix i . pjPict) pic
                    $ set (projectiles . ix i . pjUpdate) 
@@ -801,9 +767,7 @@ moveShell time i cid rot accel w
                              (moveShell (time-1) i cid rot (rotateV rot accel))
                      w
     | time > -99 = case thingHit of
-        Just p  -> projectileExplosion oldPos
+        Just p  -> doExplode
-                     $ stopSoundFrom (ShellSound i)
-                     $ over projectiles (IM.delete i) w
         Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
                    $ set randGen g
                    $ set (projectiles . ix i . pjPict) pic
@@ -816,18 +780,17 @@ moveShell time i cid rot accel w
                    $ smokeGen
                      w
     | time > -200 = case thingHit of
-        Just p  -> projectileExplosion oldPos 
+        Just p  -> doExplode
-                     $ stopSoundFrom (ShellSound i)
-                     $ over projectiles (IM.delete i) w
         Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
                    $ set (projectiles . ix i . pjPict) pic
                    $ set (projectiles . ix i . pjUpdate)
                              (moveShell (time-1) i cid rot (rotateV rot accel))
                      w
-    | otherwise = projectileExplosion oldPos 
+    | otherwise = doExplode
+  where 
+    doExplode = projectileExplosion oldPos 
         $ stopSoundFrom (ShellSound i)
         $ over projectiles (IM.delete i) w
-  where 
     pj = _projectiles w IM.! i
     oldPos   = _pjPos pj
     vel      = _pjVel pj
@@ -843,7 +806,7 @@ moveShell time i cid rot accel w
     hitWl    = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
     thingHit = hitCr <|> hitWl
     spin   = case w ^? creatures . ix cid of
-              Just cr -> min 0.1 $ max (-0.1) 
+              Just cr -> min 0.2 $ max (-0.2) 
                           $ (normalizeAnglePi (dir - _crDir cr)) / 20
               _ -> 0
     r1 = _randGen w & evalState (randInCirc 10)

src/Dodge/Layout/Tree/Annotate.hs

@@ -3,15 +3,16 @@ Annotating tree structures with desired properties for rooms.
 -}
 module Dodge.Layout.Tree.Annotate
     where
+import Dodge.Data
 import Dodge.RandomHelp
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
 import Dodge.Room.Procedural
+import Dodge.Room.Boss
 import Dodge.Room.Link
 import Dodge.Room.Data
 import Dodge.Room
 import Dodge.Room.Teleport
---import Dodge.Floor
 
 import Data.Tree
 import Control.Monad.State
@@ -30,6 +31,7 @@ data Annotation g
     | EndRoom
     | OrAno [[Annotation g]]
     | SpecificRoom (State g (Tree (Either Room Room)))
+    | BossAno Creature
 
 addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
 addLock i t = do
@@ -68,6 +70,7 @@ annoToRoomTree [StartRoom] = do
     h <- state $ randomR (200,400)
     fmap (pure . Right) $ randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
 annoToRoomTree (SpecificRoom rt:_) = rt
+annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr
 annoToRoomTree _ = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)

src/Dodge/Room/Boss.hs

@@ -0,0 +1,40 @@
+{-
+Rooms containing particularly challenging creatures.
+-}
+module Dodge.Room.Boss
+  where
+import Dodge.Data
+import Dodge.Room.Data
+import Dodge.Room.Placement
+import Dodge.LevelGen.Data
+import Geometry
+
+import Control.Monad.State
+import Control.Lens
+import System.Random
+roomOctogon
+    :: Float    -- ^ Size
+    -> Room
+roomOctogon x = Room
+    { _rmPolys = [rectNSWE x (-x) (-x) x
+                 ,rectNSWE 0 (-(x + 40)) (-20) 20
+                 ]
+    , _rmLinks = [((0,x),0),((0,-(x+40)),pi)]
+    , _rmPath  = [((0,x),(0,-(x+40)))
+                 ,((0,-(x+40)),(0,x))]
+    , _rmPS = 
+        [PS (x-10,x-10) 0 $ putLamp
+        ,PS (10-x,x-10) 0 $ putLamp
+        ,PS (10-x,10-x) 0 $ putLamp
+        ,PS (x-10,10-x) 0 $ putLamp
+        ,crystalLine (-x,x/2) (negate (x/2), x)
+        ,crystalLine (x,x/2)  (x/2, x)
+        ,crystalLine (x/2,-x) (x,negate (x/2))
+        ,crystalLine (negate $ x/2,-x) (-x,negate (x/2))
+        ,blockLine (-40,40-x) (40,40-x)
+        ]
+    , _rmBound = rectNSWE x (-x) (-x) x
+    }
+
+bossRoom :: RandomGen g => Creature -> State g Room
+bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (pi/2) (PutCrit cr) :)

src/Dodge/Room/Placement.hs

@@ -15,6 +15,10 @@ singleBlock :: Point2 -> [PlacementSpot]
 singleBlock a = [PS 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 -> PlacementSpot
 blockLine a b = PS
     { _psPos    = (0,0)
@@ -22,6 +26,10 @@ blockLine a b = PS
     , _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 -> PlacementSpot
 windowLine a b = PS 
     { _psPos    = (0,0)
@@ -29,6 +37,26 @@ windowLine a b = PS
     , _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 -> PlacementSpot
+crystalLine a b = PS 
+    { _psPos    = (0,0)
+    , _psRot    = 0
+    , _psType   = PutWindow ps $ withAlpha 0.5 aquamarine
+    }
+  where
+    ps = 
+        [ a +.+ left +.+ up
+        , (a +.+ left) -.- up
+        , (b -.- left) -.- up
+        , (b -.- left) +.+ up
+        ]
+    left = 7 *.* normalizeV (a-.-b)
+    up   = vNormal left
+
 windowLineType :: Point2 -> Point2 -> PSType
 windowLineType a b = PutLineBlock baseWindowPane 8 8 a b