yup....

yup....

module Main where

import Prelude

import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Aff, Canceler, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(..), either)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.HTTP.Method (CustomMethod, Method)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (unwrap)
import Data.String (Pattern(..), contains, length)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (getRequestData, readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (Route(Route), files, getIcons, open, remove, update, watched)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Types (FileData(..), OpenRequest(..), Path(..), RemoveRequest(..), Success(..))

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

main :: forall eff.
  Eff (AppEffects (exception :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond' json
    respond' json
      | size <- length json
      , size > 16000 = do
        buffer <- liftEff $ getBuffer size json
        respond buffer
        where
          bind = ibind
    respond' json = respond json
    respondJSON' :: forall req res url
      . IsSymbol url
      => Encode res
      => Route req res url
      -> res
      -> _
    respondJSON' _ = respondJSON <<< unsafeStringify <<< encode
    respondBadRequest e =
      writeStatus statusBadRequest
      :*> headers []
      :*> respond ("bad JSON: " <> show e)
    handleConn conn@{components: Config {dir, db}} = do
      request <- getRequestData
      case Tuple request.method request.url of
        t
          | match t files -> handleFiles files
          | match t watched -> handleWatched watched
          | match t getIcons -> handleGetIcons getIcons
          | match t open -> handleOpen open
          | match t update -> handleUpdate update
          | match t remove -> handleRemove remove
          | otherwise -> fileServer "dist" notFound
        where
          bind = ibind
          match :: forall req res url
            . IsSymbol url
            => Tuple (Either Method CustomMethod) String
            -> Route req res url
            -> Boolean
          match (Tuple m u) (Route {method}) =
            case m of
              Left m' -> m' == method && u == url
              _ -> false
            where
              url = reflectSymbol (SProxy :: SProxy url)
          withBody :: forall req res url
            . Decode req
            => Route req res url
            -> (req -> _)
            -> _
          withBody _ handler = do
            body <- readBody
            either
              respondBadRequest
              handler
              (runExcept $ decodeJSON body)

          handleFiles r = do
            files <- lift' $ readdir' dir
            respondJSON' r files

          handleWatched r = do
            rows <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify rows

          handleOpen r = withBody r \(OpenRequest or) -> do
            _ <- case platform of
              Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
              _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
            respondJSON' r $ Success {status: "success"}

          handleGetIcons r = withBody r \_ -> do
            _ <- liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
            respondJSON' r $ Success {status: "success"}

          handleUpdate r = withBody r \(FileData ur) -> do
            _ <- if ur.watched
              then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
              else queryDB' "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
            handleWatched watched

          handleRemove r = withBody r \(RemoveRequest rr) -> do
            let archive = concat [dir, "archive"]
            let name = unwrap rr.path
            let old = concat [dir, name]
            let new = concat [archive, name]
            _ <- lift' <<< attempt $ mkdir archive
            _ <- lift' <<< attempt $ rename old new
            respondJSON' r $ Success {status: "success"}

          queryDB' query params = lift' $ queryDB db query params

module Main where

import Prelude

import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Aff, Canceler, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(..), either)
import Data.Foreign.Class (class Encode, class Decode, encode)
import Data.Foreign.Generic (decodeJSON)
import Data.HTTP.Method (CustomMethod, Method)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (unwrap)
import Data.String (Pattern(..), contains, length)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (getRequestData, readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff (mkdir, readdir, rename, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, lookupEnv, platform)
import Routes (Route(Route), files, getIcons, open, remove, update, watched)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Types (FileData(..), OpenRequest(..), Path(..), RemoveRequest(..), Success(..))

readdir' :: forall eff.
  String
  -> Aff
       ( fs :: FS
       | eff
       )
       (Array Path)
readdir' path = do
  withStats <- traverse pairWithStat =<< filter (contains (Pattern "mkv"))
                                     <$> readdir path
  pure $ Path <<< fst <$> sortByDate withStats
  where
    pairWithStat file = do
      s <- stat $ concat [path, file]
      pure (Tuple file s)
    sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)

getBuffer :: forall e.
  Int
  -> String
  -> Eff
    ( buffer :: BUFFER
    | e
    )
    Buffer
getBuffer size json = do
  buffer <- create size
  _ <- writeString UTF8 0 size json buffer
  pure buffer

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

ensureDB :: forall eff. FilePath -> Aff (db :: DBEffects | eff) DBConnection
ensureDB path = do
  db <- newDB path
  _ <- queryDB db "CREATE TABLE IF NOT EXISTS watched (path varchar(20) primary key unique, created datetime);" []
  pure db

main :: forall eff.
  Eff (AppEffects (exception :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond' json
    respond' json
      | size <- length json
      , size > 16000 = do
        buffer <- liftEff $ getBuffer size json
        respond buffer
        where
          bind = ibind
    respond' json = respond json
    respondJSON' :: forall req res url
      . IsSymbol url
      => Encode res
      => Route req res url
      -> res
      -> _
    respondJSON' _ = respondJSON <<< unsafeStringify <<< encode
    respondBadRequest e =
      writeStatus statusBadRequest
      :*> headers []
      :*> respond ("bad JSON: " <> show e)
    handleConn conn@{components: Config {dir, db}} = do
      request <- getRequestData
      case Tuple request.method request.url of
        t
          | match t files -> handleFiles files
          | match t watched -> handleWatched watched
          | match t getIcons -> handleGetIcons getIcons
          | match t open -> handleOpen open
          | match t update -> handleUpdate update
          | match t remove -> handleRemove remove
          | otherwise -> fileServer "dist" notFound
        where
          bind = ibind
          match :: forall req res url
            . IsSymbol url
            => Tuple (Either Method CustomMethod) String
            -> Route req res url
            -> Boolean
          match (Tuple m u) (Route {method}) =
            case m of
              Left m' -> m' == method && u == url
              _ -> false
            where
              url = reflectSymbol (SProxy :: SProxy url)
          withBody :: forall req res url
            . Decode req
            => Route req res url
            -> (req -> _)
            -> _
          withBody _ handler = do
            body <- readBody
            either
              respondBadRequest
              handler
              (runExcept $ decodeJSON body)

          handleFiles r = do
            files <- lift' $ readdir' dir
            respondJSON' r files

          handleWatched r = do
            rows <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify rows

          handleOpen r = withBody r \(OpenRequest or) -> do
            _ <- case platform of
              Darwin -> liftEff $ void $ spawn "open" (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
              _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
            respondJSON' r $ Success {status: "success"}

          handleGetIcons r = withBody r \_ -> do
            _ <- liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
            respondJSON' r $ Success {status: "success"}

          handleUpdate r = withBody r \(FileData ur) -> do
            _ <- if ur.watched
              then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
              else queryDB' "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
            handleWatched watched

          handleRemove r = withBody r \(RemoveRequest rr) -> do
            let archive = concat [dir, "archive"]
            let name = unwrap rr.path
            let old = concat [dir, name]
            let new = concat [archive, name]
            _ <- lift' <<< attempt $ mkdir archive
            _ <- lift' $ rename old new
            respondJSON' r $ Success {status: "success"}

          queryDB' query params = lift' $ queryDB db query params


Added removeDead function

Added removeDead function

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop, deleteAt, delete)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace
import Math

import Graphics.CanvasConsole
import RandomGen
import GameState
import GameData
import Drawing
import Utils
import Level
import Astar
import Line

strlen = Data.String.length

-- Uses skill and gets experience.
useSkill :: SkillType
         -> Number -- Odds of success when unskilled (0 - 99)
         -> Number -- Experience gained
         -> GameState
         -> { success :: Boolean, game :: GameState }
useSkill skillType odds expr g@(Game state) = { success: success, game: addExp gen.game }
    where
        gen       = randInt 0 100 g
        finalOdds = odds * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup skillType state.skills)
        success   = gen.n < finalOdds
        addExp g@(Game state) | success = -- Skill increases with successes
            let skill        = fromMaybe { level: 0, prog: 0 } $ M.lookup skillType state.skills
                updatedSkill = increaseSkill skill
                gotLevel     = updatedSkill.level > skill.level
            in addLevelUpMsg gotLevel updatedSkill.level $ Game state { skills = M.insert skillType updatedSkill state.skills }
        addExp g@(Game state) | otherwise = g -- No experience gained

        expRequired :: Number -> Number
        expRequired lvl = 100 + 50 * lvl

        addLevelUpMsg :: Boolean -> Number -> GameState -> GameState
        addLevelUpMsg true newlvl = addMsg $ "Your " ++ show skillType ++ " skill increased to " ++ show newlvl ++ "."
        addLevelUpMsg _ _         = id

        increaseSkill :: Skill -> Skill
        increaseSkill skill | skill.prog + expr >= expRequired skill.level =
            skill { level = skill.level + 1, prog = skill.prog + expr - expRequired skill.level }
        increaseSkill skill | otherwise =
            skill { prog = skill.prog + expr }

-- Updates blinking timer.
updateBlinkTimer :: Number -> GameState -> GameState
updateBlinkTimer dt (Game state) | state.blinkTimer > 0.5 = Game state { blink = not state.blink, blinkTimer = 0 }
updateBlinkTimer dt (Game state) | otherwise              = Game state { blinkTimer = state.blinkTimer + dt }

-- onUpdate is called as often as possible.
onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateBlinkTimer dt <<< updateWorld true (calcSpeed g) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    blinkDraw console <<< updateBlinkTimer dt $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

-- Gets creature information from creature at index i.
get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

-- Modify creature at index i with a function.
modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcNpcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcNpcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i g@(Game state) =
            let spotRoll     = randInt 0 99 g
                newAlertAI   = updateAlertness spotRoll.n (get i g NoAI (\c -> c.ai))
                changedAlert = modifyCreatureAt i spotRoll.game (\c ->c { ai = newAlertAI })
            in updateAI changedAlert newAlertAI -- add updatePhysics?
            where
                -- Creature position
                cpos :: Point
                cpos = get i g zerop (\c -> c.pos)

                lookingAtPlayer :: Boolean
                lookingAtPlayer | get i g false (\c -> c.dir.x == 0)                               = true
                lookingAtPlayer | get i g false (\c -> c.dir.x < 0) && cpos.x > state.player.pos.x = true
                lookingAtPlayer | get i g false (\c -> c.dir.x > 0) && cpos.x < state.player.pos.x = true
                lookingAtPlayer | otherwise = false

                canSeePlayer :: Boolean
                canSeePlayer = lookingAtPlayer && (distanceSq cpos state.player.pos < 10 * 10) && (lineOfSight state.level cpos state.player.pos)

                canHide :: Number -> Boolean
                canHide roll = roll < (40 * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup Sneak state.skills))

                updateAlertness :: Number -> AI -> AI
                updateAlertness roll (AI NoAlert st)  | canSeePlayer = AI MightSee st
                updateAlertness roll (AI NoAlert st)  | otherwise    = AI NoAlert st
                updateAlertness roll (AI MightSee st) | canSeePlayer && not (canHide roll) = AI (Suspicious 1) st
                updateAlertness roll (AI MightSee st) | otherwise                          = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | n == 0                = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | not canSeePlayer      = AI (Suspicious (n - 1)) st
                updateAlertness roll (AI (Suspicious n) st) | canSeePlayer && n < 4 = AI (Suspicious (n + 1)) st
                updateAlertness roll (AI (Suspicious n) st) | otherwise             = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | canSeePlayer = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | n == 0       = AI NoAlert st
                updateAlertness roll (AI (Alert n) st) | otherwise    = AI (Alert (n - 1)) st
                updateAlertness _ x = x

                newPatrolPoint :: GameState -> { p :: Point, game :: GameState }
                newPatrolPoint g' = let points = validPatrolPoints
                                        gen    = randInt 0 (length points - 1) g'
                                    in { p: fromMaybe zerop (points !! gen.n), game: gen.game }

                validPatrolPoints :: [Point]
                validPatrolPoints = filter canWalkOn $ levelPoints state.level
                    where
                        canWalkOn p = isValidMove state.level p && not (isValidMove state.level (p .+. {x: 0, y: 1}))

                updateAI :: GameState -> AI -> GameState
                updateAI g (AI (Alert _) _) | get i g Peasant (\c -> c.ctype) == Archer && canSeePlayer = get i g g (flip npcAttack g)
                updateAI g (AI (Alert _) _)      = mover g $ moveToPlayer
                updateAI g (AI (Suspicious _) _) = mover g $ moveToPlayer
                updateAI g (AI _ (Idle p))       = mover g $ moveToPoint p
                updateAI g (AI a (Patrol p)) =
                    if length (pathToPoint g cpos p) <= 2 then
                        let gen = newPatrolPoint g
                        in modifyCreatureAt i gen.game (\c -> c { ai = AI a (Patrol gen.p) })
                    else mover g $ moveToPoint p
                updateAI g _ = g

                mover :: GameState -> (Creature -> Point) -> GameState
                mover g@(Game state) f = let nextPoint = get i g zerop f
                            in if state.player.pos .==. nextPoint then
                                -- get doesn't really get anything from creature, I'm just exploiting
                                -- it's type to make the attack.
                                -- get :: Number -> GameState -> GameState -> (Creature -> GameState) -> Gamestate
                                get i g g (flip npcAttack g)
                            else modifyCreatureAt i g $ walk nextPoint

                walk :: Point -> Creature -> Creature
                walk p c = c { pos = p, dir = p .-. c.pos }

                moveToPoint :: Point -> Creature -> Point
                moveToPoint p c = case head (pathToPoint g c.pos p) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

                moveToPlayer :: Creature -> Point
                moveToPlayer c = case head (pathToPlayer g c.pos) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

        pathToPoint :: GameState -> Point -> Point -> [Point]
        pathToPoint (Game state) start end = findPath state.pathfinder start end

        pathToPlayer :: GameState -> Point -> [Point]
        pathToPlayer g@(Game state) start = pathToPoint g start (groundProject state.player.pos)
            where
                -- Projects position to ground or climbable tile.
                groundProject :: Point -> Point
                groundProject p | isClimbable state.level (p .+. {x:0, y:0}) = p
                groundProject p | isValidMove state.level (p .+. {x:0, y:1}) = groundProject (p .+. {x:0, y:1})
                groundProject p | otherwise = p

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

npcWeapon :: Creature -> Item
npcWeapon _ = { itemType: Weapon { weaponType: Sword, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

-- todo: get player weapon from equipment
playerWeapon :: GameState -> Item
playerWeapon _ = { itemType: Weapon { weaponType: Axe, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

playerAttack :: Number -> GameState -> GameState
playerAttack i g@(Game state) = let attack = playerHit g
                                in if attack.hit then addMsg ("You hit the " ++ (get i g "" (\c -> show c.ctype)) ++ "!") $ modifyCreatureAt i attack.game (takeDamage (playerWeapon g) state.player)
                                   else addMsg ("You missed the " ++ get i g "" (\c -> show c.ctype) ++ "!") attack.game

npcAttack :: Creature -> GameState -> GameState
npcAttack c g = let attack = npcHit c g
                in if attack.hit then addMsg (show c.ctype ++ " hit you!") <<< (\(Game st) -> Game st { player = takeDamage (npcWeapon c) c st.player }) $ attack.game
                else addMsg (capitalize (show c.ctype) ++ " tried to " ++ attackVerb c.ctype ++ " you, but missed.") attack.game
    where
        attackVerb Archer = "shoot"
        attackVerb _      = "attack"

baseHitChance :: Creature -> Number
baseHitChance c = 50 + 5 * (statModf c.stats.dex)

playerHit :: GameState -> { hit :: Boolean, game :: GameState }
playerHit g@(Game state) = let u = useSkill WeaponSkill (baseHitChance state.player) 20 g
                           in { hit: u.success, game: u.game }

npcHit :: Creature -> GameState -> { hit :: Boolean, game :: GameState }
npcHit c g = let u = randInt 0 99 g in { hit: u.n < baseHitChance c, game: u.game }

takeDamage :: Item -> Creature -> Creature -> Creature
takeDamage weapon attacker defender = defender { stats = defender.stats { hp = defender.stats.hp - damage } }
    where
        damage = (weaponStat weapon).damage + statModf attacker.stats.str

-- Moves an object that has position. Checks collisions with solid tiles.
move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos
        w (Level level) = level.width
        h (Level level) = level.height

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 (w state.level - 1), y: clamp pos.y 0 (h state.level - 1) }

-- Remove dead npcs from game
removeDead :: GameState -> GameState
removeDead (Game state@{ npcs = n }) = (Game state { npcs = deadGrind n })
    where
        deadGrind :: [Creature] -> [Creature]
        deadGrind [] = []
        deadGrind (x:xs) | x.stats.hp <= 0 = deadGrind xs
        deadGrind (x:xs) = x : deadGrind xs

-- Updates the game world.
updateWorld :: Boolean -- Update player also?
            -> Number  -- How many time units the game world advances
            -> GameState -> GameState
updateWorld updatePlayer advance =
    updateCreatures advance >>> (if updatePlayer then updatePlayerPhysics else id) >>> updateItemPhysics
    where
        updatePlayerPhysics (Game state) | isClimbable state.level state.player.pos =
            Game state
        updatePlayerPhysics (Game state) | otherwise =
            Game state { player = updatePhysics (Game state) state.player }

        updateItemPhysics (Game state) = Game state { items = map (updatePhysics (Game state)) state.items }

-- Sets tile at point p to tile t. Recalculates pathfinding graph.
setTile' :: Point -> Tile -> GameState -> GameState
setTile' p t (Game state) = let newlevel = setTile state.level p t
                            in Game state { level = newlevel, pathfinder = makePathfinder (levelWeights newlevel) }

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = climb || (isFree {x:0, y: 1} && (ledge (-1) || ledge 1))
    where
        climb = isClimbable level c.pos
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) = let blockIndex = enemyBlocks state.npcs 0
    in if blockIndex >= 0 then
        updateWorld false (weaponStat $ playerWeapon g).attackSpeed $ playerAttack blockIndex g
        else if canMove then
            updateWorld false (calcSpeed g) <<< useMoveSkill $ Game state { player = move (Game state) state.player { vel = zerop } delta }
            else checkTile <<< fromMaybe Air <<< getTile state.level $ newpos
    where
        useMoveSkill :: GameState -> GameState
        useMoveSkill g@(Game state) | state.move == RunMode && not (delta .==. zerop) = (useSkill Athletics 50 2 g).game
        useMoveSkill g@(Game state) | state.move == SneakMode && canGetSneakSkill g && not (delta .==. zerop) = (useSkill Sneak 100 5 g).game
        useMoveSkill g@(Game state) | otherwise = g

        canGetSneakSkill :: GameState -> Boolean
        canGetSneakSkill (Game state) = any (\c -> lineOfSight state.level c.pos state.player.pos) $ filter (\c -> noAlert c.ai) state.npcs

        noAlert :: AI -> Boolean
        noAlert (AI NoAlert _)  = true
        noAlert (AI MightSee _) = true
        noAlert _               = false

        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

        enemyBlocks (c:cs) i | c.pos .==. newpos = i
        enemyBlocks (c:cs) i | otherwise         = enemyBlocks cs (i + 1)
        enemyBlocks [] _                         = -1

        checkTile :: Tile -> GameState
        checkTile DoorClosed = updateWorld false 500 $ addMsg "You open the door." $ setTile' newpos DoorOpen g
        checkTile DoorLocked = updateWorld false 2000 $ pickLock
        checkTile _          = g

        pickLock :: GameState
        pickLock = let use = useSkill Lockpick 10 20 g
                   in if use.success then addMsg "The door is locked. You managed to pick the lock." $ setTile' newpos DoorClosed use.game
                   else addMsg "The door is locked. You fail to pick the lock." use.game

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | not (isValidMove state.level (state.player.pos .+. {x: xdir, y: -1})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isClimbable state.level (state.player.pos .+. {x: xdir, y: -1}) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}
                          ,numpad 1 // {x: -1, y:  1}
                          ,numpad 3 // {x:  1, y:  1}]

numberkeys :: [Number]
numberkeys = (48 .. 57) ++ (96 .. 105)

numbers :: M.Map Number Number
numbers = M.fromList [48 // 0, 49 // 1, 50 // 2, 51 // 3, 52  // 4, 53  // 5, 54  // 6, 55  // 7, 56  // 8, 57  // 9
                     ,96 // 0, 97 // 1, 98 // 2, 99 // 3, 100 // 4, 101 // 5, 102 // 6, 103 // 7, 104 // 8, 105 // 9]

-- Player tries to pick up an item.
pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just ( { itemType = Loot { value = points } } ) -> addMsg ("You found " ++ show points ++ " $!") $ Game state { items = deleteItem state.items point, points = state.points + points }
        Just item -> case ( ( carryingWeight (M.values state.equipments) + carryingWeight state.inventory ) / maxCarryingCapacity state.player ) < 110 of
                         true  -> addMsg ("You acquired: " ++ show item.itemType) $ Game state { items = deleteItem state.items point, inventory = item : state.inventory }
                         false -> addMsg "You can't carry that much weight!" $ Game state
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

-- Player tries to drop item while in inventory.
dropItem :: Number -> GameState -> GameState
dropItem itemNumber g@(Game state@{ window = InventoryW wi, inventory = inv, items = itemsOnGround }) =
    case (!!) inv i of
        (Just item) -> addMsg ("You dropped: " ++ show item.itemType) $ (Game state { inventory = deleteAt i 1 inv, items = (item { pos = state.player.pos }) : itemsOnGround, window = InventoryW wi { index = 0 } })
        Nothing -> g
    where
        i = itemNumber + wi.index * 10
dropItem _ g = g

-- Remove some equipment in particular slot
removeOldEquip :: EquipmentSlot -> M.Map EquipmentSlot Item -> M.Map EquipmentSlot Item
removeOldEquip slot eq =
    case M.lookup slot eq of
        Just item -> M.delete slot eq
        Nothing   -> eq

-- Equip function (used while in inventory and equipment slot is chosen).
equip :: Number -> GameState -> GameState
equip i g@(Game state@{ equipments = eq, window = InventoryW { equip = (Just slot) }, inventory = inv }) =
    case (!!) inv i of
        Just item -> case isValidEquip item.itemType slot of
                        true  -> Game state { equipments = M.insert slot item eq , inventory = deleteAt i 1 inv, window = EquipW }
                        false -> addMsg ("Can't equip that item " ++ show slot) g
        Nothing -> addMsg "There is no item in there." g
equip _ g = g

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState

-- If player has 0 hp left, kill the player (no key can save you!)
-- onKeyPress console (Game state) _ | state.player.stats.hp <= 0 = return $ Death { playerName: state.playerName, points: state.points }
-- In death, press enter to star again
onKeyPress console (Death d) key | key == 13 = return $ MainMenu

onKeyPress console g@(Game state) _   | playerCannotAct state.level state.player = return g

-- Change page in inventory with + and -
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107) && floor ((length inv) / 10) <= iw.index = drawGame console $ Game state { window = InventoryW iw { index = 0 } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index + 1) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109) && iw.index == 0                         = drawGame console $ Game state { window = InventoryW iw { index = (floor ((length inv) / 10)) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index - 1) } }

-- Choosing equipment slot in equipment window
onKeyPress console g@(Game state@{ window = EquipW , equipments = eq , inventory = inv }) key | elem key numberkeys =
    case (!!) allEquipmentSlots number of
        Just slot  -> case M.lookup slot eq of
                          Just item -> drawGame console $ (Game state { window = EquipW, equipments = removeOldEquip slot eq, inventory = item : inv })
                          Nothing   -> drawGame console $ (Game state { window = InventoryW { index: 0, command: NoCommand, equip: Just slot } })
        Nothing  -> return g
        where
            number :: Number
            number =
                case M.lookup key numbers of
                    Just n  -> n
                    Nothing -> -1

-- Using command in inventory
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == 68        = drawGame console $ Game state { window = InventoryW { index: iw.index, command: Drop, equip: Nothing } }
onKeyPress console g@(Game state@{ window = InventoryW iw@{ command = Drop, equip = Nothing } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ dropItem number (Game state { window = InventoryW iw { command = NoCommand } })
        Nothing     -> return g

-- Equipping item while in inventory window (when equip option is valid)
onKeyPress console g@(Game state@{ window = InventoryW iw@{ equip = slot } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ equip number g
        Nothing     -> return g

-- Change game states window with s, i and e (GameW, EquipW and InventoryW) TODO: add skillwindow
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "I" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = EquipW  })       key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }

-- Esc closes inventory, equipment or skill window and returns the player to the game window
onKeyPress console (Game state) key | key == 27 = drawGame console $ Game state { window = GameW }

-- Change movement mode
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move == RunMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move /= RunMode = drawGame console $ Game state { move = RunMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move == SneakMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move /= SneakMode = drawGame console $ Game state { move = SneakMode }

onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 7               = drawGame console $ playerJump g (-1)
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 9               = drawGame console $ playerJump g 1
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 8               = drawGame console $ playerJump g 0
onKeyPress console g@(Game state@{ window = GameW }) key | key == makeCharCode "G"       = drawGame console $ pickUp (state.player.pos) g
onKeyPress console g@(Game state@{ window = GameW }) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                              | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation { playerName = pname }) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation { playerName = xs })    key | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation { playerName = "" })    key                   = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation { playerName = xs })    key | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation { playerName = xs })    key                   = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation { playerName = xs })    key | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop, deleteAt, delete)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace
import Math

import Graphics.CanvasConsole
import RandomGen
import GameState
import GameData
import Drawing
import Utils
import Level
import Astar
import Line

strlen = Data.String.length

-- Uses skill and gets experience.
useSkill :: SkillType
         -> Number -- Odds of success when unskilled (0 - 99)
         -> Number -- Experience gained
         -> GameState
         -> { success :: Boolean, game :: GameState }
useSkill skillType odds expr g@(Game state) = { success: success, game: addExp gen.game }
    where
        gen       = randInt 0 100 g
        finalOdds = odds * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup skillType state.skills)
        success   = gen.n < finalOdds
        addExp g@(Game state) | success = -- Skill increases with successes
            let skill        = fromMaybe { level: 0, prog: 0 } $ M.lookup skillType state.skills
                updatedSkill = increaseSkill skill
                gotLevel     = updatedSkill.level > skill.level
            in addLevelUpMsg gotLevel updatedSkill.level $ Game state { skills = M.insert skillType updatedSkill state.skills }
        addExp g@(Game state) | otherwise = g -- No experience gained

        expRequired :: Number -> Number
        expRequired lvl = 100 + 50 * lvl

        addLevelUpMsg :: Boolean -> Number -> GameState -> GameState
        addLevelUpMsg true newlvl = addMsg $ "Your " ++ show skillType ++ " skill increased to " ++ show newlvl ++ "."
        addLevelUpMsg _ _         = id

        increaseSkill :: Skill -> Skill
        increaseSkill skill | skill.prog + expr >= expRequired skill.level =
            skill { level = skill.level + 1, prog = skill.prog + expr - expRequired skill.level }
        increaseSkill skill | otherwise =
            skill { prog = skill.prog + expr }

-- Updates blinking timer.
updateBlinkTimer :: Number -> GameState -> GameState
updateBlinkTimer dt (Game state) | state.blinkTimer > 0.5 = Game state { blink = not state.blink, blinkTimer = 0 }
updateBlinkTimer dt (Game state) | otherwise              = Game state { blinkTimer = state.blinkTimer + dt }

-- onUpdate is called as often as possible.
onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | playerCannotAct state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateBlinkTimer dt <<< updateWorld true (calcSpeed g) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    blinkDraw console <<< updateBlinkTimer dt $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

-- Gets creature information from creature at index i.
get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

-- Modify creature at index i with a function.
modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcNpcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcNpcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i g@(Game state) =
            let spotRoll     = randInt 0 99 g
                newAlertAI   = updateAlertness spotRoll.n (get i g NoAI (\c -> c.ai))
                changedAlert = modifyCreatureAt i spotRoll.game (\c ->c { ai = newAlertAI })
            in updateAI changedAlert newAlertAI -- add updatePhysics?
            where
                -- Creature position
                cpos :: Point
                cpos = get i g zerop (\c -> c.pos)

                lookingAtPlayer :: Boolean
                lookingAtPlayer | get i g false (\c -> c.dir.x == 0)                               = true
                lookingAtPlayer | get i g false (\c -> c.dir.x < 0) && cpos.x > state.player.pos.x = true
                lookingAtPlayer | get i g false (\c -> c.dir.x > 0) && cpos.x < state.player.pos.x = true
                lookingAtPlayer | otherwise = false

                canSeePlayer :: Boolean
                canSeePlayer = lookingAtPlayer && (distanceSq cpos state.player.pos < 10 * 10) && (lineOfSight state.level cpos state.player.pos)

                canHide :: Number -> Boolean
                canHide roll = roll < (40 * pow 1.2 (fromMaybe 0 $ (\s -> s.level) <$> M.lookup Sneak state.skills))

                updateAlertness :: Number -> AI -> AI
                updateAlertness roll (AI NoAlert st)  | canSeePlayer = AI MightSee st
                updateAlertness roll (AI NoAlert st)  | otherwise    = AI NoAlert st
                updateAlertness roll (AI MightSee st) | canSeePlayer && not (canHide roll) = AI (Suspicious 1) st
                updateAlertness roll (AI MightSee st) | otherwise                          = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | n == 0                = AI NoAlert st
                updateAlertness roll (AI (Suspicious n) st) | not canSeePlayer      = AI (Suspicious (n - 1)) st
                updateAlertness roll (AI (Suspicious n) st) | canSeePlayer && n < 4 = AI (Suspicious (n + 1)) st
                updateAlertness roll (AI (Suspicious n) st) | otherwise             = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | canSeePlayer = AI (Alert 10) st
                updateAlertness roll (AI (Alert n) st) | n == 0       = AI NoAlert st
                updateAlertness roll (AI (Alert n) st) | otherwise    = AI (Alert (n - 1)) st
                updateAlertness _ x = x

                newPatrolPoint :: GameState -> { p :: Point, game :: GameState }
                newPatrolPoint g' = let points = validPatrolPoints
                                        gen    = randInt 0 (length points - 1) g'
                                    in { p: fromMaybe zerop (points !! gen.n), game: gen.game }

                validPatrolPoints :: [Point]
                validPatrolPoints = filter canWalkOn $ levelPoints state.level
                    where
                        canWalkOn p = isValidMove state.level p && not (isValidMove state.level (p .+. {x: 0, y: 1}))

                updateAI :: GameState -> AI -> GameState
                updateAI g (AI (Alert _) _) | get i g Peasant (\c -> c.ctype) == Archer && canSeePlayer = get i g g (flip npcAttack g)
                updateAI g (AI (Alert _) _)      = mover g $ moveToPlayer
                updateAI g (AI (Suspicious _) _) = mover g $ moveToPlayer
                updateAI g (AI _ (Idle p))       = mover g $ moveToPoint p
                updateAI g (AI a (Patrol p)) =
                    if length (pathToPoint g cpos p) <= 2 then
                        let gen = newPatrolPoint g
                        in modifyCreatureAt i gen.game (\c -> c { ai = AI a (Patrol gen.p) })
                    else mover g $ moveToPoint p
                updateAI g _ = g

                mover :: GameState -> (Creature -> Point) -> GameState
                mover g@(Game state) f = let nextPoint = get i g zerop f
                            in if state.player.pos .==. nextPoint then
                                -- get doesn't really get anything from creature, I'm just exploiting
                                -- it's type to make the attack.
                                -- get :: Number -> GameState -> GameState -> (Creature -> GameState) -> Gamestate
                                get i g g (flip npcAttack g)
                            else modifyCreatureAt i g $ walk nextPoint

                walk :: Point -> Creature -> Creature
                walk p c = c { pos = p, dir = p .-. c.pos }

                moveToPoint :: Point -> Creature -> Point
                moveToPoint p c = case head (pathToPoint g c.pos p) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

                moveToPlayer :: Creature -> Point
                moveToPlayer c = case head (pathToPlayer g c.pos) of
                                   Just p'  -> p'
                                   Nothing -> c.pos

        pathToPoint :: GameState -> Point -> Point -> [Point]
        pathToPoint (Game state) start end = findPath state.pathfinder start end

        pathToPlayer :: GameState -> Point -> [Point]
        pathToPlayer g@(Game state) start = pathToPoint g start (groundProject state.player.pos)
            where
                -- Projects position to ground or climbable tile.
                groundProject :: Point -> Point
                groundProject p | isClimbable state.level (p .+. {x:0, y:0}) = p
                groundProject p | isValidMove state.level (p .+. {x:0, y:1}) = groundProject (p .+. {x:0, y:1})
                groundProject p | otherwise = p

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }
updatePhysics _ c = c { vel = zerop }

npcWeapon :: Creature -> Item
npcWeapon _ = { itemType: Weapon { weaponType: Sword, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

-- todo: get player weapon from equipment
playerWeapon :: GameState -> Item
playerWeapon _ = { itemType: Weapon { weaponType: Axe, material: Iron, prefix: [Masterwork] }, pos: zerop, vel: zerop }

playerAttack :: Number -> GameState -> GameState
playerAttack i g@(Game state) = let attack = playerHit g
                                in if attack.hit then addMsg ("You hit the " ++ (get i g "" (\c -> show c.ctype)) ++ "!") $ modifyCreatureAt i attack.game (takeDamage (playerWeapon g) state.player)
                                   else addMsg ("You missed the " ++ get i g "" (\c -> show c.ctype) ++ "!") attack.game

npcAttack :: Creature -> GameState -> GameState
npcAttack c g = let attack = npcHit c g
                in if attack.hit then addMsg (show c.ctype ++ " hit you!") <<< (\(Game st) -> Game st { player = takeDamage (npcWeapon c) c st.player }) $ attack.game
                else addMsg (capitalize (show c.ctype) ++ " tried to " ++ attackVerb c.ctype ++ " you, but missed.") attack.game
    where
        attackVerb Archer = "shoot"
        attackVerb _      = "attack"

baseHitChance :: Creature -> Number
baseHitChance c = 50 + 5 * (statModf c.stats.dex)

playerHit :: GameState -> { hit :: Boolean, game :: GameState }
playerHit g@(Game state) = let u = useSkill WeaponSkill (baseHitChance state.player) 20 g
                           in { hit: u.success, game: u.game }

npcHit :: Creature -> GameState -> { hit :: Boolean, game :: GameState }
npcHit c g = let u = randInt 0 99 g in { hit: u.n < baseHitChance c, game: u.game }

takeDamage :: Item -> Creature -> Creature -> Creature
takeDamage weapon attacker defender = defender { stats = defender.stats { hp = defender.stats.hp - damage } }
    where
        damage = (weaponStat weapon).damage + statModf attacker.stats.str

-- Moves an object that has position. Checks collisions with solid tiles.
move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos
        w (Level level) = level.width
        h (Level level) = level.height

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 (w state.level - 1), y: clamp pos.y 0 (h state.level - 1) }

-- Updates the game world.
updateWorld :: Boolean -- Update player also?
            -> Number  -- How many time units the game world advances
            -> GameState -> GameState
updateWorld updatePlayer advance =
    updateCreatures advance >>> (if updatePlayer then updatePlayerPhysics else id) >>> updateItemPhysics
    where
        updatePlayerPhysics (Game state) | isClimbable state.level state.player.pos =
            Game state
        updatePlayerPhysics (Game state) | otherwise =
            Game state { player = updatePhysics (Game state) state.player }

        updateItemPhysics (Game state) = Game state { items = map (updatePhysics (Game state)) state.items }

-- Sets tile at point p to tile t. Recalculates pathfinding graph.
setTile' :: Point -> Tile -> GameState -> GameState
setTile' p t (Game state) = let newlevel = setTile state.level p t
                            in Game state { level = newlevel, pathfinder = makePathfinder (levelWeights newlevel) }

canGrab :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
canGrab level c = climb || (isFree {x:0, y: 1} && (ledge (-1) || ledge 1))
    where
        climb = isClimbable level c.pos
        ledge dx = isFree {x: dx, y: -1} && blocked {x: dx, y: 0}
        isFree delta  = isValidMove level (c.pos .+. delta)
        blocked = not <<< isFree

playerCannotAct :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
playerCannotAct level c = inFreeFall level c && not (canGrab level c)

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) = let blockIndex = enemyBlocks state.npcs 0
    in if blockIndex >= 0 then
        updateWorld false (weaponStat $ playerWeapon g).attackSpeed $ playerAttack blockIndex g
        else if canMove then
            updateWorld false (calcSpeed g) <<< useMoveSkill $ Game state { player = move (Game state) state.player { vel = zerop } delta }
            else checkTile <<< fromMaybe Air <<< getTile state.level $ newpos
    where
        useMoveSkill :: GameState -> GameState
        useMoveSkill g@(Game state) | state.move == RunMode && not (delta .==. zerop) = (useSkill Athletics 50 2 g).game
        useMoveSkill g@(Game state) | state.move == SneakMode && canGetSneakSkill g && not (delta .==. zerop) = (useSkill Sneak 100 5 g).game
        useMoveSkill g@(Game state) | otherwise = g

        canGetSneakSkill :: GameState -> Boolean
        canGetSneakSkill (Game state) = any (\c -> lineOfSight state.level c.pos state.player.pos) $ filter (\c -> noAlert c.ai) state.npcs

        noAlert :: AI -> Boolean
        noAlert (AI NoAlert _)  = true
        noAlert (AI MightSee _) = true
        noAlert _               = false

        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

        enemyBlocks (c:cs) i | c.pos .==. newpos = i
        enemyBlocks (c:cs) i | otherwise         = enemyBlocks cs (i + 1)
        enemyBlocks [] _                         = -1

        checkTile :: Tile -> GameState
        checkTile DoorClosed = updateWorld false 500 $ addMsg "You open the door." $ setTile' newpos DoorOpen g
        checkTile DoorLocked = updateWorld false 2000 $ pickLock
        checkTile _          = g

        pickLock :: GameState
        pickLock = let use = useSkill Lockpick 10 20 g
                   in if use.success then addMsg "The door is locked. You managed to pick the lock." $ setTile' newpos DoorClosed use.game
                   else addMsg "The door is locked. You fail to pick the lock." use.game

playerJump :: GameState -> Number -> GameState
playerJump g@(Game state) xdir | not (isValidMove state.level (state.player.pos .+. {x: xdir, y: -1})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isValidMove state.level (state.player.pos .+. {x: xdir, y: -1}) && not (isValidMove state.level (state.player.pos .+. {x: xdir, y: 0})) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | isClimbable state.level (state.player.pos .+. {x: xdir, y: -1}) =
    movePlayer {x: xdir, y: -1} g
playerJump g@(Game state) xdir | otherwise =
    Game state { player = state.player { vel = {x: xdir, y: -3} } }

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}
                          ,numpad 1 // {x: -1, y:  1}
                          ,numpad 3 // {x:  1, y:  1}]

numberkeys :: [Number]
numberkeys = (48 .. 57) ++ (96 .. 105)

numbers :: M.Map Number Number
numbers = M.fromList [48 // 0, 49 // 1, 50 // 2, 51 // 3, 52  // 4, 53  // 5, 54  // 6, 55  // 7, 56  // 8, 57  // 9
                     ,96 // 0, 97 // 1, 98 // 2, 99 // 3, 100 // 4, 101 // 5, 102 // 6, 103 // 7, 104 // 8, 105 // 9]

-- Player tries to pick up an item.
pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just ( { itemType = Loot { value = points } } ) -> addMsg ("You found " ++ show points ++ " $!") $ Game state { items = deleteItem state.items point, points = state.points + points }
        Just item -> case ( ( carryingWeight (M.values state.equipments) + carryingWeight state.inventory ) / maxCarryingCapacity state.player ) < 110 of
                         true  -> addMsg ("You acquired: " ++ show item.itemType) $ Game state { items = deleteItem state.items point, inventory = item : state.inventory }
                         false -> addMsg "You can't carry that much weight!" $ Game state
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

-- Player tries to drop item while in inventory.
dropItem :: Number -> GameState -> GameState
dropItem itemNumber g@(Game state@{ window = InventoryW wi, inventory = inv, items = itemsOnGround }) =
    case (!!) inv i of
        (Just item) -> addMsg ("You dropped: " ++ show item.itemType) $ (Game state { inventory = deleteAt i 1 inv, items = (item { pos = state.player.pos }) : itemsOnGround, window = InventoryW wi { index = 0 } })
        Nothing -> g
    where
        i = itemNumber + wi.index * 10
dropItem _ g = g

-- Remove some equipment in particular slot
removeOldEquip :: EquipmentSlot -> M.Map EquipmentSlot Item -> M.Map EquipmentSlot Item
removeOldEquip slot eq =
    case M.lookup slot eq of
        Just item -> M.delete slot eq
        Nothing   -> eq

-- Equip function (used while in inventory and equipment slot is chosen).
equip :: Number -> GameState -> GameState
equip i g@(Game state@{ equipments = eq, window = InventoryW { equip = (Just slot) }, inventory = inv }) =
    case (!!) inv i of
        Just item -> case isValidEquip item.itemType slot of
                        true  -> Game state { equipments = M.insert slot item eq , inventory = deleteAt i 1 inv, window = EquipW }
                        false -> addMsg ("Can't equip that item " ++ show slot) g
        Nothing -> addMsg "There is no item in there." g
equip _ g = g

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState

-- If player has 0 hp left, kill the player (no key can save you!)
onKeyPress console (Game state) _ | state.player.stats.hp <= 0 = return $ Death { playerName: state.playerName, points: state.points }
-- In death, press enter to star again
onKeyPress console (Death d) key | key == 13 = return $ MainMenu

onKeyPress console g@(Game state) _   | playerCannotAct state.level state.player = return g

-- Change page in inventory with + and -
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107) && floor ((length inv) / 10) <= iw.index = drawGame console $ Game state { window = InventoryW iw { index = 0 } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 187 || key == 107)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index + 1) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109) && iw.index == 0                         = drawGame console $ Game state { window = InventoryW iw { index = (floor ((length inv) / 10)) } }
onKeyPress console (Game state@{ window = InventoryW iw, inventory = inv }) key | (key == 189 || key == 109)                                          = drawGame console $ Game state { window = InventoryW iw { index = (iw.index - 1) } }

-- Choosing equipment slot in equipment window
onKeyPress console g@(Game state@{ window = EquipW , equipments = eq , inventory = inv }) key | elem key numberkeys =
    case (!!) allEquipmentSlots number of
        Just slot  -> case M.lookup slot eq of
                          Just item -> drawGame console $ (Game state { window = EquipW, equipments = removeOldEquip slot eq, inventory = item : inv })
                          Nothing   -> drawGame console $ (Game state { window = InventoryW { index: 0, command: NoCommand, equip: Just slot } })
        Nothing  -> return g
        where
            number :: Number
            number =
                case M.lookup key numbers of
                    Just n  -> n
                    Nothing -> -1

-- Using command in inventory
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == 68        = drawGame console $ Game state { window = InventoryW { index: iw.index, command: Drop, equip: Nothing } }
onKeyPress console g@(Game state@{ window = InventoryW iw@{ command = Drop, equip = Nothing } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ dropItem number (Game state { window = InventoryW iw { command = NoCommand } })
        Nothing     -> return g

-- Equipping item while in inventory window (when equip option is valid)
onKeyPress console g@(Game state@{ window = InventoryW iw@{ equip = slot } }) key | elem key numberkeys =
    case M.lookup key numbers of
        Just number -> drawGame console $ equip number g
        Nothing     -> return g

-- Change game states window with s, i and e (GameW, EquipW and InventoryW) TODO: add skillwindow
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "I" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = EquipW  })       key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "I" = drawGame console $ Game state { window = InventoryW { index: 0, command: NoCommand, equip: Nothing } }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "E" = drawGame console $ Game state { window = EquipW }
onKeyPress console (Game state@{ window = InventoryW iw }) key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = EquipW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }
onKeyPress console (Game state@{ window = SkillW })        key | key == makeCharCode "A" = drawGame console $ Game state { window = GameW }
onKeyPress console (Game state@{ window = GameW })         key | key == makeCharCode "A" = drawGame console $ Game state { window = SkillW }

-- Esc closes inventory, equipment or skill window and returns the player to the game window
onKeyPress console (Game state) key | key == 27 = drawGame console $ Game state { window = GameW }

-- Change movement mode
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move == RunMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "R" && move /= RunMode = drawGame console $ Game state { move = RunMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move == SneakMode = drawGame console $ Game state { move = NormalMode }
onKeyPress console (Game state@{ move = move }) key | key == makeCharCode "S" && move /= SneakMode = drawGame console $ Game state { move = SneakMode }

onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 7               = drawGame console $ playerJump g (-1)
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 9               = drawGame console $ playerJump g 1
onKeyPress console g@(Game state@{ window = GameW }) key | key == numpad 8               = drawGame console $ playerJump g 0
onKeyPress console g@(Game state@{ window = GameW }) key | key == makeCharCode "G"       = drawGame console $ pickUp (state.player.pos) g
onKeyPress console g@(Game state@{ window = GameW }) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                              | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation { playerName = pname }) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation { playerName = xs })    key | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation { playerName = "" })    key                   = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation { playerName = xs })    key | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation { playerName = xs })    key                   = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation { playerName = xs })    key | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}


Add Machine.snapshot and Machine.halted

Add Machine.snapshot and Machine.halted

The former exposes a formatted root expression and trace, and the latter
allows the caller to determine if a Machine is in the halt state

module Machine
  ( Machine(..)
  , new
  , step
  , add
  , remove
  , halted
  , snapshot
  , testBig
  , testSmall
  ) where

import Prelude hiding (add)

import Effect (Effect)
import Control.Monad.Rec.Class (tailRecM, Step(..))
import Control.Monad.State (class MonadState, evalState, execState, gets, modify_)
import Data.Foldable (class Foldable, fold)
import Data.List (List(..), (:))
import Language.Parse (unsafeParse, parseSyntax)
import Effect.Console (log)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), uncurry)
import Language.Expr (Expr(..), syntaxToExpr)
import Language.Syntax (Syntax(..))
import Language.PrettyPrint (prettyPrint, sugar)
import Language.Name (Name, name_)
import Machine.Address (Address)
import Machine.Globals (Globals)
import Machine.Globals as Globals
import Machine.Heap (Heap)
import Machine.Heap as Heap
import Machine.Node (Node(..), Stuck(..))
import Machine.Node as Node
import Machine.Stack (Stack)
import Machine.Stack as Stack
import Machine.Stash (Stash)
import Machine.Stash as Stash
import Machine.Trace (Trace(..))
import Partial.Unsafe (unsafeCrashWith)

type Machine =
  { root :: Address
  , stack :: Stack
  , stash :: Stash
  , heap :: Heap Node
  , globals :: Globals
  , trace :: Trace
  }

new :: forall f. Foldable f => f (Tuple Name Expr) -> Expr -> Machine
new rawGlobals expr =
  { root
  , heap
  , globals
  , stack: Stack.singleton root
  , stash: Stash.empty
  , trace: Start
  }
 where
  empty = { heap: Heap.empty, globals: Globals.empty }
  {root, globals, heap} = flip evalState empty $ do
    traverse_ (uncurry Node.define) rawGlobals
    root <- Node.compile expr
    heap <- gets _.heap
    globals <- gets _.globals
    pure {root, globals, heap}

halted :: Machine -> Boolean
halted m = case m.trace of
  Halted _ -> true
  _ -> false

add :: Name -> Expr -> Machine -> Machine
add name expr = execState $ Node.define name expr

remove :: Name -> Machine -> Machine
remove name = execState $ Globals.remove name

emit :: forall s m. MonadState { trace :: Trace | s } m => Trace -> m Unit
emit message = modify_ _ { trace = message }

step :: Machine -> Machine
step = stepWith interesting

stepWith :: (Trace -> Boolean) -> Machine -> Machine
stepWith stop m = execState (tailRecM go unit) m
 where
  go _ = do
    { top } <- gets _.stack
    eval top =<< Heap.fetch top
    trace <- gets _.trace
    pure if stop trace
      then Done unit
      else Loop unit

interesting :: Trace -> Boolean
interesting = case _ of
  Fetched _ -> true
  Substituted _ _ -> true
  Halted _ -> true
  _ -> false

eval :: forall m. MonadState Machine m => Address -> Node -> m Unit
eval top = case _ of
  Node f _ -> do
    Stack.push f
    emit $ Unwound f

  Pointer address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> pure unit
    Stack.replace address
    emit $ Followed address

  Global name address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> Heap.update top $ Pointer address
    Stack.replace address
    emit $ Fetched name

  Closure env name e ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        node <- Node.instantiate (Cons arg env) e
        Heap.update app $ Pointer node
        Stack.discard
        Stack.replace node
        emit $ Substituted name arg
      Nothing -> do
        arg <- Heap.alloc $ Stuck $ StuckVar name
        node <- Node.instantiate (Cons arg env) e
        stuck <- Heap.alloc $ Stuck $ StuckBind name node
        Heap.update top $ Pointer stuck
        Stack.replace node
        emit $ WentUnder top

  Stuck _ ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        stuck <- Heap.alloc $ Stuck $ StuckApp top arg
        Heap.update app $ Pointer stuck
        Stack.discard
        Stack.replace arg
        Stash.suspend
        emit $ Discarded top arg
      Nothing ->
        Stash.restore >>= case _ of
          Just arg -> emit $ Discarded top arg
          Nothing -> emit $ Halted top

fetchArg :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Address
fetchArg address = do
  node <- Heap.fetch address
  case node of
    Node _ arg -> pure arg
    _ -> unsafeCrashWith $ fold
      [ "Non-application below top of stack: "
      , show node
      ]

formatNode :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Syntax
formatNode address = do
  node <- Heap.fetch address
  case node of
    Node f a -> Apply <$> formatNode f <*> formatNode a
    Closure env0 name e -> do
      env <- traverse formatNode env0
      pure $ Lambda name $ toSyntax (Var name : env) e
    Stuck term -> formatStuck term
    Pointer a -> formatNode a
    Global name _ -> pure $ Var name

toSyntax :: List Syntax -> Expr -> Syntax
toSyntax env = case _ of
  Bind n e -> Lambda n $ toSyntax (Var n : env) e
  App f a -> Apply (toSyntax env f) (toSyntax env a)
  Bound i -> Node.deref i env
  Free n -> Var n

formatStuck :: forall s m. MonadState { heap :: Heap Node | s } m => Stuck -> m Syntax
formatStuck = case _ of
  StuckVar name -> pure $ Var name
  StuckBind name e  -> Lambda name <$> formatNode e
  StuckApp f a -> Apply <$> formatNode f <*> formatNode a

formatSyntax :: Syntax -> String
formatSyntax = sugar <<< prettyPrint

formatTrace :: forall s m. MonadState { heap :: Heap Node | s } m => Trace -> m String
formatTrace = map fold <<< case _ of
  Start -> pure ["Start"]
  Unwound address -> do
    node <- formatNode address
    pure
      [ "Unwound "
      , formatSyntax node
      ]
  Followed address -> do
    node <- formatNode address
    pure
      [ "Followed #"
      , show address
      , " to "
      , formatSyntax node
      ]
  Fetched name -> pure
    [ "Fetched "
    , show name
    ]
  Instantiated address -> do
    node <- formatNode address
    pure
      [ "Instantiated new copy of "
      , formatSyntax node
      ]
  Substituted name address -> do
    stuck <- isStuck <$> Heap.fetch address
    node <- formatNode address
    pure
      [ "Substituted "
      , if stuck then "stuck term " else ""
      , formatSyntax node
      , " in for "
      , show name
      ]
  WentUnder address -> do
    node <- formatNode address
    pure
      [ "Went under stuck lambda "
      , formatSyntax node
      ]
  Discarded discarded next -> do
    stuck <- formatNode discarded
    node <- formatNode next
    pure
      [ "Discarded stuck term "
      , formatSyntax stuck
      , "; evaluating "
      , formatSyntax node
      ]
  Halted address -> do
    node <- formatNode address
    pure
      [ "Halted with "
      , formatSyntax node
      , " on top of stack"
      ]
 where
  isStuck = case _ of
    Stuck _ -> true
    _ -> false

snapshot :: Machine -> { root :: Syntax, trace :: String }
snapshot = evalState do
  root <- formatNode =<< gets _.root
  trace <- formatTrace =<< gets _.trace
  pure { root, trace }

testBig :: Int -> String -> Effect Unit
testBig = testWith (stepWith interesting)

testSmall :: Int -> String -> Effect Unit
testSmall = testWith (stepWith $ const true)

testWith :: (Machine -> Machine) -> Int -> String -> Effect Unit
testWith next n = go 0 <<< new prelude <<< parse
 where
  go i m
    | i >= n = log $ "Did not halt in " <> show n <> " steps"
    | otherwise = do
        let { root, trace } = snapshot m
        log $ "Step " <> show i
        log $ "  trace: " <> trace
        log $ "  root:  " <> formatSyntax root
        case m.trace of
          Halted _ -> pure unit
          _ -> go (i + 1) $ next m

parse :: String -> Expr
parse = syntaxToExpr <<< unsafeParse parseSyntax

def :: String -> String -> Tuple Name Expr
def n = Tuple (name_ n) <<< parse

infix 1 def as =.

prelude :: Array (Tuple Name Expr)
prelude =
  [ "identity" =. "λx. x"
  , "const" =. "λx y. x"
  , "true" =. "λt f. t"
  , "false" =. "λt f. f"
  , "fix" =. "λf. (λx. f (x x)) (λy. f (y y))"
  , "and" =. "λx y. x y false"
  , "or" =. "λx y. x true y"
  , "not" =. "λx. x false true"
  , "foldr" =. "λf z l. l f z"
  , "all" =. "foldr and true"
  , "any" =. "foldr or false"
  , "cons" =. "λx xs cons nil. cons x (xs cons nil)"
  , "nil" =. "λx xs cons nil. nil"
  , "iterate" =. "fix (λnext. λf x. cons x (next f (f x)))"
  , "repeat" =. "fix (λnext. λx. cons x (next x))"
  , "pair" =. "λa b f. f a b"
  , "fst" =. "λp. p (λa b. a)"
  , "snd" =. "λp. p (λa b. b)"
  , "succ" =. "λn s z. s (n s z)"
  , "add" =. "λm n s z. m s (n s z)"
  , "mul" =. "λm n s z. m (n s) z"
  , "pred" =. "λn f x. n (λg. λh. h (g f)) (λu. x) (λu. u)"
  , "is-zero?" =. "λn. n (λx. false) true"
  ]

module Machine
  ( Machine(..)
  , new
  , step
  , add
  , remove
  , testBig
  , testSmall
  ) where

import Prelude hiding (add)

import Effect (Effect)
import Control.Monad.Rec.Class (tailRecM, Step(..))
import Control.Monad.State (class MonadState, evalState, execState, gets, modify_)
import Data.Foldable (class Foldable, fold)
import Data.List (List(..), (:))
import Language.Parse (unsafeParse, parseSyntax)
import Effect.Console (log)
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), uncurry)
import Language.Expr (Expr(..), syntaxToExpr)
import Language.Syntax (Syntax(..))
import Language.PrettyPrint (prettyPrint, sugar)
import Language.Name (Name, name_)
import Machine.Address (Address)
import Machine.Globals (Globals)
import Machine.Globals as Globals
import Machine.Heap (Heap)
import Machine.Heap as Heap
import Machine.Node (Node(..), Stuck(..))
import Machine.Node as Node
import Machine.Stack (Stack)
import Machine.Stack as Stack
import Machine.Stash (Stash)
import Machine.Stash as Stash
import Machine.Trace (Trace(..))
import Partial.Unsafe (unsafeCrashWith)

type Machine =
  { root :: Address
  , stack :: Stack
  , stash :: Stash
  , heap :: Heap Node
  , globals :: Globals
  , trace :: Trace
  }

new :: forall f. Foldable f => f (Tuple Name Expr) -> Expr -> Machine
new rawGlobals expr =
  { root
  , heap
  , globals
  , stack: Stack.singleton root
  , stash: Stash.empty
  , trace: Start
  }
 where
  empty = { heap: Heap.empty, globals: Globals.empty }
  {root, globals, heap} = flip evalState empty $ do
    traverse_ (uncurry Node.define) rawGlobals
    root <- Node.compile expr
    heap <- gets _.heap
    globals <- gets _.globals
    pure {root, globals, heap}

add :: Name -> Expr -> Machine -> Machine
add name expr = execState $ Node.define name expr

remove :: Name -> Machine -> Machine
remove name = execState $ Globals.remove name

emit :: forall s m. MonadState { trace :: Trace | s } m => Trace -> m Unit
emit message = modify_ _ { trace = message }

step :: Machine -> Machine
step = stepWith interesting

stepWith :: (Trace -> Boolean) -> Machine -> Machine
stepWith stop m = execState (tailRecM go unit) m
 where
  go _ = do
    { top } <- gets _.stack
    eval top =<< Heap.fetch top
    trace <- gets _.trace
    pure if stop trace
      then Done unit
      else Loop unit

interesting :: Trace -> Boolean
interesting = case _ of
  Fetched _ -> true
  Substituted _ _ -> true
  Halted _ -> true
  _ -> false

eval :: forall m. MonadState Machine m => Address -> Node -> m Unit
eval top = case _ of
  Node f _ -> do
    Stack.push f
    emit $ Unwound f

  Pointer address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> pure unit
    Stack.replace address
    emit $ Followed address

  Global name address -> do
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        Heap.update app $ Node address arg
      Nothing -> Heap.update top $ Pointer address
    Stack.replace address
    emit $ Fetched name

  Closure env name e ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        node <- Node.instantiate (Cons arg env) e
        Heap.update app $ Pointer node
        Stack.discard
        Stack.replace node
        emit $ Substituted name arg
      Nothing -> do
        arg <- Heap.alloc $ Stuck $ StuckVar name
        node <- Node.instantiate (Cons arg env) e
        stuck <- Heap.alloc $ Stuck $ StuckBind name node
        Heap.update top $ Pointer stuck
        Stack.replace node
        emit $ WentUnder top

  Stuck _ ->
    Stack.peek 1 >>= case _ of
      Just app -> do
        arg <- fetchArg app
        stuck <- Heap.alloc $ Stuck $ StuckApp top arg
        Heap.update app $ Pointer stuck
        Stack.discard
        Stack.replace arg
        Stash.suspend
        emit $ Discarded top arg
      Nothing ->
        Stash.restore >>= case _ of
          Just arg -> emit $ Discarded top arg
          Nothing -> emit $ Halted top

fetchArg :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Address
fetchArg address = do
  node <- Heap.fetch address
  case node of
    Node _ arg -> pure arg
    _ -> unsafeCrashWith $ fold
      [ "Non-application below top of stack: "
      , show node
      ]

formatNode :: forall s m. MonadState { heap :: Heap Node | s } m => Address -> m Syntax
formatNode address = do
  node <- Heap.fetch address
  case node of
    Node f a -> Apply <$> formatNode f <*> formatNode a
    Closure env0 name e -> do
      env <- traverse formatNode env0
      pure $ Lambda name $ toSyntax (Var name : env) e
    Stuck term -> formatStuck term
    Pointer a -> formatNode a
    Global name _ -> pure $ Var name

toSyntax :: List Syntax -> Expr -> Syntax
toSyntax env = case _ of
  Bind n e -> Lambda n $ toSyntax (Var n : env) e
  App f a -> Apply (toSyntax env f) (toSyntax env a)
  Bound i -> Node.deref i env
  Free n -> Var n

formatStuck :: forall s m. MonadState { heap :: Heap Node | s } m => Stuck -> m Syntax
formatStuck = case _ of
  StuckVar name -> pure $ Var name
  StuckBind name e  -> Lambda name <$> formatNode e
  StuckApp f a -> Apply <$> formatNode f <*> formatNode a

formatSyntax :: Syntax -> String
formatSyntax = sugar <<< prettyPrint

formatTrace :: forall s m. MonadState { heap :: Heap Node | s } m => Trace -> m String
formatTrace = map fold <<< case _ of
  Start -> pure ["Start"]
  Unwound address -> do
    node <- formatNode address
    pure
      [ "Unwound "
      , formatSyntax node
      ]
  Followed address -> do
    node <- formatNode address
    pure
      [ "Followed #"
      , show address
      , " to "
      , formatSyntax node
      ]
  Fetched name -> pure
    [ "Fetched "
    , show name
    ]
  Instantiated address -> do
    node <- formatNode address
    pure
      [ "Instantiated new copy of "
      , formatSyntax node
      ]
  Substituted name address -> do
    stuck <- isStuck <$> Heap.fetch address
    node <- formatNode address
    pure
      [ "Substituted "
      , if stuck then "stuck term " else ""
      , formatSyntax node
      , " in for "
      , show name
      ]
  WentUnder address -> do
    node <- formatNode address
    pure
      [ "Went under stuck lambda "
      , formatSyntax node
      ]
  Discarded discarded next -> do
    stuck <- formatNode discarded
    node <- formatNode next
    pure
      [ "Discarded stuck term "
      , formatSyntax stuck
      , "; evaluating "
      , formatSyntax node
      ]
  Halted address -> do
    node <- formatNode address
    pure
      [ "Halted with "
      , formatSyntax node
      , " on top of stack"
      ]
 where
  isStuck = case _ of
    Stuck _ -> true
    _ -> false

format :: Machine -> { root :: String, trace :: String }
format = evalState do
  root <- map formatSyntax <<< formatNode =<< gets _.root
  trace <- formatTrace =<< gets _.trace
  pure { root, trace }

testBig :: Int -> String -> Effect Unit
testBig = testWith (stepWith interesting)

testSmall :: Int -> String -> Effect Unit
testSmall = testWith (stepWith $ const true)

testWith :: (Machine -> Machine) -> Int -> String -> Effect Unit
testWith next n = go 0 <<< new prelude <<< parse
 where
  go i m
    | i >= n = log $ "Did not halt in " <> show n <> " steps"
    | otherwise = do
        let { root, trace } = format m
        log $ "Step " <> show i
        log $ "  trace: " <> trace
        log $ "  root:  " <> root
        case m.trace of
          Halted _ -> pure unit
          _ -> go (i + 1) $ next m

parse :: String -> Expr
parse = syntaxToExpr <<< unsafeParse parseSyntax

def :: String -> String -> Tuple Name Expr
def n = Tuple (name_ n) <<< parse

infix 1 def as =.

prelude :: Array (Tuple Name Expr)
prelude =
  [ "identity" =. "λx. x"
  , "const" =. "λx y. x"
  , "true" =. "λt f. t"
  , "false" =. "λt f. f"
  , "fix" =. "λf. (λx. f (x x)) (λy. f (y y))"
  , "and" =. "λx y. x y false"
  , "or" =. "λx y. x true y"
  , "not" =. "λx. x false true"
  , "foldr" =. "λf z l. l f z"
  , "all" =. "foldr and true"
  , "any" =. "foldr or false"
  , "cons" =. "λx xs cons nil. cons x (xs cons nil)"
  , "nil" =. "λx xs cons nil. nil"
  , "iterate" =. "fix (λnext. λf x. cons x (next f (f x)))"
  , "repeat" =. "fix (λnext. λx. cons x (next x))"
  , "pair" =. "λa b f. f a b"
  , "fst" =. "λp. p (λa b. a)"
  , "snd" =. "λp. p (λa b. b)"
  , "succ" =. "λn s z. s (n s z)"
  , "add" =. "λm n s z. m s (n s z)"
  , "mul" =. "λm n s z. m (n s) z"
  , "pred" =. "λn f x. n (λg. λh. h (g f)) (λu. x) (λu. u)"
  , "is-zero?" =. "λn. n (λx. false) true"
  ]


Uppercase effect

Uppercase effect

module Console where

import Control.Monad.Eff

-- | The `CONSOLE` effect represents those computations which write to the console.
foreign import data CONSOLE :: !

-- | Write a message to the console.
foreign import log
  """
  function log(s) {
    return function() {
      console.log(s);
      return {};
    };
  }
  """ :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write an error to the console.
foreign import error
  """
  function error(s) {
    return function() {
      console.error(s);
      return {};
    };
  }
  """ :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write a value to the console, using its `Show` instance to produce a `String`.
print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
print = log <<< show

module Console where

import Control.Monad.Eff

-- | The `Console` effect represents those computations which write to the console.
foreign import data Console :: !

-- | Write a `String` to the console.
foreign import log
  """
  function log(s) {
    return function() {
      console.log(s);
      return {};
    };
  }
  """ :: forall eff. String -> Eff (console :: Console | eff) Unit

-- | Write an error to the console
foreign import error
  """
  function error(s) {
    return function() {
      console.error(s);
      return {};
    };
  }
  """ :: forall eff. String -> Eff (console :: Console | eff) Unit

-- | Write a value to the console, using its `Show` instance to produce a `String`.
print :: forall a eff. (Show a) => a -> Eff (console :: Console | eff) Unit
print o = log (show o)