content: {-# LANGUAGE ViewPatterns #-}
  -- Example of the slit-scan effect.
  -- You must provide your own Doctor Who theme music.
  --
  -- Based on code from:
  --    http://roy.red/slitscan-.html
  --
  
  module Main where
  
  import Config
  
  import Data.Label
  
  import Data.Array.Accelerate                                        as A hiding ( clamp, V2, V3 )
  import Data.Array.Accelerate.Examples.Internal                      as A
  
  import Data.Array.Accelerate.Linear.Metric
  import Data.Array.Accelerate.Linear.Vector
  import Data.Array.Accelerate.Linear.V2
  import Data.Array.Accelerate.Linear.V3
  
  import Data.Array.Accelerate.Control.Lens                           ( (^.) )
  
  import Graphics.Gloss.Accelerate.Raster.Field                       hiding ( clamp )
  
  import Prelude                                                      ( IO, fmap )
  
  
  -- Fractional part of a number
  --
  fract :: Exp Float -> Exp Float
  fract x = x - toFloating (A.floor x :: Exp Int)
  
  clamp :: Exp Float -> Exp Float -> Exp Float -> Exp Float
  clamp v inf sup = inf `A.max` v `A.min` sup
  
  -- Interpolation using Hermite polynomial after clamping values to a range.
  --
  smoothstep :: Exp Float -> Exp Float -> Exp Float -> Exp Float
  smoothstep edge0 edge1 x =
    let t = clamp ((x-edge0) / (edge1-edge0)) 0.0 1.0
    in  t*t*(3 - 2*t)
  
  rand2 :: Exp (V2 Float) -> Exp (V2 Float)
  rand2 p =
    let x = constant (V2 127.1 311.7)
        y = constant (V2 269.5 183.3)
        q = lift $ V2 (dot p x) (dot p y)
    in
    lift1 (fmap fract :: V2 (Exp Float) -> V2 (Exp Float))
      $ sin(q) * constant 43758.5453
  
  rand1 :: Exp (V2 Float) -> Exp Float
  rand1 p =
    let z = constant (V2 419.2 371.9)
    in  fract (sin (dot p z) * 833458.57832)
  
  
  -- Procedural pattern generation that generalise cell-noise, perlin-noise, and
  -- voronoi tessellation.
  --
  --   http://iquilezles.org/www/articles/voronoise/voronoise.htm
  --   https://www.shadertoy.com/view/Xd23Dh
  --
  voronoise :: Exp (V2 Float) -> Exp Float -> Exp Float -> Exp Float
  voronoise xy irregular smoothness =
    let
        cell        = lift1 (fmap A.toFloating :: V2 (Exp Int) -> V2 (Exp Float))
                    $ lift1 (fmap A.floor :: V2 (Exp Float) -> V2 (Exp Int))   xy
        cellOffset  = lift1 (fmap fract   :: V2 (Exp Float) -> V2 (Exp Float)) xy
        sharpness   = 1.0 + 63.0 * ((1.0-smoothness) ** 4.0)
  
        -- -- Sample the surrounding cells from [-2..2].
        -- samples = P.foldr1 (+) [ sample i j | i <- [-2..2], j <- [-2..2] ]
        samples =
          iterFromTo (-2) 2 0 $ \i x ->
          iterFromTo (-2) 2 x $ \j y ->
            y + sample i j
  
        sample :: Exp Int -> Exp Int -> Exp (V2 Float)
        sample i j =
          let
              samplePos = lift $ V2 (A.fromIntegral i) (A.fromIntegral j)
  
              -- Centre of the cell is not in the centre of the block for
              -- irregular noise. All coordinates are in block-space coordinates;
              -- 0 is the current block, 1 is one block over, etc...
              centre      = rand2 (cell + samplePos) ^* irregular
              centreDist  = norm (samplePos - cellOffset + centre)
  
              -- High sharpness = only extreme values = hard borders = 64
              -- Low sharpness  = no extreme values   = soft borders = 1
              det         = (1.0 - smoothstep 0.0 1.414 centreDist) ** sharpness
  
              -- A different "colour" (shade of grey) for each cell
              colour      = rand1 (cell + samplePos)
          in
          lift $ V2 (colour * det) det
    in
    samples^._x / samples^._y
  
  
  iterFromTo :: Elt a => Exp Int -> Exp Int -> Exp a -> (Exp Int -> Exp a -> Exp a) -> Exp a
  iterFromTo inf sup x body
    = A.snd
    $ A.while (\ix -> A.fst ix <= sup)
              (\ix -> A.lift (A.fst ix + 1, A.uncurry body ix))
              (lift (inf, x))
  
  v2OfPoint :: Exp Point -> Exp (V2 Float)
  v2OfPoint p =
    let (x,y) = xyOfPoint p
    in  lift (V2 x y)
  
  -- The time vortex
  --
  tunnel :: Exp Float -> Exp Point -> Exp Colour
  tunnel time (v2OfPoint -> pt1) =
    let
        rInv      = 1.0 / norm pt2
        pt2       = 1.2 * pt1
        pt3       = pt2 ^* rInv - lift (V2 (rInv + 2.0 * mod' time 6000.0) 0.0)
        c1        = constant (V3 0.659 0.772 1.000) -- slate-blue-ish
        c2        = c1 ^* ( (voronoise (5.0*pt3) 1.0 1.0) + 0.240*rInv )
        --
        V3 r g b  = unlift c2
    in
    rgba r g b 1.0
  
  
  main :: IO ()
  main = do
    beginMonitoring
    (conf, opts, rest)    <- parseArgs options defaults header footer
  
    let width     = get configWidth conf
        height    = get configHeight conf
        zoom      = get configZoom conf
        backend   = get optBackend opts
  
        frame     = run1 backend
                  $ makeField width height (\time -> tunnel (the time))
  
    runBenchmarks opts rest
      [ bench "tunnel" $ whnf frame (A.fromList Z [1.0]) ]
  
    runInteractive opts rest
      $ animateFieldWith
            (run1 backend)
            (InWindow "Tunnel" (width * zoom, height * zoom) (10, 10))
            (zoom, zoom)
            tunnel
  
  