mini-1.6.4.0: src/Mini/Linear/Space.hs

-- | Vector spaces of up to four dimensions
module Mini.Linear.Space (
  -- * Elements
  V0 (V0),
  V1 (V1),
  V2 (V2),
  V3 (V3),
  V4 (V4),

  -- * Spaces
  R1 (
    x
  ),
  R2 (
    y,
    xy,
    yx
  ),
  R3 (
    z,
    xz,
    yz,
    zx,
    zy,
    xyz,
    xzy,
    yxz,
    yzx,
    zxy,
    zyx
  ),
  R4 (
    w,
    xw,
    yw,
    zw,
    wx,
    wy,
    wz,
    xyw,
    xzw,
    xwy,
    xwz,
    yxw,
    yzw,
    ywx,
    ywz,
    zxw,
    zyw,
    zwx,
    zwy,
    wxy,
    wxz,
    wyx,
    wyz,
    wzx,
    wzy,
    xyzw,
    xywz,
    xzyw,
    xzwy,
    xwyz,
    xwzy,
    yxzw,
    yxwz,
    yzxw,
    yzwx,
    ywxz,
    ywzx,
    zxyw,
    zxwy,
    zyxw,
    zywx,
    zwxy,
    zwyx,
    wxyz,
    wxzy,
    wyxz,
    wyzx,
    wzxy,
    wzyx
  ),
) where

import Control.Applicative (
  liftA2,
 )
import Control.Monad (
  ap,
  liftM,
 )
import Mini.Hash.Class (
  Hashable (
    toBytes
  ),
 )
import Mini.Linear.Approx (
  Approx,
  (~=),
 )
import Mini.Optics.Lens (
  Lens,
  view,
 )
import Mini.Random.Class (
  Random,
  random,
 )
import Prelude (
  Applicative,
  Bool (
    False,
    True
  ),
  Eq,
  Foldable,
  Functor,
  Monad,
  Monoid,
  Ord,
  Semigroup,
  Show,
  Traversable,
  and,
  concatMap,
  fmap,
  foldr,
  id,
  length,
  mempty,
  null,
  pure,
  traverse,
  ($),
  (.),
  (<$>),
  (<*>),
  (<>),
  (>>=),
 )

-- Spaces

-- | Vector space with at least one dimension
class R1 v where
  -- | Basis vector lens of the first dimension
  x :: Lens (v a) (v a) a a

-- | Vector space with at least two dimensions
class (R1 v) => R2 v where
  -- | Basis vector lens of the second dimension
  y :: Lens (v a) (v a) a a
  y f = xy (\(V2 a0 a1) -> V2 a0 <$> f a1)

  xy :: Lens (v a) (v a) (V2 a) (V2 a)
  yx :: Lens (v a) (v a) (V2 a) (V2 a)
  yx f = xy (\v -> f $ V2 (view y v) (view x v))

-- | Vector space with at least three dimensions
class (R2 v) => R3 v where
  -- | Basis vector lens of the third dimension
  z :: Lens (v a) (v a) a a
  z f = xyz (\(V3 a0 a1 a2) -> V3 a0 a1 <$> f a2)

  xz :: Lens (v a) (v a) (V2 a) (V2 a)
  xz f =
    xyz
      ( \v ->
          (\v' -> V3 (view x v') (view y v) (view y v'))
            <$> f (V2 (view x v) (view z v))
      )

  yz :: Lens (v a) (v a) (V2 a) (V2 a)
  yz f =
    xyz
      ( \v ->
          (\v' -> V3 (view x v) (view x v') (view y v'))
            <$> f (V2 (view y v) (view z v))
      )

  zx :: Lens (v a) (v a) (V2 a) (V2 a)
  zx f =
    xyz
      ( \v ->
          (\v' -> V3 (view y v') (view y v) (view x v'))
            <$> f (V2 (view z v) (view x v))
      )

  zy :: Lens (v a) (v a) (V2 a) (V2 a)
  zy f =
    xyz
      ( \v ->
          (\v' -> V3 (view x v) (view y v') (view x v'))
            <$> f (V2 (view z v) (view y v))
      )

  xyz :: Lens (v a) (v a) (V3 a) (V3 a)
  xzy :: Lens (v a) (v a) (V3 a) (V3 a)
  xzy f = xyz (\v -> f $ V3 (view x v) (view z v) (view y v))

  yxz :: Lens (v a) (v a) (V3 a) (V3 a)
  yxz f = xyz (\v -> f $ V3 (view y v) (view x v) (view z v))

  yzx :: Lens (v a) (v a) (V3 a) (V3 a)
  yzx f = xyz (\v -> f $ V3 (view y v) (view z v) (view x v))

  zxy :: Lens (v a) (v a) (V3 a) (V3 a)
  zxy f = xyz (\v -> f $ V3 (view z v) (view x v) (view y v))

  zyx :: Lens (v a) (v a) (V3 a) (V3 a)
  zyx f = xyz (\v -> f $ V3 (view z v) (view y v) (view x v))

-- | Vector space with at least four dimensions
class (R3 v) => R4 v where
  -- | Basis vector lens of the fourth dimension
  w :: Lens (v a) (v a) a a
  w f = xyzw (\(V4 a0 a1 a2 a3) -> V4 a0 a1 a2 <$> f a3)

  xw :: Lens (v a) (v a) (V2 a) (V2 a)
  xw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view y v) (view z v) (view y v'))
            <$> f (V2 (view x v) (view w v))
      )
  yw :: Lens (v a) (v a) (V2 a) (V2 a)
  yw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view x v') (view z v) (view y v'))
            <$> f (V2 (view y v) (view w v))
      )
  zw :: Lens (v a) (v a) (V2 a) (V2 a)
  zw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view y v) (view x v') (view y v'))
            <$> f (V2 (view z v) (view w v))
      )
  wx :: Lens (v a) (v a) (V2 a) (V2 a)
  wx f =
    xyzw
      ( \v ->
          (\v' -> V4 (view y v') (view y v) (view z v) (view x v'))
            <$> f (V2 (view w v) (view x v))
      )
  wy :: Lens (v a) (v a) (V2 a) (V2 a)
  wy f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view y v') (view z v) (view x v'))
            <$> f (V2 (view w v) (view y v))
      )
  wz :: Lens (v a) (v a) (V2 a) (V2 a)
  wz f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view y v) (view y v') (view x v'))
            <$> f (V2 (view w v) (view z v))
      )
  xyw :: Lens (v a) (v a) (V3 a) (V3 a)
  xyw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view y v') (view z v) (view z v'))
            <$> f (V3 (view x v) (view y v) (view w v))
      )
  xzw :: Lens (v a) (v a) (V3 a) (V3 a)
  xzw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view y v) (view y v') (view z v'))
            <$> f (V3 (view x v) (view z v) (view w v))
      )
  xwy :: Lens (v a) (v a) (V3 a) (V3 a)
  xwy f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view y v') (view z v) (view y v'))
            <$> f (V3 (view x v) (view w v) (view y v))
      )
  xwz :: Lens (v a) (v a) (V3 a) (V3 a)
  xwz f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view y v) (view z v') (view y v'))
            <$> f (V3 (view x v) (view w v) (view z v))
      )
  yxw :: Lens (v a) (v a) (V3 a) (V3 a)
  yxw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v') (view x v') (view z v) (view z v'))
            <$> f (V3 (view y v) (view x v) (view w v))
      )
  yzw :: Lens (v a) (v a) (V3 a) (V3 a)
  yzw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view x v') (view y v') (view z v'))
            <$> f (V3 (view y v) (view z v) (view w v))
      )
  ywx :: Lens (v a) (v a) (V3 a) (V3 a)
  ywx f =
    xyzw
      ( \v ->
          (\v' -> V4 (view z v') (view x v') (view z v) (view y v'))
            <$> f (V3 (view y v) (view w v) (view x v))
      )
  ywz :: Lens (v a) (v a) (V3 a) (V3 a)
  ywz f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view x v') (view z v') (view y v'))
            <$> f (V3 (view y v) (view w v) (view z v))
      )
  zxw :: Lens (v a) (v a) (V3 a) (V3 a)
  zxw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view y v') (view y v) (view x v') (view z v'))
            <$> f (V3 (view z v) (view x v) (view w v))
      )
  zyw :: Lens (v a) (v a) (V3 a) (V3 a)
  zyw f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view y v') (view x v') (view z v'))
            <$> f (V3 (view z v) (view y v) (view w v))
      )
  zwx :: Lens (v a) (v a) (V3 a) (V3 a)
  zwx f =
    xyzw
      ( \v ->
          (\v' -> V4 (view z v') (view y v) (view x v') (view y v'))
            <$> f (V3 (view z v) (view w v) (view x v))
      )
  zwy :: Lens (v a) (v a) (V3 a) (V3 a)
  zwy f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view z v') (view x v') (view y v'))
            <$> f (V3 (view z v) (view w v) (view y v))
      )
  wxy :: Lens (v a) (v a) (V3 a) (V3 a)
  wxy f =
    xyzw
      ( \v ->
          (\v' -> V4 (view y v') (view z v') (view z v) (view x v'))
            <$> f (V3 (view w v) (view x v) (view y v))
      )
  wxz :: Lens (v a) (v a) (V3 a) (V3 a)
  wxz f =
    xyzw
      ( \v ->
          (\v' -> V4 (view y v') (view y v) (view z v') (view x v'))
            <$> f (V3 (view w v) (view x v) (view z v))
      )
  wyx :: Lens (v a) (v a) (V3 a) (V3 a)
  wyx f =
    xyzw
      ( \v ->
          (\v' -> V4 (view z v') (view y v') (view z v) (view x v'))
            <$> f (V3 (view w v) (view y v) (view x v))
      )
  wyz :: Lens (v a) (v a) (V3 a) (V3 a)
  wyz f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view y v') (view z v') (view x v'))
            <$> f (V3 (view w v) (view y v) (view z v))
      )
  wzx :: Lens (v a) (v a) (V3 a) (V3 a)
  wzx f =
    xyzw
      ( \v ->
          (\v' -> V4 (view z v') (view y v) (view y v') (view x v'))
            <$> f (V3 (view w v) (view z v) (view x v))
      )
  wzy :: Lens (v a) (v a) (V3 a) (V3 a)
  wzy f =
    xyzw
      ( \v ->
          (\v' -> V4 (view x v) (view z v') (view y v') (view x v'))
            <$> f (V3 (view w v) (view z v) (view y v))
      )
  xyzw :: Lens (v a) (v a) (V4 a) (V4 a)
  xywz :: Lens (v a) (v a) (V4 a) (V4 a)
  xywz f = xyzw (\v -> f $ V4 (view x v) (view y v) (view w v) (view z v))
  xzyw :: Lens (v a) (v a) (V4 a) (V4 a)
  xzyw f = xyzw (\v -> f $ V4 (view x v) (view z v) (view y v) (view w v))
  xzwy :: Lens (v a) (v a) (V4 a) (V4 a)
  xzwy f = xyzw (\v -> f $ V4 (view x v) (view z v) (view w v) (view y v))
  xwyz :: Lens (v a) (v a) (V4 a) (V4 a)
  xwyz f = xyzw (\v -> f $ V4 (view x v) (view w v) (view y v) (view z v))
  xwzy :: Lens (v a) (v a) (V4 a) (V4 a)
  xwzy f = xyzw (\v -> f $ V4 (view x v) (view w v) (view z v) (view y v))
  yxzw :: Lens (v a) (v a) (V4 a) (V4 a)
  yxzw f = xyzw (\v -> f $ V4 (view y v) (view x v) (view z v) (view w v))
  yxwz :: Lens (v a) (v a) (V4 a) (V4 a)
  yxwz f = xyzw (\v -> f $ V4 (view y v) (view x v) (view w v) (view z v))
  yzxw :: Lens (v a) (v a) (V4 a) (V4 a)
  yzxw f = xyzw (\v -> f $ V4 (view y v) (view z v) (view x v) (view w v))
  yzwx :: Lens (v a) (v a) (V4 a) (V4 a)
  yzwx f = xyzw (\v -> f $ V4 (view y v) (view z v) (view w v) (view x v))
  ywxz :: Lens (v a) (v a) (V4 a) (V4 a)
  ywxz f = xyzw (\v -> f $ V4 (view y v) (view w v) (view x v) (view z v))
  ywzx :: Lens (v a) (v a) (V4 a) (V4 a)
  ywzx f = xyzw (\v -> f $ V4 (view y v) (view w v) (view z v) (view x v))
  zxyw :: Lens (v a) (v a) (V4 a) (V4 a)
  zxyw f = xyzw (\v -> f $ V4 (view z v) (view x v) (view y v) (view w v))
  zxwy :: Lens (v a) (v a) (V4 a) (V4 a)
  zxwy f = xyzw (\v -> f $ V4 (view z v) (view x v) (view w v) (view y v))
  zyxw :: Lens (v a) (v a) (V4 a) (V4 a)
  zyxw f = xyzw (\v -> f $ V4 (view z v) (view y v) (view x v) (view w v))
  zywx :: Lens (v a) (v a) (V4 a) (V4 a)
  zywx f = xyzw (\v -> f $ V4 (view z v) (view y v) (view w v) (view x v))
  zwxy :: Lens (v a) (v a) (V4 a) (V4 a)
  zwxy f = xyzw (\v -> f $ V4 (view z v) (view w v) (view x v) (view y v))
  zwyx :: Lens (v a) (v a) (V4 a) (V4 a)
  zwyx f = xyzw (\v -> f $ V4 (view z v) (view w v) (view y v) (view x v))
  wxyz :: Lens (v a) (v a) (V4 a) (V4 a)
  wxyz f = xyzw (\v -> f $ V4 (view w v) (view x v) (view y v) (view z v))
  wxzy :: Lens (v a) (v a) (V4 a) (V4 a)
  wxzy f = xyzw (\v -> f $ V4 (view w v) (view x v) (view z v) (view y v))
  wyxz :: Lens (v a) (v a) (V4 a) (V4 a)
  wyxz f = xyzw (\v -> f $ V4 (view w v) (view y v) (view x v) (view z v))
  wyzx :: Lens (v a) (v a) (V4 a) (V4 a)
  wyzx f = xyzw (\v -> f $ V4 (view w v) (view y v) (view z v) (view x v))
  wzxy :: Lens (v a) (v a) (V4 a) (V4 a)
  wzxy f = xyzw (\v -> f $ V4 (view w v) (view z v) (view x v) (view y v))
  wzyx :: Lens (v a) (v a) (V4 a) (V4 a)
  wzyx f = xyzw (\v -> f $ V4 (view w v) (view z v) (view y v) (view x v))

-- Elements

-- | Zero-dimensional vector
data V0 a = V0
  deriving (Show, Eq, Ord)

instance Functor V0 where
  fmap = liftM

instance Applicative V0 where
  pure _ = V0
  (<*>) = ap

instance Monad V0 where
  _ >>= _ = V0

instance Foldable V0 where
  foldr _ b _ = b
  null _ = True
  length _ = 0

instance Traversable V0 where
  traverse _ _ = pure V0

instance Semigroup (V0 a) where
  _ <> _ = V0

instance Monoid (V0 a) where
  mempty = V0

instance Approx (V0 a) where
  _ ~= _ = True

instance Hashable (V0 a) where
  toBytes _ = []

instance Random (V0 a) where
  random g = (V0, g)

-- | One-dimensional vector
newtype V1 a = V1 a
  deriving (Show, Eq, Ord)

instance R1 V1 where
  x f (V1 a0) = V1 <$> f a0

instance Functor V1 where
  fmap = liftM

instance Applicative V1 where
  pure = V1
  (<*>) = ap

instance Monad V1 where
  m >>= k = k $ view x m

instance Foldable V1 where
  foldr f b v = f (view x v) b
  null _ = False
  length _ = 1

instance Traversable V1 where
  traverse f v = V1 <$> f (view x v)

instance (Semigroup a) => Semigroup (V1 a) where
  (<>) = liftA2 (<>)

instance (Monoid a) => Monoid (V1 a) where
  mempty = pure mempty

instance (Approx a) => Approx (V1 a) where
  u ~= v = view x u ~= view x v

instance (Hashable a) => Hashable (V1 a) where
  toBytes = concatMap toBytes

instance (Random a) => Random (V1 a) where
  random g = let (a, g') = random g in (V1 a, g')

-- | Two-dimensional vector
data V2 a = V2 a a
  deriving (Show, Eq, Ord)

instance R1 V2 where
  x f (V2 a0 a1) = (`V2` a1) <$> f a0

instance R2 V2 where
  xy = id

instance Functor V2 where
  fmap = liftM

instance Applicative V2 where
  pure a = V2 a a
  (<*>) = ap

instance Monad V2 where
  m >>= k = V2 (view x . k $ view x m) (view y . k $ view y m)

instance Foldable V2 where
  foldr f b v = f (view x v) $ f (view y v) b
  null _ = False
  length _ = 2

instance Traversable V2 where
  traverse f v = V2 <$> f (view x v) <*> f (view y v)

instance (Semigroup a) => Semigroup (V2 a) where
  (<>) = liftA2 (<>)

instance (Monoid a) => Monoid (V2 a) where
  mempty = pure mempty

instance (Approx a) => Approx (V2 a) where
  u ~= v = and $ liftA2 (~=) u v

instance (Hashable a) => Hashable (V2 a) where
  toBytes = concatMap toBytes

instance (Random a) => Random (V2 a) where
  random g =
    let (a0, g') = random g
        (a1, g'') = random g'
     in (V2 a0 a1, g'')

-- | Three-dimensional vector
data V3 a = V3 a a a
  deriving (Show, Eq, Ord)

instance R1 V3 where
  x f (V3 a0 a1 a2) = (\a0' -> V3 a0' a1 a2) <$> f a0

instance R2 V3 where
  xy f (V3 a0 a1 a2) =
    (\(V2 a0' a1') -> V3 a0' a1' a2)
      <$> f (V2 a0 a1)

instance R3 V3 where
  xyz = id

instance Functor V3 where
  fmap = liftM

instance Applicative V3 where
  pure a = V3 a a a
  (<*>) = ap

instance Monad V3 where
  m >>= k =
    V3
      (view x . k $ view x m)
      (view y . k $ view y m)
      (view z . k $ view z m)

instance Foldable V3 where
  foldr f b v = f (view x v) . f (view y v) $ f (view z v) b
  null _ = False
  length _ = 3

instance Traversable V3 where
  traverse f v = V3 <$> f (view x v) <*> f (view y v) <*> f (view z v)

instance (Semigroup a) => Semigroup (V3 a) where
  (<>) = liftA2 (<>)

instance (Monoid a) => Monoid (V3 a) where
  mempty = pure mempty

instance (Approx a) => Approx (V3 a) where
  u ~= v = and $ liftA2 (~=) u v

instance (Hashable a) => Hashable (V3 a) where
  toBytes = concatMap toBytes

instance (Random a) => Random (V3 a) where
  random g =
    let (a0, g') = random g
        (a1, g'') = random g'
        (a2, g''') = random g''
     in (V3 a0 a1 a2, g''')

-- | Four-dimensional vector
data V4 a = V4 a a a a
  deriving (Show, Eq, Ord)

instance R1 V4 where
  x f (V4 a0 a1 a2 a3) = (\a0' -> V4 a0' a1 a2 a3) <$> f a0

instance R2 V4 where
  xy f (V4 a0 a1 a2 a3) = (\(V2 a0' a1') -> V4 a0' a1' a2 a3) <$> f (V2 a0 a1)

instance R3 V4 where
  xyz f (V4 a0 a1 a2 a3) =
    (\(V3 a0' a1' a2') -> V4 a0' a1' a2' a3)
      <$> f (V3 a0 a1 a2)

instance R4 V4 where
  xyzw = id

instance Functor V4 where
  fmap = liftM

instance Applicative V4 where
  pure a = V4 a a a a
  (<*>) = ap

instance Monad V4 where
  m >>= k =
    V4
      (view x . k $ view x m)
      (view y . k $ view y m)
      (view z . k $ view z m)
      (view w . k $ view w m)

instance Foldable V4 where
  foldr f b v = f (view x v) . f (view y v) . f (view z v) $ f (view w v) b
  null _ = False
  length _ = 4

instance Traversable V4 where
  traverse f v =
    V4
      <$> f (view x v)
      <*> f (view y v)
      <*> f (view z v)
      <*> f (view w v)

instance (Semigroup a) => Semigroup (V4 a) where
  (<>) = liftA2 (<>)

instance (Monoid a) => Monoid (V4 a) where
  mempty = pure mempty

instance (Approx a) => Approx (V4 a) where
  u ~= v = and $ liftA2 (~=) u v

instance (Hashable a) => Hashable (V4 a) where
  toBytes = concatMap toBytes

instance (Random a) => Random (V4 a) where
  random g =
    let (a0, g') = random g
        (a1, g'') = random g'
        (a2, g''') = random g''
        (a3, g'''') = random g'''
     in (V4 a0 a1 a2 a3, g'''')