gruff-0.3: src/View.hs

module View
  ( Location(..), zoom, translate, defLocation
  , Viewport(..), rotate, defViewport
  , Window(..), windowSize, defWindow
  , Colours(..), defColours, Colour(..)
  , Label(..), Line(..)
  , Image(..), defImage
  , BufferSize(..), bufferSize
  , pixelLocation, delta, tileSize, locationPixel
  , visibleQuads, originQuad
  ) where

import Control.Monad (guard)
import Data.Bits (bit)
import Data.Ratio ((%))

import Fractal.RUFF.Types.Complex (Complex((:+)))

import Fractal.GRUFF

import QuadTree (Quad(..), Child(..), child)

pixelLocation :: Window -> Viewport -> Location -> Double -> Double -> Complex Rational
pixelLocation w v l = let f = fromScreenCoords w v l in \x y -> f (x :+ y)

locationPixel :: Window -> Viewport -> Location -> Complex Rational -> (Double, Double)
locationPixel w v l = let f = toScreenCoords w v l in \c -> let (x :+ y) = f c in (x, y)

zoom :: Double -> Location -> Location
zoom f l = l{ radius = radius l * f}

translate :: Complex Rational -> Location -> Location
translate u l = l{ center = center l + u }

rotate :: Double -> Viewport -> Viewport
rotate a v = v{ orient = orient v + a }

windowSize :: Window -> Int
windowSize w = ceiling . sqrt . (fromIntegral :: Int -> Double) . diagonal2 $ w

diagonal2 :: Window -> Int
diagonal2 w = width w * width w + height w * height w

data BufferSize = BufferSize
  { texels :: !Int -- power of two
  }
  deriving (Read, Show, Eq)

bufferSize :: Int -> Window -> BufferSize
bufferSize o w = BufferSize{ texels = roundUp2 . ceiling . ((2::Double) ^^ o *) . sqrt . fromIntegral . diagonal2 $ w }

roundUp2 :: Int -> Int -- fails for too small and too large inputs
roundUp2 x = head . dropWhile (x >=) . iterate (2 *) $ 1

level :: Location -> Int
level = floor . negate . logBase 2 . radius

radius' :: Location -> Double
radius' l = 0.5 ** fromIntegral (level l)

delta :: Location -> Double -- in [0,1)
delta l = logBase 2 $ radius' l / radius l

tileSize :: Int
tileSize = 256

tileLevel :: Location -> BufferSize -> Int
tileLevel l b = level l + (floor . logBase (2 :: Double) . fromIntegral) (texels b `div` tileSize)

tileOrigin :: Complex Rational
tileOrigin = negate $ 4 :+ 4

tileOriginRadius :: Complex Rational
tileOriginRadius = 8

bufferOrigin :: Location -> Quad -> Maybe (Complex Int)
bufferOrigin l Quad{ quadLevel = ql, quadWest = qw, quadNorth = qn } = do
  guard $ ql >= 0
  let qd = bit ql
      qc = (qw % qd) :+ (qn % qd)
      tx :+ ty = fromIntegral tileSize * fromIntegral qd * (qc - (center l - tileOrigin) / tileOriginRadius)
  return (floor tx :+ floor ty)

originQuad :: Location -> BufferSize -> Maybe Quad
originQuad l b =
  let cx :+ cy = center l
      ql = tileLevel l b
      qs = bit ql % 1
      qw = floor $ (cx + 4) / 8 * qs
      qn = floor $ (cy + 4) / 8 * qs
  in  if ql <= 0 then Nothing else Just Quad{ quadLevel = ql, quadWest = qw, quadNorth = qn }

bufferQuads :: Location -> BufferSize -> Maybe [(Complex Int, Quad)]
bufferQuads l b = do
  q0 <- originQuad l b
  i0 :+ j0 <- bufferOrigin l q0
  let m = texels b
      u = fromIntegral $ (m `div` 2) `div` tileSize
      v = fromIntegral $ (m `div` 2) `div` tileSize
  return
    [ (i :+ j, q0{ quadWest = w, quadNorth = n })
    | (i, w) <- takeWhile ((< m) . fst) $ [ i0, i0 + tileSize .. ] `zip` [ quadWest  q0 - u .. ]
    , (j, n) <- takeWhile ((< m) . fst) $ [ j0, j0 + tileSize .. ] `zip` [ quadNorth q0 - v .. ]
    ]

childQuads :: (Complex Int, Quad) -> [(Complex Int, Quad)]
childQuads (i :+ j, q) =
  let i0 = 2 * i
      j0 = 2 * j
      i1 = i0 + tileSize
      j1 = j0 + tileSize
  in  [ (i0 :+ j0, NorthWest `child` q)
      , (i0 :+ j1, SouthWest `child` q)
      , (i1 :+ j0, NorthEast `child` q)
      , (i1 :+ j1, SouthEast `child` q)
      ]

visibleQuads :: Window -> Viewport -> Location -> Int -> Maybe ([(Complex Int, Quad)], [(Complex Int, Quad)])
visibleQuads w v l o = do
  let b = bufferSize o w
      a = orient v
      co = cos a
      si = sin a
      k = 0.5 ** (delta l - fromIntegral o)
      x1 = k * fromIntegral (width  w)
      y1 = k * fromIntegral (height w)
      x0 = - x1
      y0 = - y1
      visible t (i :+ j, _) =
        let d = if t then texels b else texels b `div` 2
        in  not . and $
              [ x < x0 || y < y0 || x1 < x || y1 < y
              | di <- [0, 1], let i' = fromIntegral (i - d + di * tileSize)
              , dj <- [0, 1], let j' = fromIntegral (j - d + dj * tileSize)
              , let x =  co * i' + si * j', let y = -si * i' + co * j'
              ]
  qs0 <- bufferQuads l b
  let qs1 = concatMap childQuads qs0
  return ( filter (visible False) qs0 , filter (visible True) qs1 )

defImage :: Image
defImage = Image
  { imageWindow = defWindow
  , imageViewport = defViewport
  , imageLocation = defLocation
  , imageColours = defColours
  , imageLabels = []
  , imageLines = []
  }

defColours :: Colours
defColours = Colours
  { colourInterior = Colour 1 0 0
  , colourBoundary = Colour 0 0 0
  , colourExterior = Colour 1 1 1
  }

defLocation :: Location
defLocation = Location{ center = 0, radius = 2 }

defWindow :: Window
defWindow = Window{ width = 512, height = 288, supersamples = 1 }

defViewport :: Viewport
defViewport = Viewport{ aspect = 16/9, orient = 0 }