Work on placements

src/Dodge/Corpse/Draw.hs

@@ -1,7 +0,0 @@
-module Dodge.Corpse.Draw where
-import Dodge.Data.Corpse
-import ShapePicture
-
--- not currently used, too simple
---drawCorpse :: Corpse -> SPic
---drawCorpse = _cpSPic

src/Dodge/Creature/Update.hs

@@ -109,17 +109,13 @@ checkDeath' cr w = case cr ^. crHP of
 -- could look at the amount of damage here (given by maxDamage) too
 corpseOrGib :: Creature -> World -> World
 corpseOrGib cr w = w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
-    Just CookingDamage -> -- addcorpse (thecorpse & cpSPic %~ scorchSPic)
-        sethp (CrIsCorpse $ scorchSPic thecorpse)
-    Just PoisonDamage -> --addcorpse (thecorpse & cpSPic %~ poisonSPic)
-        sethp (CrIsCorpse $ poisonSPic thecorpse)
+    Just CookingDamage -> sethp (CrIsCorpse $ scorchSPic thecorpse)
+    Just PoisonDamage -> sethp (CrIsCorpse $ poisonSPic thecorpse)
     Just PhysicalDamage | _crPain cr > 200 -> addCrGibs cr
          . sethp CrIsGibs
-    _ -> -- addcorpse thecorpse
-         sethp (CrIsCorpse thecorpse)
+    _ -> sethp (CrIsCorpse thecorpse)
   where
     sethp x = cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ x
---    addcorpse ctype = plNew (cWorld . lWorld . corpses) cpID ctype
     thecorpse = makeCorpse cr
 
 scorchSPic :: SPic -> SPic

src/Dodge/Data/Corpse.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Dodge.Data.Corpse where
-
-import Control.Lens
-import Data.Aeson
-import Data.Aeson.TH
-import Geometry.Data
-import ShapePicture.Data
-
---data CorpseResurrection = NoResurrection
---    deriving (Eq, Ord, Show, Read) --Generic, Flat)
---
---data Corpse = Corpse
---    { _cpID :: Int
---    , _cpPos :: Point2
---    , _cpDir :: Float
---    , _cpSPic :: SPic
---    , _cpRes :: CorpseResurrection
---    }
---    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
---makeLenses ''Corpse
---deriveJSON defaultOptions ''CorpseResurrection
---deriveJSON defaultOptions ''Corpse

src/Dodge/Data/GenWorld.hs

@@ -8,6 +8,7 @@ module Dodge.Data.GenWorld (
     module Dodge.Data.World,
 ) where
 
+import ShortShow
 import Color
 import Control.Lens
 import Control.Monad.State
@@ -62,6 +63,30 @@ data PSType
     | PutID {_putID :: Int}
     | PutChasm {_putChasmPoly :: [Point2]}
 
+instance ShortShow PSType where
+    shortShow PutCrit {} = "PutCrit"
+    shortShow PutMachine {} = "PutMachine"
+    shortShow PutLS {} = "PutLS"
+    shortShow PutButton {} = "PutButton"
+    shortShow PutProp {} = "PutProp"
+    shortShow PutTerminal {} = "PutTerminal"
+    shortShow PutFlIt {} = "PutFlIt"
+    shortShow PutPPlate {} = "PutPPlate"
+    shortShow PutBlock {} = "PutBlock"
+    shortShow PutCoord {} = "PutCoord"
+    shortShow PutMod {} = "PutMod"
+    shortShow PutTrigger {} = "PutTrigger"
+    shortShow PutLineBlock {} = "PutLineBlock"
+    shortShow PutWall {} = "PutWall"
+    shortShow PutSlideDr {} = "PutSlideDr"
+    shortShow PutDoor {} = "PutDoor"
+    shortShow RandPS {} = "RandPS"
+    shortShow PutForeground {} = "PutForeground"
+    shortShow PutWorldUpdate {} = "PutWorldUpdate"
+    shortShow PutNothing = "PutNothing"
+    shortShow PutID {} = "PutID"
+    shortShow PutChasm {} = "PutChasm"
+
 -- maybe there is a monadic implementation of this?
 -- add room effect for any placement spot?
 data PlacementSpot

src/Dodge/Data/LWorld.hs

@@ -11,7 +11,6 @@ module Dodge.Data.LWorld (
     module Dodge.Data.Bullet,
     module Dodge.Data.Button,
     module Dodge.Data.Cloud,
-    module Dodge.Data.Corpse,
     module Dodge.Data.CrGroupParams,
     module Dodge.Data.Creature,
     module Dodge.Data.Damage,
@@ -60,7 +59,6 @@ import Dodge.Data.Bounds
 import Dodge.Data.Bullet
 import Dodge.Data.Button
 import Dodge.Data.Cloud
-import Dodge.Data.Corpse
 import Dodge.Data.CrGroupParams
 import Dodge.Data.Creature
 import Dodge.Data.Damage

src/Dodge/Render/ShapePicture.hs

@@ -28,7 +28,6 @@ worldSPic cfig u =
         <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
         <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
         <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
---        <> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
         <> foldup (drawCreature (u ^. uvWorld . cWorld . lWorld . items)) 
                 (filtOn _crPos _creatures)
         <> foldup (Prelude.uncurry floorItemSPic) (IM.intersectionWith (,) (u^.uvWorld.cWorld.lWorld.items) (filtOn _flItPos _floorItems))
@@ -84,12 +83,6 @@ shiftDraw fpos fdir fdraw x =
         . rotateSP (fdir x)
         $ fdraw x x
 
---shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
---shiftDraw' fpos fdir fdraw x =
---    uncurryV translateSPxy (fpos x)
---        . rotateSP (fdir x)
---        $ fdraw x
-
 cullPoint :: Config -> World -> Point2 -> Bool
 cullPoint cfig w p
     | debugOn Close_shape_culling cfig = pointInPoly p (w ^. wCam . camBoundBox)

src/Dodge/Room/Tutorial.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Tutorial where
 
+import ShortShow
 import Dodge.Data.MTRS
 import Dodge.Room.Room
 import Dodge.Cleat
@@ -33,6 +34,8 @@ import LensHelp
 --import Padding
 import RandomHelp
 import TreeHelp
+import qualified Data.IntSet as IS
+import qualified Data.IntMap.Strict as IM
 
 --import Data.List (intersperse)
 
@@ -108,7 +111,10 @@ tutRooms is = do
     i <- nextLayoutInt
     j <- nextLayoutInt
     k <- nextLayoutInt
-    let a gw = analyserByNthLinkWithPrompt 3 sensorTut (RequireEquipment (AMMOMAG DRUMMAG)) k
+    let a gw = analyserByNthLinkWithPrompt 
+            3 (makeTermPara $ show is <> show (getRoomsFromInts is gw)
+                <>(getCrsFromRooms' is gw)) 
+                (RequireDeadCreatures $ getCrsFromRooms is gw) k
     x <-
         shuffleLinks 
             . analyserByDoorWithPrompt sensorTut (RequireEquipment (AMMOMAG DRUMMAG)) i
@@ -167,6 +173,31 @@ tutRooms is = do
         , makeTermLine "---------------------------------------------"
         ]
 
+getRoomsFromInts :: [Int] -> GenWorld -> IS.IntSet
+getRoomsFromInts is gw 
+    = foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)
+
+getCrsFromRooms' :: [Int] -> GenWorld -> String
+getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRooms) js)
+  where
+    h ',' = ' '
+    h x = x
+    js = getRoomsFromInts is gw
+    f rm = shortShow <$> rm ^.. rmPmnts . each . plType
+    --f rm = foldMap g $ rm ^. rmPmnts
+    --g x = case x ^. plType of
+    --    PutCrit _ -> [x ^?! plMID . _Just]
+    --    _ -> []
+
+getCrsFromRooms :: [Int] -> GenWorld -> [Int]
+getCrsFromRooms is gw = foldMap f (IM.restrictKeys (gw ^. genRooms) js)
+  where
+    js = foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)
+    f rm = foldMap g $ rm ^. rmPmnts
+    g x = case x ^. plType of
+        PutCrit _ -> [x ^?! plMID . _Just]
+        _ -> []
+
 sensorTut :: [TerminalLine]
 sensorTut =
         [ makeTermLine "--------------------------------------------"