Juggling.hs

{-# LANGUAGE PolymorphicComponents, StandaloneDeriving #-}

module Juggling where

import Data.Bits
import Data.Maybe
import Control.Monad
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import qualified Graphics.UI.GLUT.Callbacks.Window as W
import Graphics.UI.GLUT.State
import Graphics.Rendering.OpenGL.GL
import Data.IORef

newtype Height = Height { height :: Int } deriving (Show, Eq, Ord)

newtype Pattern = Pattern { pattern :: [Height] } deriving (Show, Eq)

newtype State = State { state :: Int } deriving (Show, Eq, Ord)

data Point2d = Point2d { xCoord :: GLfloat
                       , yCoord :: GLfloat } deriving (Show)

data PatternOptions = PatternOptions
  { timePerThrow    :: (Integral a) => a                       
  , pauseTime       :: (Ord a, Fractional a) => a	
  , handMovement    :: (Ord a, Fractional a) => a
  } 
  
deriving instance Show PatternOptions
  
defaultOptions :: PatternOptions
defaultOptions = PatternOptions 300 0.4 0.3
  
increaseSpeed :: PatternOptions -> PatternOptions
increaseSpeed opts = opts { timePerThrow = max 100 (timePerThrow opts - 100) }
  
decreaseSpeed :: PatternOptions -> PatternOptions
decreaseSpeed opts = opts { timePerThrow = min 2000 (timePerThrow opts + 100) }
  
handsTogether :: PatternOptions -> PatternOptions
handsTogether opts = opts { handMovement = max (-1.0) (handMovement opts - 0.1) }
  
handsApart :: PatternOptions -> PatternOptions
handsApart opts = opts { handMovement = min 1.0 (handMovement opts + 0.1) }
  
increasePause :: PatternOptions -> PatternOptions
increasePause opts = opts { pauseTime = min 0.9 (pauseTime opts + 0.1) }
  
decreasePause :: PatternOptions -> PatternOptions
decreasePause opts = opts { pauseTime = max 0.1 (pauseTime opts - 0.1) }

fromList :: [Int] -> Pattern
fromList = Pattern . map Height
         
cascade :: Pattern
cascade = fromList [3, 3]

shower :: Pattern
shower = fromList [1, 5]

fountain :: Pattern
fountain = fromList [4, 4]

numberOfProps :: Pattern -> Int
numberOfProps p = 
  let heights = map height $ pattern p in
  sum heights `div` length heights
  
rotateList :: Int -> [a] -> [a]
rotateList 0 xs     = xs
rotateList n (x:xs) = rotateList (n - 1) $ xs ++ [x]
  
rotatePattern :: Int -> Pattern -> Pattern
rotatePattern n = Pattern . rotateList n . pattern

heightAtTime :: Pattern -> Float -> Height
heightAtTime p@(Pattern (Height h:heights)) t 
  | t < fromIntegral h           = Height h
  | otherwise                    = heightAtTime (rotatePattern h p) (t - fromIntegral h)
  
xAtTime :: PatternOptions -> Pattern -> Float -> Float
xAtTime opts p@(Pattern (Height h:heights)) t 
  | t < (pauseTime opts) = t / (pauseTime opts) * (handMovement opts)
  | t < fromIntegral h && even h   = (handMovement opts) * (fromIntegral h - t) / (fromIntegral h - (pauseTime opts))
  | t < fromIntegral h             = (handMovement opts) + (1 - (handMovement opts)) * (t - (pauseTime opts)) / (fromIntegral h - (pauseTime opts))
  | even h                         = xAtTime opts (rotatePattern h p) (t - fromIntegral h)
  | otherwise                      = 1 + xAtTime opts (rotatePattern h p) (t - fromIntegral h)
  
yAtTime :: PatternOptions -> Pattern -> Float -> Float
yAtTime opts p@(Pattern (Height h:heights)) t 
  | t < (pauseTime opts) = 0
  | t < fromIntegral h             = (t - (pauseTime opts)) / (fromIntegral h - (pauseTime opts))
  | otherwise                      = yAtTime opts (rotatePattern h p) (t - fromIntegral h)
  
clip :: Float -> Float
clip x | 0 <= x && x <= 1        = x
       | x < 0                   = clip (-x)
       | x > 1                   = 1 - clip (x - 1)

circle :: GLfloat -> IO ()
circle r = GL.renderPrimitive GL.TriangleFan $ mapM_ GL.vertex points where
  points = flip map [0..10] $ \deg -> 
    GL.Vertex2 (r * sin (2 * pi * deg / 10)) 
               (r * cos (2 * pi * deg / 10)) :: GL.Vertex2 GLfloat    
 
project :: Float -> Float -> Height -> Height -> Point2d
project x y (Height height) (Height maxHeight) = 
  let xProj = 2 * x - 1
      yProj = 8 * (fromIntegral height) * y * (1 - y) / (fromIntegral maxHeight) - 1 in
  Point2d xProj yProj
 
positionOfBallAt :: PatternOptions -> Pattern -> Height -> Float -> Int -> Point2d
positionOfBallAt opts pattern maxHeight time index =
  let (x, y) = (xAtTime opts pattern time, yAtTime opts pattern time)
      height = heightAtTime pattern time
      cx     = clip $ fromIntegral index + x in
  project cx y height maxHeight
 
positions :: PatternOptions -> Pattern -> Int -> [Point2d]
positions opts p millis = 
  let props           = numberOfProps p 
      period          = 2 * (sum $ map height $ pattern p)
      timePeriod      = (timePerThrow opts) * period
      maxHeight       = Height $ maximum $ map height $ pattern p in
  do
    index <- [0 .. period - 1]
    let startMillis     = index * fromIntegral (timePerThrow opts)
    let relativeTime    = fromIntegral ((millis - startMillis) `mod` timePeriod) / fromIntegral (timePerThrow opts)
    let rotatedPattern  = rotatePattern index p
    guard $ 0 < (height $ head $ pattern rotatedPattern)
    return $ positionOfBallAt opts rotatedPattern maxHeight relativeTime index
                       
render :: IORef PatternOptions -> Pattern -> IO ()
render optsRef p = do
  time <- get elapsedTime
  opts <- get optsRef
  GL.clearColor $= GL.Color4 0 0 0 1
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
  GL.matrixMode $= GL.Projection
  GL.loadIdentity
  GL.ortho (-1.2) (1.2) (-1.2) (1.2) (-1.0) (1.0)
  GL.matrixMode $= GL.Modelview 0
  GL.loadIdentity
  flip mapM_ (positions opts p time) $ \p -> preservingMatrix $ do
    GL.color (GL.Color4 1 1 1 1 :: GL.Color4 GLclampf)
    translate (Vector3 (xCoord p) (yCoord p) 0.0) 
    circle 0.05
  GL.flush
  GLUT.swapBuffers
  GLUT.postRedisplay Nothing
  
keyboardMouse :: IORef PatternOptions -> W.Key -> W.KeyState -> W.Modifiers -> Position -> IO ()
keyboardMouse opts (W.SpecialKey key) _ _ _ = updateOptions opts (fromKeyPress key) where
  updateOptions opts f = do
    modifyIORef opts f
    readIORef opts >>= print
  fromKeyPress W.KeyUp = increaseSpeed
  fromKeyPress W.KeyDown = decreaseSpeed
  fromKeyPress W.KeyLeft = handsTogether
  fromKeyPress W.KeyRight = handsApart
  fromKeyPress W.KeyPageUp = increasePause
  fromKeyPress W.KeyPageDown = decreasePause
  fromKeyPress _ = id

animate :: Pattern -> IO ()
animate pattern = do
  opts <- newIORef defaultOptions
  GLUT.initialDisplayMode $= [ GLUT.RGBAMode,
                               GLUT.Multisampling,
                               GLUT.DoubleBuffered,
                               GLUT.WithAlphaComponent ] 
  GLUT.initialWindowSize $= GL.Size 600 600
  _ <- GLUT.getArgsAndInitialize
  GLUT.createWindow "OpenGL Juggling"
  GLUT.displayCallback $= render opts pattern
  GLUT.keyboardMouseCallback $= Just (keyboardMouse opts)
  GLUT.mainLoop