prepare to make cache size runtime settable
[ruff:gruff.git] / Browser.hs
1 module Browser (iInitialize) where
2
3 import Prelude hiding (log)
4 import Control.Concurrent
5   ( forkIO, MVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay )
6 import Control.Monad (forever, forM_, liftM2, replicateM, when)
7 import Data.Bits (bit)
8 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
9 import Data.List (sortBy)
10 import qualified Data.Map as M
11 import Data.Map (Map)
12 import Data.Maybe (isJust, mapMaybe)
13 import Data.Ord (comparing)
14 import Data.Ratio ((%))
15 import qualified Data.Set as S
16 import Data.Set ((\\))
17 import Foreign (Ptr, malloc, alloca, peek, poke, nullPtr)
18 import Foreign.C (CFloat, CInt)
19 import GHC.Conc (numCapabilities)
20 import Graphics.Rendering.OpenGL hiding (Angle, Point, Position, Size)
21 import qualified Graphics.Rendering.OpenGL as GL
22 import Graphics.Rendering.OpenGL.Raw
23   ( glTexImage2D, gl_TEXTURE_2D, gl_R32F, gl_RGBA, gl_LUMINANCE
24   , gl_FLOAT, gl_UNSIGNED_BYTE, gl_FALSE, glClampColor
25   , gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR, gl_CLAMP_FRAGMENT_COLOR
26   , glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D
27   , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, glGenerateMipmap
28   )
29 import Graphics.UI.Gtk hiding (get, Region, Size)
30
31 import Number
32 import GLUTGtk
33 import Shader (shader)
34 import QuadTree
35 import Tile (Tile(Tile), getTile, freeTile, rootSquare)
36 import Logger (Logger, LogLevel(Debug))
37 import qualified Logger as Log
38 import Paths_gruff (getDataFileName)
39
40 type TextureObject3 = (TextureObject, TextureObject, TextureObject)
41 data GruffImage = GruffImage
42   { center :: (Rational, Rational)
43   , level :: Int
44   , size :: Size
45   , prog :: Program
46   , tiles :: Map Quad TextureObject3
47   , queue :: MVar [Tile]
48   , jobs :: MVar [Quad]
49   , viewQuads0 :: [(Square, TextureObject3)]
50   , viewQuads1 :: [(Square, TextureObject3)]
51   , workers :: [Ptr CInt]
52   , progress :: Map (Ptr CInt) Quad
53   , gl :: GLUTGtk
54   , cacheDir :: FilePath
55   , log :: LogLevel -> String -> IO ()
56   , hshift :: Double
57   , hscale :: Double
58   , zoomPhase :: Double
59   , oversampling :: Int
60   , combineProg :: Program
61   , tsheet0 :: TextureObject
62   , tsheet1 :: TextureObject
63   , sheetSize :: Size
64   , fbo :: GLuint
65   , cacheSizeMin :: Int
66   , cacheSizeMax :: Int
67   }
68
69 iDisplay :: IORef GruffImage -> IO ()
70 iDisplay iR = do
71   s0 <- readIORef iR
72   mtls <- tryTakeMVar (queue s0)
73   case mtls of
74     Just tls -> do
75       putMVar (queue s0) []
76       forM_ tls $ \tile@(Tile q ns ds ts) -> do
77         tde <- upload ds
78         tit <- upload ns
79         ttt <- upload ts
80 --        GL.finish
81         freeTile tile
82         atomicModifyIORef iR $ \s' ->
83           ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')
84               , progress = M.filter (/= q) (progress s') }
85           , ())
86       update iR False
87     Nothing -> return ()
88   s <- readIORef iR
89   log s Debug $ "displayCallback " ++ show (center s, level s)
90   renderSheet s False
91   renderSheet s True
92   let Size w h = size s
93   viewport $=
94     (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
95   loadIdentity
96   ortho2D 0 (fromIntegral w) (fromIntegral h) 0
97   clearColor $= Color4 0.5 0.5 0.5 1
98   clear [ColorBuffer]
99   currentProgram $= Just (combineProg s)
100   lsheet0 <- get $ uniformLocation (combineProg s) "sheet0"
101   lsheet1 <- get $ uniformLocation (combineProg s) "sheet1"
102   lblend  <- get $ uniformLocation (combineProg s) "blend"
103   uniform lsheet0 $= TexCoord1 (0 :: GLint)
104   uniform lsheet1 $= TexCoord1 (1 :: GLint)
105   uniform lblend $= TexCoord1 (realToFrac (
106     let p = negate $ zoomPhase s
107     in  1 - (1 - 4**p) / (4**(p + 1) - 4**p) ) :: GLfloat)
108   activeTexture $= TextureUnit 0
109   textureBinding Texture2D $= Just (tsheet0 s)
110   activeTexture $= TextureUnit 1
111   textureBinding Texture2D $= Just (tsheet1 s)
112   let Size tw th = sheetSize s
113       t x y = texCoord $ TexCoord2
114         (0.5 + x * fromIntegral w / fromIntegral tw :: GLdouble)
115         (0.5 + y * fromIntegral h / fromIntegral th :: GLdouble)
116       v :: Int -> Int -> IO ()
117       v x y = vertex $ Vertex2
118         (fromIntegral x :: GLdouble) (fromIntegral y :: GLdouble)
119       k = realToFrac (2 ** zoomPhase s) :: GLdouble
120   translate $ Vector3(   fromIntegral w/2) (  fromIntegral h/2) (0::GLdouble)
121   scale k k k
122   translate $ Vector3 (- fromIntegral w/2) (- fromIntegral h/2) (0::GLdouble)
123   renderPrimitive Quads $ do
124     t (-1) 1 >> v 0 h
125     t (-1) (-1) >> v 0 0
126     t 1 (-1) >> v w 0
127     t 1 1 >> v w h
128   textureBinding Texture2D $= Nothing
129   activeTexture $= TextureUnit 0
130   textureBinding Texture2D $= Nothing
131   currentProgram $= Nothing
132
133 renderSheet :: GruffImage -> Bool -> IO ()
134 renderSheet s b = do
135   let Size tw th = sheetSize s
136   viewport $=
137     (GL.Position 0 0, GL.Size (fromIntegral tw) (fromIntegral th))
138   loadIdentity
139   ortho2D (negate $ fromIntegral tw / 2) (fromIntegral tw / 2) (negate $ fromIntegral th / 2) (fromIntegral th / 2)
140   bindFBO (fbo s) tsheet
141   clearColor $= Color4 0.5 0.5 0.5 0
142   clear [ColorBuffer]
143   currentProgram $= Just (prog s)
144   lde <- get $ uniformLocation (prog s) "de"
145   lit <- get $ uniformLocation (prog s) "it"
146   ltt <- get $ uniformLocation (prog s) "tt"
147   lhshift <- get $ uniformLocation (prog s) "hshift"
148   lhscale <- get $ uniformLocation (prog s) "hscale"
149   uniform lde $= TexCoord1 (0 :: GLint)
150   uniform lit $= TexCoord1 (1 :: GLint)
151   uniform ltt $= TexCoord1 (2 :: GLint)
152   uniform lhshift $= TexCoord1 (realToFrac (hshift s) :: GLfloat)
153   uniform lhscale $= TexCoord1 (realToFrac (hscale s) :: GLfloat)
154   mapM_ (drawQuad (toPixel s dl)) vquads
155   currentProgram $= Nothing
156   unbindFBO
157   textureBinding Texture2D $= Just tsheet
158   glGenerateMipmap gl_TEXTURE_2D
159   textureBinding Texture2D $= Nothing
160   where
161     tsheet = (if b then tsheet1 else tsheet0) s
162     vquads = (if b then viewQuads1 else viewQuads0) s
163     dl = if b then 1 else 0
164   
165 -- writeSnapshot (show (level s) ++ ".ppm") (Position 0 0) (size s)
166
167 drawQuad :: (Rational -> Rational -> (GLdouble, GLdouble)) -> (Square, TextureObject3) -> IO ()
168 drawQuad toPx (sq, (tde, tit, ttt)) = do
169   let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
170       v x y = vertex $ Vertex2 x y
171       (x0, y0) = toPx (squareWest sq) (squareNorth sq)
172       x1 = x0 + fromIntegral tileSize
173       y1 = y0 + fromIntegral tileSize
174   activeTexture $= TextureUnit 0
175   textureBinding Texture2D $= Just tde
176   activeTexture $= TextureUnit 1
177   textureBinding Texture2D $= Just tit
178   activeTexture $= TextureUnit 2
179   textureBinding Texture2D $= Just ttt
180   renderPrimitive Quads $ do
181     color $ Color3 1 1 (1::GLdouble)
182     t 0 1 >> v x0 y1
183     t 0 0 >> v x0 y0
184     t 1 0 >> v x1 y0
185     t 1 1 >> v x1 y1
186   textureBinding Texture2D $= Nothing
187   activeTexture $= TextureUnit 1
188   textureBinding Texture2D $= Nothing
189   activeTexture $= TextureUnit 0
190   textureBinding Texture2D $= Nothing
191
192 iReshape :: IORef GruffImage -> Size -> IO ()
193 iReshape iR size' = do
194   s' <- readIORef iR
195   log s' Debug $ "reshapeCallback " ++ show size'
196   atomicModifyIORef iR $ \s -> (s{ size = size' }, ())
197   update iR True
198
199 iMouse :: IORef GruffImage -> IO () -> Key -> KeyState -> [Modifier] -> Position -> IO ()
200 iMouse sR updateGUI (MouseButton LeftButton  ) Down _ p@(Position x y) = do
201   s' <- readIORef sR
202   log s' Debug $ "leftMouse " ++ show p
203   atomicModifyIORef sR $ \s -> let level' = (level s + 1) in
204     ( s{ center = fromPixel s (round x) (round y), level = level' }
205     , ())
206   update sR True >> updateGUI
207 iMouse sR updateGUI (MouseButton MiddleButton) Down _ p@(Position x y) = do
208   s' <- readIORef sR
209   log s' Debug $ "middleMouse " ++ show p
210   atomicModifyIORef sR $ \s ->
211     ( s{ center = fromPixel s (round x) (round y) }
212     , ())
213   update sR True >> updateGUI
214 iMouse sR updateGUI (MouseButton RightButton ) Down _ p@(Position x y) = do
215   s' <- readIORef sR
216   log s' Debug $ "rightMouse " ++ show p
217   atomicModifyIORef sR $ \s -> let level' = (level s - 1) `max` 0 in
218     ( s{ center = fromPixel s (round x) (round y), level = level' }
219     , ())
220   update sR True >> updateGUI
221 iMouse _ _ _ _ _ _ = return ()
222
223 fromPixel :: GruffImage -> Int -> Int -> (Rational, Rational)
224 fromPixel s x y = (x', y')
225   where
226     Size w h = size s
227     a = fromIntegral w / fromIntegral h
228     (cx, cy) = center s
229     r = 4 / 2 ^ level s * fromIntegral h / fromIntegral tileSize
230     x' = cx + r * realToFrac ((fromIntegral x / fromIntegral w - 0.5) / 2 ** realToFrac (zoomPhase s) :: Double) * a
231     y' = cy + r * realToFrac ((fromIntegral y / fromIntegral h - 0.5) / 2 ** realToFrac (zoomPhase s) :: Double)
232
233 toPixel :: GruffImage -> Int -> Rational -> Rational -> (GLdouble, GLdouble)
234 toPixel s dl = \x y -> ( fromRational ((x - cx) * e) * k
235                        , fromRational ((y - cy) * e) * k )
236   where
237     Size _ h = sheetSize s
238     (cx, cy) = center s
239     r = 4 * fromIntegral h / fromIntegral tileSize
240     e = bit (level s + dl + 1) % 1
241     k = fromIntegral h / r
242
243 tileSize :: Int
244 tileSize = 256
245
246 centerQuad :: GruffImage -> Quad
247 centerQuad s =
248   let (cx, cy) = center s
249       f = contains (Point cx cy) . square rootSquare
250       refine = filter f . liftM2 child [minBound .. maxBound]
251   in  case iterate refine [root] !! (level s + oversampling s) of
252         (q:_) -> q
253         [] -> root
254
255 quadDistance :: Quad -> Quad -> Double
256 quadDistance q0 q1 =
257   let Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } = q0
258       Quad{ quadLevel = l, quadWest = r, quadNorth = i} = q1
259       dl = abs (fromIntegral l - fromIntegral l0)
260       d x x0
261         | l >  l0 = fromIntegral $ abs (x - x0 * 2 ^ (l - l0))
262         | l == l0 = fromIntegral $ abs (x - x0)
263         | l <  l0 = fromIntegral $ abs (x0 - x * 2 ^ (l0 - l))
264       d _ _ = error "score"
265   in  dl + d r r0 + d i i0
266
267 prune :: IORef GruffImage -> IO ()
268 prune sR = do
269   s0 <- readIORef sR
270   let cacheSize = M.size (tiles s0)
271   when (cacheSize > cacheSizeMax s0) $ do
272     log s0 Debug . concat $
273       [ "pruning texture cache "
274       , show cacheSize, " > ", show (cacheSizeMax s0)
275       , " --> ", show (cacheSizeMin s0)
276       ]
277     bad <- atomicModifyIORef sR $ \s -> 
278       let q0 = centerQuad s
279           score = quadDistance q0
280           o = comparing (score . fst)
281           (good, bad)
282             = splitAt (cacheSizeMin s) . sortBy o . M.toList . tiles $ s
283       in  (s{ tiles = M.fromList good }, bad)
284     let t (_, (t1, t2, t3)) = [t1, t2, t3]
285     deleteObjectNames $ concatMap t bad
286
287 update :: IORef GruffImage -> Bool -> IO ()
288 update sR newView = do
289   prune sR
290   s' <- readIORef sR
291   log s' Debug $ "updateCallback " ++ show newView
292   todo' <- atomicModifyIORef sR $ \s ->
293     let Size w h = size s
294         ((bw,bn),(be,bs)) =
295           ( fromPixel s 0 0
296           , fromPixel s (fromIntegral w) (fromIntegral h) )
297         view = Region
298           { regionWest = bw, regionNorth = bn
299           , regionEast = be, regionSouth = bs }
300         qs0 = quads rootSquare view (level s + oversampling s)
301         qs1 = quads rootSquare view (level s + oversampling s + 1)
302         qs = qs0 ++ qs1
303         todo = S.filter (`M.notMember` tiles s) (S.fromList qs)
304         getQuad q = (,) (square rootSquare q) `fmap` M.lookup q (tiles s)
305         quads0 = mapMaybe getQuad qs0
306         quads1 = mapMaybe getQuad qs1
307     in  (s{ viewQuads0 = quads0, viewQuads1 = quads1 }, todo)
308   when newView $ do
309     -- cancel in-progress jobs that aren't still needed
310     _ <- takeMVar (jobs s')
311     p <- atomicModifyIORef sR $ \s -> (s{ progress = M.filter (`S.member` todo') (progress s) }, progress s)
312     mapM_ (`poke` 1) . filter (\w -> case M.lookup w p of Nothing -> False ; Just q -> q `S.notMember` todo') . workers $ s'
313     -- set new jobs
314     let q0 = centerQuad s'
315         score = quadDistance q0
316     putMVar (jobs s') . sortBy (comparing score) . S.toList $ todo' \\ S.fromList (M.elems p)
317     postRedisplay (gl s')
318
319 putTile :: IORef GruffImage -> Ptr CInt -> Tile -> IO ()
320 putTile sR p t = do
321   qu <- atomicModifyIORef sR $ \s ->
322     (s{ progress = M.delete p (progress s) }, queue s)
323   ts <- takeMVar qu
324   putMVar qu (t:ts)
325
326 putJobs :: IORef GruffImage -> [Quad] -> IO ()
327 putJobs sR qs = do
328   s <- readIORef sR
329   _ <- takeMVar (jobs s)
330   putMVar (jobs s) qs
331
332 takeJob :: IORef GruffImage -> Ptr CInt -> IO Quad
333 takeJob sR p = do
334   s <- readIORef sR
335   qs <- takeMVar (jobs s)
336   case qs of
337     [] -> do
338       putMVar (jobs s) []
339       threadDelay 10000
340       takeJob sR p
341     (q:qs') -> do
342       atomicModifyIORef sR $ \s' ->
343         ( s'{ progress = M.insert p q (progress s') }, ())
344       putMVar (jobs s) qs'
345       return q
346
347 worker :: IORef GruffImage -> Ptr CInt -> IO ()
348 worker sR p = forever $ do
349   s <- readIORef sR
350   q <- takeJob sR p
351   mt <- getTile (log s Debug) (cacheDir s) p q
352   case mt of
353     Nothing -> return ()
354     Just t -> putTile sR p t
355
356 timer :: IORef GruffImage -> IO ()
357 timer sR = do
358   s <- readIORef sR
359   mtls <- tryTakeMVar (queue s)
360   case mtls of
361     Just tls@(_:_) -> do
362       putMVar (queue s) tls
363       postRedisplay (gl s)
364     Just [] -> do
365       putMVar (queue s) []
366     _ -> return ()
367
368 upload :: Ptr CFloat -> IO TextureObject
369 upload p = do
370   [tex] <- genObjectNames 1
371   texture Texture2D $= Enabled
372   textureBinding Texture2D $= Just tex
373   glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)
374     (fromIntegral tileSize) (fromIntegral tileSize) 0
375       gl_LUMINANCE gl_FLOAT p
376   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
377   textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
378   textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
379   textureBinding Texture2D $= Nothing
380   texture Texture2D $= Disabled
381   return tex
382
383 defSize :: Size
384 defSize = Size 1920 1080
385
386 msPerFrame :: Int
387 msPerFrame = 400
388
389 iInitialize :: GLUTGtk -> Pixbuf -> Logger -> FilePath
390             -> IO ( Window
391                   , Maybe R -> Maybe R -> Maybe R -> Maybe Double -> Maybe Double -> IO ()
392                   , (R -> R -> R -> IO ()) -> IO () -> IO ()
393                   , IO ()
394                   )
395 iInitialize gl' icon lg cacheDir' = do
396   -- image window
397   iw <- windowNew
398   let Size defW defH = defSize
399   windowSetDefaultSize iw defW defH
400   set iw
401     [ containerBorderWidth := 0
402     , containerChild := widget gl'
403     , windowIcon  := Just icon
404     , windowTitle := "gruff browser"
405     ]
406   queue' <- newMVar []
407   jobs' <- newMVar []
408   iR <- newIORef GruffImage
409     { center = (0, 0)
410     , level = 0
411     , size = defSize
412     , tiles = M.empty
413     , queue = queue'
414     , jobs = jobs'
415     , progress = M.empty
416     , viewQuads0 = []
417     , viewQuads1 = []
418     , gl = gl'
419     , cacheDir = cacheDir'
420     , log = Log.log lg
421     , workers = []
422     , prog = undefined
423     , hshift = 0
424     , hscale = 1
425     , zoomPhase = 0
426     , oversampling = 2
427     , fbo = 0
428     , combineProg = undefined
429     , tsheet0 = undefined
430     , tsheet1 = undefined
431     , sheetSize = Size 8192 8192
432     , cacheSizeMin = 1200
433     , cacheSizeMax = 1600
434     }
435   realizeCallback gl' $= iRealize iR
436   reshapeCallback gl' $= iReshape iR
437   displayCallback gl' $= iDisplay iR
438   let iUpdate mre mim mz mhshift mhscale = do
439         case mz of
440           Just z | z > 0 ->
441             let (n, f) = properFraction . negate . logBase 2 $ z
442             in  atomicModifyIORef iR $ \s ->
443                   ( s { level = max 0 n, zoomPhase = realToFrac f }, () )
444           _ -> return ()
445         case liftM2 (,) mre mim of
446           Just (r, i) -> atomicModifyIORef iR $ \s ->
447               ( s { center = (toRational' (level s) r, negate $ toRational' (level s) i) }, () )
448           Nothing -> return ()
449         case mhshift of
450           Just x -> atomicModifyIORef iR $ \s ->
451               ( s { hshift = x }, () )
452           _ -> return ()
453         case mhscale of
454           Just x -> atomicModifyIORef iR $ \s ->
455               ( s { hscale = x }, () )
456           _ -> return ()
457         update iR (any isJust [mre, mim, mz])
458         postRedisplay gl'
459       iInitializeLate aUpdate aExit = do
460         let updateCoordinates = do
461               i <- readIORef iR
462               let re = fromRational .          fst . center $ i
463                   im = fromRational . negate . snd . center $ i
464                   z  = fromRational . recip . (2 ^) . level $ i
465               aUpdate re im z
466         _ <- iw `onDestroy` aExit
467         _ <- timeoutAdd (timer iR >> return True) msPerFrame
468         keyboardMouseCallback gl' $= iMouse iR updateCoordinates
469       iStop = do
470         i <- readIORef iR
471         putJobs iR []
472         atomicModifyIORef iR $ \s -> (s{ progress = M.empty }, ())
473         mapM_ (`poke` 1) . workers $ i
474   return (iw, iUpdate, iInitializeLate, iStop)
475
476 iRealize :: IORef GruffImage -> IO ()
477 iRealize iR = do
478   s <- readIORef iR
479   log s Debug "realizeCallback"
480   drawBuffer $= BackBuffers
481   glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE
482   glClampColor gl_CLAMP_READ_COLOR gl_FALSE
483   glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE
484   f <- getDataFileName "colourize.frag"
485   prog' <- shader Nothing (Just f)
486   f' <- getDataFileName "merge.frag"
487   combineProg' <- shader Nothing (Just f')
488   fbo' <- newFBO
489   ts@[tsheet0', tsheet1'] <- genObjectNames 2
490   let Size tw th = sheetSize s
491   forM_ ts $ \t -> do
492     texture Texture2D $= Enabled
493     textureBinding Texture2D $= Just t
494     glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA)
495       (fromIntegral tw) (fromIntegral th) 0 gl_RGBA gl_UNSIGNED_BYTE
496       nullPtr
497     textureFilter Texture2D $= ((Linear', Just Linear'), Linear')
498     textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
499     textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
500     textureBinding Texture2D $= Nothing
501     texture Texture2D $= Disabled
502   ps <- replicateM numCapabilities $ do
503     p <- malloc
504     _ <- forkIO (worker iR p)
505     return p
506   atomicModifyIORef iR $ \i -> (i
507     { prog = prog'
508     , workers = ps
509     , fbo = fbo'
510     , combineProg = combineProg'
511     , tsheet0 = tsheet0'
512     , tsheet1 = tsheet1'
513     }, ())
514
515 newFBO :: IO GLuint
516 newFBO = alloca $ \p -> glGenFramebuffers 1 p >> peek p
517
518 bindFBO :: GLuint -> TextureObject -> IO ()
519 bindFBO f (TextureObject t) = do
520   glBindFramebuffer gl_FRAMEBUFFER f
521   glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D t 0
522
523 unbindFBO :: IO ()
524 unbindFBO = do
525   glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0
526   glBindFramebuffer gl_FRAMEBUFFER 0