    {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators
               , TypeFamilies, TypeSynonymInstances
               , UndecidableInstances  #-}
    {-# OPTIONS_GHC -Wall #-}
    ----------------------------------------------------------------------
    -- |
    -- Module      :  Data.Cross
    -- Copyright   :  (c) Conal Elliott 2008
    -- License     :  BSD3
    --
    -- Maintainer  :  conal@conal.net
    -- Stability   :  experimental
    --
    -- Cross products and normals
    ----------------------------------------------------------------------

    module Data.Cross
      (
        HasNormal(..), normal
      , One, Two, Three
      , HasCross2(..), HasCross3(..)
      ) where

    import Data.VectorSpace
    import Data.MemoTrie
    import Data.Basis

    import Data.Derivative

    -- | Thing with a normal vector (not necessarily normalized).
    class HasNormal v where normalVec :: v -> v

    -- | Normalized normal vector.  See also 'cross'.
    normal :: (HasNormal v, InnerSpace v, Floating (Scalar v)) => v -> v
    normal :: forall v.
    (HasNormal v, InnerSpace v, Floating (Scalar v)) =>
    v -> v
    normal = v -> v
    forall v s. (InnerSpace v, s ~ Scalar v, Floating s) => v -> v
    normalized (v -> v) -> (v -> v) -> v -> v
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . v -> v
    forall v. HasNormal v => v -> v
    normalVec

    -- | Singleton
    type One   s = s

    -- | Homogeneous pair
    type Two   s = (s,s)

    -- | Homogeneous triple
    type Three s = (s,s,s)

    -- | Cross product of various forms of 2D vectors
    class HasCross2 v where cross2 :: v -> v

    instance AdditiveGroup u => HasCross2 (u,u) where
      cross2 :: (u, u) -> (u, u)
    cross2 (u
    x,u
    y) = (u -> u
    forall v. AdditiveGroup v => v -> v
    negateV u
    y,u
    x)  -- or @(y,-x)@?

    instance (HasTrie (Basis a), HasCross2 v) => HasCross2 (a:>v) where
      -- 2d cross-product is linear
      cross2 :: (a :> v) -> a :> v
    cross2 = (v -> v) -> (a :> v) -> a :> v
    forall a b c. HasTrie (Basis a) => (b -> c) -> (a :> b) -> a :> c
    fmapD v -> v
    forall v. HasCross2 v => v -> v
    cross2

    instance (HasBasis s, HasTrie (Basis s), Basis s ~ ()) =>
             HasNormal (One s :> Two s) where
      normalVec :: (One s :> Two (One s)) -> One s :> Two (One s)
    normalVec One s :> Two (One s)
    v = (One s :> Two (One s)) -> One s :> Two (One s)
    forall v. HasCross2 v => v -> v
    cross2 (One s :> Two (One s)
    v (One s :> Two (One s)) -> Basis (One s) -> One s :> Two (One s)
    forall a b.
    (HasTrie (Basis a), HasBasis a, AdditiveGroup b) =>
    (a :> b) -> Basis a -> a :> b
    `derivAtBasis` ())

    -- When I use atBasis (from LinearMap) instead of the more liberally-typed
    -- atB (below), I get a type error:
    --
    --     Couldn't match expected type `Basis a1' against inferred type `()'
    --       Expected type: a1 :-* (s :> Two s)
    --       Inferred type: s  :-* (s :> Two s)
    --     In the first argument of `atB', namely `derivative v'
    --
    -- I think this type error is a GHC bug, but I'm not sure.

    -- atB :: (AdditiveGroup b, HasTrie a) => Maybe (a :->: b) -> a -> b
    -- -- atB :: (AdditiveGroup b, HasBasis a, HasTrie (Basis a)) =>
    -- --        Maybe (Basis a :->: b) -> Basis a -> b
    -- l `atB` b = maybe zeroV (`untrie` b) l

    instance (VectorSpace s, HasBasis s, HasTrie (Basis s), Basis s ~ ())
        => HasNormal (Two (One s :> s)) where
      normalVec :: Two (One s :> One s) -> Two (One s :> One s)
    normalVec = (One s :> (One s, One s)) -> Two (One s :> One s)
    forall a b c.
    HasTrie (Basis a) =>
    (a :> (b, c)) -> (a :> b, a :> c)
    unpairD ((One s :> (One s, One s)) -> Two (One s :> One s))
    -> (Two (One s :> One s) -> One s :> (One s, One s))
    -> Two (One s :> One s)
    -> Two (One s :> One s)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (One s :> (One s, One s)) -> One s :> (One s, One s)
    forall v. HasNormal v => v -> v
    normalVec ((One s :> (One s, One s)) -> One s :> (One s, One s))
    -> (Two (One s :> One s) -> One s :> (One s, One s))
    -> Two (One s :> One s)
    -> One s :> (One s, One s)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Two (One s :> One s) -> One s :> (One s, One s)
    forall a b c.
    (HasBasis a, HasTrie (Basis a), VectorSpace b, VectorSpace c) =>
    (a :> b, a :> c) -> a :> (b, c)
    pairD

    -- I don't know why I can't eliminate the @HasTrie (Basis s)@ constraints
    -- above, considering @Basis s ~ ()@ and @HasTrie ()@.

    -- | Cross product of various forms of 3D vectors
    class HasCross3 v where cross3 :: v -> v -> v

    instance Num s => HasCross3 (s,s,s) where
      (s
    ax,s
    ay,s
    az) cross3 :: (s, s, s) -> (s, s, s) -> (s, s, s)
    `cross3` (s
    bx,s
    by,s
    bz) = ( s
    ay s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    bz s -> s -> s
    forall a. Num a => a -> a -> a
    - s
    az s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    by
                                       , s
    az s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    bx s -> s -> s
    forall a. Num a => a -> a -> a
    - s
    ax s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    bz
                                       , s
    ax s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    by s -> s -> s
    forall a. Num a => a -> a -> a
    - s
    ay s -> s -> s
    forall a. Num a => a -> a -> a
    * s
    bx )

    -- TODO: Eliminate the 'Num' constraint by using 'VectorSpace' operations.

    instance (HasBasis a, HasTrie (Basis a), VectorSpace v, HasCross3 v) => HasCross3 (a:>v) where
      -- 3D cross-product is bilinear (curried linear)
      cross3 :: (a :> v) -> (a :> v) -> a :> v
    cross3 = (v -> v -> v) -> (a :> v) -> (a :> v) -> a :> v
    forall a b c u.
    (HasBasis a, HasTrie (Basis a), AdditiveGroup u) =>
    (b -> c -> u) -> (a :> b) -> (a :> c) -> a :> u
    distrib v -> v -> v
    forall v. HasCross3 v => v -> v -> v
    cross3

    instance (Num s, HasTrie (Basis (s, s)), HasBasis s, Basis s ~ ()) =>
             HasNormal (Two s :> Three s) where
      normalVec :: (Two s :> Three s) -> Two s :> Three s
    normalVec Two s :> Three s
    v = Basis (Two s) -> Two s :> Three s
    d (() -> Either () ()
    forall a b. a -> Either a b
    Left ()) (Two s :> Three s) -> (Two s :> Three s) -> Two s :> Three s
    forall v. HasCross3 v => v -> v -> v
    `cross3` Basis (Two s) -> Two s :> Three s
    d (() -> Either () ()
    forall a b. b -> Either a b
    Right ())
       where
         d :: Basis (Two s) -> Two s :> Three s
    d = (Two s :> Three s) -> Basis (Two s) -> Two s :> Three s
    forall a b.
    (HasTrie (Basis a), HasBasis a, AdditiveGroup b) =>
    (a :> b) -> Basis a -> a :> b
    derivAtBasis Two s :> Three s
    v

    instance ( VectorSpace s, HasBasis s, HasTrie (Basis s)
             , HasNormal (Two s :> Three s) )
             => HasNormal (Three (Two s :> s)) where
      normalVec :: Three (Two s :> s) -> Three (Two s :> s)
    normalVec = (Two s :> Three s) -> Three (Two s :> s)
    forall a b c d.
    HasTrie (Basis a) =>
    (a :> (b, c, d)) -> (a :> b, a :> c, a :> d)
    untripleD ((Two s :> Three s) -> Three (Two s :> s))
    -> (Three (Two s :> s) -> Two s :> Three s)
    -> Three (Two s :> s)
    -> Three (Two s :> s)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Two s :> Three s) -> Two s :> Three s
    forall v. HasNormal v => v -> v
    normalVec ((Two s :> Three s) -> Two s :> Three s)
    -> (Three (Two s :> s) -> Two s :> Three s)
    -> Three (Two s :> s)
    -> Two s :> Three s
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Three (Two s :> s) -> Two s :> Three s
    forall a b c d.
    (HasBasis a, HasTrie (Basis a), VectorSpace b, VectorSpace c,
     VectorSpace d) =>
    (a :> b, a :> c, a :> d) -> a :> (b, c, d)
    tripleD