gruff-0.3: src/Interact.hs

module Interact
  ( mouseCallbacks
  , MouseCallbacks
  , MouseCallback
  , Click
  , But(..)
  , Mod(..)
  ) where

import Data.Map (Map, fromList)

import Fractal.RUFF.Mandelbrot.Address
import Fractal.RUFF.Mandelbrot.Atom
import Fractal.RUFF.Types.Complex

import Fractal.GRUFF

import Progress

type MouseCallbacks = Map Click MouseCallback

type Click = (But, Mod)

data But = L | M | R      deriving (Eq, Ord, Show)
data Mod = U | S | C | SC deriving (Eq, Ord, Show)

type MouseCallback = Complex Rational -> Image -> IO ()

type MouseHandler = Progress -> Complex Rational -> Image -> Cont Image

mouseCallbacks :: IO Colour -> Progress -> (Maybe Image -> IO ()) -> MouseCallbacks
mouseCallbacks gc p next = fromList
  [ ( (L, U), w $ mouseZoom 0.9   )
  , ( (R, U), w $ mouseZoom 1.1   )
  , ( (M, U), w $ mouseCenter     )
  , ( (L, S), w $ mouseZoom 0.1   )
  , ( (R, S), w $ mouseZoom 10    )
  , ( (M, S), w $ mouseLocateGo   )
  , ( (L, C), w $ mousePeriod  gc )
  , ( (R, C), w $ mouseAddress gc )
  ]
  where w cb c i = cb p c i next

mouseCenter :: MouseHandler
mouseCenter _ c i next = do
  next . Just $ i{ imageLocation = (imageLocation i){ center = c } }

mouseZoom :: Double -> MouseHandler
mouseZoom f _ c i next = do
  let o = center (imageLocation i)
      r = radius (imageLocation i)
      f' = toRational f :+ 0
      r' = f * r
      o' = f' * o + (1 - f') * c
  next . Just $ i{ imageLocation = (imageLocation i){ center = o', radius = r' } }

mouseLocateGo :: MouseHandler
mouseLocateGo p c i next = do
  let r0 = radius (imageLocation i) / 32
  progressLocate p c r0 $ \mmu -> case mmu of
    Nothing -> next Nothing
    Just mu -> do
      let n = muNucleus mu
          r = muSize    mu * 16
          a = muOrient  mu - pi/2
      next . Just $ i{ imageLocation = (imageLocation i){ center = n, radius = r }, imageViewport = (imageViewport i){ orient = a } }

mousePeriod :: IO Colour -> MouseHandler
mousePeriod gv p c i next = do
  let r = radius (imageLocation i) / 32
  progressLocate p c r $ \mmu -> case mmu of
    Nothing -> next Nothing
    Just mu -> do
      let n = muNucleus mu
          t = show (muPeriod mu)
      v <- gv
      next . Just $ labelAppend n v t i

mouseAddress :: IO Colour -> MouseHandler
mouseAddress gv p c i next = do
  let r = radius (imageLocation i) / 32
  progressLocate p c r $ \mmu -> case mmu of
    Nothing -> next Nothing
    Just mu -> do
      progressAddress p mu $ \mad -> case mad of
        Nothing -> next Nothing
        Just ad -> do
          let n = muNucleus mu
              t = prettyAngledInternalAddress ad
          v <- gv
          next . Just $ labelAppend n v t i