1votos

Dibujar triangulo de sierpinski en Haskell

por josejuan hace 5 años

Obviando mi poco estilo gráfico, la versión en 3D rotando sobre la vertical del famoso triángulo.

Gráfica el triangulo de sierpinski.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
import Graphics.Rendering.OpenGL 
import Graphics.UI.GLUT 
import Data.IORef 
import Control.Arrow ((***)) 
import Control.Monad 
import System.Time 
import Data.Time.Clock 
import Control.Concurrent (threadDelay) 
 
main = do 
    _ <- getArgsAndInitialize 
    initialDisplayMode $= [DoubleBuffered, RGBMode, WithDepthBuffer] 
    createWindow "Sierpinski Haskell OpenGL" 
    lighting $= Enabled 
    normalize $= Enabled 
    cullFace $= Nothing 
    depthFunc $= Just Lequal 
    forM_ [(0, 0.3, 0.3, 0.3,  5, 1, -3) 
          ,(1, 0.3, 0.3, 0.3,  1, 9, -1) 
          ,(2, 0.7, 1.0, 0.7, -5, 1, -2)] $ \(n, r, g, b, x, y, z) -> do 
                                                                        ambient  (Light n) $= fColor (r/5) (g/5) (b/5) 1 
                                                                        diffuse  (Light n) $= fColor r g b 1 
                                                                        light    (Light n) $= Enabled 
                                                                        position (Light n) $= Vertex4 x y z 0 
    obj <- pyramid >>= createSierpinski 5 
    displayCallback $= display obj 
    idleCallback $= Just (threadDelay 20 >> postRedisplay Nothing) 
    mainLoop 
 
createSierpinski :: Int -> DisplayList -> IO DisplayList 
createSierpinski 0 o = return o 
createSierpinski n o = do o' <- createSierpinski (n - 1) o 
                          let moveTo x = preservingMatrix $ do translate x 
                                                               fScale 0.5 0.5 0.5 
                                                               callList o' 
                              corners' = map (\(x, z) -> fVector x 0 z) $ fCorners (0.5*) 
                          defineNewList Compile $ mapM_ moveTo (fVector 0 0.5 0: corners') 
 
 
display sierpinski = do 
    t <- getCurrentTime >>= return.(id :: GLfloat -> GLfloat).realToFrac.utctDayTime 
    clear [ColorBuffer, DepthBuffer] 
    matrixMode $= Projection 
    loadIdentity 
    perspective 40 1 1 10 
    matrixMode $= Modelview 0 
    loadIdentity 
    lookAt (Vertex3 0 2.5 4) (Vertex3 0 0.7 0) (Vector3 0 1 0) 
    color $ fColor 1 1 1 1 
    fScale 1 2 1 
    rotate (30 * t) $ fVector 0 1 0 
    preservingMatrix $ callList sierpinski 
    swapBuffers 
 
-- ============================================================================================ 
-- Helpers gráficos ----------------------------------------------------------------------------- 
pyramidVertex :: [Vertex3f] 
pyramidVertex = concatMap t $ zip corners (tail $ cycle corners) 
                where t ((a, b),(c, d)) = [fVertex 0 1 0, fVertex a 0 b, fVertex c 0 d] 
 
doFaces :: [Vertex3f] -> IO () 
doFaces (a:b:c:xs) = normal (toNormal $ cross (b-.a) (c-.a)) >> mapM_ vertex [a,b,c] >> doFaces xs 
doFaces _ = return () 
 
pyramid :: IO DisplayList 
pyramid = defineNewList Compile $ renderPrimitive Triangles $ doFaces pyramidVertex 
 
 
-- ============================================================================================ 
-- Algunos alias y helpers ----------------------------------------------------------------------------- 
type Vertex3f = Vertex3 GLfloat 
fColor = Color4 :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat 
fVertex = Vertex3 :: GLfloat -> GLfloat -> GLfloat -> Vertex3f 
fVector = Vector3 :: GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat 
fScale = scale :: GLfloat -> GLfloat -> GLfloat -> IO () 
fTranslate = ((translate.).).fVector :: GLfloat -> GLfloat -> GLfloat -> IO () 
corners = [(-1, -1), (1, -1), (1, 1), (-1, 1)] :: [(GLfloat, GLfloat)] 
fCorners f = map (f *** f) corners 
(Vertex3 a b c) -. (Vertex3 aa bb cc) = Vertex3 (a - aa) (b - bb) (c - cc) 
cross (Vertex3 a b c) (Vertex3 aa bb cc) = Vertex3 (b * cc - c * bb) (c * aa - a * cc) (a * bb - b * aa) 
toNormal (Vertex3 x y z) = Normal3 x y z 
1 comentario

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.