gruff-0.1: CacheView.hs

module CacheView (cInitialize) where

import Control.Concurrent (forkIO)
import Control.Monad (forM_, liftM2, when)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (catMaybes, mapMaybe)
import System.FilePath ((</>), dropExtension)

import Foreign (alloca, peek, nullPtr)
import Graphics.Rendering.OpenGL hiding (Position, Size)
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL.Raw
  ( glGenFramebuffers, glBindFramebuffer, glFramebufferTexture2D
  , gl_FRAMEBUFFER, gl_COLOR_ATTACHMENT0, gl_TEXTURE_2D
  , glTexImage2D, gl_R32F, gl_LUMINANCE, gl_FLOAT
  , gl_FALSE, glClampColor, gl_CLAMP_VERTEX_COLOR, gl_CLAMP_READ_COLOR
  , gl_CLAMP_FRAGMENT_COLOR )
import Graphics.UI.Gtk hiding (Region, Size)

import Numeric.QD (QuadDouble)

import GLUTGtk
import Shader (shader)
import QuadTree (Child(..), unsafeName, Quad, Square(..), square, child, root, outside, Region(..))
--import Tile (rootSquare)
import Utils (getFilesRecursive)

import Paths_gruff (getDataFileName)

rootSquare :: Square
rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }

names :: Map Char [Child]
names = M.fromList names1 `M.union` M.fromList names2
  where
    names1 = [ (unsafeName [i], [i]) | i <- [minBound..maxBound] ]
    names2 = [ (unsafeName [i,j], [i,j]) | i <- [minBound..maxBound], j <- [minBound..maxBound] ]

fromPath :: ([FilePath], FilePath) -> Maybe [Child]
fromPath (ps, f) =
  let s = concat ps ++ dropExtension f
      p = concat $ mapMaybe (`M.lookup` names) s
  in  if all (`M.member` names) s then Just p else Nothing

cDisplay :: IORef GruffCache -> IO ()
cDisplay cR = do
  c <- readIORef cR
  let Size w h = cSize c
      TextureObject tex = cTex c
  when (cRecalc c) $ do
    viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
    loadIdentity
    ortho2D 0 (fromIntegral w) (fromIntegral h) 0
    withFBO (cFBO c) tex $ do
      clearColor $= Color4 0 0 0 1
      clear [ColorBuffer]
      let toPixel' = toPixel c
          qs = cQuads c
          zm = fromIntegral . snd . head $ qs
      withBlend (One, One) $ renderPrimitive Quads $ forM_ qs $ \(q, z) -> do
        let sq = square rootSquare q
            s = squareSize sq `max` cSquareSize c
            (x0, y0) = toPixel' (squareWest sq) (squareNorth sq)
            (x1, y1) = toPixel' (squareWest sq + s) (squareNorth sq + s)
            v x y = vertex $ Vertex2 (fromRational x :: GLdouble) (fromRational y :: GLdouble)
            k = fromIntegral z / zm :: GLdouble
        color $ Color3 k k k
        v x0 y1 >> v x0 y0 >> v x1 y0 >> v x1 y1
    atomicModifyIORef cR $ \c' -> (c'{ cRecalc = False }, ())
  -- draw texture
  loadIdentity
  ortho2D 0 1 1 0
  textureBinding Texture2D $= Just (cTex c)
  currentProgram $= Just (cProg c)
  lt <- GL.get $ uniformLocation (cProg c) "tex"
  uniform lt $= TexCoord1 (0 :: GLint)
  renderPrimitive Quads $ do
    let Size tw th = cTexSize c
    let tx = fromIntegral w / fromIntegral tw
        ty = fromIntegral h / fromIntegral th
        v :: GLdouble -> GLdouble -> IO ()
        v x y = do
          texCoord $ TexCoord2 (tx * x) (ty * (1-y))
          vertex $ Vertex2 x y
    v 0 1 >> v 0 0 >> v 1 0 >> v 1 1
  currentProgram $= Nothing
  textureBinding Texture2D $= Nothing

withFBO :: GLuint -> GLuint -> IO () -> IO ()
withFBO fbo tex act = do
  glBindFramebuffer gl_FRAMEBUFFER fbo
  glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D tex 0
  act
  glFramebufferTexture2D gl_FRAMEBUFFER gl_COLOR_ATTACHMENT0 gl_TEXTURE_2D 0 0
  glBindFramebuffer gl_FRAMEBUFFER 0

withBlend :: (BlendingFactor, BlendingFactor) -> IO a -> IO a
withBlend bf act = do
  ob <- GL.get blend
  obf <- GL.get blendFunc
  blend $= Enabled
  blendFunc $= bf
  r <- act
  blendFunc $= obf
  blend $= ob
  return r

data GruffCache = GruffCache
  { cSize       :: Size
  , cCenter     :: (Rational, Rational)
  , cLevel      :: Int
  , cCacheDir   :: FilePath
  , cGL         :: GLUTGtk
  , cProg       :: Program
  , cTex        :: TextureObject
  , cTexSize    :: Size
  , cFBO        :: GLuint
  , cRecalc     :: Bool
  , cQTree      :: QTree Integer
  }

fromPixel :: GruffCache -> Int -> Int -> (Rational, Rational)
fromPixel c x y = (x', y')
  where
    Size w h = cSize c
    a = fromIntegral w / fromIntegral h
    (cx, cy) = cCenter c
    r = 8 / 2 ^ cLevel c * fromIntegral h / (2 * fromIntegral tileSize)
    x' = cx + r * (fromIntegral x / fromIntegral w - 0.5) * a
    y' = cy + r * (fromIntegral y / fromIntegral h - 0.5)

toPixel :: GruffCache -> Rational -> Rational -> (Rational, Rational)
toPixel c = f
  where
    f x y = {-# SCC "toPixel'" #-} (x', y')
      where
        x' = ((x - cx) / r' + 0.5) * w'
        y' = ((y - cy) / r  + 0.5) * h'
    Size w h = cSize c
    w' = fromIntegral w
    h' = fromIntegral h
    a = w' / h'
    (cx, cy) = cCenter c
    r = 8 / 2 ^ cLevel c * h' / (2 * fromIntegral tileSize)
    r' = a * r

tileSize :: Int
tileSize = 256

cRealize :: IORef GruffCache -> IO ()
cRealize cR = do
  f <- getDataFileName "cache.frag"
  prog <- shader Nothing (Just f)
  drawBuffer $= BackBuffers
  glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE
  glClampColor gl_CLAMP_READ_COLOR gl_FALSE
  glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE
  [tex] <- genObjectNames 1
  texture Texture2D $= Enabled
  textureBinding Texture2D $= Just tex
  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
  textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
  textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
  textureBinding Texture2D $= Nothing
  texture Texture2D $= Disabled
  fbo <- alloca $ \p -> glGenFramebuffers 1 p >> peek p
  atomicModifyIORef cR $ \c -> (c{ cProg = prog, cFBO = fbo, cTex = tex }, ())
  c <- readIORef cR
  cReshape cR (cSize c)

cSquareSize :: GruffCache -> Rational
cSquareSize c = squareSize rootSquare / 2 ^ cLevel c / (2 * fromIntegral tileSize)

cInitialize :: GLUTGtk -> Pixbuf -> FilePath
            -> IO ( Window
                  , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> IO ()
                  , IO () -> IO ()
                  )
cInitialize gl' icon cacheDir' = do
  -- image window
  cw <- windowNew
  let Size defW defH = defSize
  windowSetDefaultSize cw defW defH
  set cw
    [ containerBorderWidth := 0
    , containerChild := widget gl'
    , windowIcon  := Just icon
    , windowTitle := "gruff cache"
    ]
  cR <- newIORef GruffCache
    { cCenter = (0, 0)
    , cLevel = 0
    , cSize = defSize
    , cQTree = QTree 0 Nothing Nothing Nothing Nothing
    , cCacheDir = cacheDir'
    , cGL = gl'
    , cProg = undefined
    , cFBO = 0
    , cTex = TextureObject 0
    , cTexSize = roundUpSize defSize
    , cRecalc = False
    }
  realizeCallback gl' $= cRealize cR
  reshapeCallback gl' $= cReshape cR
  displayCallback gl' $= cDisplay cR
  keyboardMouseCallback gl' $= cMouse cR
  let cUpdateCoords mre mim mz = do
        case liftM2 (,) mre mim of
          Just (r, i) -> atomicModifyIORef cR $ \s ->
              ( s { cCenter = (toRational r, negate $ toRational i) }, () )
          Nothing -> return ()
        case mz of
          Just z | z > 0 -> atomicModifyIORef cR $ \s ->
              ( s { cLevel = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () )
          _ -> return ()
        cUpdate cR True
      cInitializeLate aExit = do
        _ <- cw `onDestroy` aExit
        _ <- forkIO $ cRescan cR
        return ()
  return (cw, cUpdateCoords, cInitializeLate)

cRescan :: IORef GruffCache -> IO ()
cRescan cR = do
  c' <- readIORef cR
  fs <- getFilesRecursive (cCacheDir c' </> ".")
  let q = depthQ . treeQ .  mapMaybe fromPath $ fs
  atomicModifyIORef cR $ \c -> (c{ cQTree = q }, ())
  postGUISync (cUpdate cR True)

maxLevel :: Int
maxLevel = 200
defSize :: Size
defSize = Size 320 200

cUpdate :: IORef GruffCache -> Bool -> IO ()
cUpdate cR rec = do
  c' <- readIORef cR
  atomicModifyIORef cR $ \c -> (c{ cRecalc = cRecalc c || rec }, ())
  postRedisplay (cGL c')

cReshape :: IORef GruffCache -> Size -> IO ()
cReshape iR size' = do
  c <- readIORef iR
  let tsize@(Size tw th) = roundUpSize size'
  textureBinding Texture2D $= Just (cTex c)
  glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)
    (fromIntegral tw) (fromIntegral th) 0 gl_LUMINANCE gl_FLOAT nullPtr
  textureBinding Texture2D $= Nothing
  atomicModifyIORef iR $ \s -> (s{ cSize = size', cTexSize = tsize }, ())
  cUpdate iR True

cMouse :: IORef GruffCache -> Key -> KeyState -> [Modifier] -> Position -> IO ()
cMouse sR (MouseButton LeftButton  ) Down _ (Position x y) = do
  atomicModifyIORef sR $ \s -> let level' = (cLevel s + 1) `min` maxLevel in
    ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }
    , ())
  cUpdate sR True
cMouse sR (MouseButton MiddleButton) Down _ (Position x y) = do
  atomicModifyIORef sR $ \s ->
    ( s{ cCenter = fromPixel s (round x) (round y) }
    , ())
  cUpdate sR True
cMouse sR (MouseButton RightButton ) Down _ (Position x y) = do
  atomicModifyIORef sR $ \s -> let level' = (cLevel s - 1) `max` 0 in
    ( s{ cCenter = fromPixel s (round x) (round y), cLevel = level' }
    , ())
  cUpdate sR True
cMouse _ _ _ _ _ = return ()

roundUpSize :: Size -> Size
roundUpSize (Size w h) = Size (roundUp w) (roundUp h)

roundUp :: Int -> Int
roundUp x = head . filter (>= x) . iterate (2*) $ 1

data QTree a = QTree a (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a)) (Maybe (QTree a))

payloadQ :: QTree a -> a
payloadQ (QTree w _ _ _ _) = w

childQ :: Child -> QTree a -> Maybe (QTree a)
childQ NorthWest (QTree _ a _ _ _) = a
childQ NorthEast (QTree _ _ b _ _) = b
childQ SouthWest (QTree _ _ _ c _) = c
childQ SouthEast (QTree _ _ _ _ d) = d

emptyQ :: QTree Bool
emptyQ = QTree False Nothing Nothing Nothing Nothing

insertQ :: [Child] -> QTree Bool -> QTree Bool
insertQ [] (QTree _ a b c d) = QTree True a b c d
insertQ (x:xs) (QTree w a b c d) = case x of
  NorthWest -> case a of
    Nothing -> QTree w (Just $ insertQ xs emptyQ) b c d
    Just a' -> QTree w (Just $ insertQ xs a'    ) b c d
  NorthEast -> case b of
    Nothing -> QTree w a (Just $ insertQ xs emptyQ) c d
    Just b' -> QTree w a (Just $ insertQ xs b'    ) c d
  SouthWest -> case c of
    Nothing -> QTree w a b (Just $ insertQ xs emptyQ) d
    Just c' -> QTree w a b (Just $ insertQ xs c'    ) d
  SouthEast -> case d of
    Nothing -> QTree w a b c (Just $ insertQ xs emptyQ)
    Just d' -> QTree w a b c (Just $ insertQ xs d'    )

treeQ :: [[Child]] -> QTree Bool
treeQ = foldr insertQ emptyQ

{-
sizeQ :: QTree Bool -> QTree Integer
sizeQ (QTree w a b c d) = QTree n a' b' c' d'
  where
    s@[a', b', c', d'] = fmap sizeQ `map` [a, b, c, d]
    n = (if w then 1 else 0) + (sum . map payloadQ . catMaybes) s
-}

depthQ :: QTree a -> QTree Integer
depthQ = depthQ' 0
  where
    depthQ' n (QTree _ Nothing Nothing Nothing Nothing) = QTree n Nothing Nothing Nothing Nothing
    depthQ' n (QTree _ a b c d) = QTree m a' b' c' d'
      where
        s@[a', b', c', d'] = fmap (depthQ' (n + 1)) `map` [a, b, c, d]
        m = maximum . map payloadQ . catMaybes $ s

pruneQ :: Int -> QTree a -> QTree a
pruneQ 0 (QTree w _ _ _ _) = QTree w Nothing Nothing Nothing Nothing
pruneQ n (QTree w a b c d) = QTree w a' b' c' d'
  where
    [a', b', c', d'] = fmap (pruneQ (n - 1)) `map` [a, b, c, d]

cQuads :: GruffCache -> [(Quad, Integer)]
cQuads c = map (fmap payloadQ) . concat . quadsQ view . pruneQ (cLevel c + 12) . cQTree $ c
  where
    Size w h = cSize c
    ((bw,bn),(be,bs)) =
      ( fromPixel c 0 0
      , fromPixel c (fromIntegral w) (fromIntegral h) )
    view = Region
      { regionWest = bw, regionNorth = bn
      , regionEast = be, regionSouth = bs }

quadsQ :: Region -> QTree a -> [[(Quad, QTree a)]]
quadsQ view q = takeWhile (not . null) . iterate (filter keep . children') $ [(root, q)]
  where
    keep = not . outside view . square rootSquare . fst
    children' = catMaybes . liftM2 child' [minBound .. maxBound]
    child' c (quad, qtree) = (,) (child c quad) `fmap` childQ c qtree