I found this weird old Python file on my hard drive (which I think I got here) and tried reimplementing it in Haskell for shits and giggles. The original had a more verbose, plain text output, but I changed it to a curses-based thing to make debugging easy.
data World = World
{ tickNumber :: Int
, actors :: [Actor]
, bounds :: ((Int, Int), (Int, Int))
} deriving (Eq, Show)
makeExpectancy Ages{..} = do
gestation <- roughly gestation
puberty <- roughly puberty
adulthood <- roughly adulthood
sterility <- roughly sterility
death <- roughly death
return Ages{..}
makeActor species@(Species{..}) location = do
ageMap <- makeExpectancy typicalAgeMap
isFemale <- randomIO
let names = ["somebody"]
age = 0
gender = if isFemale then Female else Male
Just sigils = lookup gender defaultSigils
bodyState = Nothing
mindState = Wandering (puberty ageMap)
alive = True
return Actor{..}
wanderFrom (x, y) = do
x <- x +/- 1
y <- y +/- 1
return (x, y)
ageUp actor = actor { age = age actor + 1 }
Name:
Anonymous2013-09-10 17:24
Simulate.hs (part 2):
doEncounters actors tickNumber = do
let (breeders, rest) = partition canHaveSex actors
groups = batch location breeders
breeders' <- mapM (runEncounter tickNumber) groups
return (concat (rest : breeders'))
runEncounter :: Int -> [Actor] -> IO [Actor]
runEncounter tickNumber (x : y : ys) = do
let (a, b) = if virility x > virility y
then (x, y)
else (y, x)
b <- impregnate tickNumber a b
ab' <- mapM beginSex [a, b]
return (ab' ++ ys)
runEncounter _ xs = return xs
beginSex :: Actor -> IO Actor
beginSex Actor{..} = do
mindState <- HavingSex `fmap` roughly 10
return Actor{..}
impregnate :: Int -> Actor -> Actor -> IO Actor
impregnate whenBegan father mother
| virility father + fertility mother > 1.0 = do
pregnant <- do
let withSpecies = species father
gperiod = gestation (ageMap father)
numOffspring <- randomRIO (broodSize withSpecies)
whenEnding <- (whenBegan +) `fmap` roughly gperiod
return Pregnant{..}
return mother { bodyState = Just pregnant }
impregnate _ _ nope = return nope
giveBirth time mother@(Actor{ bodyState = Just Pregnant{..} })
| whenEnding >= time = do
locations <- replicateM numOffspring $ wanderFrom (location mother)
children <- mapM (makeActor withSpecies) locations
return (mother { bodyState = Nothing } : children)
giveBirth _ whatever = return [whatever]
cullDead Actor{..} | not alive || age > death ageMap = return []
cullDead actor = return [actor]
Name:
Anonymous2013-09-10 17:25
Simulate.hs (part 3):
anyLoc (low, high) = do
x <- randomRIO (fst low, fst high)
y <- randomRIO (snd low, snd high)
return (x, y)
randomAges Actor{..} = do
age <- puberty ageMap +/- 100
return Actor{..}
makeWorld width height = do
let tickNumber = 1
species = take 20 (repeat human) ++ take 5 (repeat demon)
w = width `div` 2
h = height `div` 2
bounds = ((0 - w, 0 - h), (0 + w, 0 + h))
locations <- mapM anyLoc (take 25 $ repeat bounds)
actors <- sequence $ zipWith makeActor species locations
actors <- mapM randomAges actors
return World{..}
clamp v low high
| v < low = low
| v > high = high
| otherwise = v
stepMindState (Actor{..}) =
case mindState of
Horny -> Horny
Wandering 0 -> Horny
Wandering n -> Wandering (n - 1)
HavingSex 0 -> Wandering (fatigue species)
HavingSex n -> HavingSex (n - 1)
stepActor ((lx, ly), (hx, hy)) a@(Actor{..}) = do
mindState <- return $ stepMindState a
location <- case stepMindState a of
HavingSex _ -> do
return location
_ -> do
(x, y) <- wanderFrom location
return (clamp x lx hx, clamp y ly hy)
return Actor{..}
simulateUntil :: World -> (World -> Bool) -> IO World
simulateUntil world p = do
world <- stepWorld world
if p world
then return world
else simulateUntil world p
screenCoords World{ bounds = (low, high) } (x, y) = do
-- Assume the coords are properly bounded for now
let x' = x - fst low
y' = snd high - y
return (x', y')
drawWorld w@(World{..}) = do
erase
forM_ actors $ \a@Actor{..} -> do
(x, y) <- screenCoords w location
mvAddCh y x (renderSigil a)
refresh
runGame = withCurses $ do
(ySize, xSize) <- scrSize
world <- makeWorld xSize ySize
runLoop world
runLoop w = do
drawWorld w
test <- checkInput
if test
then stepWorld w >>= runLoop
else return ()
checkInput = do
test <- hReady stdin
if test
then do
input <- getCh
return $ case input of
KeyChar '.' -> True
_ -> False
else do
threadDelay 100000
return True
n +/- k = do
r <- randomRIO (0, k * 2)
return $ (n - k) + r
roughly n = n +/- (n `div` 10)
shuffle :: [a] -> IO [a]
shuffle xs = do
let n = length xs
-- Have to declare a type
new :: [a] -> IO (IOArray Int a)
new = newListArray (1, n)
ar <- new xs
forM [1 .. n] $ \i -> do
j <- randomRIO (i, n)
vi <- readArray ar i
vj <- readArray ar j
writeArray ar j vi
return vj
priorityOn f xs = do
batches <- mapM shuffle $ groupBy ((==) `on` f) $ sort xs
return (concat batches)
interpolate j (i, yi) (k, yk)
| j < i = yi
| j > k = yk
| otherwise = yi + (yk - yi) * (j - i) / (k - i)
Name:
Anonymous2013-09-11 10:55
but I changed it to a curses-based thing to make debugging easy.
That's why TDD exists, fucking shitfucker
Name:
Anonymous2013-09-11 13:10
>>10
I could be a smartass about "it compiles so my code is right" but realistically there's just one unit test that would have helped me out:
testAgeRestriction = do
world <- makeWorld 10 10
let condition World{..} = null actors || any childHavingSex actors
childHavingSex a = isChild a && isHavingSex a
World{..} <- simulateUntil world condition
return $ if any childHavingSex actors
then Left "THERE ARE CHILDREN HAVING SEX"
else Right "OK, all entities dead"
Turning on the warnings in my compiler would also have helped, since the source of this bug was a binding I didn't use.
Name:
Anonymous2013-10-16 0:16
Made a drop-in replacement for the curses UI. Just change the import line in Main (from UI to UI.Gloss) and it should work. It highlights sex, pregnancy, and young/old age. Gloss is all right.
drawWorld :: World -> IO Picture
drawWorld world = do
pictures <- forM (actors world) $ drawActor world
return (Pictures pictures)
drawActor :: World -> Actor -> IO Picture
drawActor world actor = do
(x, y) <- screenCoords world (location actor)
let sigil = showSigil actor
colorMod
| age actor < puberty (ageMap actor) = light
| age actor > sterility (ageMap actor) = light . light . light
| otherwise = id
color
| sigil `elem` "fF" = magenta
| sigil `elem` "mM" = blue
| sigil `elem` "sS" = red
| sigil `elem` "xX" = green
| otherwise = white
scale = 0.075
colorSigil = Color (colorMod color) . Translate (-3) (-4) .
Scale scale scale $ Text [sigil]
signal
| HavingSex n <- mindState actor =
[Color white $ Circle (realToFrac n)]
| Just (Pregnant {}) <- bodyState actor =
[Color cyan $ Circle 7]
| otherwise = []
return . Translate (realToFrac x) (realToFrac y) . Pictures $
(colorSigil:signal)
runGame :: IO ()
runGame = do
world <- makeWorld 64 48
let disp = InWindow "Genie" (640, 480) (320, 240)
grayRatio = 9 / 10
bg = mixColors grayRatio (1 - grayRatio) black white
fps = 10
simulateIO disp bg fps world drawWorld $ \_ _ -> stepWorld