diff options
author | Aspen Smith <grfn@gws.fyi> | 2024-02-12T03·00-0500 |
---|---|---|
committer | clbot <clbot@tvl.fyi> | 2024-02-14T19·37+0000 |
commit | 82ecd61f5c699cf3af6c4eadf47a1c52b1d696c6 (patch) | |
tree | 429c5e078528000591742ec3211bc768ae913a78 /users/grfn/xanthous/src/Xanthous/Random.hs | |
parent | 0ba476a4266015f278f18d74094299de74a5a111 (diff) |
chore(users): grfn -> aspen r/7511
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9 Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809 Autosubmit: aspen <root@gws.fyi> Reviewed-by: sterni <sternenseemann@systemli.org> Tested-by: BuildkiteCI Reviewed-by: lukegb <lukegb@tvl.fyi>
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Random.hs')
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Random.hs | 186 |
1 files changed, 0 insertions, 186 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs deleted file mode 100644 index 329b321b8bda..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Random.hs +++ /dev/null @@ -1,186 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Random - ( Choose(..) - , ChooseElement(..) - , Weighted(..) - , evenlyWeighted - , weightedBy - , subRand - , chance - , chooseSubset - , chooseRange - , FiniteInterval(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) -import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) -import Data.Functor.Compose -import Data.Random.Shuffle.Weighted -import Data.Random.Distribution -import Data.Random.Distribution.Uniform -import Data.Random.Distribution.Uniform.Exclusive -import Data.Random.Sample -import qualified Data.Random.Source as DRS -import Data.Interval ( Interval, lowerBound', Extended (Finite) - , upperBound', Boundary (Closed), lowerBound, upperBound - ) --------------------------------------------------------------------------------- - -instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where - getRandomWord8 = getRandom - getRandomWord16 = getRandom - getRandomWord32 = getRandom - getRandomWord64 = getRandom - getRandomDouble = getRandom - getRandomNByteInteger n = getRandomR (0, 256 ^ n) - -class Choose a where - type RandomResult a - choose :: MonadRandom m => a -> m (RandomResult a) - -newtype ChooseElement a = ChooseElement a - -instance MonoFoldable a => Choose (ChooseElement a) where - type RandomResult (ChooseElement a) = Maybe (Element a) - choose (ChooseElement xs) = do - chosenIdx <- getRandomR (0, olength xs - 1) - let pick _ (Just x) = Just x - pick (x, i) Nothing - | i == chosenIdx = Just x - | otherwise = Nothing - pure $ ofoldr pick Nothing $ zip (toList xs) [0..] - -instance MonoFoldable a => Choose (NonNull a) where - type RandomResult (NonNull a) = Element a - choose - = fmap (fromMaybe (error "unreachable")) -- why not lol - . choose - . ChooseElement - . toNullable - -instance Choose (NonEmpty a) where - type RandomResult (NonEmpty a) = a - choose = choose . fromNonEmpty @[_] - -instance Choose (a, a) where - type RandomResult (a, a) = a - choose (x, y) = choose (x :| [y]) - -newtype Weighted w t a = Weighted (t (w, a)) - deriving (Functor, Foldable) via (t `Compose` (,) w) - -deriving newtype instance Eq (t (w, a)) => Eq (Weighted w t a) -deriving newtype instance Show (t (w, a)) => Show (Weighted w t a) -deriving newtype instance NFData (t (w, a)) => NFData (Weighted w t a) - -instance Traversable t => Traversable (Weighted w t) where - traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa - -evenlyWeighted :: [a] -> Weighted Int [] a -evenlyWeighted = Weighted . itoList - --- | Weight the elements of some functor by a function. Larger values of 'w' per --- its 'Ord' instance will be more likely to be generated -weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a -weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) - => Choose (Weighted w [] a) where - type RandomResult (Weighted w [] a) = Maybe a - choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws - -instance (Num w, Ord w, Distribution Uniform w, Excludable w) - => Choose (Weighted w NonEmpty a) where - type RandomResult (Weighted w NonEmpty a) = a - choose (Weighted ws) = - sample - $ fromMaybe (error "unreachable") . headMay - <$> weightedSample 1 (toList ws) - -subRand :: MonadRandom m => Rand StdGen a -> m a -subRand sub = evalRand sub . mkStdGen <$> getRandom - --- | Has a @n@ chance of returning 'True' --- --- eg, chance 0.5 will return 'True' half the time -chance - :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m) - => w - -> m Bool -chance n = choose $ weightedBy (bool 1 (n * 2)) bools - --- | Choose a random subset of *about* @w@ of the elements of the given --- 'Witherable' structure -chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w - , Witherable t - , MonadRandom m - ) => w -> t a -> m (t a) -chooseSubset = filterA . const . chance - --- | Choose a random @n@ in the given interval -chooseRange - :: ( MonadRandom m - , Distribution Uniform n - , Enum n - , Bounded n - , Ord n - ) - => Interval n - -> m (Maybe n) -chooseRange int = traverse sample distribution - where - (lower, lowerBoundary) = lowerBound' int - lowerR = case lower of - Finite x -> if lowerBoundary == Closed - then x - else succ x - _ -> minBound - (upper, upperBoundary) = upperBound' int - upperR = case upper of - Finite x -> if upperBoundary == Closed - then x - else pred x - _ -> maxBound - distribution - | lowerR <= upperR = Just $ Uniform lowerR upperR - | otherwise = Nothing - -instance ( Distribution Uniform n - , Enum n - , Bounded n - , Ord n - ) - => Choose (Interval n) where - type RandomResult (Interval n) = n - choose = fmap (fromMaybe $ error "Invalid interval") . chooseRange - -newtype FiniteInterval a - = FiniteInterval { unwrapFiniteInterval :: (Interval a) } - -instance ( Distribution Uniform n - , Ord n - ) - => Choose (FiniteInterval n) where - type RandomResult (FiniteInterval n) = n - -- TODO broken with open/closed right now - choose - = sample - . uncurry Uniform - . over both getFinite - . (lowerBound &&& upperBound) - . unwrapFiniteInterval - where - getFinite (Finite x) = x - getFinite _ = error "Infinite value" - --------------------------------------------------------------------------------- - -bools :: NonEmpty Bool -bools = True :| [False] |