{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# OPTIONS_GHC -Wno-orphans #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Combinatorial.Instances
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Arbitrary instances for the types in hgeometry-combinatorial
--
--------------------------------------------------------------------------------
module HGeometry.Combinatorial.Instances where

import           HGeometry.Ext
import           HGeometry.Cyclic
import           HGeometry.Number.Ratio.Generalized
import           HGeometry.Number.Real.Rational
import qualified HGeometry.Sign as Sign
-- import HGeometry.Number.Real.Symbolic
import           Test.QuickCheck
import           Test.QuickCheck.Instances ()
import           GHC.TypeLits
import           HGeometry.Tree.Binary.Static

import qualified Data.Set.NonEmpty as NESet

--------------------------------------------------------------------------------

instance (Arbitrary c, Arbitrary e) => Arbitrary (c :+ e) where
  arbitrary :: Gen (c :+ e)
arbitrary = c -> e -> c :+ e
forall core extra. core -> extra -> core :+ extra
(:+) (c -> e -> c :+ e) -> Gen c -> Gen (e -> c :+ e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen c
forall a. Arbitrary a => Gen a
arbitrary Gen (e -> c :+ e) -> Gen e -> Gen (c :+ e)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen e
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: (c :+ e) -> [c :+ e]
shrink = (c :+ e) -> [c :+ e]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink


--------------------------------------------------------------------------------

deriving newtype instance Arbitrary (f a) => Arbitrary (Cyclic f a)

--------------------------------------------------------------------------------

-- instance ( forall r. VectorLike_ (Vector d r)
--          ) => Arbitrary1 (Vector d) where
--   liftArbitrary gen = generateA (const gen)
--   -- I think this instance is unreachable, so let's comment it for now.

instance (Arbitrary a, Num a, Eq a) => Arbitrary (GRatio a) where
  arbitrary :: Gen (GRatio a)
arbitrary = GRatio a -> GRatio a -> GRatio a
forall a. Fractional a => a -> a -> a
(/) (GRatio a -> GRatio a -> GRatio a)
-> Gen (GRatio a) -> Gen (GRatio a -> GRatio a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (GRatio a)
forall a. Arbitrary a => Gen a
arbitrary Gen (GRatio a -> GRatio a) -> Gen (GRatio a) -> Gen (GRatio a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Gen (GRatio a)
forall a. Arbitrary a => Gen a
arbitrary Gen (GRatio a) -> (GRatio a -> Bool) -> Gen (GRatio a)
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (GRatio a -> GRatio a -> Bool
forall a. Eq a => a -> a -> Bool
/= GRatio a
0))
  shrink :: GRatio a -> [GRatio a]
shrink GRatio a
r = GRatio a
0 GRatio a -> [GRatio a] -> [GRatio a]
forall a. a -> [a] -> [a]
: GRatio a
1 GRatio a -> [GRatio a] -> [GRatio a]
forall a. a -> [a] -> [a]
: [ a
a' a -> a -> GRatio a
forall a. (Eq a, Num a) => a -> a -> GRatio a
% a
b'
                     | a
a' <- a -> [a]
forall a. Arbitrary a => a -> [a]
shrink (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ GRatio a -> a
forall a. GRatio a -> a
numerator GRatio a
r
                     , a
b' <- Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
forall a. Arbitrary a => a -> [a]
shrink (GRatio a -> a
forall a. GRatio a -> a
denominator GRatio a
r)
                     , a
b' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
                     ]

instance KnownNat p => Arbitrary (RealNumber p) where
  arbitrary :: Gen (RealNumber p)
arbitrary = Fixed (NatPrec p) -> RealNumber p
forall (p :: Nat). KnownNat p => Fixed (NatPrec p) -> RealNumber p
fromFixed (Fixed (NatPrec p) -> RealNumber p)
-> Gen (Fixed (NatPrec p)) -> Gen (RealNumber p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Fixed (NatPrec p))
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: RealNumber p -> [RealNumber p]
shrink = RealNumber p -> [RealNumber p]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary Sign.Sign where
  arbitrary :: Gen Sign
arbitrary = (\Bool
b -> if Bool
b then Sign
Sign.Positive else Sign
Sign.Negative) (Bool -> Sign) -> Gen Bool -> Gen Sign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary

--------------------------------------------------------------------------------
-- * Symbolic instances

-- instance (Arbitrary i, Ord i) => Arbitrary (EpsFold i) where
--   arbitrary = mkEpsFold . take 4 <$> listOf arbitrary

-- instance (Arbitrary r, Arbitrary (EpsFold i), Ord i) => Arbitrary (Term i r) where
  -- arbitrary = Term <$> arbitrary <*> arbitrary

-- instance (Arbitrary r, Ord i, Arbitrary (EpsFold i)) => Arbitrary (Symbolic i r) where
--   arbitrary = Sum <$> arbitrary

-- instance (Arbitrary a, Ord a) => Arbitrary (Bag a) where
--   arbitrary = foldMap singleton <$> listOf arbitrary

--------------------------------------------------------------------------------
-- * Binary tree instances

instance (Arbitrary a, Arbitrary v) => Arbitrary (BinLeafTree v a) where
  arbitrary :: Gen (BinLeafTree v a)
arbitrary = (Int -> Gen (BinLeafTree v a)) -> Gen (BinLeafTree v a)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (BinLeafTree v a)
forall {t} {a} {v}.
(Ord t, Num t, Random t, Arbitrary a, Arbitrary v) =>
t -> Gen (BinLeafTree v a)
f
    where f :: t -> Gen (BinLeafTree v a)
f t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = a -> BinLeafTree v a
forall v a. a -> BinLeafTree v a
Leaf (a -> BinLeafTree v a) -> Gen a -> Gen (BinLeafTree v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary
              | Bool
otherwise = do
                              l <- (t, t) -> Gen t
forall a. Random a => (a, a) -> Gen a
choose (t
0,t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)
                              Node <$> f l <*> arbitrary <*> f (n-l-1)
  -- shrink = genericShrink

instance Arbitrary a => Arbitrary (BinaryTree a) where
  arbitrary :: Gen (BinaryTree a)
arbitrary = (Int -> Gen (BinaryTree a)) -> Gen (BinaryTree a)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (BinaryTree a)
forall {t} {a}.
(Ord t, Num t, Random t, Arbitrary a) =>
t -> Gen (BinaryTree a)
f
    where f :: t -> Gen (BinaryTree a)
f t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0    = BinaryTree a -> Gen (BinaryTree a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BinaryTree a
forall a. BinaryTree a
Nil
              | Bool
otherwise = do
                              l <- (t, t) -> Gen t
forall a. Random a => (a, a) -> Gen a
choose (t
0,t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)
                              Internal <$> f l <*> arbitrary <*> f (n-l-1)
  -- shrink = genericShrink


-- * Orphan instance
instance (Arbitrary a, Ord a) => Arbitrary (NESet.NESet a) where
  arbitrary :: Gen (NESet a)
arbitrary = NonEmpty a -> NESet a
forall a. Ord a => NonEmpty a -> NESet a
NESet.fromList (NonEmpty a -> NESet a) -> Gen (NonEmpty a) -> Gen (NESet a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (NonEmpty a)
forall a. Arbitrary a => Gen a
arbitrary