{- ORMOLU_DISABLE -}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module ImplicitSpec (spec) where

import Prelude (Fractional, fmap, pure, negate, (+),  Show, Monoid, mempty, (*), (/), (<>), (-), (/=), ($), (.), pi, id)
import Test.Hspec (describe, parallel, Spec)
import Graphics.Implicit
    ( difference,
      rotate,
      transform,
      rotate3,
      rotate3V,
      transform3,
      union,
      SymbolicObj2,
      SymbolicObj3,
      scale,
      emptySpace,
      fullSpace,
      complement,
      differenceR,
      translate,
      withRounding,
      unionR,
      intersectR,
      extrude,
      cylinder2,
      mirror,
      Object )
import Graphics.Implicit.Primitives (rotateQ)
import Test.QuickCheck (Arbitrary(arbitrary), suchThat, forAll, NonZero)
import Data.Foldable ( for_ )
import Test.Hspec.QuickCheck (prop)
import Linear (V2(V2), V3(V3), V4(V4), (^*))
import qualified Linear
import Graphics.Implicit.Test.Instances (Observe, (=~=), arbitraryNonZeroV)

------------------------------------------------------------------------------
-- Tests showing equivalencies between algebraic formulations of symbolic
-- objects, in both 2d and 3d. Equality is observational, based on random
-- sampling of the underlying 'getImplicit' function.
spec :: Spec
spec = parallel $ do
  describe "symbolic obj 2" $ do
    idempotenceSpec  @SymbolicObj2
    identitySpec     @SymbolicObj2
    homomorphismSpec @SymbolicObj2
    monoidSpec       @SymbolicObj2
    inverseSpec      @SymbolicObj2
    annihilationSpec @SymbolicObj2
    rotation2dSpec
    transform2dSpec

  describe "symbolic obj 3" $ do
    idempotenceSpec  @SymbolicObj3
    identitySpec     @SymbolicObj3
    homomorphismSpec @SymbolicObj3
    monoidSpec       @SymbolicObj3
    inverseSpec      @SymbolicObj3
    annihilationSpec @SymbolicObj3
    rotation3dSpec
    transform3dSpec
    misc3dSpec

------------------------------------------------------------------------------
-- All the constraints we need in scope to parameterize tests by both 2d and
-- 3d symbolic objects.
type TestInfrastructure obj f a test outcome =
  ( Object obj f a
  , Observe test outcome obj
  , Monoid obj
  , Show outcome
  , Show test
  , Show obj
  , Show (f a)
  , Arbitrary obj
  , Arbitrary (f a)
  , Arbitrary (f (NonZero a))
  , Fractional (f a)
  )

------------------------------------------------------------------------------
-- Tests proving that symbolic objects form a monoid.
monoidSpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
monoidSpec = describe "monoid laws" $ do
  prop "a <> mempty = a" $ \obj ->
    obj =~= obj <> mempty @obj

  prop "mempty <> a = a" $ \obj ->
    obj =~= mempty @obj <> obj

  prop "(a <> b) <> c = a <> (b <> c)" $ \a b (c :: obj) ->
    (a <> b) <> c =~= a <> (b <> c)

------------------------------------------------------------------------------
-- Tests showing that 'translate' is a no-op for both 'emptySpace' and
-- 'fullSpace'. Additionally, that 'scale' is a no-op on 'emptySpace' (but not
-- for 'fullSpace', because scaling by 0 is instead 'emptySpace').
idempotenceSpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
idempotenceSpec = describe "idempotence" $ do
  for_ [("empty", emptySpace @obj), ("full", fullSpace)] $ \(name, obj) ->
    describe name $ do
      prop "idempotent wrt translate" $ \xyz ->
        translate xyz obj
          =~= obj

  prop "empty idempotent wrt scale" $ \xyz ->
    scale xyz emptySpace
      =~= emptySpace @obj

  prop "withRounding always takes the last value idempotent" $ \r r' ->
    withRounding r . withRounding r'
      =~= withRounding @obj r'

------------------------------------------------------------------------------
-- Proofs of the invertability of operations.
inverseSpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
inverseSpec = describe "inverses" $ do
  prop "complement inverse" $
    complement @obj . complement
      =~= id

  prop "translate inverse" $ \xyz ->
    translate @obj xyz . translate (negate xyz)
      =~= id

  prop "scale inverse" $
    forAll arbitraryNonZeroV $ \xyz ->
      scale @obj xyz . scale (1 / xyz)
      =~= id

------------------------------------------------------------------------------
-- Proofs that 'fullSpace' is an annhilative element with respect to union.
annihilationSpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
annihilationSpec = describe "annihilation" $ do
  prop "full <> obj = full" $ \obj ->
    fullSpace <> obj
      =~= fullSpace @obj
  prop "obj <> full = full" $ \obj ->
    obj <> fullSpace
      =~= fullSpace @obj

------------------------------------------------------------------------------
-- Misc proofs regarding 2d rotation.
rotation2dSpec :: Spec
rotation2dSpec = describe "2d rotation" $ do
  prop "360 degrees is id" $
    rotate (2 * pi)
      =~= id

  prop "(x + y = 360) degrees is id" $ \rads -> do
      rotate (2 * pi - rads) . rotate rads
        =~= id

  prop "rotate" $ \rads1 rads2 ->
    rotate rads1 . rotate rads2
      =~= rotate (rads1 + rads2)

  prop "full idempotent wrt rotate" $ \rads ->
    rotate rads fullSpace
      =~= fullSpace

  prop "empty idempotent wrt rotate" $ \rads ->
    rotate rads emptySpace
      =~= emptySpace

------------------------------------------------------------------------------
-- Misc proofs regarding 3d transformation.
transform2dSpec :: Spec
transform2dSpec = describe "2d transform" $ do
  prop "identity" $
    transform Linear.identity
    =~= id

  prop "same as translation" $ \tr@(V2 x y) ->
    transform
      (V3
        (V3 1 0 x)
        (V3 0 1 y)
        (V3 0 0 1)
      )
    =~= translate tr

------------------------------------------------------------------------------
-- Misc proofs regarding 3d rotation.
rotation3dSpec :: Spec
rotation3dSpec = describe "3d rotation" $ do
  for_ [ ("YZ", V3 1 0 0)
       , ("XZ", V3 0 1 0)
       , ("XY", V3 0 0 1)
       ] $ \(axis, vec) -> do
    describe ("rotation in the " <> axis <> " plane") $ do
      prop "360 degrees is id" $
        rotate3 (vec ^* (2 * pi))
          =~= id
      prop "(x + y = 360) degrees is id" $ \rads ->
        rotate3 (vec ^* (2 * pi - rads)) . rotate3 (vec ^* rads)
          =~= id

  prop "360 degrees is id" $
    forAll (arbitrary `suchThat` (/= pure 0)) $ \vec ->
      rotate3V (2 * pi) vec
        =~= id
  prop "(x + y = 360) degrees is id" $ \rads -> do
    forAll (arbitrary `suchThat` (/= pure 0)) $ \vec ->
      rotate3V (2 * pi - rads) vec . rotate3V rads vec
        =~= id

  prop "rotate" $ \q1 q2 ->
    rotateQ q2 . rotateQ q1
      =~= rotateQ (q2 * q1)

  prop "full idempotent wrt rotate" $ \xyz ->
    rotate3 xyz fullSpace
      =~= fullSpace

  prop "empty idempotent wrt rotate" $ \xyz ->
    rotate3 xyz emptySpace
      =~= emptySpace

------------------------------------------------------------------------------
-- Misc proofs regarding 3d transformation.
transform3dSpec :: Spec
transform3dSpec = describe "3d transform" $ do
  prop "identity" $
    transform3 Linear.identity
    =~= id

  prop "same as rotation and translation" $ \quat tr ->
    transform3 (Linear.mkTransformation quat tr)
    =~= translate tr . rotateQ quat

  prop "scale"
    $ forAll arbitraryNonZeroV $ \s@(V3 x y z) ->
    transform3
      (V4 (V4 x 0 0 0)
          (V4 0 y 0 0)
          (V4 0 0 z 0)
          (V4 0 0 0 1)
          )
    =~= scale s

  prop "mirror" $
    transform3
    -- mirroring about Y plane
      (V4 (V4 (-1) 0 0 0)
          (V4   0  1 0 0)
          (V4   0  0 1 0)
          (V4   0  0 0 1)
          )
    =~= mirror (V3 1 0 0)

------------------------------------------------------------------------------
-- Misc tests that make sense only in 3d
misc3dSpec :: Spec
misc3dSpec = describe "misc 3d tests" $ do
  prop "object-rounding value doesn't jump from 3d to 2d" $ \r obj ->
    withRounding r . extrude obj
      =~= withRounding r . extrude (withRounding 0 obj)

  prop "cylinder with negative height is a flipped cylinder with positive height" $ \r1 r2 h ->
    cylinder2 r1 r2 h =~= mirror (V3 0 0 1) (cylinder2 r1 r2 (-h))

  prop "negative scale in X is mirror about Y plane" $
    scale @SymbolicObj3 (V3 (-1) 1 1) =~= mirror (V3 1 0 0)

------------------------------------------------------------------------------
-- Misc identity proofs that should hold for all symbolic objects.
identitySpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
identitySpec = describe "identity" $ do
  prop "complement empty" $
    complement @obj emptySpace
      =~= fullSpace

  prop "complement full" $
    complement @obj fullSpace
      =~= emptySpace

  prop "difference of empty" $ \r objs ->
    differenceR @obj r emptySpace objs
      =~= emptySpace

  prop "difference is complement" $ \objs ->
    difference @obj fullSpace objs
      =~= complement (union objs)

  prop "difference of obj" $ \r obj ->
    differenceR @obj r obj []
      =~= obj

  prop "union [a] = a" $ \obj ->
    union @obj [obj] =~= obj

------------------------------------------------------------------------------
-- Functions proving symbolic objects form homomorphisms with respect to
-- translate and scale.
homomorphismSpec
    :: forall obj f a test outcome
     . TestInfrastructure obj f a test outcome
    => Spec
homomorphismSpec = describe "homomorphism" $ do
  prop "translate" $ \xyz1 xyz2 ->
    translate @obj xyz2 . translate xyz1
      =~= translate (xyz1 + xyz2)

  prop "scale" $
    forAll arbitraryNonZeroV $ \xyz1 ->
      forAll arbitraryNonZeroV $ \xyz2 ->
        scale @obj xyz2 . scale xyz1
          =~= scale (xyz1 * xyz2)

  prop "withRounding/unionR" $ \r_obj r_combo ->
    withRounding @obj r_obj . unionR r_combo
      =~= unionR r_combo . fmap (withRounding r_obj)

  prop "withRounding/differenceR" $ \r_obj r_combo obj ->
    withRounding @obj r_obj . differenceR r_combo obj
      =~= differenceR r_combo (withRounding r_obj obj) . fmap (withRounding r_obj)

  prop "withRounding/intersectR" $ \r_obj r_combo ->
    withRounding @obj r_obj . intersectR r_combo
      =~= intersectR r_combo . fmap (withRounding r_obj)