prepare to make cache size runtime settable
[ruff:gruff.git] / CacheView.hs
1 module CacheView (cInitialize) where
2
3 import Control.Concurrent (forkIO)
4 import Control.Monad (forM_, liftM2, when)
5 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
6 import qualified Data.Map as M
7 import Data.Map (Map)
8 import Data.Maybe (catMaybes, mapMaybe)
9 import System.FilePath ((</>), dropExtension)
10
11 import Foreign (alloca, peek, nullPtr)
12 import Graphics.Rendering.OpenGL hiding (Position, Size)
13 import qualified Graphics.Rendering.OpenGL as GL
14 import Graphics.Rendering.OpenGL.Raw
15   ( glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D
16   , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, gl_TEXTURE_2D
17   , glTexImage2D, gl_R32F, gl_LUMINANCE, gl_FLOAT
18   , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR
19   , gl_CLAMP_FRAGMENT_COLOR )
20 import Graphics.UI.Gtk hiding (Region, Size)
21
22 import Number
23 import GLUTGtk
24 import Shader (shader)
25 import QuadTree (Child(..), unsafeName, Quad, Square(..), square, child, root, outside, Region(..))
26 --import Tile (rootSquare)
27 import Utils (getFilesRecursive)
28
29 import Paths_gruff (getDataFileName)
30
31 rootSquare :: Square
32 rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }
33
34 names :: Map Char [Child]
35 names = M.fromList names1 `M.union` M.fromList names2
36   where
37     names1 = [ (unsafeName [i], [i]) | i <- [minBound..maxBound] ]
38     names2 = [ (unsafeName [i,j], [i,j]) | i <- [minBound..maxBound], j <- [minBound..maxBound] ]
39
40 fromPath :: ([FilePath], FilePath) -> Maybe [Child]
41 fromPath (ps, f) =
42   let s = concat ps ++ dropExtension f
43       p = concat $ mapMaybe (`M.lookup` names) s
44   in  if all (`M.member` names) s then Just p else Nothing
45
46 cDisplay :: IORef GruffCache -> IO ()
47 cDisplay cR = do
48   c <- readIORef cR
49   let Size w h = cSize c
50       TextureObject tex = cTex c
51   when (cRecalc c) $ do
52     viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
53     loadIdentity
54     ortho2D 0 (fromIntegral w) (fromIntegral h) 0
55     withFBO (cFBO c) tex $ do
56       clearColor $= Color4 0 0 0 1
57       clear [ColorBuffer]
58       let toPixel' = toPixel c
59           qs = cQuads c
60           zm = fromIntegral . snd . head $ qs
61       withBlend (One, One) $ renderPrimitive Quads $ forM_ qs $ \(q, z) -> do
62         let sq = square rootSquare q
63             s = squareSize sq `max` cSquareSize c
64             (x0, y0) = toPixel' (squareWest sq) (squareNorth sq)
65             (x1, y1) = toPixel' (squareWest sq + s) (squareNorth sq + s)
66             v x y = vertex $ Vertex2 (fromRational x :: GLdouble) (fromRational y :: GLdouble)
67             k = fromIntegral z / zm :: GLdouble
68         color $ Color3 k k k
69         v x0 y1 >> v x0 y0 >> v x1 y0 >> v x1 y1
70     atomicModifyIORef cR $ \c' -> (c'{ cRecalc = False }, ())
71   -- draw texture
72   loadIdentity
73   ortho2D 0 1 1 0
74   textureBinding Texture2D $= Just (cTex c)
75   currentProgram $= Just (cProg c)
76   lt <- GL.get $ uniformLocation (cProg c) "tex"
77   uniform lt $= TexCoord1 (0 :: GLint)
78   renderPrimitive Quads $ do
79     let Size tw th = cTexSize c
80     let tx = fromIntegral w / fromIntegral tw
81         ty = fromIntegral h / fromIntegral th
82         v :: GLdouble -> GLdouble -> IO ()
83         v x y = do
84           texCoord $ TexCoord2 (tx * x) (ty * (1-y))
85           vertex $ Vertex2 x y
86     v 0 1 >> v 0 0 >> v 1 0 >> v 1 1
87   currentProgram $= Nothing
88   textureBinding Texture2D $= Nothing
89
90 withFBO :: GLuint -> GLuint -> IO () -> IO ()
91 withFBO fbo tex act = do
92   glBindFramebuffer gl_FRAMEBUFFER fbo
93   glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D tex 0
94   act
95   glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0
96   glBindFramebuffer gl_FRAMEBUFFER 0
97
98 withBlend :: (BlendingFactor, BlendingFactor) -> IO a -> IO a
99 withBlend bf act = do
100   ob <- GL.get blend
101   obf <- GL.get blendFunc
102   blend $= Enabled
103   blendFunc $= bf
104   r <- act
105   blendFunc $= obf
106   blend $= ob
107   return r
108
109 data GruffCache = GruffCache
110   { cSize       :: Size
111   , cCenter     :: (Rational, Rational)
112   , cLevel      :: Int
113   , cCacheDir   :: FilePath
114   , cGL         :: GLUTGtk
115   , cProg       :: Program
116   , cTex        :: TextureObject
117   , cTexSize    :: Size
118   , cFBO        :: GLuint
119   , cRecalc     :: Bool
120   , cQTree      :: QTree Integer
121   }
122
123 fromPixel :: GruffCache -> Int -> Int -> (Rational, Rational)
124 fromPixel c x y = (x', y')
125   where
126     Size w h = cSize c
127     a = fromIntegral w / fromIntegral h
128     (cx, cy) = cCenter c
129     r = 8 / 2 ^ cLevel c * fromIntegral h / (2 * fromIntegral tileSize)
130     x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a
131     y' = cy + r * (fromIntegral y / fromIntegral h - 0.5)
132
133 toPixel :: GruffCache -> Rational -> Rational -> (Rational, Rational)
134 toPixel c = f
135   where
136     f x y = {-# SCC "toPixel'" #-} (x', y')
137       where
138         x' = ((x - cx) / r' + 0.5) * w'
139         y' = ((y - cy) / r  + 0.5) * h'
140     Size w h = cSize c
141     w' = fromIntegral w
142     h' = fromIntegral h
143     a = w' / h'
144     (cx, cy) = cCenter c
145     r = 8 / 2 ^ cLevel c * h' / (2 * fromIntegral tileSize)
146     r' = a * r
147
148 tileSize :: Int
149 tileSize = 256
150
151 cRealize :: IORef GruffCache -> IO ()
152 cRealize cR = do
153   f <- getDataFileName "cache.frag"
154   prog <- shader Nothing (Just f)
155   drawBuffer $= BackBuffers
156   glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE
157   glClampColor gl_CLAMP_READ_COLOR gl_FALSE
158   glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE
159   [tex] <- genObjectNames 1
160   texture Texture2D $= Enabled
161   textureBinding Texture2D $= Just tex
162   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
163   textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
164   textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
165   textureBinding Texture2D $= Nothing
166   texture Texture2D $= Disabled
167   fbo <- alloca $ \p -> glGenFramebuffers 1 p >> peek p
168   atomicModifyIORef cR $ \c -> (c{ cProg = prog, cFBO = fbo, cTex = tex }, ())
169   c <- readIORef cR
170   cReshape cR (cSize c)
171
172 cSquareSize :: GruffCache -> Rational
173 cSquareSize c = squareSize rootSquare / 2 ^ cLevel c / (2 * fromIntegral tileSize)
174
175 cInitialize :: GLUTGtk -> Pixbuf -> FilePath
176             -> IO ( Window
177                   , Maybe R -> Maybe R -> Maybe R -> IO ()
178                   , IO () -> IO ()
179                   )
180 cInitialize gl' icon cacheDir' = do
181   -- image window
182   cw <- windowNew
183   let Size defW defH = defSize
184   windowSetDefaultSize cw defW defH
185   set cw
186     [ containerBorderWidth := 0
187     , containerChild := widget gl'
188     , windowIcon  := Just icon
189     , windowTitle := "gruff cache"
190     ]
191   cR <- newIORef GruffCache
192     { cCenter = (0, 0)
193     , cLevel = 0
194     , cSize = defSize
195     , cQTree = QTree 0 Nothing Nothing Nothing Nothing
196     , cCacheDir = cacheDir'
197     , cGL = gl'
198     , cProg = undefined
199     , cFBO = 0
200     , cTex = TextureObject 0
201     , cTexSize = roundUpSize defSize
202     , cRecalc = False
203     }
204   realizeCallback gl' $= cRealize cR
205   reshapeCallback gl' $= cReshape cR
206   displayCallback gl' $= cDisplay cR
207   keyboardMouseCallback gl' $= cMouse cR
208   let cUpdateCoords mre mim mz = do
209         case mz of
210           Just z | z > 0 -> atomicModifyIORef cR $ \s ->
211               ( s { cLevel = max 0 . floor . negate . logBase 2 $ z }, () )
212           _ -> return ()
213         case liftM2 (,) mre mim of
214           Just (r, i) -> atomicModifyIORef cR $ \s ->
215               ( s { cCenter = (toRational' (cLevel s) r, negate $ toRational' (cLevel s) i) }, () )
216           Nothing -> return ()
217         cUpdate cR True
218       cInitializeLate aExit = do
219         _ <- cw `onDestroy` aExit
220         _ <- forkIO $ cRescan cR
221         return ()
222   return (cw, cUpdateCoords, cInitializeLate)
223
224 cRescan :: IORef GruffCache -> IO ()
225 cRescan cR = do
226   c' <- readIORef cR
227   fs <- getFilesRecursive (cCacheDir c' </> ".")
228   let q = depthQ . treeQ .  mapMaybe fromPath $ fs
229   atomicModifyIORef cR $ \c -> (c{ cQTree = q }, ())
230   postGUISync (cUpdate cR True)
231
232 defSize :: Size
233 defSize = Size 320 200
234
235 cUpdate :: IORef GruffCache -> Bool -> IO ()
236 cUpdate cR rec = do
237   c' <- readIORef cR
238   atomicModifyIORef cR $ \c -> (c{ cRecalc = cRecalc c || rec }, ())
239   postRedisplay (cGL c')
240
241 cReshape :: IORef GruffCache -> Size -> IO ()
242 cReshape iR size' = do
243   c <- readIORef iR
244   let tsize@(Size tw th) = roundUpSize size'
245   textureBinding Texture2D $= Just (cTex c)
246   glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)
247     (fromIntegral tw) (fromIntegral th) 0 gl_LUMINANCE gl_FLOAT nullPtr
248   textureBinding Texture2D $= Nothing
249   atomicModifyIORef iR $ \s -> (s{ cSize = size', cTexSize = tsize }, ())
250   cUpdate iR True
251
252 cMouse :: IORef GruffCache -> Key -> KeyState -> [Modifier] -> Position -> IO ()
253 cMouse sR (MouseButton LeftButton  ) Down _ (Position x y) = do
254   atomicModifyIORef sR $ \s -> let level' = (cLevel s + 1) in
255     ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }
256     , ())
257   cUpdate sR True
258 cMouse sR (MouseButton MiddleButton) Down _ (Position x y) = do
259   atomicModifyIORef sR $ \s ->
260     ( s{ cCenter = fromPixel s (round x) (round y) }
261     , ())
262   cUpdate sR True
263 cMouse sR (MouseButton RightButton ) Down _ (Position x y) = do
264   atomicModifyIORef sR $ \s -> let level' = (cLevel s - 1) `max` 0 in
265     ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }
266     , ())
267   cUpdate sR True
268 cMouse _ _ _ _ _ = return ()
269
270 roundUpSize :: Size -> Size
271 roundUpSize (Size w h) = Size (roundUp w) (roundUp h)
272
273 roundUp :: Int -> Int
274 roundUp x = head . filter (>= x) . iterate (2*) $ 1
275
276 data QTree a = QTree a (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a))
277
278 payloadQ :: QTree a -> a
279 payloadQ (QTree w _ _ _ _) = w
280
281 childQ :: Child -> QTree a -> Maybe (QTree a)
282 childQ NorthWest (QTree _ a _ _ _) = a
283 childQ NorthEast (QTree _ _ b _ _) = b
284 childQ SouthWest (QTree _ _ _ c _) = c
285 childQ SouthEast (QTree _ _ _ _ d) = d
286
287 emptyQ :: QTree Bool
288 emptyQ = QTree False Nothing Nothing Nothing Nothing
289
290 insertQ :: [Child] -> QTree Bool -> QTree Bool
291 insertQ [] (QTree _ a b c d) = QTree True a b c d
292 insertQ (x:xs) (QTree w a b c d) = case x of
293   NorthWest -> case a of
294     Nothing -> QTree w (Just $ insertQ xs emptyQ) b c d
295     Just a' -> QTree w (Just $ insertQ xs a'    ) b c d
296   NorthEast -> case b of
297     Nothing -> QTree w a (Just $ insertQ xs emptyQ) c d
298     Just b' -> QTree w a (Just $ insertQ xs b'    ) c d
299   SouthWest -> case c of
300     Nothing -> QTree w a b (Just $ insertQ xs emptyQ) d
301     Just c' -> QTree w a b (Just $ insertQ xs c'    ) d
302   SouthEast -> case d of
303     Nothing -> QTree w a b c (Just $ insertQ xs emptyQ)
304     Just d' -> QTree w a b c (Just $ insertQ xs d'    )
305
306 treeQ :: [[Child]] -> QTree Bool
307 treeQ = foldr insertQ emptyQ
308
309 {-
310 sizeQ :: QTree Bool -> QTree Integer
311 sizeQ (QTree w a b c d) = QTree n a' b' c' d'
312   where
313     s@[a', b', c', d'] = fmap sizeQ `map` [a, b, c, d]
314     n = (if w then 1 else 0) + (sum . map payloadQ . catMaybes) s
315 -}
316
317 depthQ :: QTree a -> QTree Integer
318 depthQ = depthQ' 0
319   where
320     depthQ' n (QTree _ Nothing Nothing Nothing Nothing) = QTree n Nothing Nothing Nothing Nothing
321     depthQ' n (QTree _ a b c d) = QTree m a' b' c' d'
322       where
323         s@[a', b', c', d'] = fmap (depthQ' (n + 1)) `map` [a, b, c, d]
324         m = maximum . map payloadQ . catMaybes $ s
325
326 pruneQ :: Int -> QTree a -> QTree a
327 pruneQ 0 (QTree w _ _ _ _) = QTree w Nothing Nothing Nothing Nothing
328 pruneQ n (QTree w a b c d) = QTree w a' b' c' d'
329   where
330     [a', b', c', d'] = fmap (pruneQ (n - 1)) `map` [a, b, c, d]
331
332 cQuads :: GruffCache -> [(Quad, Integer)]
333 cQuads c = map (fmap payloadQ) . concat . quadsQ view . pruneQ (cLevel c + 12) . cQTree $ c
334   where
335     Size w h = cSize c
336     ((bw,bn),(be,bs)) =
337       ( fromPixel c 0 0
338       , fromPixel c (fromIntegral w) (fromIntegral h) )
339     view = Region
340       { regionWest = bw, regionNorth = bn
341       , regionEast = be, regionSouth = bs }
342
343 quadsQ :: Region -> QTree a -> [[(Quad, QTree a)]]
344 quadsQ view q = takeWhile (not . null) . iterate (filter keep . children') $ [(root, q)]
345   where
346     keep = not . outside view . square rootSquare . fst
347     children' = catMaybes . liftM2 child' [minBound .. maxBound]
348     child' c (quad, qtree) = (,) (child c quad) `fmap` childQ c qtree