{-# 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 )
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