{-# LANGUAGE DeriveGeneric #-}
module Game.LambdaHack.Common.Vector
( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector
, moves, movesCardinal, movesDiagonal, compassText
, vicinity, vicinityUnsafe, vicinityCardinal, vicinityCardinalUnsafe
, squareUnsafeSet
, shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded
, vectorToFrom, computeTrajectory
, RadianAngle, rotate, towards
#ifdef EXPOSE_INTERNAL
, maxVectorDim, _moveTexts, longMoveTexts, normalize, normalizeVector
, pathToTrajectory
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.DeepSeq
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Int (Int32)
import GHC.Generics (Generic)
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Time
data Vector = Vector
{ vx :: X
, vy :: Y
}
deriving (Show, Read, Eq, Ord, Generic)
instance Binary Vector where
put = put . (fromIntegral :: Int -> Int32) . fromEnum
get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get
instance Enum Vector where
fromEnum (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent)
toEnum n =
let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)
(vx, vy) | x > maxVectorDim = (x - 2 ^ maxLevelDimExponent, y + 1)
| x < - maxVectorDim = (x + 2 ^ maxLevelDimExponent, y - 1)
| otherwise = (x, y)
in Vector{..}
instance NFData Vector
maxVectorDim :: Int
{-# INLINE maxVectorDim #-}
maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1
isUnit :: Vector -> Bool
{-# INLINE isUnit #-}
isUnit v = chessDistVector v == 1
isDiagonal :: Vector -> Bool
{-# INLINE isDiagonal #-}
isDiagonal (Vector x y) = x * y /= 0
neg :: Vector -> Vector
{-# INLINE neg #-}
neg (Vector vx vy) = Vector (-vx) (-vy)
chessDistVector :: Vector -> Int
{-# INLINE chessDistVector #-}
chessDistVector (Vector x y) = max (abs x) (abs y)
euclidDistSqVector :: Vector -> Vector -> Int
euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =
(x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)
moves :: [Vector]
moves =
map (uncurry Vector)
[(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]
movesCardinal :: [Vector]
movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)]
movesDiagonal :: [Vector]
movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)]
_moveTexts :: [Text]
_moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]
longMoveTexts :: [Text]
longMoveTexts = [ "northwest", "north", "northeast", "east"
, "southeast", "south", "southwest", "west" ]
compassText :: Vector -> Text
compassText v = let m = EM.fromList $ zip moves longMoveTexts
assFail = error $ "not a unit vector" `showFailure` v
in EM.findWithDefault assFail v m
vicinity :: X -> Y
-> Point
-> [Point]
vicinity lxsize lysize p =
if inside p (1, 1, lxsize - 2, lysize - 2)
then vicinityUnsafe p
else [ res | dxy <- moves
, let res = shift p dxy
, inside res (0, 0, lxsize - 1, lysize - 1) ]
vicinityUnsafe :: Point -> [Point]
vicinityUnsafe p = [ shift p dxy | dxy <- moves ]
vicinityCardinal :: X -> Y
-> Point
-> [Point]
vicinityCardinal lxsize lysize p =
[ res | dxy <- movesCardinal
, let res = shift p dxy
, inside res (0, 0, lxsize - 1, lysize - 1) ]
vicinityCardinalUnsafe :: Point -> [Point]
vicinityCardinalUnsafe p = [ shift p dxy | dxy <- movesCardinal ]
squareUnsafeSet :: Point -> ES.EnumSet Point
squareUnsafeSet (Point x y) =
ES.fromDistinctAscList $ map (uncurry Point)
[ (x - 1, y - 1)
, (x, y - 1)
, (x + 1, y - 1)
, (x - 1, y)
, (x, y)
, (x + 1, y)
, (x - 1, y + 1)
, (x, y + 1)
, (x + 1, y + 1) ]
shift :: Point -> Vector -> Point
{-# INLINE shift #-}
shift (Point x0 y0) (Vector x1 y1) = Point (x0 + x1) (y0 + y1)
shiftBounded :: X -> Y -> Point -> Vector -> Point
shiftBounded lxsize lysize pos v@(Vector xv yv) =
if inside pos (-xv, -yv, lxsize - xv - 1, lysize - yv - 1)
then shift pos v
else pos
trajectoryToPath :: Point -> [Vector] -> [Point]
trajectoryToPath _ [] = []
trajectoryToPath start (v : vs) = let next = shift start v
in next : trajectoryToPath next vs
trajectoryToPathBounded :: X -> Y -> Point -> [Vector] -> [Point]
trajectoryToPathBounded _ _ _ [] = []
trajectoryToPathBounded lxsize lysize start (v : vs) =
let next = shiftBounded lxsize lysize start v
in next : trajectoryToPathBounded lxsize lysize next vs
vectorToFrom :: Point -> Point -> Vector
{-# INLINE vectorToFrom #-}
vectorToFrom (Point x0 y0) (Point x1 y1) = Vector (x0 - x1) (y0 - y1)
pathToTrajectory :: [Point] -> [Vector]
pathToTrajectory [] = []
pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1
computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int))
computeTrajectory weight throwVelocity throwLinger path =
let speed = speedFromWeight weight throwVelocity
trange = rangeFromSpeedAndLinger speed throwLinger
btrajectory = pathToTrajectory $ take (trange + 1) path
in (btrajectory, (speed, trange))
type RadianAngle = Double
rotate :: RadianAngle -> Vector -> Vector
rotate angle (Vector x' y') =
let x = fromIntegral x'
y = fromIntegral y'
dx = x * cos (-angle) - y * sin (-angle)
dy = x * sin (-angle) + y * cos (-angle)
in normalize dx dy
normalize :: Double -> Double -> Vector
normalize dx dy =
assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `swith` (dx, dy)) $
let angle :: Double
angle = atan (dy / dx) / (pi / 2)
dxy | angle <= -0.75 && angle >= -1.25 = (0, -1)
| angle <= -0.25 = (1, -1)
| angle <= 0.25 = (1, 0)
| angle <= 0.75 = (1, 1)
| angle <= 1.25 = (0, 1)
| otherwise = error $ "impossible angle" `showFailure` (dx, dy, angle)
in if dx >= 0
then uncurry Vector dxy
else neg $ uncurry Vector dxy
normalizeVector :: Vector -> Vector
normalizeVector v@(Vector vx vy) =
let res = normalize (fromIntegral vx) (fromIntegral vy)
in assert (not (isUnit v) || v == res
`blame` "unit vector gets untrivially normalized"
`swith` (v, res))
res
towards :: Point -> Point -> Vector
towards pos0 pos1 =
assert (pos0 /= pos1 `blame` "towards self" `swith` (pos0, pos1))
$ normalizeVector $ pos1 `vectorToFrom` pos0