{-
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 AmmannA3 (AmmannA3(), ammannA3, Tile(..), Tile'(..), tiles, zoom, zoomTo, stepIn) where

import Data.Maybe (fromMaybe)
import Data.Tree

import Bounds
import Utils
import Vector

data Tile = A | B | C
  deriving (Show, Read, Eq, Ord, Enum, Bounded)

bounds0 :: Tile -> Bounds
bounds0 x = bounds0' !! fromEnum x

bounds0' :: [Bounds]
bounds0' = [ sbound 1 phi' -- A
           , sbound 2 1    -- B
           , sbound 1 1    -- C
           ]

sbound :: R -> R -> Bounds
sbound w h =
  bounds [ V x y 1 | x <- [negate w, w], y <- [negate h, h] ]

transforms :: [( Tile, [( Tile, (M, Integer) )] )]
transforms =
  [ (A, [ (B, (t ( 0) (p * n/2 - f/2)                 0                             , 1))
        , (A, (t (-1) (f/2 - p * e/2)                 0                             , 2)) ])
  , (B, [ (A, (t ( 1) (p * e/2               - n/2)   (p * f/2 - k/2 - m/2)         , 3))
        , (C, (t ( 2) (p * (a + x/2 + v/2)   - n/2)   (p * (s/2 + u/2) - k/2 - m/2) , 4))
        , (A, (t (-1) (p * (a + v - c + e/2) - n/2)   (k/2 + m/2         - p * f/2) , 5))
        , (A, (t ( 0) (n/2               - p * f/2)   (p * e/2         - k/2 - m/2) , 6)) ])
  , (C, [ (C, (t ( 2) (p * (x/2 + v/2) - x/2 - v/2)   (p * (s/2 + u/2) - s/2 - u/2) , 7))
        , (A, (t (-1) (p * (v - c + e/2) - x/2 - v/2) (s/2 + u/2 - p * f/2)         , 8))
        , (A, (t ( 0) (x/2 + v/2 - p * f/2)           (p * e/2        - s/2 - u/2)  , 9)) ])
  ]
  where
    t da dx dy = translate (dx*2) (dy*2) ^^*^^ rotate (da * pi / 2) ^^*^^ scale p p
    p = phi'
    a = p * p
    c = p * p * p
    e = p
    f = 1
    k = p
    m = p * p
    n = (1 - p * p * p) / p
    s = p
    u = p * p
    v = p * p * p + p
    x = p * p * p * p

centerC :: V
centerC =
  let Just ts    = lookup C transforms
      Just (t,_) = lookup C ts
      ps = iterate (t ^^*^) (V 0 0 1)
  in  ps !! 256

inRadiusC :: R
inRadiusC =
  let cornerC = V (1/2 - phi') (1/2 - phi' * phi') 1
  in  cornerC ^|-|^ centerC

data Tile'' =
  Tile''
    { ttTile      :: !Tile
    , ttId        :: !Integer
    , ttTransform :: !M
    }

builder :: Tile'' -> (Tile'', [Tile''])
builder tm = tm `seq` (tm, map mkTile (mine transforms))
  where
    mine = concatMap snd . filter ((==) (ttTile tm) . fst)
    mkTile (x, (mm, j)) =
      Tile''
        { ttTile = x
        , ttId = 10 * ttId tm + j
        , ttTransform = ttTransform tm ^^*^^ mm
        }

data Tile' =
  Tile'
    { tTile   :: !Tile
    , tBounds :: !Bounds
    , tCenter :: !V
    , tDepth  :: !Int
    , tLevel  :: !Int
    , tId     :: !Integer
    }

tree :: R -> Tree Tile'
tree maxRadius =
  let s = maxRadius / inRadiusC
      V x y _ = centerC
      tr = scale s s ^^*^^ translate (-x) (-y)
      t0 = Tile''{ ttTile = C, ttId = 7, ttTransform = tr }
  in toTiles (Just (V 0 0 1)) C 0 (tree' t0)

tree' :: Tile'' -> Tree Tile''
tree' t = unfoldTree builder t

tB :: M -> Tile -> Bounds
tB m t = m `transform'` bounds0 t

toTiles :: Maybe V -> Tile -> Int -> Tree Tile'' -> Tree Tile'
toTiles v0 t0 level tr =
  let Tile''{ ttTile = t, ttId = n, ttTransform = m } = rootLabel tr
      ts  = subForest tr
      v1 = fromMaybe (centerPoint m) v0
      v2 = if t0 == C && t == C then v0 else Nothing
      b1 = tB m t
      nn = normalizeId n
      tile =
        Tile'
          { tTile = t
          , tBounds = b1
          , tCenter = v1
          , tDepth  = idToLevel' nn
          , tLevel  = level
          , tId = nn
          }
      level' = level + 1
      forest = level' `seq` map (toTiles v2 t level') ts
  in tile `seq` Node{ rootLabel = tile, subForest = forest }

centerPoint :: M -> V
centerPoint = (^^*^ centerC)

data LevelA3 =
  LevelA3
    { lInnerTiles :: Forest Tile'
    , lOuterTiles :: Forest Tile'
    , lBounds     :: Bounds
    }

data AmmannA3 =
  AmmannA3
    { aOuter  :: [LevelA3]
    , aFocus  ::  LevelA3
    , aBounds :: Bounds
    , aRadius :: R
    }

ammannA3 :: Bounds -> AmmannA3
ammannA3 box =
  let r = diagonal box / 2
      (is, os, _) = triPart box [tree r]
      l = LevelA3{ lInnerTiles = is, lOuterTiles = os, lBounds = box }
  in  AmmannA3{ aOuter = [l], aFocus = l, aBounds = box, aRadius = r }

triPart :: Bounds -> [Tree Tile'] -> ([Tree Tile'], [Tree Tile'], [Tree Tile'])
triPart box = foldr go ([],[],[])
  where
    go t (is, es, os)
      | b `insideOrEqual` box = (t:is, es, os)
      | b `outside`       box = (is, es, t:os)
      | otherwise             = (is, t:es, os)
      where b = tBounds . rootLabel $ t

zoomTo :: Bounds -> AmmannA3 -> Maybe AmmannA3
zoomTo box a3
  | box `insideOrEqual` region =
    (if factor >= phi'
      then Just
      else zoomTo box . (\a -> a{ aRadius = phi' * aRadius a }) . stepIn) $
        let focus = aFocus a3
            ots   = prune box (lOuterTiles focus)
            (its, ots', _) = triPart box (lInnerTiles focus)
        in  a3{ aFocus = focus{ lOuterTiles = ots' ++ ots
                              , lInnerTiles = its
                              , lBounds = box
                              } }
  | otherwise = zoomTo box =<< stepOut a3{ aRadius = phi  * aRadius a3 }
  where
    factor = radius / aRadius a3
    radius = diagonal box / 2
    region = lBounds . aFocus $ a3

zoom :: R -> AmmannA3 -> Maybe AmmannA3
zoom factor a3 = flip zoomTo a3 . expand factor . lBounds . aFocus $ a3

prune :: Bounds -> Forest Tile' -> Forest Tile'
prune box = filter (not . outside box . tBounds . rootLabel)

stepOut :: AmmannA3 -> Maybe AmmannA3
stepOut a3 =
  case aOuter a3 of
    []     -> Nothing
    os@[l] -> Just a3{ aOuter = os, aFocus = l, aRadius = aRadius a3 * phi' }
    (l:os) -> Just a3{ aOuter = os, aFocus = l }

stepIn  :: AmmannA3 -> AmmannA3
stepIn  a3 =
  let l0  =    aFocus a3
      os  = l0:aOuter a3
      box = lBounds l0
      its =                          concatMap subForest . lInnerTiles $ l0
      (its', ots, _) = triPart box . concatMap subForest . lOuterTiles $ l0
      l   = l0{ lInnerTiles = its' ++ its, lOuterTiles = ots }
  in a3{ aOuter = os, aFocus = l }

tiles :: Int -> AmmannA3 -> [Tile']
tiles lod = map rootLabel . (\l -> lOuterTiles l ++ lInnerTiles l) . aFocus . (!!lod) . iterate stepIn

normalizeId :: Integer -> Integer -- C=>C is transform 7
normalizeId n = let (d, m) = n `divMod` 10 in if m == 7 then normalizeId d else n

idToLevel' :: Integer -> Int -- n must be normalized
idToLevel' n = snd . head . dropWhile ((<n) . fst) $ tens

tens :: [(Integer, Int)]
tens = iterate (10*) 1 `zip` [0..]