Last active
September 22, 2017 22:11
-
-
Save mitchellwrosen/3176026c9a2b25b2503ec365b30030b3 to your computer and use it in GitHub Desktop.
A simple Invoker practice terminal app using reactive-banana
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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 |
To do?
- Start counting time on first key press, not on program start
- Challenges longer than 3
- Pre-defined combos
- Automatically check for newer version
- Show optimal key presses after challenge is completed
- Add responses for invoking already-invoked spells
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
To build & run:
stack
: https://docs.haskellstack.org/en/stable/README/#how-to-installchmod u+x invoker.hs
./invoker.hs
To compile so it starts faster:
stack ghc invoker.hs -- -threaded
./invoker