|
| 1 | +module RandomNumberGameNode.Main where |
| 2 | + |
| 3 | +import Prelude |
| 4 | + |
| 5 | +import Control.Monad.Reader (class MonadAsk, ReaderT, ask, asks, runReaderT) |
| 6 | +import Data.Array (elem, snoc) |
| 7 | +import Data.Either (Either(..)) |
| 8 | +import Data.Int (fromString) |
| 9 | +import Data.Interpolate (i) |
| 10 | +import Data.Maybe (Maybe(..)) |
| 11 | +import Effect (Effect) |
| 12 | +import Effect.Aff (Aff, makeAff, nonCanceler, runAff_) |
| 13 | +import Effect.Aff.Class (class MonadAff, liftAff) |
| 14 | +import Effect.Class (class MonadEffect, liftEffect) |
| 15 | +import Effect.Class.Console (log) |
| 16 | +import Effect.Random (randomInt) |
| 17 | +import Effect.Ref (Ref) |
| 18 | +import Effect.Ref as Ref |
| 19 | +import Node.ReadLine (Interface, close, createConsoleInterface, noCompletion) |
| 20 | +import Node.ReadLine as NRL |
| 21 | +import Type.Equality (class TypeEquals, from) |
| 22 | + |
| 23 | +main :: Effect Unit |
| 24 | +main = do |
| 25 | + -- get/create environment values |
| 26 | + interface <- createConsoleInterface noCompletion |
| 27 | + randomNumber <- randomInt 1 10 |
| 28 | + remainingGuesses <- Ref.new 4 |
| 29 | + previousGuesses <- Ref.new [] |
| 30 | + |
| 31 | + let env = { randomNumber, remainingGuesses, previousGuesses, interface } |
| 32 | + |
| 33 | + -- now run our game using custom monad |
| 34 | + runAff_ |
| 35 | + (\_ -> close interface) |
| 36 | + (runAppM env game) |
| 37 | + |
| 38 | +-- All the impure API our monad needs to support to run the program |
| 39 | +-- Normally, this would be broken up into more type classes for higher |
| 40 | +-- granularity. |
| 41 | +class (Monad m) <= GameCapabilities m where |
| 42 | + notifyUser :: String -> m Unit |
| 43 | + getUserInput :: String -> m String |
| 44 | + |
| 45 | + getRandomNumber :: m Int |
| 46 | + |
| 47 | + getRemainingGuesses :: m Int |
| 48 | + |
| 49 | + getPreviousGuesses :: m (Array Int) |
| 50 | + |
| 51 | + storeGuess :: Int -> m Unit |
| 52 | + |
| 53 | +-- Game logic using only the above capabilities |
| 54 | +game :: forall m. |
| 55 | + GameCapabilities m => |
| 56 | + m Unit |
| 57 | +game = do |
| 58 | + remaining <- getRemainingGuesses |
| 59 | + notifyUser $ i "Guess the random number. It's between 1 and 10. You have " |
| 60 | + (remaining + 1) " guesses. Enter 'q' to quit. \ |
| 61 | + \Invalid inputs will not count against you." |
| 62 | + |
| 63 | + result <- gameLoop |
| 64 | + |
| 65 | + case result of |
| 66 | + PlayerWins correctAnswer remainingGuesses -> do |
| 67 | + notifyUser $ i "Player won! The answer was " correctAnswer |
| 68 | + notifyUser $ i "Player guessed the random number with " remainingGuesses |
| 69 | + " guesses remaining." |
| 70 | + PlayerLoses correctAnswer allGuessesMade -> do |
| 71 | + notifyUser $ i "Player lost! The answer was " correctAnswer |
| 72 | + notifyUser $ i "Guesses made: " (show allGuessesMade) |
| 73 | + PlayerQuits -> do |
| 74 | + notifyUser "Player quit the game. Bye!" |
| 75 | + |
| 76 | +-- This function is normally NOT stack-safe because of its recursive nature. |
| 77 | +-- However, as long as the base/foundational monad is `Aff`, which is always |
| 78 | +-- stack-safe, we don't have to worry about this concern. |
| 79 | +gameLoop :: forall m. GameCapabilities m => m GameResult |
| 80 | +gameLoop = do |
| 81 | + prev <- getPreviousGuesses |
| 82 | + notifyUser $ i "\n\ |
| 83 | + \Prevous guesses: " (show prev) |
| 84 | + nextInput <- getUserInput "Guess a number between 1 - 10: " |
| 85 | + case nextInput of |
| 86 | + "q" -> pure PlayerQuits |
| 87 | + x -> case fromString x of |
| 88 | + Nothing -> do |
| 89 | + notifyUser $ i "'" x "' is not an integer. Try again (Use 'q' to quit)." |
| 90 | + gameLoop |
| 91 | + Just guess |
| 92 | + | not (between 1 10 guess) -> do |
| 93 | + notifyUser $ i guess " was not between 1 and 10. Try again." |
| 94 | + gameLoop |
| 95 | + | elem guess prev -> do |
| 96 | + notifyUser $ i "You already guessed " guess " previously. \ |
| 97 | + \Please guess a different number." |
| 98 | + gameLoop |
| 99 | + | otherwise -> do |
| 100 | + answer <- getRandomNumber |
| 101 | + if (guess == answer) then do |
| 102 | + remaining <- getRemainingGuesses |
| 103 | + pure $ PlayerWins guess remaining |
| 104 | + else do |
| 105 | + remaining <- getRemainingGuesses |
| 106 | + if remaining <= 0 then do |
| 107 | + pure $ PlayerLoses answer (prev `snoc` guess) |
| 108 | + else do |
| 109 | + storeGuess guess |
| 110 | + gameLoop |
| 111 | + |
| 112 | +data GameResult |
| 113 | + = PlayerWins Int Int |
| 114 | + | PlayerLoses Int (Array Int) |
| 115 | + | PlayerQuits |
| 116 | + |
| 117 | +-- ReaderT Design Pattern |
| 118 | + |
| 119 | +type Environment = { randomNumber :: Int |
| 120 | + , interface :: Interface |
| 121 | + , remainingGuesses :: Ref Int |
| 122 | + , previousGuesses :: Ref (Array Int) |
| 123 | + } |
| 124 | + |
| 125 | +newtype AppM a = AppM (ReaderT Environment Aff a) |
| 126 | + |
| 127 | +-- Given an Environment value, we can convert an `AppM` computation |
| 128 | +-- into an `Aff` computation. |
| 129 | +runAppM :: Environment -> AppM ~> Aff |
| 130 | +runAppM env (AppM m) = runReaderT m env |
| 131 | + |
| 132 | +derive newtype instance functorAppM :: Functor AppM |
| 133 | +derive newtype instance applicativeAppM :: Applicative AppM |
| 134 | +derive newtype instance applyAppM :: Apply AppM |
| 135 | +derive newtype instance bindAppM :: Bind AppM |
| 136 | +derive newtype instance monadAppM :: Monad AppM |
| 137 | +derive newtype instance monadEffectAppM :: MonadEffect AppM |
| 138 | +derive newtype instance monadAffAppM :: MonadAff AppM |
| 139 | + |
| 140 | +-- Since Environment is a type alias, we need to use `TypeEquals` |
| 141 | +-- to make this work without newtyping Envirnoment. |
| 142 | +-- This limitation will likely be removed in a future PS release |
| 143 | +instance monadAskAppM :: TypeEquals e Environment => MonadAsk e AppM where |
| 144 | + ask = AppM $ asks from |
| 145 | + |
| 146 | +------------------------- |
| 147 | + |
| 148 | +instance gameCapabilitiesAppM :: GameCapabilities AppM where |
| 149 | + notifyUser :: String -> AppM Unit |
| 150 | + notifyUser = log |
| 151 | + |
| 152 | + getUserInput :: String -> AppM String |
| 153 | + getUserInput prompt = do |
| 154 | + iface <- asks _.interface |
| 155 | + -- Note: `purescript-node-readline-aff` isn't in the package set, |
| 156 | + -- so we'll reimplement `question` in this file. |
| 157 | + liftAff $ question prompt iface |
| 158 | + |
| 159 | + getRandomNumber :: AppM Int |
| 160 | + getRandomNumber = asks _.randomNumber |
| 161 | + |
| 162 | + getRemainingGuesses :: AppM Int |
| 163 | + getRemainingGuesses = asks _.remainingGuesses >>= (liftEffect <<< Ref.read) |
| 164 | + |
| 165 | + getPreviousGuesses :: AppM (Array Int) |
| 166 | + getPreviousGuesses = asks _.previousGuesses >>= (liftEffect <<< Ref.read) |
| 167 | + |
| 168 | + storeGuess :: Int -> AppM Unit |
| 169 | + storeGuess guess = do |
| 170 | + rec <- ask |
| 171 | + liftEffect do |
| 172 | + Ref.modify_ (_ - 1) rec.remainingGuesses |
| 173 | + Ref.modify_ (\a -> a `snoc` guess) rec.previousGuesses |
| 174 | + |
| 175 | +-- Provides an Aff wrapper around Node.Readline.question |
| 176 | +question :: String -> Interface -> Aff String |
| 177 | +question prompt iface = |
| 178 | + makeAff \runCallback -> do |
| 179 | + NRL.question prompt (\value -> runCallback (Right value)) iface |
| 180 | + pure nonCanceler |
0 commit comments