Clock using Haskell and OpenGL

Clock.hs

module ProveGL.Clock where

import           Data.IORef
import           Data.Time.LocalTime
import           Graphics.UI.GLUT

applyTo :: (a, a) -> (a -> b) -> (b, b)
applyTo (x, y) f = (f x, f y)


resizeTo :: GLfloat -> (GLfloat, GLfloat) -> GLfloat
resizeTo n s = n * 2 / uncurry min s


toRadians :: (Floating a) => a -> a
toRadians d = d / 180 * pi


vector3f :: GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
vector3f = Vector3


vertex3f :: (GLfloat, GLfloat, GLfloat) -> IO ()
vertex3f (x, y, z) = vertex $ Vertex3 x y z


size :: (GLfloat, GLfloat)
size = (300, 300)
radius :: GLfloat
radius = resizeTo 140 size
hRadius :: GLfloat
hRadius = resizeTo 80 size
mRadius :: GLfloat
mRadius = resizeTo 120 size
sRadius :: GLfloat
sRadius = resizeTo 130 size


display :: IORef (GLfloat, GLfloat, GLfloat) -> DisplayCallback
display time = do
  clear [ColorBuffer]
  loadIdentity
  let points = [(radius * cos t, radius * sin t, 0) | t <- [0,0.2..2*pi]]
  (h, m, s) <- get time

  renderPrimitive LineLoop $
     mapM_ vertex3f points

  drawPointer (toRadians $ -90 + 30 * h) hRadius 3
  drawPointer (toRadians $ -90 + 6 * m) mRadius 2
  drawPointer (toRadians $ -90 + 6 * s) sRadius 1

  -- TODO non funziona
  preservingMatrix $ do
    translate $ vector3f 0 (negate 0.5) 0
    scale 0.001 0.001 (0.001 :: GLfloat)
    renderString Helvetica12 "Ciao!"

  swapBuffers


idle :: IORef (GLfloat, GLfloat, GLfloat) -> IdleCallback
idle time = do
    curtime <- getTime
    time $= curtime
    postRedisplay Nothing


getTime :: IO (GLfloat, GLfloat, GLfloat)
getTime = do
    t <- getZonedTime
    let tt = zonedTimeToLocalTime t
    let ttt = localTimeOfDay tt
    return (fromIntegral $ todHour ttt,
            fromIntegral $ todMin ttt,
            fromIntegral . truncate $ todSec ttt)


preservingVar :: StateVar a -> a -> IO () -> IO ()
preservingVar var value action = do
    oldVal <- get var
    var $= value
    action
    var $= oldVal


drawPointer :: GLfloat -> GLfloat -> GLfloat -> IO ()
drawPointer angle radius' w =
    preservingVar lineWidth w $
        renderPrimitive Lines $ do
            vertex3f (0, 0, 0)
            vertex3f (radius' * cos angle, -radius' * sin angle, 0)    


main :: IO ()
main = do
  (_progName, _args) <- getArgsAndInitialize
  initialDisplayMode $= [DoubleBuffered]
  _window <- createWindow "Clock!"
  initialWindowSize $= uncurry Size (applyTo size truncate)
  time <- newIORef (0,0,0)
  displayCallback $= display time
  idleCallback $= Just (idle time)
  mainLoop