Eurosong game predictor - See http://games.usvsth3m.com/eurosong/

Main.hs

module Main where

import Control.Applicative ((<$>))
import Control.Monad (replicateM)
import Text.Read (readMaybe)
import Data.Maybe (fromJust)
import System.IO (hFlush, stdout)
import Text.Printf (printf)
import Data.List (genericLength)


-- Gets around the FlexibleInstances restriction
newtype Ints = Ints { getInts :: [Int] } deriving Show

-- Defines how, to show qualities in a user friendly manner
class Show a => ShowQuality a where
    showQuality :: a -> String
    showQuality = show

instance ShowQuality Int
instance ShowQuality Bool
-- Sum arrays for ease of comperhension
instance ShowQuality Ints where
    showQuality = show . sum . getInts


chooseCostume :: Bool -> IO (Int, Int)
chooseCostume = pickProp "Which dress? " [("Orange Sequins"  , -1)
                                         ,("Blue Sequins"    , 1)
                                         ,("Purple Sequins"  , 1)
                                         ,("Cyan Jumpsuit"   , 1)
                                         ,("Pink Jumpsuit"   , -1)
                                         ,("Green Jumpsuit"  , -1)
                                         ,("White Leather"   , -1)
                                         ,("Red Leather"     , 1)
                                         ,("Black Leather"   , 1)
                                         ,("See-through"     , -1)
                                         ,("Polish Milkmaid" , 1)]


chooseTopic :: Bool -> IO (Int, Int)
chooseTopic = pickProp "Which topic? " [("Peace"    , -1)
                                       ,("Love"     , 1)
                                       ,("Freedom"  , -1)
                                       ,("Cake"     , 1)
                                       ,("Sunshine" , 1)
                                       ,("Kittens"  , 1)
                                       ,("Internet" , 1)
                                       ,("Grandma"  , -1)
                                       ,("Football" , -1)
                                       ,("Europe"   , -1)]


chooseMusic :: Bool -> IO (Int, Int)
chooseMusic = pickProp "Which genre? " [("Glam Rock"     , -1)
                                       ,("Power Ballad"  , 1)
                                       ,("R&B"           , 1)
                                       ,("’70s Disco"    , -1)
                                       ,("Celtic"        , 1)
                                       ,("Europop"       , 1)
                                       ,("Reggae"        , -1)
                                       ,("50s Rock&Roll" , -1)
                                       ,("’90s Dance"    , 1)
                                       ,("Country"       , -1)]


choosePreformer :: Bool -> IO (Int, Int)
choosePreformer = pickProp "Which performer? " [("Long blond hair, woman",           1)
                                               ,("Long brown hair, woman",          -1)
                                               ,("Long red hair, woman",            -1)
                                               ,("Black, black hair, woman",         1)
                                               ,("Punk woman",                      -1)
                                               ,("Blond short hair, woman",          1)
                                               ,("Bearded, brown hair, man",         1)
                                               ,("Red hair, man",                   -1)
                                               ,("Black, bald, something",           1)
                                               ,("Mustache, black hair, man",       -1)
                                               ,("Bearded, long brown hair, woman",  2)]


chooseExtra :: Bool -> IO (Int, Int)
chooseExtra = pickProp "Which extra? " [("None"           , 0)
                                       ,("Headphones"     , 1)
                                       ,("Red Nose"       , -1)
                                       ,("Contact Lenses" , -1)
                                       ,("New Teeth"      , 1)
                                       ,("Gold Chain"     , 1)
                                       ,("Studded Collar" , -1)
                                       ,("Glam Make-up"   , -1)
                                       ,("Sunglasses"     , 1)]


chooseEffect :: Bool -> IO (Int, Int)
chooseEffect = pickProp "Which gimmick? " [("Bucks Fizz  ",  1)
                                          ,("Flying",        1)
                                          ,("Darkness",     -1)
                                          ,("Green Screen", -1)
                                          ,("Lasers",        1)
                                          ,("Riverprance",  -1)
                                          ,("Candles",      -1)
                                          ,("Balloons",     -1)
                                          ,("Rainbow",       1)
                                          ,("Smartphone",    1)]


chooseCountry :: Bool -> IO (Int, Ints)
chooseCountry = pickProp "Which country? " [("Utd Kingdom", Ints [10,5,8,3,7,3,1,2,4,2,4,3,3,1])
                                           ,("Ireland",     Ints [10,5,5,5,5,3,6,5,5,7,4,3,3,4])
                                           ,("Israel",      Ints [6,6,5,5,5,4,5,5,5,5,3,5,3,5])
                                           ,("Malta",       Ints [6,6,5,6,5,5,5,5,5,7,6,4,5,2])
                                           ,("France",      Ints [4,4,4,7,6,8,8,2,3,8,5,3,6,3])
                                           ,("Spain",       Ints [5,5,5,6,4,7,8,5,4,6,6,5,6,5])
                                           ,("Italy",       Ints [3,3,5,9,7,6,6,5,4,7,5,5,5,4])
                                           ,("Germany",     Ints [4,4,5,3,8,4,5,5,4,7,5,4,6,6])
                                           ,("Russia",      Ints [4,4,5,3,4,6,5,2,9,4,4,10,5,5])
                                           ,("Latvia",      Ints [3,4,5,3,5,5,5,3,7,3,6,9,3,8])
                                           ,("Luxembourg",  Ints [1,5,5,6,7,6,5,5,5,5,5,5,5,5])
                                           ,("Greece",      Ints [4,4,5,5,4,6,8,2,5,5,5,6,5,6])
                                           ,("Ukraine",     Ints [3,3,5,4,3,3,5,6,10,8,3,6,5,6])
                                           ,("Sweden",      Ints [9,6,5,3,4,4,5,7,3,4,3,5,5,10])
                                           ,("Finland",     Ints [8,6,5,4,5,4,5,6,3,4,3,6,3,10])]


-- Ask user for number of performers and get their qualities
pickPerformers :: Bool -> IO ([Int], Int)
pickPerformers sq = do hm <- fromJust <$> loopWhile (maybeInRange 1 5) ask
                       (pn, pq) <- unzip <$> replicateM hm (choosePreformer sq)
                       return (pn, floor $ avarage pq)
    where ask = readMaybe <$> prompt "How many performers (1-4)? "


-- Save various propeerties as hash string
-- Pass array in this order [country, music, topic, effect]
-- Followed by performers, costume, extra
urlSave :: [Int] -> [Int] -> Int -> Int -> String
urlSave nm ps co ex = concat [tosigns nm, addblank ps, repl co, repl ex, "Z"]
    where tosigns = map ("0123456789ABCDEF_" !!)
          addblank nb = tosigns . take 4 $ nb ++ replicate 4 16
          repl i = addblank $ replicate (length ps) i


main :: IO ()
main = do sq <- snd <$> showQualities False
          (country,    countryq)    <- chooseCountry sq
          (performers, performersq) <- pickPerformers sq
          (music,      musicq)      <- chooseMusic sq
          (topic,      topicq)      <- chooseTopic sq
          (costume,    costumeq)    <- chooseCostume sq
          (extra,      extraq)      <- chooseExtra sq
          (effect,     effectq)     <- chooseEffect sq
          let adjust = sum [performersq, musicq, topicq, costumeq, extraq, effectq] - 2
              vote    = sum . map (adjustvote adjust) $ getInts countryq
              hash    = urlSave [country, music, topic, effect] performers costume extra
          putStrLn $ "Score: " ++ show vote
          putStrLn $ "Url: http://games.usvsth3m.com/eurosong/#" ++ hash
    where adjustvote ad vo
            | av < 1     = 0
            | av >= 10   = 12
            | av == 9    = 10
            | otherwise  = av
            where av = ad + vo
          showQualities = pickProp "Show qualities? " [("Show hidden qualities",       True)
                                                      ,("Don't show hidden qualities", False)]


-- Repeat an IO action while a function returns false
loopWhile :: (a -> Bool) -> IO a -> IO a
loopWhile f a = a >>= \r -> if f r then return r else loopWhile f a


inRange :: Ord a => a -> a -> a -> Bool
inRange f t n
    | n < f     = False
    | n >= t    = False
    | otherwise = True


maybeInRange :: (Ord a) => a -> a -> Maybe a -> Bool
maybeInRange s t = maybe False (inRange s t)


-- Nicely ask user for something
prompt :: String -> IO String
prompt s = putStr s >> hFlush stdout >> getLine


-- Get avarage of an array of reals
avarage :: Real a => [a] -> Double
avarage xs = realToFrac (sum xs) / genericLength xs


-- Print all the properties user can pick
showProps :: ShowQuality a => [(String, a)] -> Bool -> IO ()
showProps ps sq = mapM_ showp $ zipWith (\i (n,v) -> (i,n,v)) [0..] ps
    where showp :: (ShowQuality a) => (Int, String, a) -> IO ()
          showp (i, n, q)
            | sq        = printf "%d. %s (%s)\n" i n $ showQuality q
            | otherwise = printf "%d. %s\n" i n


-- Pick on property and it's quality from a list
pickProp :: ShowQuality a => String -> [(String, a)] -> Bool -> IO (Int, a)
pickProp pro ps sq = do showProps ps sq
                        num <- fromJust <$> loopWhile (maybeInRange 0 $ length ps) ask
                        return (num, snd $ ps !! num)
    where ask = readMaybe <$> prompt pro