

> {-# LANGUAGE MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances #-}



> module Main where



> import qualified Data.Map as M

> import Control.Monad

> infixl 5 .+

> infixl 6 .*





> data Space = X | Y | Z deriving (Eq,Show,Ord)



V Float Space



> u,v,w :: V Float Space

> u = return X .- return Y

> v = return X .+ 2.* return Y

> w = return Y .- return Z



() -> V Float Space



> cup :: (Space,Space) -> V Float ()

> cup (i,j) = case (i,j) of

> (X,X) -> return ()

> (Y,Y) -> return ()

> (Z,Z) -> return ()

> otherwise -> 0 .* return ()





> vdotw = do

> i <- v

> j <- w

> cup (i,j)





> dual :: V Float Space -> Space -> V Float ()

> dual v i = do

> j <- v

> cup (i,j)





> cross :: (Space,Space) -> V Float Space

> cross (X,Y) = return Z

> cross (Y,Z) = return X

> cross (Z,X) = return Y



> cross (Y,X) = (-1) .* return Z

> cross (Z,Y) = (-1) .* return X

> cross (X,Z) = (-1) .* return Y



> cross _ = mzero





> trident :: (Space,Space,Space) -> V Float ()

> trident (i,j,k) = do

> l <- cross (i,j)

> cup (l,k)





> cap :: () -> V Float (Space,Space)

> cap () = return (X,X) .+ return (Y,Y) .+ return (Z,Z)





> cupcap i = do

> (j,k) <- cap ()

> cup (i,j)

> return k



cupcap

return

cup

cap

cup

cap



> fork () = do

> (i,j) <- cap ()

> (k,l) <- cap ()

> m <- cross (j,k)

> return (i,l,m)





> a :: Space -> V Float Space

> a X = 2 .* return X

> a Y = return Z

> a Z = (-1) .* return Y





> b :: Space -> V Float Space

> b l = do

> (i,j) <- cap ()

> k <- a j

> cup (k,l)

> return i





> det a = do

> (i,j,k) <- fork ()

> i' <- a i

> j' <- a j

> k' <- a k

> (1/6.0) .* trident (i',j',k')





> swap (x,y) = (y,x)



> class Num k => VectorSpace k v | v -> k where

> zero :: v

> (.+) :: v -> v -> v

> (.*) :: k -> v -> v

> (.-) :: v -> v -> v

> v1 .- v2 = v1 .+ ((-1).*v2)



> data V k a = V { unV :: [(k,a)] }

> instance (Num k,Ord a,Show a) => Show (V k a) where

> show (V x) = show (reduce x)



> reduce x = filter ((/=0) . fst) $ fmap swap $ M.toList $ M.fromListWith (+) $ fmap swap $ x



> instance (Ord a,Num k) => Eq (V k a) where

> V x==V y = reduce x==reduce y



> instance (Ord a,Num k,Ord k) => Ord (V k a) where

> compare (V x) (V y) = compare (reduce x) (reduce y)



> instance Num k => Functor (V k) where

> fmap f (V as) = V $ map (\(k,a) -> (k,f a)) as



> instance Num k => Monad (V k) where

> return a = V [(1,a)]

> x >>= f = join (fmap f x)

> where join x = V $ concat $ fmap (uncurry scale) $ unV $ fmap unV x

> scale k1 as = map (\(k2,a) -> (k1*k2,a)) as



> instance Num r => MonadPlus (V r) where

> mzero = V []

> mplus (V x) (V y) = V (x++y)



> instance (Num k,Ord a) => VectorSpace k (V k a) where

> zero = V []

> V x .+ V y = V (x ++ y)

> (.*) k = (>>= (\a -> V [(k,a)]))



> e = return :: Num k => a -> V k a

> coefficient b (V bs) = maybe 0 id (lookup b (map swap (reduce bs)))

