Readd wall corner collisions

src/Dodge/Creature/Action.hs

@@ -36,7 +36,7 @@ import Control.Lens
 --import Control.Monad
 --import Control.Applicative
 import Data.Maybe
---import Data.List
+import Data.List (findIndex)
 import System.Random
 import Control.Monad.Reader
 --import qualified Data.Map as M
@@ -203,11 +203,21 @@ setMinInvSize n cr = creatures . ix (_crID cr) . crInv %~ f
     f inv = IM.unionWith const inv $ IM.fromList $ [0..n-1] <&> (, NoItem)
 
 stripNoItems :: Creature -> World -> World
-stripNoItems cr = creatures . ix (_crID cr) . crInv %~ IM.mapMaybe f
+stripNoItems cr = organiseInvKeys (_crID cr) .
+    ( creatures . ix (_crID cr) . crInv %~ IM.mapMaybe f )
   where
     f NoItem = Nothing
     f x      = Just x
 
+organiseInvKeys :: Int -> World -> World
+organiseInvKeys cid w = w & creatures . ix cid %~
+    ( ( crInvSel .~ newSelKey ) . (crInv .~ newInv ) )
+  where
+    cr  = _creatures w IM.! cid
+    pairs = IM.toList (_crInv cr)
+    newSelKey = fromJust $ findIndex ( (== _crInvSel cr) . fst) pairs
+    newInv = IM.fromAscList $ zip [0..] $ map snd pairs
+
 dropUnselected :: Creature -> World -> World
 dropUnselected cr w = foldr (dropItem cr) w . IM.keys 
     $ _crInvSel cr `IM.delete` _crInv cr 

src/Dodge/Event.hs

@@ -131,6 +131,7 @@ moveYourAmmoParam i w = case yourItem w ^? wpAmmo . amPjParams . ix paramid . pj
     _ -> w
   where
     paramid = _amParamSel $ _wpAmmo $ yourItem w
+
 swapInvDir :: Int -> World -> World
 swapInvDir k w = w & creatures . ix (_yourID w) . crInv %~ IM.swapKeys (i `mod` n) ((i + k) `mod` n)
   where

src/Dodge/Item/Attachment.hs

@@ -2,8 +2,7 @@ module Dodge.Item.Attachment
     ( charFiringStratI
     , scrollCharMode
     , changeFuse
-    )
+    ) where
-    where
 import Dodge.Data
 import Dodge.Default
 

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -60,12 +60,9 @@ teslaGun = defaultGun
     , _itAimingRange = 0
     }
 teslaGunPic :: Item -> SPic
-teslaGunPic _ = 
+teslaGunPic _ = noPic $ colorSH blue $
-    ( colorSH blue $
         upperPrismPoly 5 (rectNESW xb    y xa    (-y))
         ++ upperPrismPoly 5 (rectNESW (-xa) y (-xb) (-y))
-    , mempty
-    )
   where
     xa = 1
     xb = 9

src/Dodge/Item/Weapon/Utility.hs

@@ -9,7 +9,7 @@ import Geometry
 import Picture
 --import qualified IntMapHelp as IM
 import Shape
---import ShapePicture
+import ShapePicture
 
 import Control.Lens
 shrinkGun :: Item
@@ -31,15 +31,20 @@ shrinkGun = defaultGun
     , _itLeftClickUse = Nothing
     , _wpSpread = 0.05
     , _wpRange = 20
-    , _itFloorPict = \_ -> (,) emptySH $ onLayer FlItLayer $ polygon $ map toV2[(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)]
+    , _itFloorPict = shrinkGunPic
     , _itAimingSpeed = 1
     , _itAimingRange = 0
     , _itAttachment = ItBool True
     }
 
+shrinkGunPic :: Item -> SPic
+shrinkGunPic _ = noPic $ colorSH violet $ upperPrismPoly 5 $ square 5
+
+-- be careful changing this around; potential problems include updating the
+-- creature but using the old crInvSel value
 useShrinkGun :: Item -> Creature -> World -> World
 useShrinkGun it cr w = if _itBool $ _itAttachment it
-    then tryResize 0.5 $ f False UndroppableIdentified . stripNoItems cr . dropUnselected cr
+    then tryResize 0.5 $ stripNoItems cr . f False UndroppableIdentified . dropUnselected cr
     else tryResize 1   $ f True Uncursed . setMinInvSize defaultInvSize cr
   where
     tryResize x g = maybe w g $ maybeSizeSelf x cr w

src/Dodge/LevelGen/StaticWalls.hs

@@ -19,6 +19,7 @@ import Data.Maybe
 -- | Describe a wall as two points.
 -- Order is important: the wall face is to the left of the line going from 
 -- 'fst' to 'snd'.
+-- TODO remove duplication
 type WallP = (Point2,Point2)
 -- | Remove inverse walls.
 removeInverseWalls :: [WallP] -> [WallP]

src/Dodge/WallCreatureCollisions.hs

@@ -2,6 +2,7 @@
 module Dodge.WallCreatureCollisions 
     ( colCrsWalls
     , colCrWall
+    , pushCreatureOutFromWalls
     ) where
 import Dodge.Data
 --import Dodge.Data.DamageType
@@ -23,11 +24,13 @@ colCrWall :: World -> Creature -> Creature
 colCrWall w c 
     | noclipIsOn && _crID c == 0 = c -- for noclip
     | p1 == p2  = pushOrCrush ls c
-    | _crPos c' == _crPos c'' = c'
+--    | _crPos c' == _crPos c'' = c'
-    | otherwise = c & crPos .~ _crOldPos c
+--    | otherwise = c & crPos .~ _crOldPos c
+    | otherwise = c'
   where 
-    c'' = c' & crPos %~ pushOutFromWalls rad ls
+--    c'' = c' & crPos %~ pushOutFromWalls rad ls
-    c'  = c & crPos %~ pushOutFromWalls' rad (reverse ls)
+    --c'  = c & crPos %~ pushOutFromWalls' rad (reverse ls)
+    c'  = c & crPos %~ pushOutFromCorners rad (reverse ls)
         . pushOutFromWalls rad ls 
         . flip (collidePointWalls p1) wls  -- check push throughs
     rad = _crRad c + wallBuffer
@@ -42,6 +45,9 @@ colCrWall w c
 wallBuffer :: Float
 wallBuffer = 0
 
+pushCreatureOutFromWalls :: [(Point2,Point2)] -> Creature -> Creature
+pushCreatureOutFromWalls ls cr = cr & crPos %~ pushOutFromWalls (_crRad cr) ls 
+
 -- the following tests whether or not a point is on a wall, and if so pushes it
 -- out from the wall
 -- this is then repeated if the point ends up on a new wall
@@ -91,8 +97,11 @@ pushOutFromWall' rad cp2 (wp1,wp2)
     --isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
     isOnWall = circOnSeg wp1 wp2 cp2 rad
 
---pushOutFromCorners :: World -> Creature -> Creature
+pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2
---pushOutFromCorners w cr = cr & crPos .~ newPos
+pushOutFromCorners r ls p = foldr (intersectCirclePoint r) p (map fst ls)
+
+--pushOutFromCorners' :: World -> Creature -> Creature
+--pushOutFromCorners' w cr = cr & crPos .~ newPos
 --  where
 --    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
 --    ls  = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w
@@ -101,7 +110,7 @@ pushOutFromWall' rad cp2 (wp1,wp2)
 --collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps
 
 ---- collide circles with points (outer corners)
---intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
+intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
---intersectCirclePoint rad p cCen 
+intersectCirclePoint rad p cCen 
---    | dist cCen p > rad = cCen
+    | dist cCen p > rad = cCen
---    | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
+    | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))

src/Padding.hs

@@ -50,3 +50,9 @@ rotListAt x' xs = f x' xs []
 
 insertAt :: Int -> a -> [a] -> [a]
 insertAt i x xs = let (ys,zs) = splitAt i xs in ys ++ [x] ++ zs
+
+--listElementOthersPairs :: [a] -> [(a,[a])]
+--listElementOthersPairs (x:xs) = go [] x xs
+--  where
+--    go ys y [] = [(y,ys)]
+--    go ys y (z:zs) = (y,ys++zs): go (y:ys) z zs