Personal tools

Haskell Quiz/Geodesic Dome Faces/Solution Jkramar

From HaskellWiki

< Haskell Quiz | Geodesic Dome Faces(Difference between revisions)
Jump to: navigation, search
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 :: (Alternative f) => [a] -> [f [a]]
+
chooses :: (Foldable t, Alternative f) => t a -> [f [a]]
 
chooses = foldr consider$pure []:repeat empty where
 
chooses = foldr consider$pure []:repeat empty where
 
consider x cs = zipWith (flip (<|>)) cs$map ((x:)<$>)$empty:cs
 
consider x cs = zipWith (flip (<|>)) cs$map ((x:)<$>)$empty:cs
   
tris :: (Alternative f) => [V3 a] -> f (Tri a)
+
tris :: (Foldable t, Alternative f) => t (V3 a) -> f (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
  +
  +
farth :: (Real a, Foldable t) => V3 a -> t (V3 a) -> a
  +
farth dir = maximum.map (dot dir).toList
   
 
-- 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 :: (Num a, Ord a, MonadPlus m) => [V3 a] -> m (Tri a)
+
faces :: (Real a, Foldable t, MonadPlus m) => t (V3 a) -> m (Tri a)
 
faces vs = do
 
faces vs = do
 
t@(V a b c) <- unwrapMonad $ orient <$> tris vs
 
t@(V a b c) <- unwrapMonad $ orient <$> tris vs
let dir = ((a.-b) `cross` (a.-c)); farth = maximum.map (dot dir)
+
let dir = ((a.-b) `cross` (a.-c))
guard (farth [a,b,c]==farth vs) >> return t
+
guard (farth dir [a,b,c]==farth dir vs) >> return t
   
 
-- 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 a1, Fractional a) => a1 -> Tri a -> [Tri a]
+
shatter :: (Integral a, Fractional b, MonadPlus m) =>
shatter n t = mmul t'<$>coords where
+
a -> V3 (V3 b) -> m (V3 (V3 b))
  +
shatter n t = msum$return<$>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 71: Line 74:
 
coords = (fmap fromIntegral<$>)<$>fwd++bwd
 
coords = (fmap fromIntegral<$>)<$>fwd++bwd
   
geode :: (Floating a, Ord a, Integral a1) => [V3 a] -> a1 -> [Tri a]
+
geode :: (RealFloat b, Integral a, MonadPlus m, Foldable t) =>
geode vs n = fmap normize<$>(shatter n=<<faces vs)
+
t (V3 b) -> a -> m (V3 (V3 b))
  +
geode vs n = fmap normize `liftM` (shatter n=<<faces vs)
   
 
cyc :: V3 a -> [V3 a]
 
cyc :: V3 a -> [V3 a]

Revision as of 08:01, 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 (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$map ((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.map (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 -> V3 (V3 b) -> m (V3 (V3 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 (V3 (V3 b))
geode vs n = fmap normize `liftM` (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_$map print$(geode octahed::Int->[Tri Double]) 51