{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
module World where
import Config
import Julia
import Palette
import Graphics.Gloss.Accelerate.Data.Picture as G
import Graphics.Gloss.Interface.Pure.Game hiding ( Vector, translate, scale )
import Data.Array.Accelerate ( Array, Scalar, Vector, Exp, DIM2, Elt, Z(..), (:.)(..) )
import Data.Array.Accelerate.Data.Complex
import Data.Array.Accelerate.Examples.Internal as A
import qualified Data.Array.Accelerate as A
import Data.Char
import Data.Int
import Data.Label
import Data.Word
import System.Exit
import Text.Printf
import Prelude as P
-- World state
-- -----------
type R = Double
data World = World
{ worldPicture :: !Picture
, worldAnimating :: !Bool
, worldDirty :: !Bool
, worldRender :: !(Scalar Float -> Scalar R -> Scalar R -> Scalar R -> Scalar Int32 -> Scalar R -> Array DIM2 Word32)
, worldPalette :: !(Vector Word32)
, worldSizeX :: !Int
, worldSizeY :: !Int
, worldTime :: !(Scalar Float)
, worldSpeed :: !(Scalar Float)
, worldPosX :: !(Scalar R)
, worldPosY :: !(Scalar R)
, worldWidth :: !(Scalar R)
, worldRadius :: !(Scalar R)
, worldIters :: !(Scalar Int32)
, worldPanning :: !(Maybe (Float, Float))
, worldZooming :: !(Maybe Double)
}
initialWorld :: Config -> Options -> World
initialWorld conf opts
= loadPreset opts 0
$ World
{ worldDirty = True
, worldAnimating = True
, worldPicture = blank
, worldRender = \_ _ _ _ _ _ -> A.fromList (Z:.0:.0) []
, worldPalette = run (get optBackend opts) (ultraPalette 2048)
, worldSizeX = get configWidth conf
, worldSizeY = get configHeight conf
, worldPanning = Nothing
, worldZooming = Nothing
, worldTime = unit' 0
, worldSpeed = unit' 1
, worldPosX = unit' 0
, worldPosY = unit' 0
, worldWidth = unit' 0
, worldRadius = unit' 0
, worldIters = unit' 0
}
-- Draw the world
--
draw :: World -> IO Picture
draw = return . worldPicture
-- React to events
--
react :: Config -> Options -> Event -> World -> IO World
react conf opts event world@World{..} =
case event of
-- zooming
EventKey (Char 'w') s _ _ -> toggle zooming 0.975 s world
EventKey (Char 's') s _ _ -> toggle zooming 1.025 s world
-- panning
EventKey (MouseButton LeftButton) s _ p -> toggle panning p s world
EventMotion (x,y)
| Just (x0,y0) <- worldPanning
-> let dx = (x0-x) * P.realToFrac (the' worldWidth) / P.fromIntegral worldSizeX
dy = (y0-y) * P.realToFrac (the' worldWidth) / P.fromIntegral worldSizeX
in
return . dirty
$ world { worldPosX = unit' (the' worldPosX + P.realToFrac dx)
, worldPosY = unit' (the' worldPosY - P.realToFrac dy)
, worldPanning = Just (x,y)
}
-- algorithm
EventKey (Char 'a') Down _ _ -> return . dirty
$ world { worldIters = unit' (P.truncate (P.fromIntegral (the' worldIters) * 0.8 :: Double)) }
EventKey (Char 'd') Down _ _ -> return . dirty
$ world { worldIters = unit' (P.truncate (P.fromIntegral (the' worldIters) * 1.2 :: Double)) }
EventKey (Char 'z') Down _ _ -> return . dirty
$ world { worldRadius = unit' (the' worldRadius * 0.5) }
EventKey (Char 'c') Down _ _ -> return . dirty
$ world { worldRadius = unit' (the' worldRadius * 2.0) }
EventKey (Char 'q') Down _ _ -> return . dirty
$ world { worldSpeed = unit' (the' worldSpeed * 0.75) }
EventKey (Char 'e') Down _ _ -> return . dirty
$ world { worldSpeed = unit' (the' worldSpeed * 1.25) }
-- animation
EventKey (SpecialKey KeyLeft) Down _ _ -> return . dirty
$ world { worldTime = unit' (the' worldTime - 1/60 * the' worldSpeed) }
EventKey (SpecialKey KeyRight) Down _ _ -> return . dirty
$ world { worldTime = unit' (the' worldTime + 1/60 * the' worldSpeed) }
-- presets
EventKey (Char d) Down _ _ | isDigit d -> return . dirty $ loadPreset opts (read [d]) world
-- misc
EventKey (Char '.') Down _ _ -> putStrLn (showWorld world) >> return world
EventKey (Char 'r') Down _ _ -> return $ (initialWorld conf opts) { worldAnimating = worldAnimating }
EventKey (SpecialKey KeySpace) Down _ _ -> return $ world { worldAnimating = not worldAnimating }
EventKey (SpecialKey KeyEsc) Down _ _ -> exitSuccess
_ -> return world
where
toggle f x Down = return . dirty . set f (Just x)
toggle f _ Up = return . set f Nothing
dirty w = w { worldDirty = True }
-- Move and zoom the display based on key state
--
advance :: Float -> World -> IO World
advance dt = return . updateWorld . animate . zoom
where
animate world@World{..}
| worldAnimating = world { worldDirty = True, worldTime = unit' (dt * the' worldSpeed + the' worldTime) }
| otherwise = world
--
zoom world@World{..}
| Just f <- worldZooming = world { worldDirty = True, worldWidth = unit' (P.realToFrac f * the' worldWidth) }
| otherwise = world
-- Update the picture
--
updateWorld :: World -> World
updateWorld world@World{..} =
if worldDirty
then world { worldDirty = False
, worldPicture = bitmapOfArray (renderWorld world) (not worldAnimating)
}
else world
renderWorld :: World -> Array DIM2 Word32
renderWorld World{..} =
let !r = worldRender worldTime worldPosX worldPosY worldWidth worldIters worldRadius
in r
-- Miscellaneous
-- -------------
zooming :: World :-> Maybe Double
zooming = lens worldZooming (\f World{..} -> World { worldZooming = f worldZooming, .. })
panning :: World :-> Maybe (Float,Float)
panning = lens worldPanning (\f World{..} -> World { worldPanning = f worldPanning, .. })
unit' :: Elt a => a -> Scalar a
unit' a = A.fromList Z [a]
the' :: Elt a => Scalar a -> a
the' a = a `A.indexArray` Z
-- Presets
-- -------
showWorld :: World -> String
showWorld World{..} =
printf "centre: (%f, %f), width: %f, iterations: %d, radius: %f"
(the' worldPosX)
(the' worldPosY)
(the' worldWidth)
(the' worldIters)
(the' worldRadius)
loadPreset :: Options -> Int -> World -> World
loadPreset opts n world@World{..} =
let
(f, posX, posY, width, iters, radius)
= presets !! n
render t x y w l r
= A.map (escapeToRGBA l (A.use worldPalette))
$ julia worldSizeX worldSizeY (\a b -> f (A.toFloating a) b) t x y w l r
in
world
{ worldRender = runN (get optBackend opts) render
, worldPosX = unit' posX
, worldPosY = unit' posY
, worldWidth = unit' width
, worldIters = unit' iters
, worldRadius = unit' radius
}
golden :: Floating a => a
golden = (1 + sqrt 5) / 2
presets
:: (Fractional a, A.RealFloat a)
=> [ (Exp a -> Exp (Complex a) -> Exp (Complex a), a, a, a, Int32, a) ]
presets =
[ (\t z -> z ^ (2::Int) + mkPolar 0.7885 t, 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((1 - golden) * cos t :+ A.constant 0), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((golden-2) * cos t :+ (golden-1) * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift (0.285 * cos t :+ 0.1 * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift (0.45 * cos t :+ 0.1428 * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((-0.70176) * cos t :+ (-0.3842) * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((-0.835) * cos t :+ (-0.2321) * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((-0.8) * cos t :+ 0.156 * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift ((-0.7269) * cos t :+ 0.1889 * sin t), 0, 0, 4, 255, 16.0)
, (\t z -> z ^ (2::Int) + A.lift (0 :+ (-0.8) * sin t), 0, 0, 4, 255, 16.0)
]