Invitado: Unas esferitas en Haskell

---El siguiente programa muestra algunas posibilidades de trabajo gráfico en 3D
---con Haskell; estas posibilidades son dignas de explorar en la creación de mundos
---virtuales, simulación, graficación de datos, y juegos.
---He puesto un vida de otro programa que seguiría un desarrollo más o menos natural
---al aquí presentado, brindando más experiencia tridimensional e interactiva en
 -------https://youtu.be/Ab7eQdMHF-Q
{-
   Light.hs (adapted from light.c which is (c) Silicon Graphics, Inc.)
   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>
   This file is part of HOpenGL and distributed under a BSD-style license
   See the file libraries/GLUT/LICENSE

   This program demonstrates the use of the OpenGL lighting model. A sphere
   is drawn using a grey material characteristic. A single light source
   illuminates the object.
-}


---Compilado con
---> ghc -package GLUT Light.hs -o light

---en Fedora, con Haskell tomado de www.haskell.org

import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT

windowWidth=500
windowHeight=500
blackBackground=Color4 0 0 0 0
whiteColor=Color4 1 1 1 1
degreeShininess=50

myInit :: IO ()
myInit = do
   clearColor $= blackBackground
   shadeModel $= Smooth

   materialSpecular Front $= whiteColor
   materialShininess Front $= degreeShininess
   position (Light 0) $= Vertex4 1 1 1 0
   position (Light 1) $= Vertex4 1 1 (-1) 0
   lighting $= Enabled
   light (Light 0) $= Enabled
   light (Light 1) $= Enabled
   depthFunc $= Just Less

-- Sphere(radius,subLat,subLon)

translatef = translate :: Vector3 GLfloat -> IO ()
rotatef = rotate :: GLfloat -> Vector3 GLfloat -> IO ()
rectf = rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()
normal3f = normal :: Normal3 GLfloat -> IO ()
color3f = color :: Color3 GLfloat -> IO ()
     
display :: DisplayCallback
display = do
   clear [ ColorBuffer, DepthBuffer ]
   rotatef 30 (Vector3 1 0 0)
   normal3f (Normal3 0 0 1)
   color3f (Color3 1 0.1 1)
 --  renderObject (
   translatef (Vector3 0 0 (-2.0))
   rectf (Vertex2 (-20) (-20)) (Vertex2 20 20)
   translatef (Vector3 0 0 (2.0))
   translatef (Vector3 0 0 (1.0))
   renderObject Solid (Sphere' 0.3 20 16)
   translatef (Vector3 0.5 0 0)
   renderObject Solid (Sphere' 0.3 20 16)
   translatef (Vector3 0 0.5 0)
   renderObject Solid (Sphere' 0.3 20 16)
   translatef (Vector3 0.5 0.5 0)
   renderObject Solid (Cube 0.6)

   flush

reshape :: ReshapeCallback
reshape size@(Size w h) = do
   viewport $= (Position 0 0, size)
   matrixMode $= Projection
   loadIdentity
   let wf = fromIntegral w
       hf = fromIntegral h
   if w <= h
      then ortho (-1.5) 1.5 (-1.5 * hf/wf) (1.5 * hf/wf) (-10) 10
      else ortho (-1.5 * wf/hf) (1.5 * wf/hf) (-1.5) 1.5 (-10) 10
   matrixMode $= Modelview 0
   loadIdentity

keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _            _    _ _ = return ()

main :: IO ()
main = do
   (progName, _args) <- getArgsAndInitialize
   initialDisplayMode $= [ SingleBuffered, RGBMode, WithDepthBuffer ]
   initialWindowSize $= Size windowWidth windowHeight
   initialWindowPosition $= Position 100 100
   createWindow progName
   myInit
   displayCallback $= display
   reshapeCallback $= Just reshape
   keyboardMouseCallback $= Just keyboard
   mainLoop