Skip to content

@gelisam /Main.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Example Haskell implementation requested by SrPeixinho.
-- In response to [1].
--
-- I am aiming for readability, not conciseness. Nevertheless, a note
-- explaining why the original javascript code is so much shorter:
-- Javascript skips all error checking unless you perform explicit checks.
-- Haskell enforces all error checking unless you explicitly ignore errors.
-- I have thus implemented many wrapping functions whose purpose is to use
-- incomplete pattern-matching to ignore errors.
--
-- I am using the aeson package for JSON and the download-curl package for
-- network access. I haven't used either library before, so that part might
-- not be idiomatic.
--
-- [1] http://www.reddit.com/r/haskell/comments/1zy7ut/how_would_this_program_be_implemented_in_haskell/
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Control.Concurrent as C
import qualified Data.Aeson as Json
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HashMap
import qualified Network.Curl.Download as Curl
import qualified System.Random as R
import Control.Applicative
import Control.Monad
import Text.Printf
-- sleep uses seconds, instead of threadDelay's unintuitive microseconds.
sleep :: Double -> IO ()
sleep seconds = C.threadDelay (floor (1000000 * seconds))
-- pick a random element from a list, crashing if the list is empty.
randomFrom :: [a] -> IO a
randomFrom xs = do
i <- R.randomRIO (0, length xs - 1)
return (xs !! i)
-- a version of Json.fromJSON which crashes on error.
fromJson :: Json.FromJSON a => Json.Value -> a
fromJson v = let Json.Success x = Json.fromJSON v in x
-- a version of Json.(.:) usable outside of FromJSON instances.
(.:) :: Json.FromJSON a => Json.Value -> T.Text -> a
Json.Object o .: key = let defaultValue = error "key not found"
value = HashMap.lookupDefault defaultValue key o
in fromJson value
type RestURL = String
type FullURL = String
pokemonUrl :: Int -> RestURL
pokemonUrl = printf "/api/v1/pokemon/%d"
wrapRestUrl :: RestURL -> FullURL
wrapRestUrl = printf "http://viclib.com/pokemon?query=%s"
-- download a URL, crashing on error.
downloadByteString :: FullURL -> IO B.ByteString
downloadByteString url = do
Right contents <- Curl.openURI url
return contents
-- fetch some JSON, crashing on error.
downloadJson :: FullURL -> IO Json.Value
downloadJson url = do
Just json <- Json.decodeStrict <$> downloadByteString url
return json
getRandomPokemon :: IO Json.Value
getRandomPokemon = do
pokemon_number <- R.randomRIO pokemonRange
let url = pokemonUrl pokemon_number
downloadJson (wrapRestUrl url)
where
-- only use first-generation Pokémons.
--
-- BUGFIX: the javascript version sometimes requests Pokémon number 0,
-- which doesn't exist.
pokemonRange :: (Int, Int)
pokemonRange = (1, 151)
getRandomMove :: [Json.Value] -> IO Json.Value
getRandomMove moveset = do
move <- randomFrom moveset
let url = move .: "resource_uri"
downloadJson (wrapRestUrl url)
main :: IO ()
main = do
-- Find random Pokémon
pokemon <- getRandomPokemon
let pokemon_name = pokemon .: "name" :: String
printf "Wild %s appeared!\n" pokemon_name
-- Download 4 moves from valid moveset
let moveset = pokemon .: "moves" :: [Json.Value]
moves <- replicateM 4 (getRandomMove moveset)
-- Every 1.5 seconds it attacks you
let loop hp move_count = unless (hp <= 0) $ do
move <- randomFrom moves
let move_name = move .: "name" :: String
let max_dmg = move .: "power"
* (pokemon .: "attack" + pokemon .: "sp_atk")
`div` 300
dmg <- R.randomRIO (0, max_dmg)
let hp' = hp - dmg :: Int
let move_count' = move_count + 1 :: Int
printf "%s attacked you with *%s* dealing %d damage!\n"
pokemon_name move_name dmg
if hp' > 0
then printf "You have %d hp!\n" hp'
else printf "%s defeated you in %d moves.\n" pokemon_name move_count
sleep 1.5
loop hp' move_count'
loop 200 0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.