Random.hs

module Zwirn.Core.Lib.Random where

{-
    Random.hs - simple random signals and related functions
    Copyright (C) 2025, Martin Gius

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Control.Monad (join)
import qualified Numeric.Noise as Noise
import System.Random
import Zwirn.Core.Core
import Zwirn.Core.Lib.Core
import Zwirn.Core.Lib.Modulate
import Zwirn.Core.Time (Time)
import Zwirn.Core.Types

precision :: Time
precision = 0.005

randR :: (Random a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
randR l r = zwirn q
  where
    q t = unzwirn (fmap fst $ liftA2 randomR zipp $ pure $ mkStdGen $ floor (t / precision)) t
      where
        zipp = liftA2 (,) l r

rand :: (Random a, Applicative k) => ZwirnT k st i a
rand = zwirn $ \t st -> pure (Value (fst $ random (mkStdGen $ floor (t / precision))) t [], st)

noise :: (Applicative k) => ZwirnT k st i Double
noise = rand

irand :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int
irand = randR (pure 0)

brandBy :: (Applicative k) => ZwirnT k st i Double -> ZwirnT k st i Bool
brandBy prob = liftA2 (>) prob rand

sometimesBy :: (MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
sometimesBy prob f x = innerJoin $ fmap cho (brandBy prob)
  where
    cho True = apply f x
    cho False = x

sometimes :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
sometimes = sometimesBy (pure 0.5)

often :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
often = sometimesBy (pure 0.75)

rarely :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
rarely = sometimesBy (pure 0.25)

almostNever :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
almostNever = sometimesBy (pure 0.1)

almostAlways :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
almostAlways = sometimesBy (pure 0.9)

-- TODO: FIX
degradeBy :: (MultiMonad k, HasSilence k) => ZwirnT k st i Double -> ZwirnT k st i a -> ZwirnT k st i a
degradeBy prob = sometimesBy prob (pure $ const silence)

degrade :: (MultiMonad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a
degrade = sometimes (pure $ const silence)

-- these versions take the cycle number as seed

randR' :: (Random a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
randR' r l = zwirn q
  where
    q t = unzwirn (fmap fst $ liftA2 randomR zipp $ pure $ mkStdGen $ floor t) t
      where
        zipp = liftA2 (,) l r

rand' :: (Random a, Applicative k) => ZwirnT k st i a
rand' = zwirn $ \t st -> pure (Value (fst $ random (mkStdGen $ floor t)) t [], st)

irand' :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int
irand' = randR' (pure 0)

brandBy' :: (Applicative k) => ZwirnT k st i Double -> ZwirnT k st i Bool
brandBy' prob = liftA2 (>) prob rand'

somecyclesBy :: (MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
somecyclesBy prob f x = innerJoin $ fmap cho (brandBy' prob)
  where
    cho True = apply f x
    cho False = x

somecycles :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
somecycles = somecyclesBy (pure 0.5)

------

chooseWithSeed :: (Monad k) => Int -> [ZwirnT k st i a] -> ZwirnT k st i a
chooseWithSeed i ps = (ps !!) =<< shift (pure $ fromIntegral i / precision) (irand' $ pure $ length ps - 1)

chooseList :: (Monad k) => [ZwirnT k st i a] -> ZwirnT k st i a
chooseList = chooseWithSeed 0

enumFromToChoice :: (Ord a, Num a, Monad k) => Int -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
enumFromToChoice i xz yz = join $ en <$> xz <*> yz
  where
    en x y = chooseWithSeed i $ map pure $ enumerateFromTo x y

enumFromThenToChoice :: (Ord a, Num a, Monad k) => Int -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
enumFromThenToChoice i xz yz zz = join $ en <$> xz <*> yz <*> zz
  where
    en x y z = chooseWithSeed i $ map pure $ enumerateFromThenTo x y z

perlinSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double
perlinSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.perlin2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st

perlin :: (Applicative k) => ZwirnT k st i Double
perlin = perlinSeed (pure 0)

simplexSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double
simplexSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.openSimplex2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st

simplex :: (Applicative k) => ZwirnT k st i Double
simplex = simplexSeed (pure 0)

ssimplexSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double
ssimplexSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.superSimplex2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st

ssimplex :: (Applicative k) => ZwirnT k st i Double
ssimplex = ssimplexSeed (pure 0)

valueSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double
valueSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.value2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st

valueN :: (Applicative k) => ZwirnT k st i Double
valueN = valueSeed (pure 0)

cubicSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double
cubicSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.valueCubic2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st

cubic :: (Applicative k) => ZwirnT k st i Double
cubic = cubicSeed (pure 0)