mitchellwrosen/invoker.hs

## invoker.hs
#!/usr/bin/env stack
{- stack --resolver lts-9.5 runghc
     --package clock
     --package fgl
     --package random
     --package reactive-banana
     --package vty
-}

{-# language LambdaCase          #-}
{-# language RecursiveDo         #-}
{-# language ScopedTypeVariables #-}

import Control.Concurrent
import Control.Monad
import Data.Char (toUpper)
import Data.Foldable (minimumBy)
import Data.Graph.Inductive.Graph (LEdge, LNode)
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.List.NonEmpty (NonEmpty((:|)), toList)
import Data.Ord (comparing)
import Reactive.Banana
import Reactive.Banana.Frameworks
import System.Clock
import System.Random (randomIO, randomRIO)
import Text.Printf (printf)

import qualified Data.Graph.Inductive.Graph as Graph
import qualified Data.Graph.Inductive.Query.BFS as Graph (lesp)
import qualified Graphics.Vty as Vty


--------------------------------------------------------------------------------
-- User config
--
-- Modify these values directly to suit your preferences!

keyQuas   = 'q'
keyWex    = 'w'
keyExort  = 'e'
keyInvoke = 'r'
keySpell1 = 't'
keySpell2 = 'd'


--------------------------------------------------------------------------------
-- Main

type Nanoseconds
  = Integer

version :: Int
version = 1

main :: IO ()
main = do
  -- Boilerplate vty-handle initialization.
  vty <- Vty.mkVty =<< Vty.standardIOConfig

  -- Initlaize two events external to the FRP network: key presses and an
  -- elapsed-time ticker.
  (elapsedAddHandler, fireElapsed) <- newAddHandler
  (keyAddHandler, fireKey) <- newAddHandler

  network <- compile $ mdo
    -- Event that fires with the total number of nanoseconds that have passed
    -- since the program began.
    eElapsed :: Event Nanoseconds <-
      fromAddHandler elapsedAddHandler

    -- Total elapsed time.
    bElapsed :: Behavior Nanoseconds <-
      stepper 0 eElapsed

    -- Event that fires every key press.
    eKey :: Event Key <-
      fromAddHandler keyAddHandler

    -- The total number of keys pressed.
    bPresses :: Behavior Int <-
      accumB 0 (succ <$ eKey)

    -- The total number of keys pressed, only updated when a challenge is
    -- completed (so the optimality percentage doesn't continually drop *during*
    -- a challenge, then rise when the challenge is completed). +1 for the
    -- actual spell cast.
    bPresses' :: Behavior Int <-
      stepper 0 (succ <$> bPresses <@ eNewChallenge)

    -- Is this a "new challenge", i.e. a challenge during which no key has been
    -- pressed yet?
    bIsNewChallenge :: Behavior Bool <-
      stepper True
        (unionWith const
          (True <$ eNewChallenge)
          (False <$ whenE bIsNewChallenge eKey))

    -- The keys pressed this challenge (reverse order). At the moment a new
    -- challenge is created, this still holds the keys pressed for the old
    -- challenge. This is so the keys don't clear immediately, and the user can
    -- compare his/her solution to the optimal one.
    bPressedKeys :: Behavior [Key] <- do
      let updatePressedKeys :: Bool -> Key -> [Key] -> [Key]
          updatePressedKeys isNewChallenge key oldKeys =
            if isNewChallenge
              then [key]
              else key : oldKeys

      accumB [] (updatePressedKeys <$> bIsNewChallenge <@> eKey)

    -- The orbs currently swirling Invoker.
    bOrbs :: Behavior Orbs <-
      accumB Orbs0 (castOrb <$> filterJust (keyToOrb <$> eKey))

    -- The currently-invoked spells.
    bInvoked :: Behavior Invoked <- do
      let -- An event that fires every time the "invoke" key is pressed.
          eKeyInvoke :: Event Key
          eKeyInvoke = filterE (== KeyInvoke) eKey

      let -- An event that fires every time a spell is invoked.
          eInvoke :: Event Spell
          eInvoke = filterJust (orbsToSpell <$> bOrbs <@ eKeyInvoke)

      accumB Invoked0 (invokeSpell <$> eInvoke)

    -- An event that fires whenever a spell is cast (assuming auto-cast, i.e.
    -- the spell is cast right when the hotkey is pressed).
    let eCast :: Event Spell
        eCast = unionWith const eCast1 eCast2
         where
          eCast1 :: Event Spell
          eCast1 =
            filterJust (castSpell1 <$> bInvoked <@ filterE (== KeySpell1) eKey)

          eCast2 :: Event Spell
          eCast2 =
            filterJust (castSpell2 <$> bInvoked <@ filterE (== KeySpell2) eKey)

    -- An event that fires whenever the challenge spell is cast.
    let eCorrectCast :: Event Spell
        eCorrectCast = filterApply bIsCorrectCast eCast
         where
          bIsCorrectCast :: Behavior (Spell -> Bool)
          bIsCorrectCast = isCorrectCast <$> bChallenge

          isCorrectCast :: Challenge -> Spell -> Bool
          isCorrectCast challenge spell = challengeSpell challenge == spell

    -- Responses to spells cast.
    eResponse :: Event String <-
      eResponseGen bElapsed eCast

    -- The latest response to a spell, which gets zeroed out when a spell is
    -- cast but no response is used. This way, we don't leave responses to old
    -- spells around.
    bResponse :: Behavior (Maybe String) <- do
      let eYesResponse :: Event (Maybe String)
          eYesResponse = Just <$> eResponse

      let eNoResponse :: Event (Maybe String)
          eNoResponse = Nothing <$ eCast

      -- The ordering is important here - 'eYesResponse' is always coincident
      -- with 'eNoResponse', but we want it to take precedence.
      stepper Nothing (unionWith const eYesResponse eNoResponse)

    -- The total number of correct spells cast.
    eCorrectCastCount :: Event Integer <-
      accumE 0 (succ <$ eCorrectCast)
    bCorrectCastCount :: Behavior Integer <-
      stepper 0 eCorrectCastCount

    -- The first challenge.
    challenge0 :: Challenge <-
      liftIO randomChallenge

    -- The current challenge.
    bChallenge :: Behavior Challenge <-
      stepper challenge0 (unionWith const eStepChallenge eNewChallenge)

    -- Partition correct spell casts into two cases: mid-challenge spells, which
    -- cause the challenge to simply step forward, and the last spell, which
    -- causes a new random challenge to be generated.
    --
    -- These two events are never coincident.
    (eStepChallenge :: Event Challenge, eNewChallenge :: Event Challenge) <- do
      let nextChallenge :: Challenge -> MomentIO (Either Challenge Challenge)
          nextChallenge challenge =
            case stepChallenge challenge of
              Nothing -> liftIO (Right <$> randomChallenge)
              Just challenge -> pure (Left challenge)

      split <$> execute (nextChallenge <$> bChallenge <@ eCorrectCast)

    -- Event that fires with the optimal way to complete the new challenge.
    let eOptimalKeys :: Event [Key]
        eOptimalKeys =
          optimalChallenge <$> bOrbs <*> bInvoked <@> eNewChallenge

    -- The optimal way to complete the current challenge.
    bOptimalKeys :: Behavior [Key] <-
      stepper (optimalChallenge Orbs0 Invoked0 challenge0) eOptimalKeys

    bOptimalKeys' :: Behavior (Maybe [Key]) <-
      stepper Nothing
        (unionWith const
          (Just <$> bOptimalKeys <@ eNewChallenge)
          (Nothing <$ whenE bIsNewChallenge eKey))

    -- The optimal number of presses of all challenges completed thus far.
    bOptimalPresses :: Behavior Int <- do
      let add :: [Key] -> Int -> Int
          add keys n = length keys + n

      accumB 0 (add <$> bOptimalKeys <@ eNewChallenge)

    -- Spells per second.
    bRate :: Behavior Float <- do
      let bCalculateRate :: Behavior (Integer -> Float)
          bCalculateRate = f <$> bElapsed
           where
            f :: Nanoseconds -> Integer -> Float
            f _ 0 = 0
            f ns n = 1000 / realToFrac (ns `div` 1000000 `div` n)

      -- Event that fires with the current rate every time a correct spell
      -- is cast (for immediate feedback).
      let eRate1 :: Event Float
          eRate1 = bCalculateRate <@> eCorrectCastCount

      -- Event that fires with the current rate every tick.
      let eRate2 :: Event Float
          eRate2 = bCalculateRate <*> bCorrectCastCount <@ eElapsed

      -- Combining function (const) doesn't matter here, because 'eRate1' and
      -- 'eRate2' will never be coincident.
      stepper 0 (unionWith const eRate1 eRate2)

    -- Render an image.
    let render :: Vty.Image -> IO ()
        render = Vty.update vty . Vty.picForImage

    let bScene :: Behavior Vty.Image
        bScene =
          drawScene <$> bChallenge <*> bResponse <*> bOrbs <*> bInvoked <*>
            bPresses' <*> bOptimalPresses <*> bPressedKeys <*> bOptimalKeys' <*>
            bRate

    eScene :: Event (Future Vty.Image) <-
      changes bScene

    -- Render the very first scene *now*, since it is not captured by 'changes',
    -- and thus no corresponding scene event will fire.
    liftIO . render =<< valueB bScene

    -- Render every scene.
    reactimate' (fmap render <$> eScene)

  -- Activate the event network.
  actuate network

  -- Start a background thread that fires elapsed-time events forever.
  time0 <- getTime Monotonic
  void . forkIO . forever $ do
    time1 <- getTime Monotonic
    fireElapsed (toNanoSecs (diffTimeSpec time1 time0))
    threadDelay 500000

  let loop :: IO ()
      loop =
        Vty.nextEvent vty >>= \case
          Vty.EvKey Vty.KEsc [] -> Vty.shutdown vty
          Vty.EvKey (Vty.KChar c) []
            | c == keyQuas   -> fireKey KeyQuas   >> loop
            | c == keyWex    -> fireKey KeyWex    >> loop
            | c == keyExort  -> fireKey KeyExort  >> loop
            | c == keyInvoke -> fireKey KeyInvoke >> loop
            | c == keySpell1 -> fireKey KeySpell1 >> loop
            | c == keySpell2 -> fireKey KeySpell2 >> loop
            | otherwise      -> loop
          _ -> loop

  loop

-- Generate a spell-response 'Event'.
eResponseGen
  :: Behavior Nanoseconds    -- ^ Elapsed time
  -> Event Spell             -- ^ Spell cast
  -> MomentIO (Event String) -- ^ Spell reponses
eResponseGen bElapsed eCast = mdo
  -- Timestamps of the last time a particular response was used, or Nothing if
  -- it was never used.
  bSaidAt :: Behavior [(Spell, [(String, Maybe Nanoseconds)])] <- do
    -- Initialize to: every response to every spell is tagged with Nothing.
    let initialSaidAt :: [(Spell, [(String, Maybe Nanoseconds)])]
        initialSaidAt = do
          spell <- [minBound..maxBound]
          pure (spell, do
            resp <- spellResponses spell
            pure (resp, Nothing))

    -- When a response is used, adjust the corresponding timestamp.
    let updateSaidAt
          :: Nanoseconds                              -- Elapsed time
          -> (Spell, String)                          -- Spell and response
          -> [(Spell, [(String, Maybe Nanoseconds)])] -- Old said-at list
          -> [(Spell, [(String, Maybe Nanoseconds)])] -- New said-at list
        updateSaidAt elapsed (spell, response) =
          adjust (insert response (Just elapsed)) spell

    accumB initialSaidAt (updateSaidAt <$> bElapsed <@> eResponse)

  -- Event that emits each time a response is used.
  eResponse :: Event (Spell, String) <- do
    -- Convert each spell cast to a "possibly generate a response" computation.
    let eResponse0 :: Event (Maybe (MomentIO (Maybe (Spell, String))))
        eResponse0 = respond <$> bElapsed <*> bSaidAt <@> eCast

    -- Filter out the events that correspond to no responses being off cooldown.
    let eResponse1 :: Event (MomentIO (Maybe (Spell, String)))
        eResponse1 = filterJust eResponse0

    -- Execute each computation the moment it occurs.
    let eResponse2 :: MomentIO (Event (Maybe (Spell, String)))
        eResponse2 = execute eResponse1

    -- Filter out the events that correspond to randomly not responding 25% of
    -- the time.
    let eResponse3 :: MomentIO (Event (Spell, String))
        eResponse3 = filterJust <$> eResponse2

    eResponse3

  pure (snd <$> eResponse)

 where
  respond
    :: Nanoseconds                              -- Elapsed time
    -> [(Spell, [(String, Maybe Nanoseconds)])] -- Responses last said at
    -> Spell                                    -- Spell cast
    -> Maybe (MomentIO (Maybe (Spell, String))) -- Possibly generate a response
  respond elapsed saidAt spell =
    case filter offCooldown (lookupJust spell saidAt) of
      -- If no responses are off cooldown, don't generate a response.
      [] -> Nothing

      -- If at least one response is off cooldown, pick one randomly
      -- 75% of the time. (FIXME: Not all responses have 75% chance of
      -- being used, apparently).
      responses -> Just $ do
        let randomResponse :: MomentIO String
            randomResponse = liftIO (randomElem (map fst responses))

        n :: Double <- liftIO randomIO

        if n <= 0.75
          then (\response -> Just (spell, response)) <$> randomResponse
          else pure Nothing
   where
    offCooldown :: (String, Maybe Nanoseconds) -> Bool
    offCooldown (_, Nothing) = True
    offCooldown (_, Just t) = elapsed - t >= 60000000000


--------------------------------------------------------------------------------
-- Key

data Key
  = KeyQuas
  | KeyWex
  | KeyExort
  | KeyInvoke
  | KeySpell1
  | KeySpell2
  deriving (Eq, Show)

keyToChar :: Key -> Char
keyToChar = \case
  KeyQuas   -> toUpper keyQuas
  KeyWex    -> toUpper keyWex
  KeyExort  -> toUpper keyExort
  KeyInvoke -> toUpper keyInvoke
  KeySpell1 -> toUpper keySpell1
  KeySpell2 -> toUpper keySpell2


--------------------------------------------------------------------------------
-- Orb/Orbs

-- A single orb.
data Orb
  = Quas
  | Wex
  | Exort
  deriving (Bounded, Enum, Eq, Ord, Show)

-- Which 'Orb' does this 'Key' correspond to?
keyToOrb :: Key -> Maybe Orb
keyToOrb = \case
  KeyQuas  -> Just Quas
  KeyWex   -> Just Wex
  KeyExort -> Just Exort
  _        -> Nothing

orbToKey :: Orb -> Key
orbToKey = \case
  Quas  -> KeyQuas
  Wex   -> KeyWex
  Exort -> KeyExort


-- Zero, one, two, or three orbs.
data Orbs
  = Orbs0
  | Orbs1 Orb
  | Orbs2 Orb Orb
  | Orbs3 Orb Orb Orb
  deriving (Eq, Ord, Show)

instance Bounded Orbs where
  minBound = Orbs0
  maxBound = Orbs3 Exort Exort Exort

-- Boilerplatey instance that GHC can't derive. We simply associate a unique
-- integer from [0..39] for each possible orb configuration.
--
-- This should probably be written to pattern match on each integer individually
-- so that it's more obviously correct.
instance Enum Orbs where
  toEnum 0 = Orbs0
  toEnum n
    | n < 4 = Orbs1 (toEnum (n-1))
    | n < 13 =
        let
          (x,y) = (n-4) `divMod` 3
        in
          Orbs2 (toEnum x) (toEnum y)
    | otherwise =
        let
          (x,r) = (n-13) `divMod` 9
          (y,z) = r `divMod` 3
        in
          Orbs3 (toEnum x) (toEnum y) (toEnum z)

  fromEnum = \case
    Orbs0       -> 0
    Orbs1 x     -> 1 + fromEnum x
    Orbs2 x y   -> 4 + 3 * fromEnum x + fromEnum y
    Orbs3 x y z -> 13 + 9 * fromEnum x + 3 * fromEnum y + fromEnum z

-- Casting an 'Orb' shifts 'Orbs' to the right.
castOrb :: Orb -> Orbs -> Orbs
castOrb w = \case
  Orbs0       -> Orbs1 w
  Orbs1 x     -> Orbs2 w x
  Orbs2 x y   -> Orbs3 w x y
  Orbs3 x y _ -> Orbs3 w x y

-- A directed graph with 'Orbs' nodes and 'Orb' edges, representing the 'Orbs'
-- states reachable by casting any 'Orb'.
--
-- For example, there is a 'Quas' edge from node 'Quas Wex Wex' to
-- 'Quas Quas Wex', because casting 'Quas' with orbs 'Quas Wex Wex' results in
-- orbs 'Quas Quas Wex'.
orbsGraph :: Gr Orbs Orb
orbsGraph = Graph.mkGraph nodes edges
 where
  nodes :: [LNode Orbs]
  nodes = map (\x -> (fromEnum x, x)) [minBound..maxBound]

  edges :: [LEdge Orb]
  edges = do
    orbs <- [minBound..maxBound]
    orb <- [Quas, Wex, Exort]
    pure (fromEnum orbs, fromEnum (castOrb orb orbs), orb)


--------------------------------------------------------------------------------
-- Spell

data Spell
  = Alacrity
  | ChaosMeteor
  | ColdSnap
  | DeafeningBlast
  | EMP
  | ForgeSpirit
  | GhostWalk
  | IceWall
  | SunStrike
  | Tornado
  deriving (Bounded, Enum, Eq, Show)

-- Show instance with spaces between words.
showSpell :: Spell -> String
showSpell = \case
  Alacrity       -> "Alacrity"
  ChaosMeteor    -> "Chaos Meteor"
  ColdSnap       -> "Cold Snap"
  DeafeningBlast -> "Deafening Blast"
  EMP            -> "EMP"
  ForgeSpirit    -> "Forge Spirit"
  GhostWalk      -> "Ghost Walk"
  IceWall        -> "Ice Wall"
  SunStrike      -> "Sun Strike"
  Tornado        -> "Tornado"

-- Mapping from 'Orbs' to the 'Spell' they invoke.
orbsToSpell :: Orbs -> Maybe Spell
orbsToSpell = \case
  Orbs3 Quas Quas Quas    -> Just ColdSnap
  Orbs3 Quas Quas Wex     -> Just GhostWalk
  Orbs3 Quas Quas Exort   -> Just IceWall
  Orbs3 Quas Wex Quas     -> Just GhostWalk
  Orbs3 Quas Wex Wex      -> Just Tornado
  Orbs3 Quas Wex Exort    -> Just DeafeningBlast
  Orbs3 Quas Exort Quas   -> Just IceWall
  Orbs3 Quas Exort Wex    -> Just DeafeningBlast
  Orbs3 Quas Exort Exort  -> Just ForgeSpirit
  Orbs3 Wex Quas Quas     -> Just GhostWalk
  Orbs3 Wex Quas Wex      -> Just Tornado
  Orbs3 Wex Quas Exort    -> Just DeafeningBlast
  Orbs3 Wex Wex Quas      -> Just Tornado
  Orbs3 Wex Wex Wex       -> Just EMP
  Orbs3 Wex Wex Exort     -> Just Alacrity
  Orbs3 Wex Exort Quas    -> Just DeafeningBlast
  Orbs3 Wex Exort Wex     -> Just Alacrity
  Orbs3 Wex Exort Exort   -> Just ChaosMeteor
  Orbs3 Exort Quas Quas   -> Just IceWall
  Orbs3 Exort Quas Wex    -> Just DeafeningBlast
  Orbs3 Exort Quas Exort  -> Just ForgeSpirit
  Orbs3 Exort Wex Quas    -> Just DeafeningBlast
  Orbs3 Exort Wex Wex     -> Just Alacrity
  Orbs3 Exort Wex Exort   -> Just ChaosMeteor
  Orbs3 Exort Exort Quas  -> Just ForgeSpirit
  Orbs3 Exort Exort Wex   -> Just ChaosMeteor
  Orbs3 Exort Exort Exort -> Just SunStrike
  _                       -> Nothing

-- Mapping from 'Spell' to all of the different 'Orbs' configurations that
-- invoke it.
spellOrbs :: Spell -> [Orbs]
spellOrbs = \case
  Alacrity ->
    [ Orbs3 Wex Wex Exort
    , Orbs3 Wex Exort Wex
    , Orbs3 Exort Wex Wex
    ]
  ChaosMeteor ->
    [ Orbs3 Wex Exort Exort
    , Orbs3 Exort Wex Exort
    , Orbs3 Exort Exort Wex
    ]
  ColdSnap ->
    [ Orbs3 Quas Quas Quas
    ]
  DeafeningBlast ->
    [ Orbs3 Quas Wex Exort
    , Orbs3 Quas Exort Wex
    , Orbs3 Wex Quas Exort
    , Orbs3 Wex Exort Quas
    , Orbs3 Exort Quas Wex
    , Orbs3 Exort Wex Quas
    ]
  EMP ->
    [ Orbs3 Wex Wex Wex
    ]
  ForgeSpirit ->
    [ Orbs3 Quas Exort Exort
    , Orbs3 Exort Quas Exort
    , Orbs3 Exort Exort Quas
    ]
  GhostWalk ->
    [ Orbs3 Quas Quas Wex
    , Orbs3 Quas Wex Quas
    , Orbs3 Wex Quas Quas
    ]
  IceWall ->
    [ Orbs3 Quas Quas Exort
    , Orbs3 Quas Exort Quas
    , Orbs3 Exort Quas Quas
    ]
  SunStrike ->
    [ Orbs3 Exort Exort Exort
    ]
  Tornado ->
    [ Orbs3 Quas Wex Wex
    , Orbs3 Wex Quas Wex
    , Orbs3 Wex Wex Quas
    ]

-- Responses Invoker might make to casting a 'Spell'.
spellResponses :: Spell -> [String]
spellResponses = \case
  Alacrity ->
    [ "Wex Wex Exort!", "Alacrity!", "Zeal of Wexort!"
    , "Experience true swiftness!"
    ]
  ChaosMeteor ->
    [ "Chaos Meteor!", "Exort Wex Exort!", "Voidal Pyroclasm!"
    , "Tarak's Descent of Fire!", "A celestial inferno!"
    , "Gallaron's Abyssal Carnesphere!"
    ]
  ColdSnap ->
    [ "Cold Snap!", "Quas Trionis!", "Quas Frigoris!"
    , "Sadron's Protracted Frisson!", "Learn how fragile you are!"
    ]
  DeafeningBlast ->
    [ "Quas Wex Exort!", "Tri-orbant blast!", "Stupefactive Trio!"
    , "Buluphont's Aureal Incapacitator!", "Sonic boom!"
    ]
  EMP ->
    [ "Extractive Mana Pulse!", "Wex Trionis!", "Wex magnelectros!"
    , "Shimare's Extractive Pulse!", "Endoleon's Malevolent Perturbation!"
    ]
  ForgeSpirit ->
    [ "Forge Spirit!", "Exort Quas Exort!", "Grief Elementals!"
    , "Culween's Most Cunning Fabrications!", "Ravagers of Armor and Will!"
    , "An ally from naught!"
    ]
  GhostWalk ->
    [ "Ghost walk!", "Quas Wex Quas!", "Myrault's Hinder-Gast!"
    , "Geist of Lethargy!", "I slip from sight."
    ]
  IceWall ->
    [ "Ice Wall!", "Quas Quas Exort!", "Bitter Rampart!"
    , "Killing Wall of Koryx!", "The harsh White Waste beckons."
    ]
  SunStrike ->
    [ "Sun Strike!", "Exort Trionis!", "Exort Tri-Solar!"
    , "Harlek's Incantation of Incineration!"
    ]
  Tornado ->
    [ "Tornado!", "Wex Quas Wex!", "Wex cyclonus!", "Claws of Tornarus!"
    , "My foes aloft."
    ]

-- Generate a random spell.
randomSpell :: IO Spell
randomSpell = toEnum <$> randomRIO (0, 9)


--------------------------------------------------------------------------------
-- SpellSlot

data SpellSlot
  = SpellSlot1
  | SpellSlot2

-- Which 'SpellSlot' should we press to cast the given 'Spell'?
spellSlot :: Spell -> Invoked -> Maybe SpellSlot
spellSlot x = \case
  Invoked0     -> Nothing
  Invoked1 y   -> SpellSlot1 <$ guard (x == y)
  Invoked2 y z -> SpellSlot1 <$ guard (x == y)
              <|> SpellSlot2 <$ guard (x == z)

spellSlotKey :: SpellSlot -> Key
spellSlotKey = \case
  SpellSlot1 -> KeySpell1
  SpellSlot2 -> KeySpell2


--------------------------------------------------------------------------------
-- Invoked spells

-- Zero, one, or two invoked 'Spell's.
--
-- Invariant: when two 'Spell's are invoked, they must be different.
data Invoked
  = Invoked0
  | Invoked1 Spell
  | Invoked2 Spell Spell
  deriving (Eq, Show)

-- Invoking a 'Spell' shifts invoked 'Spell's to the right, unless the 'Spell'
-- is already in the first spell slot, in which case nothing happens.
invokeSpell :: Spell -> Invoked -> Invoked
invokeSpell x Invoked0 = Invoked1 x
invokeSpell x (Invoked1 y)
  | x == y    = Invoked1 y
  | otherwise = Invoked2 x y
invokeSpell x (Invoked2 y z)
  | x == y    = Invoked2 y z
  | otherwise = Invoked2 x y

-- Which spell is in the first spell slot?
castSpell1 :: Invoked -> Maybe Spell
castSpell1 = \case
  Invoked0     -> Nothing
  Invoked1 x   -> Just x
  Invoked2 x _ -> Just x

-- Which spell is in the second spell slot?
castSpell2 :: Invoked -> Maybe Spell
castSpell2 = \case
  Invoked0     -> Nothing
  Invoked1 _   -> Nothing
  Invoked2 _ x -> Just x


--------------------------------------------------------------------------------
-- Challenge

-- A 'Challenge' is one or more spells to be cast. The integer suffix of the
-- data constructors indicates which spell is next to cast.
data Challenge
  = Challenge1_1 Spell
  | Challenge2_1 Spell Spell
  | Challenge2_2 Spell Spell
  | Challenge3_1 Spell Spell Spell
  | Challenge3_2 Spell Spell Spell
  | Challenge3_3 Spell Spell Spell
  deriving (Eq, Show)

-- What is the current spell of the challenge?
challengeSpell :: Challenge -> Spell
challengeSpell = \case
  Challenge1_1 x     -> x
  Challenge2_1 x _   -> x
  Challenge2_2 _ x   -> x
  Challenge3_1 x _ _ -> x
  Challenge3_2 _ x _ -> x
  Challenge3_3 _ _ x -> x

-- What are all spells in this challenge, regardless of how much progess we've
-- made?
challengeSpells :: Challenge -> NonEmpty Spell
challengeSpells = \case
  Challenge1_1 x     -> x :| []
  Challenge2_1 x y   -> x :| [y]
  Challenge2_2 x y   -> x :| [y]
  Challenge3_1 x y z -> x :| [y, z]
  Challenge3_2 x y z -> x :| [y, z]
  Challenge3_3 x y z -> x :| [y, z]

-- Step a challenge forward by pointing at the next spell. If there is no next
-- spell, return Nothing.
stepChallenge :: Challenge -> Maybe Challenge
stepChallenge = \case
  Challenge1_1 _     -> Nothing
  Challenge2_1 x y   -> Just (Challenge2_2 x y)
  Challenge2_2 _ _   -> Nothing
  Challenge3_1 x y z -> Just (Challenge3_2 x y z)
  Challenge3_2 x y z -> Just (Challenge3_3 x y z)
  Challenge3_3 _ _ _ -> Nothing

-- Given orbs and invoked spells, how many buttons does it take to cast the
-- given list of spells in order? Also return the actual orbs cast.
optimalChallenge :: Orbs -> Invoked -> Challenge -> [Key]
optimalChallenge orbs invoked challenge =
  optimalSpells orbs invoked (toList (challengeSpells challenge))
 where
  optimalSpells :: Orbs -> Invoked -> [Spell] -> [Key]
  optimalSpells orbs invoked = \case
    -- Optimally casting 0 spells requires 0 button presses.
    [] -> []

    -- Optimally casting 1 spell is equivalent to optimally casting the orbs
    -- that correspond to the spell, invoking the spell, and casting the spell.
    [x] ->
      case spellSlot x invoked of
        Nothing ->
          minimumBy
            (comparing length)
            (map snd (nonoptimalInvoke orbs x))
          ++ [KeySpell1]
        Just slot -> [spellSlotKey slot]

    -- To optimally cast 2 or more spells, we do the more optimal of either:
    --
    --   1. Invoke the first, cast the first, and optimally cast the second plus
    --      all remaining spells (which may itself involve invoking the *third*
    --      spell before the *second*, for example).
    --
    --      If the first spell is already invoked in either spell slot, we can
    --      skip invoking it.
    --
    --   2. Invoke the second, invoke the first, cast the first and second, and
    --      optimally cast the remaining spells.
    --
    --      If the second spell is already invoked in the first spell slot, we
    --      can skip invoking it.
    x:y:ys ->
      let
        -- (1.) above
        method1 :: [[Key]]
        method1 =
          case spellSlot x invoked of
            Nothing -> do
              (orbs', ns) <- nonoptimalInvoke orbs x
              let invoked' = invokeSpell x invoked
              let ms = optimalSpells orbs' invoked' (y:ys)
              pure (ns ++ [KeySpell1] ++ ms)
            Just slot -> [spellSlotKey slot : optimalSpells orbs invoked (y:ys)]

        -- (2.) above
        method2 :: [[Key]]
        method2 =
          case spellSlot y invoked of
            Just SpellSlot1 -> do
              (orbs', ns) <- nonoptimalInvoke orbs x
              let invoked' = invokeSpell x invoked
              let ms = optimalSpells orbs' invoked' ys
              pure (ns ++ [KeySpell1, KeySpell2] ++ ms)
            _ -> do
              (orbs', ns) <- nonoptimalInvoke orbs y
              let invoked' = invokeSpell y invoked
              (orbs'', ms) <- nonoptimalInvoke orbs' x
              let invoked'' = invokeSpell x invoked'
              let os = optimalSpells orbs'' invoked'' ys
              pure (ns ++ ms ++ [KeySpell1, KeySpell2] ++ os)
      in
        minimumBy (comparing length) (method1 ++ method2)

  -- Given orbs, find all possible ways of invoking the given spell, and return
  -- the resulting orbs, plus the keys pressed along the way (which always end
  -- in 'KeyInvoke').
  nonoptimalInvoke :: Orbs -> Spell -> [(Orbs, [Key])]
  nonoptimalInvoke orbs spell =
    if elem orbs (spellOrbs spell)
      then [(orbs, [KeyInvoke])]
      else map f (spellOrbs spell)
   where
    f :: Orbs -> (Orbs, [Key])
    f orbs' =
      let
        path :: [LNode Orb]
        path =
          Graph.unLPath (Graph.lesp (fromEnum orbs) (fromEnum orbs') orbsGraph)
      in
        (orbs', map (orbToKey . snd) (tail path) ++ [KeyInvoke])

-- A random challenge. Don't generate two of the same spell in a row.
randomChallenge :: IO Challenge
randomChallenge =
  randomRIO (1::Int, 3) >>= \case
    1 -> Challenge1_1 <$> randomSpell
    2 -> do
      x <- randomSpell
      y <- randomDifferentSpell x
      pure (Challenge2_1 x y)
    3 -> do
      x <- randomSpell
      y <- randomDifferentSpell x
      z <- randomDifferentSpell y
      pure (Challenge3_1 x y z)
 where
  randomDifferentSpell :: Spell -> IO Spell
  randomDifferentSpell spell = do
    spell' <- randomSpell
    if spell == spell'
      then randomDifferentSpell spell
      else pure spell'


--------------------------------------------------------------------------------
-- Rendering functions

drawScene
  :: Challenge -> Maybe String -> Orbs -> Invoked -> Int -> Int -> [Key]
  -> Maybe [Key] -> Float -> Vty.Image
drawScene challenge response orbs invoked presses optimal_presses pressed_keys
    optimal_keys rate = Vty.vertCat

  [ drawChallenge challenge
  , string ""
  , string (maybe "" (\r -> '“' : r ++ "”") response)
  , string ""
  , string ""
  , string "      ┌───────┬───────┬───────┐"
  , string orbsStr
  , string "┌─────┴───────┴───┬───┴───────┴─────┐"
  , string spellStr
  , string "└─────────────────┴─────────────────┘"
  , string ""
  , string ("Pressed: " ++ map keyToChar (reverse pressed_keys))
  , string ("Optimal: " ++ maybe "" (map keyToChar) optimal_keys)
  , string ""
  , let
      pct :: Int
      pct =
        case presses of
          0 -> 100
          _ ->
            round (100 * realToFrac optimal_presses /
              realToFrac presses :: Double)
    in
      string (printf "%d%% optimal" pct)
  , string (printf "%.02f spells per second" rate)
  , string (printf "%.02f seconds per spell" (if rate == 0 then 0 else 1/rate))
  , string ""
  , string ""
  , string "╓╭─────────────────────────────────────╮╖"
  , string "║│ Alacrity        │ Wex   Wex   Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Chaos Meteor    │ Wex   Exort Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Cold Snap       │ Quas  Quas  Quas  │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Deafening Blast │ Quas  Wex   Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ EMP             │ Wex   Wex   Wex   │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Forge Spirit    │ Quas  Exort Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Ghost Walk      │ Quas  Quas  Wex   │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Ice Wall        │ Quas  Quas  Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Sun Strike      │ Exort Exort Exort │║"
  , string "║│─────────────────┼───────────────────│║"
  , string "║│ Tornado         │ Quas  Wex   Wex   │║"
  , string "╙╰─────────────────┴───────────────────╯╜"
  ]
 where
  orbsStr :: String
  orbsStr = printf "      │ %-5s │ %-5s │ %-5s │" x y z
   where
    (x, y, z) =
      case orbs of
        Orbs0 -> ("", "", "")
        Orbs1 x -> (show x, "", "")
        Orbs2 x y -> (show x, show y, "")
        Orbs3 x y z -> (show x, show y, show z)

  spellStr :: String
  spellStr = printf "│ %-15s │ %-15s │" x y
   where
    (x, y) =
      case invoked of
        Invoked0 -> ("", "")
        Invoked1 x -> (showSpell x, "")
        Invoked2 x y -> (showSpell x, showSpell y)

drawChallenge :: Challenge -> Vty.Image
drawChallenge = \case
  Challenge1_1 x -> boldSpell x
  Challenge2_1 x y -> Vty.horizCat
    [ boldSpell x
    , shaveLeft 1 (spell y)
    ]
  Challenge2_2 x y -> Vty.horizCat
    [ foldedSpell x
    , boldSpell y
    ]
  Challenge3_1 x y z -> Vty.horizCat
    [ boldSpell x
    , shaveLeft 1 (spell y)
    , shaveLeft 1 (spell z)
    ]
  Challenge3_2 x y z -> Vty.horizCat
    [ foldedSpell x
    , boldSpell y
    , shaveLeft 1 (spell z)
    ]
  Challenge3_3 x y z -> Vty.horizCat
    [ foldedSpell x
    , foldedSpell y
    , boldSpell z
    ]
 where
  spell :: Spell -> Vty.Image
  spell =
    bordered '┌' '┐' '┘' '└' '─' '│' . string . printf " %s " . showSpell

  boldSpell :: Spell -> Vty.Image
  boldSpell =
    bordered '┏' '┓' '┛' '┗' '━' '┃' . bold . printf " %s " . showSpell

  foldedSpell :: Spell -> Vty.Image
  foldedSpell = Vty.cropRight 5 . spell

  shaveLeft :: Int -> Vty.Image -> Vty.Image
  shaveLeft n img = Vty.cropLeft (Vty.imageWidth img - n) img

string :: String -> Vty.Image
string = Vty.string Vty.defAttr

bold :: String -> Vty.Image
bold = Vty.string (Vty.defAttr `Vty.withStyle` Vty.bold)

bordered
  :: Char -> Char -> Char -> Char -> Char -> Char -> Vty.Image -> Vty.Image
bordered ul ur dr dl hr vr img = Vty.vertCat
  [ string (ul : replicate w hr ++ [ur])
  , Vty.horizCat [ vert, img, vert ]
  , string (dl : replicate w hr ++ [dr])
  ]
 where
  w :: Int
  w = Vty.imageWidth img

  vert :: Vty.Image
  vert = Vty.charFill Vty.defAttr vr 1 (Vty.imageHeight img)


--------------------------------------------------------------------------------
-- Miscellaneous utility functions.

-- Return a random element from a non-empty list.
randomElem :: [a] -> IO a
randomElem [] = error "randomElem: empty list"
randomElem xs = (xs !!) <$> randomRIO (0, length xs - 1)

-- Insert a value into a proplist, overwriting any existing value.
insert :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
insert k v [] = [(k, v)]
insert k v (x@(k',_):xs)
  | k == k' = (k, v) : xs
  | otherwise = x : insert k v xs

-- Adjust a value at the given key in a proplist.
adjust :: Eq k => (v -> v) -> k -> [(k, v)] -> [(k, v)]
adjust _ _ [] = []
adjust f k (x@(k',v):xs)
  | k == k' = (k', f v) : xs
  | otherwise = x : adjust f k xs

-- Look up a value in a proplist whose key must exist.
lookupJust :: Eq k => k -> [(k, v)] -> v
lookupJust x xs =
  case lookup x xs of
    Nothing -> error "lookupJust: Nothing"
    Just y -> y