Haskell Quiz/Geodesic Dome Faces/Solution Jkramar

import Prelude hiding (sum, foldr1, foldr, maximum, 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 = (sum.).liftA2 (*)
 
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 = fmap$foldr1 (.+).(<*>t).fmap (.*)
 
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 :: [a] -> [[[a]]]
chooses = foldr consider$[[]]:repeat [] where
  consider x cs = zipWith (flip (++)) cs$map (x:)<$>[]:cs
 
tris :: [V3 a] -> [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
 
-- inefficient function to generate all the positively-oriented faces of the
-- triangle-faced polyhedron with vertices at vs
faces :: (Real a) => [V3 a] -> [Tri a]
faces vs = filter isFace $ orient <$> tris vs where
  farth (V a b c) = maximum.(dot ((a.-b) `cross` (a.-c))<$>)
  isFace t@(V a b c) = farth t [a,b,c] == farth t vs
 
-- 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) => a -> Tri b -> [Tri b]
shatter n t = 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 :: (Integral a, RealFloat b) => [V3 b] -> a -> [Tri b]
geode vs n = 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]]
 
main :: IO ()
main = mapM_ print (geode octahed (51::Int)::[Tri Double])