gruff-0.1: Browser.hs

module Browser (iInitialize) where

import Prelude hiding (log)
import Control.Concurrent
  ( forkIO, MVar, newMVar, takeMVar, putMVar, tryTakeMVar, threadDelay )
import Control.Monad (forever, forM_, liftM2, replicateM, when)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
import Data.List (sortBy)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (isJust, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as S
import Data.Set (Set, (\\))
import Foreign (Ptr, malloc, poke)
import Foreign.C (CFloat, CInt)
import GHC.Conc (numCapabilities)
import Graphics.Rendering.OpenGL hiding (Angle, Point, Position, Size)
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL.Raw
  ( glTexImage2D, gl_TEXTURE_2D, 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 (get, Region, Size)
import Numeric.QD (QuadDouble)

import GLUTGtk
import Shader (shader)
import QuadTree
import Tile (Tile(Tile), getTile, freeTile, rootSquare)
import Logger (Logger, LogLevel(Debug))
import qualified Logger as Log
import Paths_gruff (getDataFileName)

type TextureObject3 = (TextureObject, TextureObject, TextureObject)
data GruffImage = GruffImage
  { center :: (Rational, Rational)
  , level :: Int
  , size :: Size
  , prog :: Program
  , tiles :: Map Quad TextureObject3
  , queue :: MVar [Tile]
  , progress :: Set Quad
  , jobs :: MVar [Quad]
  , viewQuads :: [(Square, TextureObject3)]
  , workers :: [Ptr CInt]
  , gl :: GLUTGtk
  , cacheDir :: FilePath
  , log :: LogLevel -> String -> IO ()
  , hshift :: Double
  , hscale :: Double
  }

iDisplay :: IORef GruffImage -> IO ()
iDisplay iR = do
  s0 <- readIORef iR
  mtls <- tryTakeMVar (queue s0)
  case mtls of
    Just tls -> do
      putMVar (queue s0) []
      forM_ tls $ \tile@(Tile q ns ds ts) -> do
        tde <- upload ds
        tit <- upload ns
        ttt <- upload ts
--        GL.finish
        freeTile tile
        atomicModifyIORef iR $ \s' ->
          ( s'{ tiles = M.insert q (tde, tit, ttt) (tiles s')
              , progress = S.delete q (progress s') }
          , ())
      update iR False
    Nothing -> return ()
  s <- readIORef iR
  let Size w h = size s
  log s Debug $ "displayCallback " ++ show (center s, level s)
  viewport $=
    (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
  loadIdentity
  ortho2D 0 (fromIntegral w) (fromIntegral h) 0
  clearColor $= Color4 0.5 0.5 0.5 1
  clear [ColorBuffer]
  currentProgram $= Just (prog s)
  lde <- get $ uniformLocation (prog s) "de"
  lit <- get $ uniformLocation (prog s) "it"
  ltt <- get $ uniformLocation (prog s) "tt"
  lhshift <- get $ uniformLocation (prog s) "hshift"
  lhscale <- get $ uniformLocation (prog s) "hscale"
  uniform lde $= TexCoord1 (0 :: GLint)
  uniform lit $= TexCoord1 (1 :: GLint)
  uniform ltt $= TexCoord1 (2 :: GLint)
  uniform lhshift $= TexCoord1 (realToFrac (hshift s) :: GLfloat)
  uniform lhscale $= TexCoord1 (realToFrac (hscale s) :: GLfloat)
  mapM_ (drawQuad s) (viewQuads s)
  currentProgram $= Nothing
-- writeSnapshot (show (level s) ++ ".ppm") (Position 0 0) (size s)

drawQuad :: GruffImage -> (Square, TextureObject3) -> IO ()
drawQuad s (sq, (tde, tit, ttt)) = do
  let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
      v x y = let (x', y') = toPixel s x y
              in  vertex $ Vertex2
                    (fromRational x' :: GLdouble)
                    (fromRational y' :: GLdouble)
      x0 = squareWest sq
      x1 = squareWest sq  + squareSize sq
      y0 = squareNorth sq
      y1 = squareNorth sq + squareSize sq
  activeTexture $= TextureUnit 0
  textureBinding Texture2D $= Just tde
  activeTexture $= TextureUnit 1
  textureBinding Texture2D $= Just tit
  activeTexture $= TextureUnit 2
  textureBinding Texture2D $= Just ttt
  renderPrimitive Quads $ do
    color $ Color3 1 1 (1::GLdouble)
    t 0 1 >> v x0 y1
    t 0 0 >> v x0 y0
    t 1 0 >> v x1 y0
    t 1 1 >> v x1 y1
  textureBinding Texture2D $= Nothing
  activeTexture $= TextureUnit 1
  textureBinding Texture2D $= Nothing
  activeTexture $= TextureUnit 0
  textureBinding Texture2D $= Nothing

iReshape :: IORef GruffImage -> Size -> IO ()
iReshape iR size' = do
  s' <- readIORef iR
  log s' Debug $ "reshapeCallback " ++ show size'
  atomicModifyIORef iR $ \s -> (s{ size = size' }, ())
  update iR True

iMouse :: IORef GruffImage -> IO () -> Key -> KeyState -> [Modifier] -> Position -> IO ()
iMouse sR updateGUI (MouseButton LeftButton  ) Down _ p@(Position x y) = do
  s' <- readIORef sR
  log s' Debug $ "leftMouse " ++ show p
  atomicModifyIORef sR $ \s -> let level' = (level s + 1) `min` maxLevel in
    ( s{ center = fromPixel s (round x) (round y), level = level' }
    , ())
  update sR True >> updateGUI
iMouse sR updateGUI (MouseButton MiddleButton) Down _ p@(Position x y) = do
  s' <- readIORef sR
  log s' Debug $ "middleMouse " ++ show p
  atomicModifyIORef sR $ \s ->
    ( s{ center = fromPixel s (round x) (round y) }
    , ())
  update sR True >> updateGUI
iMouse sR updateGUI (MouseButton RightButton ) Down _ p@(Position x y) = do
  s' <- readIORef sR
  log s' Debug $ "rightMouse " ++ show p
  atomicModifyIORef sR $ \s -> let level' = (level s - 1) `max` 0 in
    ( s{ center = fromPixel s (round x) (round y), level = level' }
    , ())
  update sR True >> updateGUI
iMouse _ _ _ _ _ _ = return ()

fromPixel :: GruffImage -> Int -> Int -> (Rational, Rational)
fromPixel s x y = (x', y')
  where
    Size w h = size s
    a = fromIntegral w / fromIntegral h
    (cx, cy) = center s
    r = 8 / 2 ^ level s * 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 :: GruffImage -> Rational -> Rational -> (Rational, Rational)
toPixel s x y = (x', y')
  where
    Size w h = size s
    a = fromIntegral w / fromIntegral h
    (cx, cy) = center s
    r = 8 / 2 ^ level s * fromIntegral h / (2 * fromIntegral tileSize)
    x' = ((x - cx) / a / r + 0.5) * fromIntegral w
    y' = ((y - cy)     / r + 0.5) * fromIntegral h

tileSize :: Int
tileSize = 256

cacheSizeMin, cacheSizeMax :: Int
cacheSizeMin = 160
cacheSizeMax = 250

prune :: IORef GruffImage -> IO ()
prune sR = do
  s0 <- readIORef sR
  let cacheSize = M.size (tiles s0)
  when (cacheSize > cacheSizeMax) $ do
    log s0 Debug . concat $
      [ "pruning texture cache "
      , show cacheSize, " > ", show cacheSizeMax
      , " --> ", show cacheSizeMin
      ]
    bad <- atomicModifyIORef sR $ \s -> 
      let (cx, cy) = center s
          f = contains (Point cx cy) . square rootSquare
          refine = filter f . liftM2 child [minBound .. maxBound]
          Quad{ quadLevel = l0, quadWest = r0, quadNorth = i0 } =
            head $ iterate refine [root] !! (level s + 1)
          score Quad{ quadLevel = l, quadWest = r, quadNorth = i}
            = dl + d r r0 + d i i0 :: Double
              where
                dl = abs (fromIntegral l - fromIntegral l0)
                d x x0
                  | l >  l0 = abs (xfi - x0fi / 2 ^ (l - l0))
                  | l == l0 = abs (xfi - x0fi)
                  | l <  l0 = abs (x0fi - xfi / 2 ^ (l0 - l))
                  where xfi = fromIntegral x ; x0fi = fromIntegral x0
                d _ _ = error "score"
          o = comparing (score . fst)
          (good, bad)
            = splitAt cacheSizeMin . sortBy o . M.toList . tiles $ s
      in  (s{ tiles = M.fromList good }, bad)
    let t (_, (t1, t2, t3)) = [t1, t2, t3]
    deleteObjectNames $ concatMap t bad

update :: IORef GruffImage -> Bool -> IO ()
update sR newView = do
  prune sR
  s' <- readIORef sR
  log s' Debug $ "updateCallback " ++ show newView
  todo' <- atomicModifyIORef sR $ \s ->
    let Size w h = size s
        ((bw,bn),(be,bs)) =
          ( fromPixel s 0 0
          , fromPixel s (fromIntegral w) (fromIntegral h) )
        view = Region
          { regionWest = bw, regionNorth = bn
          , regionEast = be, regionSouth = bs }
        qs = S.fromList $ quads rootSquare view (level s + 1)
        todo = S.filter (`M.notMember` tiles s) qs \\ progress s
        getQuad q = (,) (square rootSquare q) `fmap` M.lookup q (tiles s)
        drp = level s - 4
        tke = 6 + (drp `min` 0)
        quads' = mapMaybe getQuad . concat . take tke . drop drp $
                   quadss rootSquare view
    in  (s{ viewQuads = quads' }, todo)
  when newView $ do
    -- cancel in-progress jobs
    putJobs sR []
    mapM_ (`poke` 1) (workers s')
    atomicModifyIORef sR $ \s -> (s{ progress = S.empty }, ())
    -- set new jobs
    putJobs sR (S.toList todo')
    postRedisplay (gl s')

putTile :: IORef GruffImage -> Tile -> IO ()
putTile sR t = do
  s <- readIORef sR
  ts <- takeMVar (queue s)
  putMVar (queue s) (t:ts)

putJobs :: IORef GruffImage -> [Quad] -> IO ()
putJobs sR qs = do
  s <- readIORef sR
  _ <- takeMVar (jobs s)
  putMVar (jobs s) qs

takeJob :: IORef GruffImage -> IO Quad
takeJob sR = do
  s <- readIORef sR
  qs <- takeMVar (jobs s)
  case qs of
    [] -> do
      putMVar (jobs s) []
      threadDelay 10000
      takeJob sR
    (q:qs') -> do
      atomicModifyIORef sR $ \s' ->
        ( s'{ progress = S.insert q (progress s') }
        , ())
      putMVar (jobs s) qs'
      return q

worker :: IORef GruffImage -> Ptr CInt -> IO ()
worker sR p = forever $ do
  s <- readIORef sR
  q <- takeJob sR
  mt <- getTile (log s Debug) (cacheDir s) p q
  case mt of
    Nothing -> return ()
    Just t -> putTile sR t

timer :: IORef GruffImage -> IO ()
timer sR = do
  s <- readIORef sR
  mtls <- tryTakeMVar (queue s)
  case mtls of
    Just tls@(_:_) -> do
      putMVar (queue s) tls
      postRedisplay (gl s)
    Just [] -> do
      putMVar (queue s) []
    _ -> return ()

upload :: Ptr CFloat -> IO TextureObject
upload p = do
  [tex] <- genObjectNames 1
  texture Texture2D $= Enabled
  textureBinding Texture2D $= Just tex
  glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_R32F)
    (fromIntegral tileSize) (fromIntegral tileSize) 0
      gl_LUMINANCE gl_FLOAT p
  textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
  textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
  textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
  textureBinding Texture2D $= Nothing
  texture Texture2D $= Disabled
  return tex

defSize :: Size
defSize = Size 320 200

maxLevel :: Int
maxLevel = 191

msPerFrame :: Int
msPerFrame = 40

iInitialize :: GLUTGtk -> Pixbuf -> Logger -> FilePath
            -> IO ( Window
                  , Maybe QuadDouble -> Maybe QuadDouble -> Maybe QuadDouble -> Maybe Double -> Maybe Double -> IO ()
                  , (QuadDouble -> QuadDouble -> QuadDouble -> IO ()) -> IO () -> IO ()
                  )
iInitialize gl' icon lg cacheDir' = do
  -- image window
  iw <- windowNew
  let Size defW defH = defSize
  windowSetDefaultSize iw defW defH
  set iw
    [ containerBorderWidth := 0
    , containerChild := widget gl'
    , windowIcon  := Just icon
    , windowTitle := "gruff browser"
    ]
  queue' <- newMVar []
  jobs' <- newMVar []
  iR <- newIORef GruffImage
    { center = (0, 0)
    , level = 0
    , size = defSize
    , tiles = M.empty
    , queue = queue'
    , jobs = jobs'
    , progress = S.empty
    , viewQuads = []
    , gl = gl'
    , cacheDir = cacheDir'
    , log = Log.log lg
    , workers = []
    , prog = undefined
    , hshift = 0
    , hscale = 1
    }
  realizeCallback gl' $= iRealize iR
  reshapeCallback gl' $= iReshape iR
  displayCallback gl' $= iDisplay iR
  let iUpdate mre mim mz mhshift mhscale = do
        case liftM2 (,) mre mim of
          Just (r, i) -> atomicModifyIORef iR $ \s ->
              ( s { center = (toRational r, negate $ toRational i) }, () )
          Nothing -> return ()
        case mz of
          Just z | z > 0 -> atomicModifyIORef iR $ \s ->
              ( s { level = max 0 . min maxLevel . floor . negate . logBase 2 $ z }, () )
          _ -> return ()
        case mhshift of
          Just x -> atomicModifyIORef iR $ \s ->
              ( s { hshift = x }, () )
          _ -> return ()
        case mhscale of
          Just x -> atomicModifyIORef iR $ \s ->
              ( s { hscale = x }, () )
          _ -> return ()
        update iR (any isJust [mre, mim, mz])
        postRedisplay gl'
      iInitializeLate aUpdate aExit = do
        let updateCoordinates = do
              i <- readIORef iR
              let re = fromRational .          fst . center $ i
                  im = fromRational . negate . snd . center $ i
                  z  = 2 ^^ negate (level i)
              aUpdate re im z
        _ <- iw `onDestroy` aExit
        _ <- timeoutAdd (timer iR >> return True) msPerFrame
        keyboardMouseCallback gl' $= iMouse iR updateCoordinates
  return (iw, iUpdate, iInitializeLate)

iRealize :: IORef GruffImage -> IO ()
iRealize iR = do
  s <- readIORef iR
  log s Debug "realizeCallback"
  drawBuffer $= BackBuffers
  glClampColor gl_CLAMP_VERTEX_COLOR gl_FALSE
  glClampColor gl_CLAMP_READ_COLOR gl_FALSE
  glClampColor gl_CLAMP_FRAGMENT_COLOR gl_FALSE
  f <- getDataFileName "colourize.frag"
  prog' <- shader Nothing (Just f)
  ps <- replicateM numCapabilities $ do
    p <- malloc
    _ <- forkIO (worker iR p)
    return p
  atomicModifyIORef iR $ \i -> (i{ prog = prog', workers = ps }, ())