Main.hs

{-# LANGUAGE FlexibleInstances,
             DerivingVia,
             DeriveGeneric,
             DeriveFoldable,
             DeriveFunctor,
             GeneralizedNewtypeDeriving#-}
module Main where

import Control.Monad.Zip

newtype Width a = Width { getW :: a } deriving (Show, Eq, Functor, Foldable, Num)
instance Applicative Width where
  pure = Width
  f <*> a = Width (getW f (getW a))
instance Monad Width where
  v >>= f = f (getW v)
newtype Height a = Height { getH :: a } deriving (Show, Eq, Functor, Foldable, Num)
instance Applicative Height where
  pure = Height
  f <*> a = Height (getH f (getH a))
instance Monad Height where
  v >>= f = f (getH v)
newtype Depth a = Depth { getD :: a } deriving (Show, Eq, Functor, Foldable, Num)
instance Applicative Depth where
  pure = Depth
  f <*> a = Depth (getD f (getD a))
instance Monad Depth where
  v >>= f = f (getD v)

data Vec2D a = MkVec2D { v2dw :: Width a , v2dh :: Height a } deriving (Show, Eq, Functor, Foldable)
data Vec3D a = MkVec3D { v3dw :: Width a , v3dh :: Height a, v3dd :: Depth a} deriving (Show, Eq, Functor, Foldable)

instance Applicative Vec2D where
  pure v = MkVec2D (pure v) (pure v)
  (MkVec2D f g) <*> (MkVec2D a b) = MkVec2D (f <*> a) (g <*> b)

instance Applicative Vec3D where
  pure v = MkVec3D (pure v) (pure v) (pure v)
  (MkVec3D f g h) <*> (MkVec3D a b c) = MkVec3D (f <*> a) (g <*> b) (h <*> c)

instance Monad Vec2D where
  (MkVec2D x y) >>= f = let (MkVec2D x' _ ) = f (getW x)
                            (MkVec2D _ y') = f (getH y) in MkVec2D x' y'
instance Monad Vec3D where
  (MkVec3D x y z) >>= f = let (MkVec3D x' _ _) = f (getW x)
                              (MkVec3D _ y' _) = f (getH y)
                              (MkVec3D _ _ z') = f (getD z) in MkVec3D x' y' z'

instance MonadZip Vec2D  where
  mzip (MkVec2D x y) (MkVec2D a b)= MkVec2D (Width (getW x,  getW a)) (Height (getH y, getH b))

instance MonadZip Vec3D  where
  mzip (MkVec3D x y z) (MkVec3D a b c) = MkVec3D (Width (getW x,  getW a))
                                                 (Height (getH y, getH b))
                                                 (Depth (getD z, getD c))

instance (MonadZip m, Num a) => Num (m a) where
  (+) = mzipWith (+)
  (-) = mzipWith (-)
  (*) = mzipWith (*)
  abs = fmap abs
  fromInteger = pure . fromInteger
  signum = fmap signum

dot :: (Foldable t, Num a, MonadZip t) => t a -> t a -> a
dot a b = sum (mzipWith (*) a b)

lenSquared :: (Foldable t, Num a, MonadZip t) => t a -> a
lenSquared a = dot a a

main :: IO ()
main = let v = 3 :: Vec3D Int in putStrLn (show (lenSquared v))