mandulia-0.5: src/Vector.hs

{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Vector
  ( R
  , V(..)
  , M(..)
  , (^*)
  , (^/)
  , (^+^)
  , (^-^)
  , (^|-|^)
  , (^^*^)
  , (^^*^^)
  , translate
  , scale
  , rotate
  ) where

type R = Double
data V = V !R !R !R deriving (Show, Read, Eq, Ord)
data M = M !V !V !V deriving (Show, Read, Eq, Ord)

translate :: R -> R -> M
translate x y = M (V 1 0 x) (V 0 1 y) (V 0 0 1)

scale :: R -> R -> M
scale x y = M (V x 0 0) (V 0 y 0) (V 0 0 1)

rotate :: R -> M
rotate a = M (V c s 0) (V (-s) c 0) (V 0 0 1)
  where
    s = sin a
    c = cos a

(^*) :: V -> R -> V
(V a b c)  ^*   x = V (a*x) (b*x) (c*x)

(^/) :: V -> R -> V
(V a b c)  ^/   x = V (a/x) (b/x) (c/x)

(^+^) :: V -> V -> V
(V a b c)  ^+^  (V x y z) = V (a+x) (b+y) (c+z)

(^-^) :: V -> V -> V
(V a b c)  ^-^  (V x y z) = V (a-x) (b-y) (c-z)

dot :: V -> V -> R
(V a b c) `dot` (V x y z) = a*x + b*y + c*z

(^^*^) :: M -> V -> V
(M (V a b c) (V d e f) (V g h i)) ^^*^ (V r u x) =
  V (a * r + b * u + c * x)
    (d * r + e * u + f * x)
    (g * r + h * u + i * x)

(^^*^^) :: M -> M -> M
(M (V a b c) (V d e f) (V g h i)) ^^*^^ (M (V r s t) (V u v w) (V x y z)) =
  M (V (a * r + b * u + c * x) (a * s + b * v + c * y) (a * t + b * w + c * z))
    (V (d * r + e * u + f * x) (d * s + e * v + f * y) (d * t + e * w + f * z))
    (V (g * r + h * u + i * x) (g * s + h * v + i * y) (g * t + h * w + i * z))

(^|-|^) :: V -> V -> R
u ^|-|^ v = let d = u ^-^ v in sqrt $ d `dot` d