module Game.LambdaHack.Common.Vector
( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector
, moves, movesCardinal, movesDiagonal, compassText, vicinity, vicinityCardinal
, shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded
, vectorToFrom, pathToTrajectory
, RadianAngle, rotate, towards
) where
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import Data.Int (Int32)
import Data.Maybe
import Data.Text (Text)
import Game.LambdaHack.Common.Point
data Vector = Vector
{ vx :: !X
, vy :: !Y
}
deriving (Eq, Ord, Show, Read)
instance Binary Vector where
put = put . (fromIntegral :: Int -> Int32) . fromEnum
get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get
instance Enum Vector where
fromEnum = fromEnumVector
toEnum = toEnumVector
maxVectorDim :: Int
maxVectorDim = 2 ^ (maxLevelDimExponent 1) 1
fromEnumVector :: Vector -> Int
fromEnumVector (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent)
toEnumVector :: Int -> Vector
toEnumVector n =
let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)
(vx, vy) = if x > maxVectorDim
then (x 2 ^ maxLevelDimExponent, y + 1)
else if x < maxVectorDim
then (x + 2 ^ maxLevelDimExponent, y 1)
else (x, y)
in Vector{..}
isUnit :: Vector -> Bool
isUnit v = chessDistVector v == 1
isDiagonal :: Vector -> Bool
isDiagonal (Vector x y) = x * y /= 0
neg :: Vector -> Vector
neg (Vector vx vy) = Vector (vx) (vy)
euclidDistSqVector :: Vector -> Vector -> Int
euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =
let square n = n ^ (2 :: Int)
in square (x1 x0) + square (y1 y0)
chessDistVector :: Vector -> Int
chessDistVector (Vector x y) = max (abs x) (abs y)
moves :: [Vector]
moves =
map (uncurry Vector)
[(1, 1), (0, 1), (1, 1), (1, 0), (1, 1), (0, 1), (1, 1), (1, 0)]
moveTexts :: [Text]
moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]
compassText :: Vector -> Text
compassText v = let m = EM.fromList $ zip moves moveTexts
in fromMaybe (assert `failure` "not a unit vector"
`twith` v) $ EM.lookup v m
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)]
vicinity :: X -> Y
-> Point
-> [Point]
vicinity lxsize lysize p =
[ res | dxy <- moves
, let res = shift p dxy
, inside res (0, 0, lxsize 1, lysize 1) ]
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) ]
shift :: Point -> Vector -> Point
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
vectorToFrom (Point x0 y0) (Point x1 y1) = Vector (x0 x1) (y0 y1)
pathToTrajectory :: [Point] -> [Vector]
pathToTrajectory [] = []
pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1
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" `twith` (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 = assert `failure` "impossible angle"
`twith` (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"
`twith` (v, res))
res
towards :: Point -> Point -> Vector
towards pos0 pos1 =
assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1))
$ normalizeVector $ pos1 `vectorToFrom` pos0