Proof of coloured lighting concept

src/Dodge/Creature/Inanimate.hs

@@ -30,6 +30,18 @@ import Data.Monoid
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
 
+colorLamp 
+    :: Point3   -- color of lamp
+    -> Float    -- height of lamp
+    -> Creature
+colorLamp col h = defaultInanimate
+    { _crUpdate = initialiseColorLamp col h
+    , _crHP = 100
+    , _crPict = picAtCrPosNoRot (lampPic h)
+    , _crRad = 3
+    , _crMass = 3
+    }
+
 lamp :: Float -> Creature
 lamp h = defaultInanimate
     { _crUpdate = initialiseLamp h
@@ -68,6 +80,13 @@ initialiseLamp h cr _ = ( Endo addLS , Just $ cr & crUpdate .~ updateLamp h i)
     addLS = over lightSources (IM.insert i (lightAt (V3 x y h) i))
     (V2 x y) = _crPos cr
 
+initialiseColorLamp :: Point3 -> Float -> CRUpdate
+initialiseColorLamp col h cr _ = ( Endo addLS , Just $ cr & crUpdate .~ updateLamp h i)
+  where
+    i = _crID cr
+    addLS = over lightSources (IM.insert i (colorLightAt col (V3 x y h) i))
+    (V2 x y) = _crPos cr
+
 updateLamp :: Float -> Int -> CRUpdate
 updateLamp h i = unrandUpdate handleLS internalUpdate
   where

src/Dodge/LightSources.hs

@@ -1,25 +1,24 @@
 module Dodge.LightSources where
 import Dodge.Data
 --import Dodge.Base
-import Dodge.Picture.Layer
-import Dodge.LevelGen.Data
+--import Dodge.Picture.Layer
+--import Dodge.LevelGen.Data
 --import Geometry
-import Picture
+--import Picture
 import Geometry.Data
 
-lightAt :: Point3 -> Int -> LightSource
-lightAt (V3 x y z) i = 
+colorLightAt :: Point3 -> Point3 -> Int -> LightSource
+colorLightAt col pos i = 
     LS {_lsID = i
-       ,_lsPos = V3 x y z
+       ,_lsPos = pos
        ,_lsDir = 0
        ,_lsRad = 700
-       ,_lsIntensity = 0.75
+       ,_lsIntensity = col
        }
-basicLS :: PSType
-basicLS = PutLS ls dec
-  where 
-    ls = lightAt (V3 0 0 0) 0
-    dec = onLayer PtLayer $ color white $ circleSolid 8
+
+lightAt :: Point3 -> Int -> LightSource
+lightAt = colorLightAt 0.75
+
 
 tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
 tLightFade 0 rmax intensityF (V2 x y) = TLS 
@@ -54,7 +53,7 @@ tLightRad 0 rmax _ (V2 x y) = TLS
 tLightRad i rmax rmin p@(V2 x y) = TLS 
     { _tlsPos = V3 x y 0
     , _tlsRad = rmax
-    , _tlsIntensity = 0.5
+    , _tlsIntensity = V3 0.5 0.5 0
     , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
     }
 

src/Dodge/Room/Placement.hs

@@ -12,6 +12,9 @@ import Geometry
 import Data.List
 import Control.Lens
 
+putColorLamp :: Point3 -> PSType
+putColorLamp col = PutCrit (colorLamp col 90)
+
 putLamp :: PSType
 putLamp = PutCrit (lamp 90)
 

src/Dodge/Room/Start.hs

@@ -4,6 +4,7 @@ import Dodge.Room.Data
 import Dodge.Room.Door
 import Dodge.Room.Link
 import Dodge.Room.Procedural
+import Dodge.Room.Placement
 import Dodge.Room.Foreground
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
@@ -26,10 +27,10 @@ startRoom = do
                highPipe 80 (V2  0    (h/3)) (V2  w    (h/2))
             ++ highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
             ++ highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
-            -- ++ highPipe 20 (0,2*h/3) (w, h/3)
---            , girderV cola 10 (0,3*h/4) (w, 3*h/4)
---            , girder colb 5 (0,5*h/8) (w, 5*h/8)
-    treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
+        theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.25 0.25)
+    treeFromPost [Left rezBox, Left door] . Right 
+        <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
+                $ roomRectAutoLinks w h & rmPS .~ [fground,theLamp])
 --  where
 --    cola = dark . dark . light . light $ light red
 --    colb = dark . dark . light . light $ light blue