Monday, June 22, 2009

Charlemagne, Disraeli, and Jefferson combined could not have done better! (in Haskell)

...but hopefully you can. I added the “in Haskell” part because I'm not sure exactly what summons the Haskelling hordes.

I finished up a first pass at translating the ancient game Hamurabi from BASIC to Haskell; I recently bought Real World Haskell and wanted to have another of my periodic goes at using the language.

The original BASIC program weighs in at 4,230 bytes and 121 lines. My port is somewhat more portly, at 10,280 bytes and 287 lines. The executable compiled by GHC is a mere 1.414 MB, which is a couple of orders of magnitude larger than the original probably would have been. Here is the source as it stands now:

-- Converted from the original FOCAL program and modified for Edusystem 70 by David Ahl, Digital
-- Modified for 8K Microsoft BASIC by Peter Turnbull
-- Ported to Haskell by James McNeill

import Char
import Random
import IO
import Text.Printf

-- Data structures

data GameState = GameState {
year :: Int,
people :: Int,
food :: Int, -- bushels
land :: Int, -- acres
landPrice :: Int, -- bushels per acre
totalDeaths :: Int,
cumDeathRate :: Double,
rng :: StdGen
} deriving (Show)

data Orders = Quit | Orders {
acresToBuyOrSell :: Int, -- negative number means sell
acresToPlant :: Int,
bushelsForFood :: Int
} deriving (Show)

data Results = Results {
peopleStarved :: Int,
peopleDiedOfPlague :: Int,
peopleBorn :: Int,
bushelsEatenByRats :: Int,
bushelsPerAcre :: Int
} deriving (Show)

data ValidateResult a = Abort String | Retry String | Accept a

-- Code

main = do
rng <- getStdGen
putStrLn "Try your hand at governing ancient Sumeria successfully for a 10-year term of\noffice."
let s = initialState rng
showResults s initialResults
doYears s
putStrLn "So long for now."

showResults :: GameState -> Results -> IO ()
showResults state results = do
printf "\nHamurabi: I beg to report to you,\n"
printf "In year %d, %d people starved, %d came to the city.\n" (year state) (peopleStarved results) (peopleBorn results)
printf "%s" (if (peopleDiedOfPlague results) > 0 then "A horrible plague struck! Half the people died.\n" else "")
printf "Population is now %d.\n" (people state)
printf "The city now owns %d acres.\n" (land state)
printf "You harvested %d bushels per acre.\n" (bushelsPerAcre results)
printf "Rats ate %d bushels.\n" (bushelsEatenByRats results)
printf "You now have %d bushels in store.\n" (food state)

doYears :: GameState -> IO ()
doYears sIn = do
let s = chooseNewLandPrice sIn
orders <- readOrders s
case orders of
Quit -> return ()
otherwise -> do
let (sOut, resultsOut) = applyOrders orders s
showResults sOut resultsOut
let fractionStarved = (fromIntegral (peopleStarved resultsOut)) / (fromIntegral (people s))
if fractionStarved > 0.45
then do
printf "You starved %d people in one year!\n" (peopleStarved resultsOut)
putStr finkMessage
if (year sOut) >= 10
then putStr $ finalReport sOut
else doYears sOut

readOrders :: GameState -> IO Orders
readOrders s = do
printf "Land is trading at %d bushels per acre.\n" (landPrice s)
buyLand s

applyOrders :: Orders -> GameState -> (GameState, Results)
applyOrders orders state = (stateOut, resultsOut)
stateOut = GameState {
year = (year state) + 1,
people = peopleFinal,
food = bushelsFinal,
land = landFinal,
landPrice = (landPrice state),
totalDeaths = (totalDeaths state) + peopleDiedOfPlague + peopleStarved,
cumDeathRate = (cumDeathRate state) + (fromIntegral peopleStarved) / (fromIntegral peopleInit),
rng = rngOut
resultsOut = Results {
peopleStarved = peopleStarved,
peopleDiedOfPlague = peopleDiedOfPlague,
peopleBorn = peopleBorn,
bushelsEatenByRats = bushelsEatenByRats,
bushelsPerAcre = harvestYield

landFinal = (land state) + (acresToBuyOrSell orders)

peopleFinal = peopleBeforePlague - peopleDiedOfPlague
peopleBeforePlague = peopleFed + peopleBorn
| plagueRandom < 0.15 = peopleBeforePlague `div` 2
| otherwise = 0
peopleFed = min peopleInit (bushelsEatenByPeople `div` 20)
peopleStarved = peopleInit - peopleFed
peopleBorn = 1 + ((birthRandom * (20 * landFinal + bushelsFinal)) `div` (peopleInit * 100))
peopleInit = people state

bushelsFinal = (bushelsBeforeRats - bushelsEatenByRats) + bushelsHarvested
| ((ratD6 `mod` 2) == 1) = 0
| otherwise = bushelsBeforeRats `div` ratD6
bushelsBeforeRats =
(food state) -
bushelsEatenByPeople -
((acresToBuyOrSell orders) * (landPrice state)) -
((acresToPlant orders) `div` 2)
bushelsEatenByPeople = bushelsForFood orders
bushelsHarvested = harvestYield * (acresToPlant orders)

(birthRandom, rng1) = randomR (1, 6) (rng state)
(harvestYield, rng2) = randomR (1, 6) rng1
(plagueRandom, rng3) = random (rng2) :: (Double, StdGen)
(ratD6, rngOut) = randomR (1, 6) rng3

buyLand :: GameState -> IO Orders
buyLand s
| maxN <= 0 = sellLand s 0
| otherwise = do
choice <- readValidatedNum prompt validate defaultN
case choice of
Nothing -> return Quit
Just n -> sellLand s { land = (land s) + n, food = (food s) - ((landPrice s) * n) } n
prompt = "How many acres do you wish to buy (0-" ++ (show maxN) ++ ")? [" ++ (show defaultN) ++ "] "
maxN = (food s) `div` (landPrice s)
defaultN = 0
validate n
| n < 0 = Abort abortMessage
| n > maxN = Retry $ printf "Hammurabi: Think again. You have only %d bushels of grain. Now then," (food s)
| otherwise = Accept n

sellLand :: GameState -> Int -> IO Orders
sellLand s acresToBuy
| acresToBuy > 0 || maxN <= 0 = feedPeople s acresToBuy
| otherwise = do
choice <- readValidatedNum prompt validate defaultN
case choice of
Nothing -> return Quit
Just n -> feedPeople s { land = (land s) - n, food = (food s) + ((landPrice s) * n) } (-n)
prompt = "How many acres do you wish to sell (0-" ++ (show maxN) ++ ")? [" ++ (show defaultN) ++ "] "
defaultN = 0
maxN = land s
validate n
| n < 0 = Abort abortMessage
| n > maxN = Retry $ printf "Hammurabi: Think again. You have only %d acres. Now then," maxN
| otherwise = Accept n

feedPeople :: GameState -> Int -> IO Orders
feedPeople s acresToBuy
| maxN <= 0 = plantFields s acresToBuy 0
| otherwise = do
choice <- readValidatedNum prompt validate defaultN
case choice of
Nothing -> return Quit
Just n -> plantFields s { food = (food s) - n } acresToBuy n
prompt = "How many bushels do you wish to feed your people (0-" ++ (show maxN) ++ ")? [" ++ (show defaultN) ++ "] "
defaultN = min maxN (20 * (people s))
maxN = food s
validate n
| n < 0 = Abort abortMessage
| n > maxN = Retry $ printf "Hammurabi: Think again. You have only %d bushels of grain. Now then," maxN
| otherwise = Accept n

plantFields :: GameState -> Int -> Int -> IO Orders
plantFields s acresToBuy bushelsToFeed
| maxN <= 0 = return (Orders acresToBuy 0 bushelsToFeed)
| otherwise = do
choice <- readValidatedNum prompt validate defaultN
case choice of
Nothing -> return Quit
Just n -> return (Orders acresToBuy n bushelsToFeed)
prompt = "How many acres do you wish to plant with seed (0-" ++ (show maxN) ++ ")? [" ++ (show defaultN) ++ "] "
defaultN = maxN
maxN = min landAvailable (min (2 * foodAvailable) (10 * (people s)))
landAvailable = land s
foodAvailable = food s
validate n
| n < 0 = Abort abortMessage
| n > landAvailable = Retry $ printf "Hammurabi: Think again. You own only %d acres. Now then," landAvailable
| n > 2 * foodAvailable = Retry $ printf "Hammurabi: Think again. You have only %d bushels of grain. Now then," foodAvailable
| n > 10 * (people s) = Retry $ printf "But you have only %d people to tend the fields. Now then," (people s)
| otherwise = Accept n

finalReport :: GameState -> String
finalReport s =
"In your " ++ show numYears ++ "-year term of office, " ++
show (round (100.0 * avgDeathRate)) ++ " percent of the\n" ++
"population starved per year on average, i.e., " ++
"a total of " ++ show numDeaths ++ " people died!!\n" ++
"You started with 10 acres per person and ended with " ++
show (round acresPerPerson) ++ " acres per person.\n" ++

numYears = year s
numPeople = people s
numAcres = land s
numDeaths = totalDeaths s
avgDeathRate = (cumDeathRate s) / (fromIntegral numYears)
acresPerPerson = (fromIntegral numAcres) / (fromIntegral numPeople)
| avgDeathRate > 0.33 || acresPerPerson < 7 = finkMessage
| avgDeathRate > 0.1 || acresPerPerson < 9 =
"Your heavy-handed performance smacks of Nero and Ivan IV.\n" ++
"The people (remaining) find you an unpleasant ruler, and,\n" ++
"frankly, hate your guts!\n"
| avgDeathRate > 0.03 || acresPerPerson < 10 =
"Your performance could have been somewhat better, but\n" ++
"really wasn't too bad at all. " ++
show numHaters ++ " people would\n" ++
"dearly like to see you assassinated but we all have our\n" ++
"trivial problems.\n"
| otherwise =
"A fantastic performance!!! Charlemagne, Disraeli, and\n" ++
"Jefferson combined could not have done better!\n"
(numHaters, _) = randomR (0, (numPeople * 4) `div` 5) (rng s)

readValidatedNum :: String -> (Int -> ValidateResult Int) -> Int -> IO (Maybe Int)
readValidatedNum prompt validate defaultValue = do
putStr prompt
hFlush stdout
line <- getLine
case maybeRead line of
Nothing -> return (Just defaultValue)
Just n ->
case validate n of
Accept n -> return (Just n)
Abort s -> do
putStrLn s
return Nothing
Retry s -> do
putStrLn s
readValidatedNum prompt validate defaultValue

maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
[(x, str)] | all isSpace str -> Just x
_ -> Nothing

chooseNewLandPrice :: GameState -> GameState
chooseNewLandPrice s = s { landPrice = newLandPrice, rng = newRng }
where (newLandPrice, newRng) = randomR (17, 26) (rng s)

initialState :: StdGen -> GameState
initialState rng = GameState {
year = 0,
people = 100,
food = 2800,
land = 1000,
landPrice = 0,
totalDeaths = 0,
cumDeathRate = 0,
rng = rng }

initialResults :: Results
initialResults = Results 0 0 5 200 3

abortMessage :: String
abortMessage = "Hammurabi: I cannot do what you wish!\nGet yourself another steward!!!!!"

finkMessage :: String
finkMessage =
"Due to this extreme mismanagement you have not only\n" ++
"been impeached and thrown out of office but you have\n" ++
"also been declared 'National Fink' !!\n"

I've tried to mimic the original functionality as closely as possible. One small addition I made was for the program to print the range of valid input numbers after a question, as well as a default number which will be used if the player just presses Enter. This makes play a bit quicker.

It really bothers me that this program is so much longer than the original. I expect newer languages to have more power for making programs easy to write and read. If you have any concrete suggestions about how to improve/shorten this code (preferably with code snippets) I would love to hear them in the comments. I know this is pretty bad code.

I've separated getting instructions from the player from updating the game state. This allows the state update to be a pure function, but also means that some of the game state update has to be simulated during the process of getting instructions, so as to predict (for example) how much grain will be available for planting after feeding people. This causes some duplication of code.

The getting-instructions part is messy; you can see four very-similarly-shaped functions named buyLand, sellLand, feedPeople, and plantFields. These correspond to the four questions asked of the player. I'd like to find a way to extract more common structure from these since they are so similar.

The question-asking functions are chained so that each calls the next, if it is necessary to go on; the last one returns the completed Orders data structure. I don't like this structure; I'd prefer one where the questions were posed more independently. Unfortunately it is possible for the game to end immediately if the player ends a negative number which complicates control flow.

I will do a Python version of this some time. I expect it will turn out a bit longer than the BASIC due to using reasonable names for things but it will likely not be anywhere near this much longer.

This week I have also become infatuated with Mike Singleton's 1984 ZX Spectrum game The Lords of Midnight. I've been playing Davor Cubranic's Java port of it. is a website with lots of good info about how to play the game or its sequel.

Lords of Midnight is kind of a precursor to games like Heroes of Might and Magic, where the player commands armies led by heroes across a map. The big innovation in Lords of Midnight is that everything's done from a first-person perspective. This is of mixed benefit: it's more immediate, but you will find yourself playing primarily from a map (which you would have drawn on graph paper, in the old days) anyway. Everybody loves the 3D, with the people and the sunsets and the arrows flying right at my eye! but so often it just isn't the best perspective.

The other novel thing, again with middling success, is that it attempts to give situational reports in prose, as you can see in the screenshot. This is something that I think could be greatly improved and could actually prove useful. In this style of game you have to cycle through all your living heroes at least once per day to move them. It can be difficult to remember just who has done what, and where they're headed. A summary paragraph could be really nice.


Peaker said...

I posted some refactoring advice in a Reddit comment.

Greg M said...

At a cursory skim: most well-written Haskell programs of this size have one or perhaps two top-level functions with an IO type. Maybe if you refactor that way first, it'll help you find a sense of functional style? Then let the functionalness trickle down. :) This translation is much too faithful to the original imperative style to gain much from Haskell's advantages.

Yair said...

I also posted some code in a Reddit comment..

MaybeT rids us of annoying indentation, and StateT rids us much mess :)

all.things.counter.original.spare.strange said...

Cool! Of course I was impeached about 5 steps into it... I'll see if my daughter can do better...

Since you were worried about size, before I compiled, I cut out the type signatures, changed to bracketed record syntax, and omitted the double newlines - none of which are found in the Basic version - and the line number fell to 211 - still almost twice as long...

Then, in the spirit of the benchmark competition carpers, I compressed ham.hs and ham.bas (the one from wieghed in at 3405 bytes, weighed in 2337. Not TOO bad....

The size of the executables is completely misleading, but I don't understand this: Haskell executables always include some of the standing runtime stuff and so on.

Experts could explain. But for example, a "Hello world" program (i.e.
Module Hello where
main = putStrLn "Hello World!" ) compiles to about half a megabyte on my mac.

So look at it this way, your Haskell Hamurabi executable is only three times the size of a Hello World executable....

James McNeill said...

Peaker and Yair: Thanks for the comment threads, especially Yair's rewrite. I'm studying that now to, among other things, learn how to use the state monad. I'm still at the awkward stage where I have trouble forming syntax that the compiler will accept.

I don't begrudge the Haskell solutions their expansive layout, which is why I included file size in my comparisons. Ease of reading and writing are paramount. In my head there is a high-school version of me, typing in listings out of a "Book of Haskell Games" he got from the library.

One thing that is interesting in my comparison of BASIC vs. Haskell: it seems like there are many, many more operators and library functions coming into play in the Haskell solutions. This may present a barrier to accessibility.

Yair said...

James: I further refactored it to make it a base for adding an undo feature as an example to my list monad transformer. see