module Hasmin.Types.TransformFunction
( TransformFunction(..)
, mkMat
, mkMat3d
, combine
) where
import Control.Monad.Reader (mapReader, Reader, ask, local)
import Control.Applicative (liftA2)
import Data.Monoid ((<>))
import Data.Either (isRight)
import qualified Data.Text as T
import Data.Number.FixedFunctions (sin, cos, acos, tan, atan)
import Prelude hiding (sin, cos, acos, tan, atan)
import qualified Data.Matrix as M
import Data.Matrix (Matrix)
import Data.List (groupBy)
import Data.Maybe (fromMaybe, isNothing, isJust, fromJust)
import Data.Text.Lazy.Builder (toLazyText, singleton, Builder)
import Data.Text.Lazy (toStrict)
import Hasmin.Config
import Hasmin.Types.Class
import Hasmin.Utils
import Hasmin.Types.Dimension
import Hasmin.Types.PercentageLength
import Hasmin.Types.Numeric
data TransformFunction = Mat (Matrix Number)
| Mat3d (Matrix Number)
| Perspective Distance
| Rotate Angle
| Rotate3d Number Number Number Angle
| RotateX Angle
| RotateY Angle
| RotateZ Angle
| Scale Number (Maybe Number)
| Scale3d Number Number Number
| ScaleX Number
| ScaleY Number
| ScaleZ Number
| Skew Angle (Maybe Angle)
| SkewX Angle
| SkewY Angle
| Translate PercentageLength (Maybe PercentageLength)
| Translate3d PercentageLength PercentageLength Distance
| TranslateX PercentageLength
| TranslateY PercentageLength
| TranslateZ Distance
deriving (Eq, Show)
instance Minifiable TransformFunction where
minifyWith (Mat3d m) = do
conf <- ask
if shouldMinifyTransformFunction conf
then case possibleRepresentations m of
[] -> pure (Mat3d m)
(x:xs) -> let simplifyAndConvertUnits a = local (const $ conf { dimensionSettings = DimMinOn }) (simplify a)
in go simplifyAndConvertUnits x xs
else pure (Mat3d m)
where go f y [] = f y
go f y (z:zs) = do
currentLength <- textualLength <$> f y
newLength <- textualLength <$> f z
if currentLength < newLength
then go f y zs
else go f z zs
minifyWith x = do
conf <- ask
if shouldMinifyTransformFunction conf
then case toMatrix3d x of
Just mat3d -> minifyWith mat3d
Nothing -> simplify x
else pure x
instance ToText TransformFunction where
toBuilder (Translate pl mpl) = "translate("
<> toBuilder pl <> maybeWithComma mpl <> singleton ')'
toBuilder (TranslateX pl) = "translatex("
<> either toBuilder toBuilder pl <> singleton ')'
toBuilder (TranslateY pl) = "translatey(" <> either toBuilder toBuilder pl <> singleton ')'
toBuilder (TranslateZ d) = "translatez(" <> toBuilder d <> singleton ')'
toBuilder (Scale n mn) = "scale(" <> toBuilder n <> maybeWithComma mn <> singleton ')'
toBuilder (ScaleX n) = "scalex(" <> toBuilder n <> singleton ')'
toBuilder (ScaleY n) = "scaley(" <> toBuilder n <> singleton ')'
toBuilder (ScaleZ n) = "scalez(" <> toBuilder n <> singleton ')'
toBuilder (Skew a ma) = "skew(" <> toBuilder a <> maybeWithComma ma <> singleton ')'
toBuilder (SkewX a) = "skewx(" <> toBuilder a <> singleton ')'
toBuilder (SkewY a) = "skewy(" <> toBuilder a <> singleton ')'
toBuilder (Rotate a) = "rotate(" <> toBuilder a <> singleton ')'
toBuilder (RotateX a) = "rotatex(" <> toBuilder a <> singleton ')'
toBuilder (RotateY a) = "rotatey(" <> toBuilder a <> singleton ')'
toBuilder (RotateZ a) = "rotatez(" <> toBuilder a <> singleton ')'
toBuilder (Rotate3d x y z a) = "rotate3d(" <> toBuilder x <> singleton ','
<> toBuilder y <> singleton ',' <> toBuilder z <> singleton ','
<> toBuilder a <> singleton ')'
toBuilder (Scale3d x y z) = "scale3d(" <> toBuilder x <> singleton ','
<> toBuilder y <> singleton ',' <> toBuilder z <> singleton ')'
toBuilder (Perspective d) = "perspective(" <> toBuilder d <> singleton ')'
toBuilder (Translate3d x y z ) = "translate3d(" <> toBuilder x <> singleton ','
<> toBuilder y <> singleton ',' <> toBuilder z <> singleton ')'
toBuilder (Mat m) = "matrix("
<> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')'
toBuilder (Mat3d m) = "matrix3d("
<> mconcatIntersperse toBuilder (singleton ',') (M.toList m) <> singleton ')'
maybeWithComma :: ToText a => Maybe a -> Builder
maybeWithComma = maybe mempty (\x -> singleton ',' <> toBuilder x)
mkMat :: [Number] -> TransformFunction
mkMat = Mat . M.fromList 3 2
mkMat3d :: [Number] -> TransformFunction
mkMat3d = Mat3d . M.fromList 4 4
toMatrix3d :: TransformFunction -> Maybe TransformFunction
toMatrix3d m@Mat3d{} = Just m
toMatrix3d (Mat x) = Just $ toMat3d (M.toList x)
where toMat3d [a,b,c,d,e,f] = mkMat3d [a, c, 0, e,
b, d, 0, f,
0, 0, 1, 0,
0, 0, 0, 1]
toMat3d _ = error "invalid matrix size!"
toMatrix3d (Translate pl mpl)
| isNonZeroPercentage pl = Nothing
| isJust mpl && isNonZeroPercentage (fromJust mpl) = Nothing
| otherwise = Just . Mat3d $ mkTranslate3dMatrix x y 0
where x = either (const 0) fromPixelsToNum pl
y = maybe 0 (fromPixelsToNum . fromRight') mpl
toMatrix3d (TranslateX pl)
| isNonZeroPercentage pl = Nothing
| isRight pl && isRelativeDistance (fromRight' pl) = Nothing
| otherwise = Just . Mat3d $ mkTranslate3dMatrix x 0 0
where x = either (const 0) fromPixelsToNum pl
toMatrix3d (TranslateY pl)
| isNonZeroPercentage pl = Nothing
| isRight pl && isRelativeDistance (fromRight' pl) = Nothing
| otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 y 0
where y = either (const 0) fromPixelsToNum pl
toMatrix3d (TranslateZ d)
| isRelativeDistance d = Nothing
| otherwise = Just . Mat3d $ mkTranslate3dMatrix 0 0 z
where z = fromPixelsToNum d
toMatrix3d (Scale n mn) = Just . Mat3d $ mkScale3dMatrix n y 1
where y = fromMaybe n mn
toMatrix3d (ScaleX n) = Just . Mat3d $ mkScale3dMatrix n 1 1
toMatrix3d (ScaleY n) = Just . Mat3d $ mkScale3dMatrix 1 n 1
toMatrix3d (ScaleZ n) = Just . Mat3d $ mkScale3dMatrix 1 1 n
toMatrix3d (Skew a ma) = Just . Mat3d $ mkSkewMatrix α β
where α = tangent a
β = maybe 0 tangent ma
toMatrix3d (SkewX a) = Just . Mat3d $ mkSkewMatrix (tangent a) 0
toMatrix3d (SkewY a) = Just . Mat3d $ mkSkewMatrix 0 (tangent a)
toMatrix3d (Translate3d pl1 pl2 d)
| isNonZeroPercentage pl1 || isNonZeroPercentage pl2 = Nothing
| isRight pl1 && isRelativeDistance (fromRight' pl1) = Nothing
| isRight pl2 && isRelativeDistance (fromRight' pl2) = Nothing
| isRelativeDistance d = Nothing
| otherwise = let x = either (const 0) fromPixelsToNum pl1
y = either (const 0) fromPixelsToNum pl2
z = fromPixelsToNum d
in Just . Mat3d $ mkTranslate3dMatrix x y z
toMatrix3d (Scale3d x y z) = Just . Mat3d $ mkScale3dMatrix x y z
toMatrix3d (Perspective d)
| d == Distance 0 Q = Nothing
| otherwise = let c = fromPixelsToNum d
in Just . Mat3d $ mkPerspectiveMatrix c
toMatrix3d _ = Nothing
matrixToRotate3d :: Matrix Number -> [TransformFunction]
matrixToRotate3d _ = []
isRelativeDistance :: Distance -> Bool
isRelativeDistance (Distance _ u) = isRelative u
fromPixelsToNum :: Distance -> Number
fromPixelsToNum (Distance n u) = toPixels n u
fromRadiansToNum :: Angle -> Number
fromRadiansToNum (Angle n u) = toRadians n u
tangent :: Angle -> Number
tangent = toNumber . tan epsilon . fromNumber . fromRadiansToNum
arctan :: Number -> Number
arctan = toNumber . atan epsilon . fromNumber
getMat :: TransformFunction -> Matrix Number
getMat (Mat q) = q
getMat (Mat3d q) = q
getMat _ = error "getMat: not a matrix!"
possibleRepresentations :: Matrix Number -> [TransformFunction]
possibleRepresentations m = matrixToRotate3d m ++ mconcat
[matrixToSkewFunctions m, matrixToTranslateFunctions m
,matrixToMat m, matrixToPerspective m
,matrixToScaleFunctions m]
matrixToSkewFunctions :: Matrix Number -> [TransformFunction]
matrixToSkewFunctions m
| skewMatrix == m = Skew a (Just b) : others
| otherwise = []
where α = M.unsafeGet 1 2 m
β = M.unsafeGet 2 1 m
a = Angle (arctan α) Rad
b = Angle (arctan β) Rad
skewMatrix = mkSkewMatrix α β
others
| α /= 0 && β == 0 = [SkewX a]
| β /= 0 && α == 0 = [SkewY b]
| otherwise = []
matrixToTranslateFunctions :: Matrix Number -> [TransformFunction]
matrixToTranslateFunctions m
| mkTranslate3dMatrix x y z == m = Translate3d tx ty tz : others
| otherwise = []
where x = M.unsafeGet 1 4 m
tx = Right $ Distance x PX
y = M.unsafeGet 2 4 m
ty = Right $ Distance y PX
z = M.unsafeGet 3 4 m
tz = Distance z PX
others
| z == 0 && y == 0 = [TranslateX tx, Translate tx (Just ty)]
| x == 0 && z == 0 = [TranslateY ty, Translate tx (Just ty)]
| y == 0 && x == 0 = [TranslateZ tz]
| otherwise = []
matrixToScaleFunctions :: Matrix Number -> [TransformFunction]
matrixToScaleFunctions m
| mkScale3dMatrix x y z == m = Scale3d x y z : others
| otherwise = []
where x = M.unsafeGet 1 1 m
y = M.unsafeGet 2 2 m
z = M.unsafeGet 3 3 m
others
| z == 1 && y == 1 = [ScaleX x, Scale x Nothing]
| y == 1 && x == 1 = [ScaleZ z]
| x == 1 && z == 1 = [ScaleY y, Scale x (Just y)]
| otherwise = []
matrixToPerspective :: Matrix Number -> [TransformFunction]
matrixToPerspective m
| c /= 0 && mkPerspectiveMatrix d == m = [Perspective $ Distance d PX]
| otherwise = []
where c = M.unsafeGet 4 3 m
d = (1)/c
matrixToMat :: Matrix Number -> [TransformFunction]
matrixToMat m
| matrix == m = [mkMat [a,b,c,d,e,f]]
| otherwise = []
where a = M.unsafeGet 1 1 m
b = M.unsafeGet 2 1 m
c = M.unsafeGet 1 2 m
d = M.unsafeGet 2 2 m
e = M.unsafeGet 1 4 m
f = M.unsafeGet 2 4 m
matrix = mkMatMatrix a b c d e f
mkMatMatrix :: Number -> Number -> Number -> Number
-> Number -> Number -> Matrix Number
mkMatMatrix a b c d e f = mk4x4Matrix [a, c, 0, e,
b, d, 0, f,
0, 0, 1, 0,
0, 0, 0, 1]
mkTranslate3dMatrix :: Number -> Number -> Number -> Matrix Number
mkTranslate3dMatrix x y z = mk4x4Matrix [1, 0, 0, x,
0, 1, 0, y,
0, 0, 1, z,
0, 0, 0, 1]
mkScale3dMatrix :: Number -> Number -> Number -> Matrix Number
mkScale3dMatrix x y z = mk4x4Matrix [x, 0, 0, 0,
0, y, 0, 0,
0, 0, z, 0,
0, 0, 0, 1]
mkSkewMatrix :: Number -> Number -> Matrix Number
mkSkewMatrix a b = mk4x4Matrix [1, a, 0, 0,
b, 1, 0, 0,
0, 0, 1, 0,
0, 0, 0, 1]
mkPerspectiveMatrix :: Number -> Matrix Number
mkPerspectiveMatrix c = let d = (1/c)
in mk4x4Matrix [1, 0, 0, 0,
0, 1, 0, 0,
0, 0, 1, 0,
0, 0, d, 0]
mk4x4Matrix :: [Number] -> Matrix Number
mk4x4Matrix = M.fromList 4 4
simplify :: TransformFunction -> Reader Config TransformFunction
simplify (Translate pl mpl)
| isNothing mpl || isZero (fromJust mpl) = do
x <- mapM minifyWith pl
pure $ Translate x Nothing
| otherwise = do x <- mapM minifyWith pl
y <- (mapM . mapM) minifyWith mpl
pure $ Translate x y
simplify (TranslateX pl) = do
x <- mapM minifyWith pl
simplify $ Translate x Nothing
simplify (TranslateY pl) = do
y <- mapM minifyWith pl
pure $ TranslateY y
simplify s@(Scale n mn) = pure $ maybe s removeDefaultArgument mn
where removeDefaultArgument x
| n == x = Scale n Nothing
| otherwise = s
simplify s@(ScaleX _) = pure s
simplify s@(ScaleY _) = pure s
simplify (Skew a ma)
| defaultSecondArgument = do ang <- minifyWith a
simplify $ Skew ang Nothing
| otherwise = liftA2 Skew (minifyWith a) (mapM minifyWith ma)
where defaultSecondArgument = maybe False (== Angle 0 Deg) ma
simplify (SkewY a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap SkewY (minifyWith a)
simplify (SkewX a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap SkewX (minifyWith a)
simplify (Rotate a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap Rotate (minifyWith a)
simplify (RotateX a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap RotateX (minifyWith a)
simplify (RotateY a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap RotateY (minifyWith a)
simplify (RotateZ a)
| a == Angle 0 Deg = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap Rotate (minifyWith a)
simplify (Rotate3d x y z a)
| abs (x 1) < ep && abs y < ep && abs z < ep = simplify $ RotateX a
| abs x < ep && abs (y 1) < ep && abs z < ep = simplify $ RotateY a
| abs x < ep && abs y < ep && abs (z 1) < ep = fmap Rotate (minifyWith a)
where ep = toNumber epsilon
simplify (ScaleZ n)
| n == 1 = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = pure $ ScaleZ n
simplify (Perspective d) = fmap Perspective (minifyWith d)
simplify (TranslateZ d)
| d == Distance 0 Q = pure $ Skew (Angle 0 Deg) Nothing
| otherwise = fmap TranslateZ (minifyWith d)
simplify s@(Scale3d x y z)
| z == 1 = simplify $ Scale x (Just y)
| x == 1 && y == 1 = simplify $ ScaleZ z
| otherwise = pure s
simplify (Translate3d x y z )
| isZero y && z == Distance 0 Q = either (f TranslateX) (g TranslateX) x
| isZero x && isZero y = simplify $ TranslateZ z
| isZero x && z == Distance 0 Q = either (f TranslateY) (g TranslateY) y
where f con a | a == 0 = simplify . con . Right $ Distance 0 Q
| otherwise = simplify . con . Left $ a
g con a = simplify . con $ Right a
simplify x = pure x
combine :: [TransformFunction] -> Reader Config [TransformFunction]
combine xs = do
combinedLength <- mapReader (getLength . asBuilder) combinedFunctions
originalLength <- mapReader (getLength . asBuilder) minifiedOriginal
if combinedLength < originalLength
then combinedFunctions
else minifiedOriginal
where getLength = T.length . toStrict . toLazyText
asBuilder = mconcatIntersperse toBuilder (singleton ' ')
combinedFunctions = mapM handleMatrices . groupByMatrices $ zip (fmap toMatrix3d xs) xs
minifiedOriginal = mapM minifyWith xs
groupByMatrices = groupBy (\(a,_) (b,_) -> isJust a && isJust b)
handleMatrices l@((x,a):_)
| isJust x = minifyWith . Mat3d . foldr (*) (M.identity 4 :: Matrix Number) $ fmap (getMat . fromJust . fst) l
| otherwise = simplify a
handleMatrices [] = error "empty list as argument to handleMatrices"