justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Function for adding random lights to roomNGon

Browse Source
This commit is contained in:
justin
2026-03-19 11:40:49 +00:00
parent d1c2870d63
commit 508b848204
20 changed files with 453 additions and 336 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/RandomHelp.hs
+55 -37
View File
@@ -2,13 +2,13 @@
{- Helpers for random generation. -}
module RandomHelp (
module System.Random,
-- module Control.Monad.State,
-- module Control.Monad.State,
module RandomHelp,
module Control.Monad.Trans.State.Lazy,
) where
import Control.Monad
--import Control.Monad.State
-- import Control.Monad.State
import Control.Monad.Trans.State.Lazy
import Data.List
import Geometry
@@ -21,8 +21,25 @@ randomRanges = join . takeOne . f
f (x : y : ys) = state (randomR (x, y)) : f ys
f _ = []
takeOne :: RandomGen g => [a] -> State g a
takeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (xs !! i))
takeOne :: (RandomGen g) => [a] -> State g a
takeOne xs = state (randomR (0, length xs - 1)) >>= \i -> return (xs !! i)
takeOneRem :: (RandomGen g) => [a] -> State g (Maybe (a, [a]))
takeOneRem [] = return Nothing
takeOneRem xs =
state (randomR (0, length xs - 1)) >>= \i -> do
let (ys, (z : zs)) = splitAt i xs
return $ Just (z, ys <> zs)
takeOneFiltered :: (RandomGen g) => (a -> Bool) -> [a] -> State g (Maybe a)
takeOneFiltered t xs = do
m <- takeOneRem xs
f m
where
f Nothing = return Nothing
f (Just (y, ys))
| t y = return $ Just y
| otherwise = takeOneFiltered t ys
takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w ws))
@@ -32,25 +49,25 @@ takeOneWeighted ws xs = state (randomR (0, sum ws)) >>= (\w -> return (xs !! i w
| otherwise = 1 + i (y - z) zs
i _ _ = 0
--{-# OPTIONS -Wno-incomplete-uni-patterns #-}
takeOneMore :: RandomGen g => ([a], [a]) -> State g ([a], [a])
-- {-# OPTIONS -Wno-incomplete-uni-patterns #-}
takeOneMore :: (RandomGen g) => ([a], [a]) -> State g ([a], [a])
takeOneMore (_, []) = error "trying to takeOneMore from empty list"
takeOneMore (xs, ys) = do
i <- state $ randomR (0, length ys - 1)
let (zs, w : ws) = splitAt i ys
return (w : xs, zs ++ ws)
takeNMore :: RandomGen g => Int -> ([a], [a]) -> State g ([a], [a])
takeNMore :: (RandomGen g) => Int -> ([a], [a]) -> State g ([a], [a])
takeNMore n p = foldl' (flip $ const (>>= takeOneMore)) (return p) [1 .. n]
takeN :: RandomGen g => Int -> [a] -> State g [a]
takeN :: (RandomGen g) => Int -> [a] -> State g [a]
takeN 0 _ = return []
takeN i xs = fst <$> takeNMore i ([], xs)
-- | Randomly shuffle a list.
shuffle :: RandomGen g => [a] -> State g [a]
shuffle :: (RandomGen g) => [a] -> State g [a]
shuffle xs = do
rands <- forM [0 .. length xs -1] $ \i -> state $ randomR (0, i)
rands <- forM [0 .. length xs - 1] $ \i -> state $ randomR (0, i)
let f ys rand =
let (as, b : bs) = splitAt rand ys
in (as ++ bs, b)
@@ -58,94 +75,95 @@ shuffle xs = do
return $ forceElements zs `seq` zs
-- | Randomly shuffle the tail of a list, not safe.
shuffleTail :: RandomGen g => [a] -> State g [a]
shuffleTail :: (RandomGen g) => [a] -> State g [a]
shuffleTail (x : xs) = (x :) <$> shuffle xs
shuffleTail _ = undefined
-- select elements from a list randomly
-- each element has the same independent chance of being selected
randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
randomSelectionFromList :: (RandomGen g) => Float -> [a] -> State g [a]
randomSelectionFromList = filterM . const . randProb
randProb :: RandomGen g => Float -> State g Bool
randProb :: (RandomGen g) => Float -> State g Bool
randProb p = do
p1 <- state $ randomR (0, 1)
return (p1 < p)
randInCirc :: RandomGen g => Float -> State g Point2
randInCirc :: (RandomGen g) => Float -> State g Point2
randInCirc = flip randInArc (2 * pi)
randOnCirc :: RandomGen g => Float -> State g Point2
randOnCirc :: (RandomGen g) => Float -> State g Point2
randOnCirc r = do
a <- state $ randomR (0, 2*pi)
a <- state $ randomR (0, 2 * pi)
return $ r *.* unitVectorAtAngle a
randInArc :: RandomGen g => Float -> Float -> State g Point2
randInArc :: (RandomGen g) => Float -> Float -> State g Point2
randInArc = randInArcStrip 0
randInArcStrip :: RandomGen g => Float -> Float -> Float -> State g Point2
randInArcStrip :: (RandomGen g) => Float -> Float -> Float -> State g Point2
randInArcStrip minrad maxRad maxangle = do
rad <- state $ randomR (minrad, maxRad)
ang <- state $ randomR (0, maxangle)
return $ rad *.* unitVectorAtAngle ang
randOnUnitSphere :: RandomGen g => State g Point3
randOnUnitSphere :: (RandomGen g) => State g Point3
randOnUnitSphere = do
z <- state $ randomR (negate 1, 1)
longitude <- state $ randomR (0, 2 * pi)
let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
return (V3 x y z)
randOnHemisphere :: RandomGen g => State g Point3
randOnHemisphere :: (RandomGen g) => State g Point3
randOnHemisphere = do
z <- state $ randomR (0, 1)
longitude <- state $ randomR (0, 2 * pi)
let (V2 x y) = sqrt (1 - z ^ (2 :: Int)) *.* unitVectorAtAngle longitude
return (V3 x y z)
randInHemisphere :: RandomGen g => State g Point3
randInHemisphere :: (RandomGen g) => State g Point3
randInHemisphere = do
p <- randOnHemisphere
r <- state $ randomR (0, 1)
return $ r *.*.* p
randInRect :: RandomGen g => Float -> Float -> State g Point2
randInRect :: (RandomGen g) => Float -> Float -> State g Point2
randInRect w h = do
x <- state $ randomR (0, w)
y <- state $ randomR (0, h)
return (V2 x y)
maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
maybeTakeOne :: (RandomGen g) => [a] -> State g (Maybe a)
maybeTakeOne [] = return Nothing
maybeTakeOne xs = state (randomR (0, length xs - 1)) >>= (\i -> return (Just (xs !! i)))
randsSpread :: RandomGen g => (Float, Float) -> Int -> State g [Float]
randsSpread :: (RandomGen g) => (Float, Float) -> Int -> State g [Float]
randsSpread (a, b) i
| i <= 0 = error "tried to take <= 0 randsSpread"
| otherwise = zipWith (+) [a + x, a + 2 * x ..] <$> replicateM i (state $ randomR (0, x))
where
x = (b - a) / fromIntegral i
randsOnCirc :: RandomGen g => Int -> State g [Float]
randsOnCirc :: (RandomGen g) => Int -> State g [Float]
randsOnCirc = randsSpread (0, 2 * pi)
randPeakedParam :: RandomGen g => Int -> Float -> Float -> Float -> State g Float
randPeakedParam :: (RandomGen g) => Int -> Float -> Float -> Float -> State g Float
randPeakedParam i a b c = do
x <- state $ randomR (-1, 1)
let y = x ^ i
return $ if y < 0
then a + y * (a-b)
else b + y * (c-b)
return $
if y < 0
then a + y * (a - b)
else b + y * (c - b)
randPeaked :: RandomGen g => Float -> Float -> Float -> State g Float
randPeaked :: (RandomGen g) => Float -> Float -> Float -> State g Float
randPeaked = randPeakedParam 3
randFromPair :: RandomGen g => Float -> (a,a) -> State g a
randFromPair x (l,r) = do
y <- state $ randomR (0,1)
randFromPair :: (RandomGen g) => Float -> (a, a) -> State g a
randFromPair x (l, r) = do
y <- state $ randomR (0, 1)
if x < y then return l else return r
shufflePair :: RandomGen g => (a,a) -> State g (a,a)
shufflePair (x,y) = do
v <- state $ randomR (0::Float,1)
if v > 0.5 then return (x,y) else return (y,x)
shufflePair :: (RandomGen g) => (a, a) -> State g (a, a)
shufflePair (x, y) = do
v <- state $ randomR (0 :: Float, 1)
if v > 0.5 then return (x, y) else return (y, x)