Haskell Quiz/Geodesic Dome Faces/Solution Jkramar

import Prelude hiding (maximum, foldr, foldr1, concat, sequence_, sum)
import Control.Monad hiding (sequence_)
import Control.Applicative
import Data.Foldable
 
data V3 a = V !a !a !a deriving (Read,Show)
instance Foldable V3 where foldr f x (V a b c) = f a$f b$f c x
instance Functor V3 where fmap f (V a b c) = V (f a) (f b) (f c)
instance Applicative V3 where
  pure a = V a a a
  V f g h <*> V a b c = V (f a) (g b) (h c)
type Tri a = V3 (V3 a)
 
(.+) :: (Num a) => V3 a -> V3 a -> V3 a
(.+) = liftA2 (+)
 
(.-) :: (Num a) => V3 a -> V3 a -> V3 a
(.-) = liftA2 (-)
 
(.*) :: (Num a) => a -> V3 a -> V3 a
(.*) = fmap.(*)
 
dot :: (Num a) => V3 a -> V3 a -> a
dot a b = sum$liftA2 (*) a b
 
cross :: (Num a) => V3 a -> V3 a -> V3 a
cross (V x y z) (V x' y' z')=V (y*z'-z*y') (z*x'-x*z') (x*y'-y*x')
 
det :: (Num a) => V3 (V3 a) -> a
det (V a b c) = (a `cross` b) `dot` c
 
-- matrix multiplication
mmul :: (Num a) => V3 (V3 a) -> V3 (V3 a) -> V3 (V3 a)
mmul t s = foldr1 (.+) <$> (flip (.*)<$>t<*>) <$> s
 
normize :: (Floating a) => V3 a -> V3 a
normize v = (1/sqrt (dot v v)).*v
 
-- chooses xs!!n gives the combinations of n elements from xs
chooses :: (Foldable t, Alternative f) => t a -> [f [a]]
chooses = foldr consider$pure []:repeat empty where
  consider x cs = zipWith (flip (<|>)) cs$fmap (x:)<$>empty:cs
 
tris :: (Foldable t, Alternative f) => t (V3 a) -> f (Tri a)
tris xs = (\[a,b,c]->V a b c) <$> (chooses xs!!3)
 
orient :: (Num a) => Tri a -> Tri a
orient t@(V a b c) = if (==1)$signum$det t then t else V a c b
 
farth :: (Real a, Foldable t) => V3 a -> t (V3 a) -> a
farth dir = maximum.(dot dir<$>).toList
 
-- inefficient function to generate all the positively-oriented faces of the
-- triangle-faced polyhedron with vertices at vs
faces :: (Real a, Foldable t, MonadPlus m) => t (V3 a) -> m (Tri a)
faces vs = do
  t@(V a b c) <- unwrapMonad $ orient <$> tris vs
  let dir = ((a.-b) `cross` (a.-c))
  guard (farth dir [a,b,c]==farth dir vs) >> return t
 
-- each triangle side is broken into n pieces, unlike in the problem statement,
-- where they use n+1 for some reason
shatter :: (Integral a, Fractional b, MonadPlus m) => a -> Tri b -> m (Tri b)
shatter n t = msum$return<$>mmul t'<$>coords where
  basis = V (V 1 0 0) (V 0 1 0) (V 0 0 1)
  fwd = [(V k j (n-1-k-j).+) <$> basis|k<-[0..n-1], j<-[0..n-1-k]]
  bwd = [(V k j (n+1-k-j).-) <$> basis|k<-[1..n], j<-[1..n-k]]
  t' = ((1/fromIntegral n).*)<$>t
  coords = (fmap fromIntegral<$>)<$>fwd++bwd
 
geode :: (RealFloat b, Integral a, MonadPlus m, Foldable t) =>
         t (V3 b) -> a -> m (Tri b)
geode vs n = return.fmap normize=<<shatter n=<<faces vs
 
cyc :: V3 a -> [V3 a]
cyc (V a b c) = [V a b c, V b c a, V c a b]
 
tetrahed :: (Floating a) => [V3 a]
tetrahed = [V (x*sqrt 1.5) (-sqrt 2/3) (-1/3)|x<-[-1,1]]++
  [V 0 (2*sqrt 2/3) (-1/3), V 0 0 1]
 
octahed :: (Num a) => [V3 a]
octahed = cyc =<< [V x 0 0|x<-[-1,1]]
 
icosahed :: (Floating a) => [V3 a]
icosahed = cyc =<< [V x (y*(1+sqrt 5/2)) 0|x<-[-1, 1], y<-[-1, 1]]
 
-- this is the test the Ruby Quiz people were doing to see how fast the code is
main :: IO ()
main = sequence_$print<$>(geode octahed::Int->[Tri Double]) 51