julia renderer in C; render worker in Haskell; test the score mechanism
[maximus:mandulia.git] / Julia.hs
1 {-# LANGUAGE ForeignFunctionInterface #-}
2 module Julia where
3
4 import Graphics.UI.GLUT
5
6 import Control.Monad (forever)
7 import Foreign.Ptr (Ptr)
8 import Foreign.C.Types
9
10 import JobQueue
11 import ResourcePool
12 import Image
13
14 data Julia =
15   Julia
16     { jLevel :: Int
17     , jCX    :: Double
18     , jCY    :: Double
19     }
20   deriving (Show, Read, Eq, Ord)
21
22 score :: Double -> Double -> Double -> Julia -> Double
23 score level cx cy j =
24   let dcx = cx - jCX j
25       dcy = cy - jCY j
26       r2 = dcx * dcx + dcy * dcy
27       y0 = phi' ** level
28       y1 = phi' ** fromIntegral (jLevel j)
29       dy = y0 - y1
30       sy = y0 + y1
31       dy2 = dy * dy
32       sy2 = sy * sy
33   in (r2 + dy2) / (r2 + sy2) -- the rest is monotonic
34   -- PoincarĂ© half-plane distance metric
35   -- 2 * atanh ( magnitude (z1 - z2) / magnitude (z1 - conjugate z2) )
36   -- http://en.wikipedia.org/wiki/Poincar%C3%A9_metric
37   -- #Metric_and_volume_element_on_the_Poincar.C3.A9_plane
38     
39 phi' :: Double
40 phi' = (sqrt 5 - 1) / 2
41
42 data JuliaJob =
43   JuliaJob
44     { jCoords :: Julia
45     , jDoneAction :: Maybe (IO TextureObject)
46     }
47
48 instance Eq JuliaJob where
49   j == k = jCoords j == jCoords k
50
51 foreign import ccall unsafe "julia.h julia_new"
52   c_juliaNew    :: CInt -> CInt -> IO (Ptr ())
53
54 foreign import ccall unsafe "julia.h julia_delete"
55   c_juliaDelete :: Ptr () -> IO ()
56
57 foreign import ccall unsafe "julia.h julia"
58   c_julia       :: Ptr () -> Ptr () -> CDouble -> CDouble -> IO ()
59
60 juliaWorker :: Int -> Int -> ResourcePool Image -> JobQueue JuliaJob -> IO ()
61 juliaWorker w h is js = do
62   c <- c_juliaNew (fromIntegral w) (fromIntegral h)
63   forever $ do
64     i <- acquire is
65     withJob js $ \j -> do
66       c_julia c (iBuffer i) (realToFrac . jCX . jCoords $ j) (realToFrac . jCY . jCoords $ j)
67       return j
68         { jDoneAction = Just $ do
69             t <- upload i
70             release is i
71             return t
72         }