{- Author: Ruben Henner Zilibowitz Date: 20/2/10 Compiles under GHC 6.10.4 with: ghc --make -O2 AttracCloudView.hs -} module Main where import Data.IORef ( IORef, newIORef, readIORef, modifyIORef, writeIORef ) import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import Graphics.Rendering.OpenGL as OpenGL import Graphics.UI.GLUT as GLUT import IO(hFlush,stdout) import Array import Data.Colour.RGBSpace.HSL import Data.Colour.SRGB as SRGB import System.Random import Char import Attrac import SprottCodes ffm cs (p1,Pt x y z) = let (p2,Mat tx _ _ ty _ _ tz _ _) = fm cs (p1,Mat x 1 1 y 0 0 z 0 0) in (p2,Pt tx ty tz) ----- type Pt2 = (Value,Value) data State = State { leftMouseButton, middleMouseButton, rightMouseButton :: IORef KeyState, mouseLoc, mouseDrag :: IORef Position, curP :: IORef (Pt,Pt), coeffs :: IORef Coeffs, screen :: IORef (Int,Int), sprottCode :: IORef Int, curTransformMat :: IORef PMat, curBuffer :: IORef (Array (Int,Int) (Value,Integer)), framesElapsed :: IORef Integer } lightPt = Pt 10 10 (-10) eyePt = Pt 0 0 (-10) findOrbit :: Coeffs -> (Pt,Pt) findOrbit cs = (iterate (ffm cs) (almostZeroPt,Pt 1 0 0)) !! 128 --- --- make initial state --- makeState :: (Int,Int) -> Coeffs -> IO State makeState dims@(width,height) cs = do leftMouseButton_ <- newIORef Up middleMouseButton_ <- newIORef Up rightMouseButton_ <- newIORef Up mouseLoc_ <- newIORef (Position 0 0) mouseDrag_ <- newIORef (Position 0 0) curP_ <- newIORef (findOrbit cs) coeffs_ <- newIORef cs screen_ <- newIORef dims sprottCode_ <- newIORef 0 curTransformMat_ <- newIORef idPMat curBuffer_ <- newIORef (listArray ((0,0),(width-1,height-1)) (repeat (0,0))) framesElapsed_ <- newIORef 0 return $ State { leftMouseButton = leftMouseButton_, middleMouseButton = middleMouseButton_, rightMouseButton = rightMouseButton_, mouseLoc = mouseLoc_, mouseDrag = mouseDrag_, curP = curP_, coeffs = coeffs_, screen = screen_, sprottCode = sprottCode_, curTransformMat = curTransformMat_, curBuffer = curBuffer_, framesElapsed = framesElapsed_ } --- --- display callback --- iterations = 1000 iterateFuncFor 0 _ z = ([],[],z) iterateFuncFor n f z = (a:w,b:x,y) where (a,b) = f z (w,x,y) = iterateFuncFor (n-1) f (a,b) shade :: Pt -> Pt -> Value shade p@(Pt x y z) t@(Pt tx ty tz) | ((lightPt <-> p) <.> (eyePt <-> p) < 0) = ka | gamma < 0 = error "sqrt (-1)" | diffuse < 0 = error "neg diffuse" | specular < 0 = error "neg specular" | otherwise = ka + kd*diffuse + ks*specular where l = normalise (lightPt <-> p) tt = t <.> t ll = l <.> l lt = l <.> t gamma = tt^2*ll - tt*lt^2 rootGamma = sqrt gamma alpha = negate (tt / rootGamma) beta = lt / rootGamma n_ = (alpha <#> l) <+> (beta <#> t) n = if (l <.> n_ < 0) then (-1) <#> n_ else n_ r = ((2 * (l <.> n)) <#> n) <-> l v = normalise (eyePt <-> p) diffuse = l <.> n shininess = 8 specular = (r <.> v) ^ shininess ka = 0.09 ks = 0.4 kd = 1 - ka - ks transform :: (Int,Int) -> PMat -> Pt -> (Int,Int) transform (width,height) m p = (round $ (fromIntegral width) * 0.5 + 100*x, round $ (fromIntegral height) * 0.5 + 100*y) where (Pt x y _) = m <*#> p colorSpeed = 1e-2 display :: State -> IO () display state = do p <- readIORef (curP state) cs <- readIORef (coeffs state) let (ps,ts,q) = iterateFuncFor iterations (ffm cs) p m <- readIORef (curTransformMat state) dims@(width,height) <- readIORef (screen state) let xs = filter (\((px,py),_) -> 0<=px&&px (x+y,c+1))) xs) buf <- readIORef (curBuffer state) renderPrimitive Points$sequence_ [let (x,c) = buf!(px,py) in let SRGB.RGB r g b = hsl (colorSpeed * fromIntegral c) 1 (x / (fromIntegral c)) in (color$Color3 r g b) >> (vertex$Vertex2 (fromIntegral px :: GLint) (fromIntegral py :: GLint)) | ((px,py),_) <- xs] writeIORef (curP state) q modifyIORef (framesElapsed state) (1 +) readIORef (framesElapsed state) >>= \f -> if (mod f 10 == 0) then putChar '.' >> hFlush stdout else return () swapBuffers postRedisplay Nothing --- --- reshape callback --- reshape :: State -> Size -> IO () reshape state size@(Size w h) = do viewport $= (Position 0 0, size) matrixMode $= Modelview 0 loadIdentity matrixMode $= Projection loadIdentity ortho2D 0 (fromIntegral w) 0 (fromIntegral h) writeIORef (screen state) (fromIntegral w,fromIntegral h) clearAll state --- --- keyboard and mouse callback --- (./) a b = (fromIntegral a) / (fromIntegral b) coeffsToSprottCode :: [Value] -> [Char] coeffsToSprottCode xs = 'I' : [chr (round (x*10) + ord 'M') | x <- xs] keyboardMouse :: State -> KeyboardMouseCallback keyboardMouse state (Char c) Down _ _ = case c of 'm' -> print =<< (readIORef $ curTransformMat state) 'p' -> print =<< (readIORef $ curP state) 'f' -> print =<< (readIORef $ framesElapsed state) 'r' -> postRedisplay Nothing ' ' -> writeIORef (curTransformMat state) idPMat >> clearAll state 'c' -> do g <- newStdGen let (cs,ly) = randomiseCoeffs g putStrLn $ "\nSprott code: " ++ coeffsToSprottCode (elems cs) ++ "\nLyapunov Exponent: " ++ show ly writeIORef (coeffs state) cs writeIORef (curP state) (findOrbit cs) clearAll state 's' -> do n <- readIORef (sprottCode state) let n' = (n + 1) `mod` (length codes) let cs = listArray (0,numCoeffs-1) (readCode (codes !! n')) putStrLn $ "\nSprott code: " ++ codes!!n' ++ "\nLyapunov Exponent: " ++ show (maxLyapunovExponent cs) writeIORef (coeffs state) cs writeIORef (curP state) (findOrbit cs) writeIORef (sprottCode state) n' clearAll state '\27' -> putStrLn "" >> exitWith ExitSuccess _ -> return () keyboardMouse state (MouseButton LeftButton) buttonState _ pos = do writeIORef (leftMouseButton state) buttonState writeIORef (mouseLoc state) pos writeIORef (mouseDrag state) pos keyboardMouse state (MouseButton MiddleButton) buttonState _ pos = do writeIORef (middleMouseButton state) buttonState writeIORef (mouseLoc state) pos writeIORef (mouseDrag state) pos keyboardMouse state (MouseButton RightButton) buttonState _ pos = do writeIORef (rightMouseButton state) buttonState writeIORef (mouseLoc state) pos writeIORef (mouseDrag state) pos keyboardMouse _ _ _ _ _ = return () clearAll state = do clear [ColorBuffer] (width,height) <- readIORef (screen state) writeIORef (curBuffer state) (listArray ((0,0),(width-1,height-1)) (repeat (0,0))) --- --- motion callback --- motion :: State -> MotionCallback motion state pos@(Position newX newY) = do clearAll state Position oldX oldY <- readIORef (mouseDrag state) writeIORef (mouseDrag state) pos let dp = Position (newX-oldX) (newY-oldY) loc <- readIORef (mouseLoc state) lmb <- readIORef (leftMouseButton state) mmb <- readIORef (middleMouseButton state) rmb <- readIORef (rightMouseButton state) case lmb of Down -> modifyIORef (curTransformMat state) ((translateXYMat dp) <*%>) Up -> return () case mmb of Down -> modifyIORef (curTransformMat state) ((scaleMat dp) <*%>) Up -> return () case rmb of Down -> modifyIORef (curTransformMat state) ((rotateXYMat dp) <*%>) Up -> return () translateXYMat :: Position -> PMat translateXYMat (Position x y) = PMat 1 0 0 (fromIntegral x * 0.01) 0 1 0 (fromIntegral y * (-0.01)) 0 0 1 0 0 0 0 1 scaleMat :: Position -> PMat scaleMat (Position x y) = PMat 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 (exp (fromIntegral x * (-0.01))) rotateXYMat :: Position -> PMat rotateXYMat (Position x y) = (PMat 1 0 0 0 0 cx (-sx) 0 0 sx cx 0 0 0 0 1) <*%> (PMat cy 0 sy 0 0 1 0 0 (-sy) 0 cy 0 0 0 0 1) where cx = cos $ 0.001 * fromIntegral (negate y) sx = sin $ 0.001 * fromIntegral (negate y) cy = cos $ 0.001 * fromIntegral (negate x) sy = sin $ 0.001 * fromIntegral (negate x) --- --- main --- initialWidth = 800 :: Int initialHeight = 800 :: Int main :: IO () main = do (_progName, args) <- getArgsAndInitialize initialDisplayMode $= [ RGBMode ] initialWindowPosition $= Position 0 0 initialWindowSize $= Size (fromIntegral initialWidth) (fromIntegral initialHeight) createWindow _progName let cs = listArray (0,numCoeffs-1) $ readCode (codes !! 0) state <- makeState (initialWidth,initialHeight) cs displayCallback $= display state reshapeCallback $= Just (reshape state) keyboardMouseCallback $= Just (keyboardMouse state) motionCallback $= Just (motion state) clearColor $= backgroundColor clear [ColorBuffer] putStrLn "Welcome. Instructions:" putStr instructions mainLoop backgroundColor = Color4 0 0 0.12 1 instructions :: String instructions = "'m' -> output transform matrix\n'p' -> output current point\n'f' -> output frames elapsed\n'r' -> post redisplay\n' ' -> reset transform matrix\n'c' -> randomise coefficients\n's' -> select next Sprott code from list\nESC -> exit\n\n'left mouse button' -> drag mouse to translate in XY plane\n'middle mouse button' -> drag mouse to scale\n'right mouse button' -> drag mouse to rotate around X and Y axes\n"