mandulia-0.4: src/TextureCache.hs

{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module TextureCache (TextureCache(), textureCache, lookupTexture, notCached, cacheTextures) where

import Prelude hiding (lookup)
import Control.Monad (forM, forM_)
import Data.Map (Map, empty, lookup, fromList, union, difference, notMember)
import Data.Either (partitionEithers)

import Graphics.UI.GLUT (TextureObject(), deleteObjectNames)

import Julia
import PriorityCache

type Cachee = Either (Julia, TextureObject) (Julia, (IO TextureObject, IO()))

data TextureCache =
  TextureCache
    { tcCache :: PriorityCache Cachee
    , tcMap   :: Map Julia TextureObject
    }

textureCache :: Int -> TextureCache
textureCache size = TextureCache{ tcCache = priorityCache size, tcMap = empty }

lookupTexture :: TextureCache -> Julia -> Maybe TextureObject
lookupTexture tc j = j `lookup` tcMap tc

notCached :: TextureCache -> Julia -> Bool
notCached tc j = j `notMember` tcMap tc

cacheTextures :: (Julia -> Double) -> TextureCache -> [Cachee] -> IO TextureCache
cacheTextures jscore tc news = do
  (pc,   olds ) <- cache (either (jscore . fst) (jscore . fst)) news (tcCache tc)
  let (texs, toups) = partitionEithers (cContents pc)
      (dels, noups) = partitionEithers olds
  deleteObjectNames (map snd dels)
  forM_ noups $ \(_j, (_up, no)) -> no
  upped <- forM toups $ \(j, (up, _no)) -> do
    t <- up
    return (j, t)
  return tc
    { tcCache = pc{ cContents = map Left (upped ++ texs) }
    , tcMap = (tcMap tc `difference` fromList dels) `union` fromList upped
    }