Fix tile rendering

src/Data/Tile.hs

@@ -4,12 +4,12 @@ module Data.Tile
 import Geometry.Data
 
 import Control.Lens
+
 data Tile = Tile
     { _tilePoly :: [Point2]
-    , _tileCenter :: Point2
+    , _tileZero :: Point2   -- ^ point in the world where tile texture is 0,0
-    , _tileX :: Point2
+    , _tileX    :: Point2   -- ^ vector in the X direction (1,0)
-    , _tileY :: Point2
+    , _tileZ    :: Float
-    , _tileZ :: Float
     }
   deriving (Eq, Ord, Show)
 makeLenses ''Tile

src/Dodge/Data.hs

@@ -292,7 +292,7 @@ data Item
         , _itZoom    :: ItZoom
         , _itAimZoom :: ItZoom
         , _itEquipPict :: Creature -> Int -> Picture
-        , _itScroll :: Float -> Creature -> World -> World
+        , _itScroll :: Float -> Creature -> Item -> Item
         , _itIdentity :: ItemIdentity
         , _itAttachment :: ItAttachment
         , _itID :: Maybe Int
@@ -372,8 +372,9 @@ data Item
         , _itInvColor   :: Color
         , _itEffect     :: ItEffect
         , _itHammer     :: HammerPosition
-        , _itScrollUp   :: Int -> World -> World
+        , _itScroll     :: Float -> Creature -> Item -> Item
-        , _itScrollDown :: Int -> World -> World
+--        , _itScrollUp   :: Int -> World -> World
+--        , _itScrollDown :: Int -> World -> World
         , _itAimStance  :: AimStance
         }
      | NoItem

src/Dodge/Default.hs

@@ -57,7 +57,7 @@ defaultCreature = Creature
     , _crTarget  = Nothing
     , _crMvTarget= Nothing
     , _crGroup   = LoneWolf
-    , _crMvType  = NoMvType
+    , _crMvType  = defaultAimMvType
     }
 defaultChaseMvType :: CrMvType
 defaultChaseMvType = ChaseMvType

src/Dodge/Event.hs

@@ -27,7 +27,7 @@ import Preload.Update
 import qualified IntMapHelp as IM
 
 import Control.Lens
-import Data.Maybe
+--import Data.Maybe
 --import Data.Char
 --import Data.List
 --import Data.Function (on)
@@ -91,10 +91,9 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
         | rbDown -> w & carteZoom %~ min 0.75 . max 0.05 . ((1+y*0.1) * )
         | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ yi)
     (_, TopInventory)
-        | rbDown -> fromMaybe (closeObjScrollDir y w) $ (yourItem w ^? itScroll) 
+        | rbDown -> case yourItem w ^? itScroll of
-            <*> pure y
+            Nothing -> closeObjScrollDir y w
-            <*> pure (you w)
+            Just f  -> w & creatures . ix 0 . crInv . ix (_crInvSel $ you w) %~ f y (you w)
-            <*> pure w
         | lbDown -> w & cameraZoom +~ y
         | invKeyDown -> swapInvDir yi $ dirInvPos yi w
         | otherwise -> dirInvPos yi w

src/Dodge/Item/Attachment.hs

@@ -1,8 +1,7 @@
 module Dodge.Item.Attachment
     ( charFiringStratI
     , scrollCharMode
-    , decreaseFuse
+    , changeFuse
-    , increaseFuse
     )
     where
 import Dodge.Data
@@ -18,27 +17,25 @@ import qualified Data.IntMap.Strict as IM
 scrollCharMode
     :: Float    -- ^ Amount scrolled
     -> Creature
-    -> World
+    -> Item
-    -> World
+    -> Item
-scrollCharMode x cr 
+scrollCharMode x _ 
-    | x > 0 = incCharMode (_crInvSel cr)
+    | x > 0 = incCharMode
-    | x < 0 = decCharMode (_crInvSel cr)
+    | x < 0 = decCharMode
     | otherwise = id
 
 incCharMode 
-    :: Int      -- ^ Inventory selection
+    :: Item 
-    -> World 
+    -> Item
-    -> World
+incCharMode = itAttachment . itCharMode %~ cycleL
-incCharMode i = creatures . ix 0 . crInv . ix i . itAttachment . itCharMode %~ cycleL
   where
     cycleL (x :<| xs) = xs |> x
     cycleL xs = xs
 
 decCharMode 
-    :: Int      -- ^ Inventory selection
+    :: Item 
-    -> World 
+    -> Item
-    -> World
+decCharMode = itAttachment . itCharMode %~ cycleR
-decCharMode i = creatures . ix 0 . crInv . ix i . itAttachment . itCharMode %~ cycleR
   where
     cycleR (xs :|> x) = x <| xs
     cycleR xs = xs
@@ -59,32 +56,15 @@ charFiringStratI strats eff item cr w = case w ^? creatures . ix cid . crInv
   where
     cid = _crID cr
 
-increaseFuse 
+changeFuse 
-    :: Int  -- ^ Old fuse time
+    :: Float  -- ^ Old fuse time
-    -> Int  -- ^ Inventory item reference (I believe)
+    -> Creature  -- ^ Inventory item reference (I believe)
-    -> World 
+    -> Item 
-    -> World
+    -> Item
-increaseFuse fuse itid w = w 
+changeFuse scrollAmount _ it = it
-    & creatures . ix 0 . crInv . ix itid %~ 
+        & ( itAttachment .~ ItFuse newTime )
-          ( itScrollUp .~ decreaseFuse newTime )
+        & ( itAimZoom .~ defaultItZoom{_itZoomMax = zm, _itZoomMin = zm} )
-        . (itScrollDown .~ increaseFuse newTime )
-        . ( itAttachment .~ ItFuse newTime )
-        . ( itAimZoom .~ defaultItZoom{_itZoomMax = zm, _itZoomMin = zm} )
   where 
-    newTime = min (fuse + 5) 90
+    oldTime = _itFuseTime $ _itAttachment it
-    zm = 50 / fromIntegral newTime
+    newTime = min 90 $ max 20 $ oldTime - round (5 * scrollAmount)
-
-decreaseFuse 
-    :: Int  -- ^ Old fuse time
-    -> Int  -- ^ Inventory item reference (I believe)
-    -> World 
-    -> World
-decreaseFuse fuse itid w = w 
-    & creatures . ix 0 . crInv . ix itid %~ 
-        ( itScrollUp .~ decreaseFuse newTime )
-        . ( itScrollDown .~ increaseFuse newTime )
-        . ( itAttachment .~ ItFuse newTime )
-        . ( itAimZoom .~ defaultItZoom {_itZoomMax = zm, _itZoomMin = zm} )
-  where 
-    newTime = max (fuse - 5) 20
     zm = 50 / fromIntegral newTime

src/Dodge/Item/Weapon.hs

@@ -528,18 +528,16 @@ longGun = defaultGun
 longGunPic :: Picture
 longGunPic = pictures  [color orange $ polygon $ rectNESW 2 12 (-2) (-12) ]
 
-zoomLongGun :: Float -> Creature -> World -> World
+zoomLongGun :: Float -> Creature -> Item -> Item
-zoomLongGun x cr
+zoomLongGun x _
-    | x > 0 = startZoomInLongGun (_crInvSel cr)
+    | x > 0 = startZoomInLongGun 
-    | x < 0 = startZoomOutLongGun (_crInvSel cr)
+    | x < 0 = startZoomOutLongGun
     | otherwise = id
 
-startZoomInLongGun :: Int -> World -> World
+startZoomInLongGun :: Item -> Item
-startZoomInLongGun  _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
+startZoomInLongGun   = itAttachment . scopeZoomChange %~ \x -> max 5 (x + 5)
-                                . itAttachment . scopeZoomChange %~ \x -> max 5 (x + 5)
+startZoomOutLongGun :: Item -> Item
-startZoomOutLongGun :: Int -> World -> World
+startZoomOutLongGun  = itAttachment . scopeZoomChange %~ \x -> min (-5) (x-5)
-startZoomOutLongGun  _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
-                                . itAttachment . scopeZoomChange %~ \x -> min (-5) (x-5)
 poisonSprayer :: Item
 poisonSprayer = defaultAutoGun 
     { _itName = "POISON"
@@ -828,8 +826,7 @@ grenade = Throwable
     , _itInvDisplay = basicWeaponDisplay
     , _itEffect = wpRecock
     , _itHammer = HammerUp
-    , _itScrollUp   = decreaseFuse fuseTime
+    , _itScroll = changeFuse
-    , _itScrollDown = increaseFuse fuseTime
     , _itAimStance = OneHand
     }
   where 

src/Dodge/Item/Weapon/Bezier.hs

@@ -37,7 +37,7 @@ bezierGun = defaultGun
     , _itFloorPict = onLayer FlItLayer bezierGunPic
     , _itEquipPict = pictureWeaponOnAim bezierGunPic
     , _itAttachment = NoItAttachment
-    , _itScroll   = removeItTarget 0
+    , _itScroll   = \_ _ -> removeItTarget
     , _itHammer = HammerUp
     , _itEffect = rbSetTarget
     , _itZoom = defaultItZoom

src/Dodge/Item/Weapon/Targeting.hs

@@ -3,7 +3,7 @@ module Dodge.Item.Weapon.Targeting
 import Dodge.Data
 
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
+--import qualified Data.IntMap.Strict as IM
 useTargetPos 
     :: (Maybe Point2 -> Creature -> World -> World)
     -> Creature
@@ -13,8 +13,5 @@ useTargetPos f cr w = case cr ^? crInv . ix (_crInvSel cr) . itTargeting . _Just
     Nothing -> w
     Just (g,_) -> f (g w) cr w
 
-removeItTarget :: Int -> Float -> Creature -> World -> World
+removeItTarget :: Item -> Item
-removeItTarget i _ _ w = w & creatures . ix i . crInv . ix itRef . itTargeting .~ Nothing
+removeItTarget = itTargeting .~ Nothing
-  where 
-    cr = _creatures w IM.! i
-    itRef = _crInvSel cr

src/Dodge/Room.hs

@@ -228,7 +228,7 @@ roomOctogon = defaultRoom
     , _rmPath  = allPairs $ map fst lnks
     , _rmPS    = []
     , _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
-    , _rmFloor = [oTile poly 7]
+    , _rmFloor = [makeTileFromPoly poly 7]
     }
   where 
     poly = map toV2 [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]

src/Dodge/Room/AddTile.hs

@@ -9,7 +9,7 @@ import Control.Lens
 addTile :: Float -> Room -> Room
 addTile z r
     | not (null (_rmFloor r)) || null rp = r
-    | otherwise = r & rmFloor .~ [oTile poly z]
+    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
   where
     rp = _rmPolys r
-    poly = convexHull $ concat rp
+    poly = orderPolygon . convexHull $ concat rp

src/Dodge/Room/Corridor.hs

@@ -16,7 +16,7 @@ corridor = defaultRoom
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
     , _rmPS    = []
     , _rmBound = [ rectNSWE 50 30 0 40 ]
-    , _rmFloor = [oTile poly 2]  
+    , _rmFloor = [makeTileFromPoly poly 2]  
     }
   where 
     poly = rectNSWE 80 0 0 40

src/Dodge/Room/Link.hs

@@ -73,9 +73,8 @@ shiftRoomBy shift r = r
     & rmBound %~ fmap (map (shiftPointBy shift))
     & rmFloor %~ map 
         ( (tilePoly %~ map (shiftPointBy shift))
-        . (tileCenter %~ shiftPointBy shift    )
+        . (tileZero %~ shiftPointBy shift    )
-        . (tileX %~ shiftPointBy shift         )
+        . (tileX    %~ shiftPointBy shift         )
-        . (tileY %~ shiftPointBy shift         )
         )
 
 shiftLinkBy 

src/Dodge/Room/Procedural.hs

@@ -53,10 +53,9 @@ roomRect x y xn yn = defaultRoom
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = [Tile 
             { _tilePoly = rectNSWE y 0 0 x
-            , _tileCenter = V2 0 0
+            , _tileZero = V2 0 0
-            , _tileX = V2 50 0
+            , _tileX    = V2 1 0
-            , _tileY = V2 0 50
+            , _tileZ    = 16
-            , _tileZ = 16
             } ]
     }
   where 

src/Tile.hs

@@ -8,7 +8,7 @@ tToRender :: Tile -> [(Point3,Point3)]
 tToRender t = polyToTris $ zip ps3 coords3
   where
     ps = _tilePoly t
-    coords = map (calcTexCoord (_tileCenter t) (_tileX t) (_tileY t)) ps
+    coords = map (calcTexCoord (_tileZero t) (_tileX t)) ps
     ps3 = map (addToV2 0) ps
     coords3 = map (addToV2 (_tileZ t)) coords
 
@@ -21,29 +21,23 @@ mkTrip z (x,y) = (x,y,z)
 calcTexCoord
     :: Point2   -- ^ tile (0,0)
     -> Point2   -- ^ tile (1,0)
-    -> Point2   -- ^ tile (0,1)
     -> Point2   -- ^ world point
     -> Point2
-calcTexCoord cen x' y' p = V2
+calcTexCoord c p x = V2 (0.02 * dotV (p -.- c) xdir) (0.02 * dotV (p -.- c) ydir)
-    ( magV (projV (p -.- cen) x) / magV x )
-    ( magV (projV (p -.- cen) y) / magV y )
   where
-    x = x' -.- cen
+    xdir = x -.- c
-    y = y' -.- cen
+    ydir = vNormal xdir
 
-oTile
+makeTileFromPoly
     :: [Point2]
     -> Float
     -> Tile
-oTile poly z = Tile
+makeTileFromPoly poly z = Tile
     { _tilePoly = poly
-    , _tileCenter = c
+    , _tileZero = c
-    , _tileX = x
+    --, _tileXY   = c +.+ xdir +.+ vNormal xdir
-    , _tileY = y
+    , _tileX  = c +.+ (normalizeV $ (poly !! 1) -.- c)
     , _tileZ = z
     }
   where
     c = head poly
-    xdir = 50 *.* normalizeV (poly !! 1 -.- c)
-    x = c +.+ xdir
-    y = c +.+ vNormal xdir