{-# LANGUAGE OverloadedStrings, TupleSections #-}

-- Napstablook (/ˈnæpstəˌbluːk/ or /ˈnæpstəˌblʊk/), known in the UnderNet as
-- NAPSTABLOOK22, is a melancholic ghost monster and musician/DJ who lives in
-- Waterfall, encountered in the Ruins as the game's first miniboss.

import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM_, mapM_)
import Control.Monad.Trans.State
import Data.Aeson (FromJSON(..), (.:), (.:?), decode, Value(..))
import Data.Char (isSpace, toLower, isPunctuation)
import Data.List (minimumBy)
import Data.Map (Map)
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime, NominalDiffTime, getCurrentTime, addUTCTime)
import Network.Zephyr
import System.Environment (getArgs)
import System.IO (hClose)
import System.Process (CreateProcess(..), createProcess, proc, StdStream(..))
import System.Random (randomRIO)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

getBody :: ZNotice -> Maybe Text
getBody notice = case z_fields notice of
    (_:x:_) -> Just $ decodeUtf8With lenientDecode x
    _ -> Nothing

lowerWordAndRest :: Text -> (Text, Text)
lowerWordAndRest txt = (T.toLower firstWord, maybe "" snd $ T.uncons notFirstWord)
    where (firstWord, notFirstWord) = T.break isSpace txt

isNapstaName :: Text -> Bool
isNapstaName "napsta" = True
isNapstaName "napstablook" = True
isNapstaName "napstablook22" = True
isNapstaName "stabby" = True
isNapstaName "blooky" = True
isNapstaName _ = False

-- rip why doesn't Text have unsnoc
isNapstaInvocation :: Text -> Bool
isNapstaInvocation "" = False
isNapstaInvocation txt = isNapstaName (T.init txt) && isPunctuation (T.last txt)

getNapstaMessage :: Text -> Maybe Text
getNapstaMessage body = if isNapstaInvocation word then Just msg else Nothing
    where (word, msg) = lowerWordAndRest body

data Song = Song { songUrl :: Text
                 , songTags :: [Text]
                 , songStart :: Maybe Text
                 , songStop :: Maybe Text
                 , songTitle :: Text
                 } deriving (Show, Eq, Ord)

instance FromJSON Song where
    parseJSON (Object v) = Song <$>
                           v .: "url" <*>
                           fmap T.words (v .: "tags") <*>
                           v .:? "start" <*>
                           v .:? "stop" <*>
                           v .: "title"

cooldownDiffTime :: NominalDiffTime
cooldownDiffTime = -12 * 60 * 60

loadSongs :: IO [Song]
loadSongs = do
    f <- L.readFile "napsta.json"
    return . fromJust $ decode f

hasTag :: Text -> Song -> Bool
hasTag tag song = tag `elem` songTags song

-- TODO: we can get by with an Int id or something, right?
type Napstate = Map Song (Maybe UTCTime)

makeInitialNapstate :: [Song] -> Napstate
makeInitialNapstate = Map.fromList . map (,Nothing)

getSongs :: Napstate -> [Song]
getSongs = Map.keys

getLastPlayed :: Napstate -> Song -> Maybe UTCTime
getLastPlayed = (Map.!)

getPlayedAtState :: Napstate -> Song -> UTCTime -> Napstate
getPlayedAtState nst song now = Map.insert song (Just now) nst

pickSong :: (IsString s) => Napstate -> (Song -> Bool) -> IO (Either s Song, Napstate)
pickSong nst predic = do
    let songs = filter predic $ getSongs nst
    if null songs
        then return (Left "no songs found :(", nst)
        else do
            now <- getCurrentTime
            let coldThreshold = addUTCTime cooldownDiffTime now
            -- songs that haven't been played recently, or at all
            let coldSongs = filter (maybe True (< coldThreshold) . getLastPlayed nst) songs

            song <- if null coldSongs
                then return $ minimumBy (comparing $ getLastPlayed nst) songs
                else do
                    rix <- randomRIO (0, length coldSongs - 1)
                    return $ coldSongs !! rix

            let nst' = getPlayedAtState nst song now
            return (Right song, nst')

pickUniqueSong :: (IsString s) => Napstate -> (Song -> Bool) -> IO (Either s Song, Napstate)
pickUniqueSong nst predic = do
    let songs = filter predic $ getSongs nst
    case songs of
        [song] -> do
            now <- getCurrentTime
            return (Right song, getPlayedAtState nst song now)
        [] -> return (Left "no songs found :(", nst)
        _ -> return (Left "more than one song found :(", nst)

parsePredicate :: Text -> Song -> Bool
parsePredicate "" = const True -- so "play something" plays arbitrarily
parsePredicate "normal" = parsePredicate "!weird"
parsePredicate txt = case T.uncons txt of
    Just ('!', txt') -> not . parsePredicate txt'
    _ -> hasTag txt

titleIncludes :: Text -> Song -> Bool
titleIncludes txt song = T.toCaseFold txt `T.isInfixOf` T.toCaseFold (songTitle song)

somehowRelated :: Text -> Song -> Bool
somehowRelated txt song = parsePredicate txt song || titleIncludes txt song

zsrTextForSong :: Song -> Text
zsrTextForSong song = songUrl song
    <> (maybe "" (" start=" <>) $ songStart song)
    <> (maybe "" (" stop="  <>) $ songStop  song)

playSong :: Song -> IO ()
playSong song = do
    TIO.putStrLn "about to print??"
    TIO.putStrLn $ zsrTextForSong song
    (Just hin, _, _, _) <- createProcess (proc "lp" ["-d", "sipbmp3"]) {
            env = Just [("CUPS_SERVER", "zsr.mit.edu")],
            std_in = CreatePipe
        }
    TIO.hPutStrLn hin $ zsrTextForSong song
    hClose hin

data SongCommand = SongCommand { songPredicate :: Song -> Bool, shouldBeUnique :: Bool }

parsePlayMessage :: Text -> SongCommand
parsePlayMessage txt = do
    let (wd, rst) = lowerWordAndRest txt
    case wd of
        "something" -> SongCommand (parsePredicate rst) False
        "the" -> do
            let (wd', rst') = lowerWordAndRest rst
            case wd' of
                "song" -> SongCommand (titleIncludes rst') True
                _ -> SongCommand (titleIncludes rst) True
        _ -> SongCommand (somehowRelated txt) False

-- Maybe Text is a possible error message. Unfortunately we need IO to
-- randomize (at least I'm too lazy to thread a more limited monad) so we can't
-- push IO further in.
executeSongCommand :: SongCommand -> Napstate -> IO (Napstate, Maybe Text)
executeSongCommand sc nst = do
    let predicate = songPredicate sc
    (maybeSong, nst') <- if shouldBeUnique sc
        then pickUniqueSong nst predicate
        else pickSong nst predicate
    print maybeSong
    case maybeSong of
        Left msg -> return (nst', Just msg)
        Right song -> do
            playSong song
            return (nst', Nothing)

pickNapstaZsig :: IO Text
pickNapstaZsig = do
    k <- (randomRIO (1, 4)) :: IO Int
    return $ case k of
        1 -> "are they gone yet"
        2 -> "sorry... i just made this more awkward..."
        3 -> "wait, ghosts can fly, can't they..."
        4 -> "oh well..."
        _ -> "oooooooooo"

respond :: ZNotice -> Text -> IO ()
respond notice msg = do
    zsig <- pickNapstaZsig
    sendNotice $ emptyNotice
        { z_class = z_class notice
        , z_instance = z_instance notice
        , z_recipient = ""
        , z_sender = Just "napstablook"
        , z_opcode = "auto"
        , z_kind = z_kind notice
        , z_fields = [encodeUtf8 zsig, encodeUtf8 msg]
        }

mainIterateForever :: Napstate -> IO ()
mainIterateForever nst = do
    notice <- receiveNotice
    let recipient = z_recipient notice
    let maybeBody = getBody notice
    let opcode = z_opcode notice
    -- let recipient = ""
    -- maybeBody <- fmap Just TIO.getLine
    -- let opcode = ""

    putStrLn "received"
    nextNst <- case (recipient, B.map toLower opcode, maybeBody) of
        (_, _, Nothing) -> do
            putStrLn "no body! oooo"
            return nst
        (_, "auto", _) -> do
            putStrLn "not responding to auto opcode"
            return nst
        ("", _, Just body) -> do
            print body
            case getNapstaMessage body of
                Nothing -> do
                    print $ lowerWordAndRest body
                    print "nothing..."
                    return nst
                Just nmsg -> case lowerWordAndRest $ T.strip nmsg of
                    ("play", playMsg) -> do
                        let cmd = parsePlayMessage playMsg
                        (nst', maybeMsg) <- executeSongCommand cmd nst
                        print maybeMsg
                        case maybeMsg of
                            Nothing -> respond notice "ok!"
                            Just msg -> respond notice msg
                        return nst'
                    _ -> do
                        putStrLn "really not feelin up to it right now. sorry."
                        respond notice "really not feelin up to it right now. sorry."
                        return nst
        _ -> do
            putStrLn "personal message, skipping"
            return nst
    mainIterateForever nextNst

cliIterateForever :: Napstate -> IO ()
cliIterateForever nst = do
    nmsg <- TIO.getLine
    nextNst <- case lowerWordAndRest $ T.strip nmsg of
        ("play", playMsg) -> do
            let cmd = parsePlayMessage playMsg
            (nst', maybeMsg) <- executeSongCommand cmd nst
            print maybeMsg
            return nst'
        _ -> do
            putStrLn "really not feelin up to it right now. sorry."
            return nst
    cliIterateForever nextNst

main :: IO ()
main = do
    args <- getArgs
    putStrLn "loading songs"
    songs <- loadSongs
    let nst = makeInitialNapstate songs
    putStrLn "songs loaded (?)"
    initialize
    putStrLn "initialized"
    putStrLn "waiting..."
    case args of
        [] -> do
            subscribeTo [ZSubscription "bpchen" "*" "*"]
            putStrLn "subbed..."
            mainIterateForever nst
        ["cli"] -> cliIterateForever nst
        _ -> error "unrecognized args"