# Haskell Quiz/Geodesic Dome Faces/Solution Jkramar

### From HaskellWiki

< Haskell Quiz | Geodesic Dome Faces(Difference between revisions)

m |
|||

Line 4: | Line 4: | ||

<haskell> | <haskell> | ||

− | import Prelude hiding ( | + | import Prelude hiding (sum, foldr1, foldr, maximum, sequence_) |

import Control.Monad hiding (sequence_) | import Control.Monad hiding (sequence_) | ||

import Control.Applicative | import Control.Applicative | ||

Line 43: | Line 43: | ||

-- chooses xs!!n gives the combinations of n elements from xs | -- chooses xs!!n gives the combinations of n elements from xs | ||

− | chooses :: | + | chooses :: [a] -> [[[a]]] |

− | chooses = foldr consider$ | + | chooses = foldr consider$[[]]:repeat [] where |

− | consider x cs = zipWith (flip ( | + | consider x cs = zipWith (flip (++)) cs$map (x:)<$>[]:cs |

− | tris :: | + | tris :: [V3 a] -> [Tri a] |

tris xs = (\[a,b,c]->V a b c) <$> (chooses xs!!3) | tris xs = (\[a,b,c]->V a b c) <$> (chooses xs!!3) | ||

orient :: (Num a) => Tri a -> Tri a | 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 | 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 | -- inefficient function to generate all the positively-oriented faces of the | ||

-- triangle-faced polyhedron with vertices at vs | -- triangle-faced polyhedron with vertices at vs | ||

− | faces :: (Real a | + | faces :: (Real a) => [V3 a] -> [Tri a] |

− | faces vs = | + | 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, | -- each triangle side is broken into n pieces, unlike in the problem statement, | ||

-- where they use n+1 for some reason | -- where they use n+1 for some reason | ||

− | shatter :: (Integral a, Fractional b | + | shatter :: (Integral a, Fractional b) => a -> Tri b -> [Tri b] |

− | shatter n t = | + | shatter n t = mmul t'<$>coords where |

basis = V (V 1 0 0) (V 0 1 0) (V 0 0 1) | 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]] | fwd = [(V k j (n-1-k-j).+) <$> basis|k<-[0..n-1], j<-[0..n-1-k]] | ||

Line 74: | Line 70: | ||

coords = (fmap fromIntegral<$>)<$>fwd++bwd | coords = (fmap fromIntegral<$>)<$>fwd++bwd | ||

− | geode :: ( | + | geode :: (Integral a, RealFloat b) => [V3 b] -> a -> [Tri b] |

− | + | geode vs n = fmap normize<$>(shatter n=<<faces vs) | |

− | geode vs n = | + | |

cyc :: V3 a -> [V3 a] | cyc :: V3 a -> [V3 a] | ||

Line 91: | Line 86: | ||

icosahed = cyc =<< [V x (y*(1+sqrt 5/2)) 0|x<-[-1, 1], y<-[-1, 1]] | icosahed = cyc =<< [V x (y*(1+sqrt 5/2)) 0|x<-[-1, 1], y<-[-1, 1]] | ||

− | |||

main :: IO () | main :: IO () | ||

− | main = sequence_$print<$>(geode octahed::Int | + | main = sequence_$print<$>(geode octahed (51::Int)::[Tri Double]) |

</haskell> | </haskell> |

## Revision as of 08:41, 17 November 2008

This problem seems to be strongly IO-bound, so actually computing the geodesic faces is not too time-sensitive. Hence there is time for computing the faces from the vertices by trying each triple of vertices to check if it's a face.

Originally I wrote this program representing vectors just by ordinary tuples, and in some places that was definitely more understandable. But of course it's more fun this way.

import Prelude hiding (sum, foldr1, foldr, maximum, sequence_) 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 :: [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 = sequence_$print<$>(geode octahed (51::Int)::[Tri Double])