linux support

linux support

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Record (get)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (EXPRESS, ExpressM, Request, Response)
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 (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Type.Prelude (class RowToList, RLProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

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

type 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
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => GetFiles (Aff e) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => GetWatched (Aff e) where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => GetIcons (Aff e) where
  getIconsData {db} _ = do
    _ <- liftAff <<< liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => UpdateWatched (Aff e) where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => OpenFile (Aff e) where
  openFile {dir} (OpenRequest or) = do
    let
      simpleOpen = case platform of
        Just Linux -> Just "xdg-open"
        Just Darwin -> Just "open"
        _ -> Nothing
    _ <- liftAff $ case simpleOpen of
          Just command -> liftEff $ void $ spawn command (pure $ concat [dir, unwrap or.path]) defaultSpawnOptions
          _ -> liftEff $ exec ("start \"\" \"rust-vlc-finder\" \"" <> concat [dir, unwrap or.path] <>  "\"") defaultExecOptions (const $ pure unit)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => RemoveFile (Aff e) where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

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

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

registerRoutes :: forall routes handlers routesL handlersL m
   . RowToList routes routesL
  => RowToList handlers handlersL
  => Monad m
  => RoutesHandlers routesL handlersL routes handlers m
  => Record routes
  -> Record handlers
  -> m Unit
registerRoutes routes handlers =
  registerRoutesImpl
    (RLProxy :: RLProxy routesL)
    (RLProxy :: RLProxy handlersL)
    routes
    handlers

class RoutesHandlers
  (routesL :: RowList)
  (handlersL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  m
  where
    registerRoutesImpl :: forall proxy
       . Monad m
      => proxy routesL
      -> proxy handlersL
      -> Record routes
      -> Record handlers
      -> m Unit

instance routesHandlersNil :: RoutesHandlers Nil Nil trash1 trash2 m where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers rTail hTail routes handlers m
  , IsSymbol name
  , RowCons name handler trash1 handlers
  , RowCons name route trash2 routes
  , RegisterHandler route handler m
  ) => RoutesHandlers (Cons name route rTail) (Cons name handler hTail) routes handlers m where
  registerRoutesImpl _ _ routes handlers = do
    registerHandlerImpl (get nameP routes) (get nameP handlers)
    registerRoutesImpl (RLProxy :: RLProxy rTail) (RLProxy :: RLProxy hTail) routes handlers
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler m
  | route -> handler m
  where
    registerHandlerImpl :: route -> handler -> m Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.post route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        body <- getBody
        case runExcept (read body) of
          Right (r :: req) -> do
            response <- liftAff $ handler r
            sendJson $ write response
          Left e -> do
            setStatus 400
            sendJson $ write {error: show e}

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.get route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        response <- liftAff handler
        sendJson $ write response

routes :: forall e
   . Config
  -> App
       ( fs :: FS
       , db :: DBEffects
       , cp :: CHILD_PROCESS
       | e
       )
routes config = do
  useExternal jsonBodyParser
  registerRoutes
    apiRoutes
    { files: getFiles config
    , watched: getWatchedData config
    , getIcons: getIconsData config
    , update: updateWatched config
    , open: openFile config
    , remove: removeFile config
    }
  use $ static "dist"

main :: forall e
   . Eff
       ( console :: CONSOLE
       , db :: DBEffects
       , process :: PROCESS
       , cp :: CHILD_PROCESS
       , express :: EXPRESS
       , fs :: FS
       | e
       )
 Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"

module Main where

import Prelude

import Control.Monad.Aff (Aff, attempt, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import Data.Array (filter, sortBy)
import Data.Either (Either(Left, Right))
import Data.Foreign (Foreign)
import Data.Function.Uncurried (Fn3)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Record (get)
import Data.String (Pattern(Pattern), contains)
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Node.Buffer (BUFFER, Buffer, create, writeString)
import Node.ChildProcess (CHILD_PROCESS, defaultExecOptions, defaultSpawnOptions, exec, spawn)
import Node.Encoding (Encoding(..))
import Node.Express.App (App, AppM, listenHttp, use, useExternal)
import Node.Express.App as E
import Node.Express.Handler (HandlerM(HandlerM))
import Node.Express.Middleware.Static (static)
import Node.Express.Response (sendJson, setStatus)
import Node.Express.Types (EXPRESS, ExpressM, Request, Response)
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 (GetRequest, PostRequest, Route, apiRoutes)
import SQLite3 (DBConnection, DBEffects, FilePath, newDB, queryDB)
import Simple.JSON (class ReadForeign, class WriteForeign, read, write)
import Type.Prelude (class RowToList, RLProxy(..))
import Type.Row (Cons, Nil, kind RowList)
import Types (FileData(FileData), GetIconsRequest, OpenRequest(OpenRequest), Path(Path), RemoveRequest(RemoveRequest), Success(Success), WatchedData)
import Unsafe.Coerce (unsafeCoerce)

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

type 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
  )

class GetFiles m where
  getFiles :: Config -> m (Array Path)

instance gfAF ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => GetFiles (Aff e) where
  getFiles {dir} = liftAff $ readdir' dir

class GetWatched m where
  getWatchedData :: Config -> m (Array WatchedData)

instance gwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => GetWatched (Aff e) where
  getWatchedData {db} = do
    watchedData :: Array WatchedData <- liftAff $ unsafeCoerce <$>
      queryDB db "SELECT path, created FROM watched;" []
    pure $ watchedData

class GetIcons m where
  getIconsData :: Config -> GetIconsRequest -> m Success

instance giA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => GetIcons (Aff e) where
  getIconsData {db} _ = do
    _ <- liftAff <<< liftEff $ spawn "node" ["get-icons.js"] defaultSpawnOptions
    pure $ Success {status: "ok"}

class UpdateWatched m where
  updateWatched :: Config -> FileData -> m (Array WatchedData)

instance uwA ::
  ( MonadAff (db :: DBEffects | trash) (Aff e)
  ) => UpdateWatched (Aff e) where
  updateWatched config@{db} (FileData ur) = do
    _ <- liftAff $ if ur.watched
      then queryDB db "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [unwrap ur.path]
      else queryDB db "DELETE FROM watched WHERE path = $1" [unwrap ur.path]
    getWatchedData config

class OpenFile m where
  openFile :: Config -> OpenRequest -> m (Success)

instance ofA ::
  ( MonadAff (cp :: CHILD_PROCESS | trash) (Aff e)
  ) => OpenFile (Aff e) where
  openFile {dir} (OpenRequest or) = do
    _ <- liftAff $ case platform of
          Just 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)
    pure $ Success {status: "ok"}

class RemoveFile m where
  removeFile :: Config -> RemoveRequest -> m (Success)

instance rfA ::
  ( MonadAff (fs :: FS | trash) (Aff e)
  ) => RemoveFile (Aff e) where
  removeFile {dir} (RemoveRequest rr) = do
    let archive = concat [dir, "archive"]
    let name = unwrap rr.path
    let old = concat [dir, name]
    let new = concat [archive, name]
    _ <- liftAff $ do
      void $ attempt $ mkdir archive
      void $ attempt $ rename old new
    pure $ Success {status: "ok"}

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

foreign import jsonBodyParser :: forall e. Fn3 Request Response (ExpressM e Unit) (ExpressM e Unit)

foreign import _getBody :: Request -> Foreign

getBody :: forall e. HandlerM e Foreign
getBody = HandlerM \req _ _ -> pure $ _getBody req

registerRoutes :: forall routes handlers routesL handlersL m
   . RowToList routes routesL
  => RowToList handlers handlersL
  => Monad m
  => RoutesHandlers routesL handlersL routes handlers m
  => Record routes
  -> Record handlers
  -> m Unit
registerRoutes routes handlers =
  registerRoutesImpl
    (RLProxy :: RLProxy routesL)
    (RLProxy :: RLProxy handlersL)
    routes
    handlers

class RoutesHandlers
  (routesL :: RowList)
  (handlersL :: RowList)
  (routes :: # Type)
  (handlers :: # Type)
  m
  where
    registerRoutesImpl :: forall proxy
       . Monad m
      => proxy routesL
      -> proxy handlersL
      -> Record routes
      -> Record handlers
      -> m Unit

instance routesHandlersNil :: RoutesHandlers Nil Nil trash1 trash2 m where
  registerRoutesImpl _ _ _ _ = pure unit

instance routesHandlersCons ::
  ( RoutesHandlers rTail hTail routes handlers m
  , IsSymbol name
  , RowCons name handler trash1 handlers
  , RowCons name route trash2 routes
  , RegisterHandler route handler m
  ) => RoutesHandlers (Cons name route rTail) (Cons name handler hTail) routes handlers m where
  registerRoutesImpl _ _ routes handlers = do
    registerHandlerImpl (get nameP routes) (get nameP handlers)
    registerRoutesImpl (RLProxy :: RLProxy rTail) (RLProxy :: RLProxy hTail) routes handlers
    where
      nameP = SProxy :: SProxy name

class RegisterHandler route handler m
  | route -> handler m
  where
    registerHandlerImpl :: route -> handler -> m Unit

instance registerHandlerPost ::
  ( IsSymbol url
  , ReadForeign req
  , WriteForeign res
  ) => RegisterHandler
         (Route PostRequest req res url)
         (req -> Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.post route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        body <- getBody
        case runExcept (read body) of
          Right (r :: req) -> do
            response <- liftAff $ handler r
            sendJson $ write response
          Left e -> do
            setStatus 400
            sendJson $ write {error: show e}

instance registerHandlerGet ::
  ( IsSymbol url
  , WriteForeign res
  ) => RegisterHandler
         (Route GetRequest Void res url)
         (Aff (express :: EXPRESS | e) res)
         (AppM (express :: EXPRESS | e)) where
  registerHandlerImpl route handler =
    E.get route' handler'
    where
      route' = reflectSymbol (SProxy :: SProxy url)
      handler' = do
        response <- liftAff handler
        sendJson $ write response

routes :: forall e
   . Config
  -> App
       ( fs :: FS
       , db :: DBEffects
       , cp :: CHILD_PROCESS
       | e
       )
routes config = do
  useExternal jsonBodyParser
  registerRoutes
    apiRoutes
    { files: getFiles config
    , watched: getWatchedData config
    , getIcons: getIconsData config
    , update: updateWatched config
    , open: openFile config
    , remove: removeFile config
    }
  use $ static "dist"

main :: forall e
   . Eff
       ( console :: CONSOLE
       , db :: DBEffects
       , process :: PROCESS
       , cp :: CHILD_PROCESS
       , express :: EXPRESS
       , fs :: FS
       | e
       )
 Unit
main = void $ launchAff do
  dir' <- liftEff $ lookupEnv "FILETRACKER_DIR"
  case dir' of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- ensureDB $ concat [dir, "filetracker"]
      void $ liftEff $ listenHttp (routes {db, dir}) 3000 \_ ->
        log "Started server"


Moved incTime function into the do notation for an 11% improvement

module Core where

import Prelude (show, (++), ($), (&&), (==), (||), (+), bind, (<$>), (/=)
               ,(>>=), return, id, (<<<), (-), (<=))
import Data.Int.Bits ((.&.), (.|.))
import Data.Tuple (Tuple(Tuple), snd, fst)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Either (Either(Left, Right))
import Data.Foldable (elem)
import Data.Functor ((<$))
import Control.Monad.Eff (Eff)
import Control.Bind ((=<<))
import Control.Monad.Rec.Class (tailRecM)

import Types (Z80State, MemAccess, SavedRegs, Regs, Mem, I8, I16)
import MainMem (getIme, getIntE, getIntF, rd8, cleanMainMem, setIme, setIntF
               ,setVblIntrr, setGpu, getGpu, updImeCnt, setRom)
import Ops (callRoutine, getOpTiming, getCpuOp)
import OpCodeMap (mme2op, basicOpTimings, branchBasicOpTimings, cbOpTimings
                 ,basicOps)
import Gpu (Canvas, gpuStep)
import Utils (toHexStr, getOnBit)
import Regs

import Debug (StatTimer, condTr, timeIt)

--Get a fresh initial Z80State.
--The MemAccess effect is due to some writing operations during initialization.
reset :: forall e. Array I8 -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
reset rom = do
  cs <- cleanState
  return
    cs {
      mem = cs.mem {
        mainMem = setRom rom cs.mem.mainMem
      }
    }

--Run emulation until 'interval' clocks have passed.
run :: forall e. Int -> Z80State -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right st
  go { intr, st } | intr <= 0 = return $ Right st
  go { intr, st } = do
    {--if (shldTrc st) then traceA "-------step-------" else return unit--}
    st' <- step st
    {--st' <- stepTime st--}
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--Perform a single state operation, along with updatig accompanying state.
step :: forall e. Z80State -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
step state@{ mem = oldMem@{regs = oldRegs} } = do
  opt <- opTiming
  let incTime st@{totalM} = do
        return st { totalM = st.totalM + opt }
  state2 <- op state
  state3 <- incPc oldPc state2
  state4 <- incTime state3
  let state5 = updImeCntInMem state4
  handleGpu opt
    state5
    {--$ traceState state5--}
 where
  oldPc = pc oldRegs
  op st = if checkShldHndlIntrr st
    then interruptOp st
    else regularOp st
  regularOp st = do
    coc <- getCurrOpCode st
    getCpuOp coc basicOps st
  getCurrOpCode st = rd8 (pc st.mem.regs) st.mem.mainMem
  opTiming = getCurrOpTiming oldPc state
  updImeCntInMem st = st { mem = st.mem { mainMem = updImeCnt st.mem.mainMem } }

--Get the clock amount of the current operation.
getCurrOpTiming :: forall e. I16 -> Z80State -> Eff (ma :: MemAccess | e) Int
getCurrOpTiming oldPc st = do
  opCode <- rd8 oldPc st.mem.mainMem
  let isExtOp = opCode == 0xCB
  addr <- if isExtOp
    then rd8 (oldPc+1) st.mem.mainMem
    else return opCode
  let opTimingTable = if isExtOp
        then cbOpTimings
        else
          if brTkn st.mem.regs
            then branchBasicOpTimings
            else basicOpTimings
  return $ getOpTiming addr opTimingTable

--Update the gpu's state with the time it took to do the current operation,
--as it is waiting a certain amount of time between the different modes of
--updating the screen.
--NOTE is there a better way to set nested properties?
--consider checking the lens-equivalent in purescript.
incPc :: forall e. I8 -> Z80State -> Eff (ma :: MemAccess | e) Z80State
incPc oldPc st =
  if oldPc /= pc st.mem.regs
    then return st
    else st <$ setPC (65535 .&. (pc st.mem.regs + 1)) st.mem.regs

--NOTE change handleGpu to get the op timing itself, instead of reacquiring it here.
handleGpu :: forall e. Int -> Z80State
          -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
handleGpu opTiming st = do
  gpu' <- gpuStep opTiming (getGpu st.mem.mainMem)
  let intF' = (if gpu'.vblIntrr
                 then
                   ({-trace ("screen refresh, clk-count: " ++ show st.totalM) \_ ->-}
                     (0x01 .|. _))
                   else id)
                $ getIntF st.mem.mainMem

  setGpu gpu' st.mem.mainMem
  setVblIntrr false st.mem.mainMem
  setIntF intF' st.mem.mainMem
  return st

--Get the current interrupt handling operation, if there is an interrupt
--waiting to be handled
interruptOp :: forall e. Z80State -> Eff (ma :: MemAccess | e) Z80State
interruptOp st = do
  setIntF (fst res $ getIntF st.mem.mainMem) st.mem.mainMem
  setIme false st.mem.mainMem
  snd res st
 where
  res :: Tuple (Int -> Int) (Z80State -> Eff (ma :: MemAccess | e) Z80State)
  res = fromMaybe (Tuple id return) mRes
  mRes = getOnBit (interruptBits st) >>= \x -> case x of
           1  -> Just $ Tuple (0xFE .&. _) (mme2op $ callRoutine true 0x40 )
           2  -> Just $ Tuple (0xFD .&. _) (mme2op $ callRoutine true 0x48 )
           4  -> Just $ Tuple (0xFB .&. _) (mme2op $ callRoutine true 0x50 )
           8  -> Just $ Tuple (0xF7 .&. _) (mme2op $ callRoutine true 0x58 )
           16 -> Just $ Tuple (0xEF .&. _) (mme2op $ callRoutine true 0x60 )
           otherwise -> Nothing -- NOTE log this

--Get bit flags of interrupts waiting to be handled AND enabled
interruptBits :: Z80State -> I8
interruptBits st = getIntE st.mem.mainMem .&. getIntF st.mem.mainMem

checkShldHndlIntrr :: Z80State -> Boolean
checkShldHndlIntrr st = getIme st.mem.mainMem && interruptBits st /= 0

cleanState :: forall e. Eff (ma :: MemAccess | e) Z80State
cleanState =
  { mem : _
  , totalM : 1
  , halt : false
  , stop : false
  } <$> cleanMem

cleanMem :: forall e. Eff (ma :: MemAccess | e) Mem
cleanMem = do
  cmm <- cleanMainMem
  cr <- cleanRegs
  return
    { regs : cr
    , svdRegs : cleanSavedRegs
    , mainMem : cmm
    }

--Debug functions

--Step function that uses the Timing functions of Debug to compute average
--running times for operations.
stepTime :: forall e. Z80State
         -> Eff (ma :: MemAccess, canvas :: Canvas, timer :: StatTimer | e) Z80State
stepTime state = do
  currOpCode <- rd8 (pc state.mem.regs) state.mem.mainMem
  currImm <- rd8 (pc state.mem.regs + 1) state.mem.mainMem
  let timerIx = if (currOpCode `elem` memModifyOps)
                || (currOpCode == 0xCB && (currImm `elem` cbMemModifyOps))
                  then 1 else 0
  timeIt timerIx (\_ -> step state)
 where
  memModifyOps =
    [ 0x02 ,0x08 ,0x12 ,0x22 ,0x32 ,0x34 ,0x35 ,0x36 ,0x70 ,0x71
    , 0x72 ,0x73 ,0x74 ,0x75 ,0x77 ,0xc4 ,0xc5 ,0xc7 ,0xcc ,0xcd ,0xcf ,0xd4
    , 0xd5 ,0xd7 ,0xd9 ,0xdc ,0xdf ,0xe0 ,0xe2 ,0xe5 ,0xe7 ,0xea ,0xef ,0xf3
    , 0xf5 ,0xf7 ,0xfb ,0xff
    ]
  cbMemModifyOps =
    [ 0x06, 0x0e, 0x16, 0x1e, 0x26, 0x2e, 0x36, 0x3e, 0x86, 0x8e, 0x96, 0x9e
    , 0xa6, 0xae, 0xb6, 0xbe, 0xc6, 0xce, 0xd6, 0xde, 0xe6, 0xee, 0xf6, 0xfe
    ]

--Useful function for tracing various properties of the Z80State,
--every cpu step as long as shldTrc condition is satisfied.
--Commented lines remain for ease of enabling.
traceState :: Z80State -> Z80State
traceState state@{ mem = oldMem@{regs = oldRegs} } =
  condTr (shldTrc state) (\_ -> "totalM: "++show (state.totalM)) $
  {--condTr (shldTrc state) (\_ -> "totalM: "++show (state.totalM - 123958)) $--}

  {--condTr (shldTrc state) (\_ -> tileMap0Str state.mem) $--}
  {--condTr (shldTrc state) (\_ -> tileSet0Str state.mem) $--}

  condTr (shldTrc state) (\_ -> regsStr oldRegs) $
  {--condTr (shldTrc state) (\_ -> pcArea oldMem) $--}
  {--condTr (shldTrc state) (\_ -> spArea oldMem) $--}
  {--condTr shldTrc (\_ -> ioArea oldMem) $--}

  condTr (shldTrc state) (\_ -> "IntF: " ++ toHexStr 2 (getIntF state.mem.mainMem)) $
  condTr (shldTrc state) (\_ -> "IntE: " ++ toHexStr 2 (getIntE state.mem.mainMem)) $
  condTr (shldTrc state) (\_ -> "Ime: " ++ show (getIme state.mem.mainMem)) $

  {--condTr shldTrc (\_ -> "IntBits: " ++ toHexStr 2 intBits) $--}
  {--condTr shldTrc (\_ -> "getOnBit: " ++ show (getOnBit intBits)) $--}
  {--condTr shldTrc (\_ -> "shldHndlIntrr: " ++ show (shldHndlIntrr state)) $--}
  {--condTr shldTrc (\_ -> "intF after interruptop: " ++ toHexStr 2 (getIntF (interruptOp state).mem.mainMem)) $--}

  {--condTr (shldTrc state) (\_ -> "enbCnt: " ++ show (getImeEnableCnt state.mem.mainMem)) $--}

  {--condTr (shldTrc state) (\_ -> rd8RangeStr "FF40" 0xFF40 0xFF40 state.mem) $--}
  {--condTr (shldTrc state) (\_ -> rd8RangeStr "FF44" 0xFF44 0xFF44 state.mem) $--}
  state

shldTrc :: Z80State -> Boolean
{--shldTrc state = state.totalM == 233644--}
shldTrc state = false
{--shldTrc state = state.mem.regs.pc == 0x0405 || state.mem.regs.pc == 0x0371--}

module Core where

import Prelude (show, (++), ($), (&&), (==), (||), (+), bind, (<$>), (/=)
               ,(>>=), return, id, (<<<), (-), (<=))
import Data.Int.Bits ((.&.), (.|.))
import Data.Tuple (Tuple(Tuple), snd, fst)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Either (Either(Left, Right))
import Data.Foldable (elem)
import Data.Functor ((<$))
import Control.Monad.Eff (Eff)
import Control.Bind ((=<<))
import Control.Monad.Rec.Class (tailRecM)

import Types (Z80State, MemAccess, SavedRegs, Regs, Mem, I8, I16)
import MainMem (getIme, getIntE, getIntF, rd8, cleanMainMem, setIme, setIntF
               ,setVblIntrr, setGpu, getGpu, updImeCnt, setRom)
import Ops (callRoutine, getOpTiming, getCpuOp)
import OpCodeMap (mme2op, basicOpTimings, branchBasicOpTimings, cbOpTimings
                 ,basicOps)
import Gpu (Canvas, gpuStep)
import Utils (toHexStr, getOnBit)
import Regs

import Debug (StatTimer, condTr, timeIt)

--Get a fresh initial Z80State.
--The MemAccess effect is due to some writing operations during initialization.
reset :: forall e. Array I8 -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
reset rom = do
  cs <- cleanState
  return
    cs {
      mem = cs.mem {
        mainMem = setRom rom cs.mem.mainMem
      }
    }

--Run emulation until 'interval' clocks have passed.
run :: forall e. Int -> Z80State -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right st
  go { intr, st } | intr <= 0 = return $ Right st
  go { intr, st } = do
    {--if (shldTrc st) then traceA "-------step-------" else return unit--}
    st' <- step st
    {--st' <- stepTime st--}
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--Perform a single state operation, along with updatig accompanying state.
step :: forall e. Z80State -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
step state@{ mem = oldMem@{regs = oldRegs} } = do
  opt <- opTiming
  state2 <- op state
  state3 <- incPc oldPc state2
  state4 <- incTime state3
  let state5 = updImeCntInMem state4
  handleGpu opt
    state5
    {--$ traceState state5--}
 where
  oldPc = pc oldRegs
  op st = if checkShldHndlIntrr st
    then interruptOp st
    else regularOp st
  regularOp st = do
    coc <- getCurrOpCode st
    getCpuOp coc basicOps st
  getCurrOpCode st = rd8 (pc st.mem.regs) st.mem.mainMem
  incTime st@{totalM} = do
    opt <- opTiming
    return st { totalM = st.totalM + opt }
  opTiming = getCurrOpTiming oldPc state
  updImeCntInMem st = st { mem = st.mem { mainMem = updImeCnt st.mem.mainMem } }

--Get the clock amount of the current operation.
getCurrOpTiming :: forall e. I16 -> Z80State -> Eff (ma :: MemAccess | e) Int
getCurrOpTiming oldPc st = do
  opCode <- rd8 oldPc st.mem.mainMem
  let isExtOp = opCode == 0xCB
  addr <- if isExtOp
    then rd8 (oldPc+1) st.mem.mainMem
    else return opCode
  let opTimingTable = if isExtOp
        then cbOpTimings
        else
          if brTkn st.mem.regs
            then branchBasicOpTimings
            else basicOpTimings
  return $ getOpTiming addr opTimingTable

--Update the gpu's state with the time it took to do the current operation,
--as it is waiting a certain amount of time between the different modes of
--updating the screen.
--NOTE is there a better way to set nested properties?
--consider checking the lens-equivalent in purescript.
incPc :: forall e. I8 -> Z80State -> Eff (ma :: MemAccess | e) Z80State
incPc oldPc st =
  if oldPc /= pc st.mem.regs
    then return st
    else st <$ setPC (65535 .&. (pc st.mem.regs + 1)) st.mem.regs

--NOTE change handleGpu to get the op timing itself, instead of reacquiring it here.
handleGpu :: forall e. Int -> Z80State
          -> Eff (ma :: MemAccess, canvas :: Canvas | e) Z80State
handleGpu opTiming st = do
  gpu' <- gpuStep opTiming (getGpu st.mem.mainMem)
  let intF' = (if gpu'.vblIntrr
                 then
                   ({-trace ("screen refresh, clk-count: " ++ show st.totalM) \_ ->-}
                     (0x01 .|. _))
                   else id)
                $ getIntF st.mem.mainMem

  setGpu gpu' st.mem.mainMem
  setVblIntrr false st.mem.mainMem
  setIntF intF' st.mem.mainMem
  return st

--Get the current interrupt handling operation, if there is an interrupt
--waiting to be handled
interruptOp :: forall e. Z80State -> Eff (ma :: MemAccess | e) Z80State
interruptOp st = do
  setIntF (fst res $ getIntF st.mem.mainMem) st.mem.mainMem
  setIme false st.mem.mainMem
  snd res st
 where
  res :: Tuple (Int -> Int) (Z80State -> Eff (ma :: MemAccess | e) Z80State)
  res = fromMaybe (Tuple id return) mRes
  mRes = getOnBit (interruptBits st) >>= \x -> case x of
           1  -> Just $ Tuple (0xFE .&. _) (mme2op $ callRoutine true 0x40 )
           2  -> Just $ Tuple (0xFD .&. _) (mme2op $ callRoutine true 0x48 )
           4  -> Just $ Tuple (0xFB .&. _) (mme2op $ callRoutine true 0x50 )
           8  -> Just $ Tuple (0xF7 .&. _) (mme2op $ callRoutine true 0x58 )
           16 -> Just $ Tuple (0xEF .&. _) (mme2op $ callRoutine true 0x60 )
           otherwise -> Nothing -- NOTE log this

--Get bit flags of interrupts waiting to be handled AND enabled
interruptBits :: Z80State -> I8
interruptBits st = getIntE st.mem.mainMem .&. getIntF st.mem.mainMem

checkShldHndlIntrr :: Z80State -> Boolean
checkShldHndlIntrr st = getIme st.mem.mainMem && interruptBits st /= 0

cleanState :: forall e. Eff (ma :: MemAccess | e) Z80State
cleanState =
  { mem : _
  , totalM : 1
  , halt : false
  , stop : false
  } <$> cleanMem

cleanMem :: forall e. Eff (ma :: MemAccess | e) Mem
cleanMem = do
  cmm <- cleanMainMem
  cr <- cleanRegs
  return
    { regs : cr
    , svdRegs : cleanSavedRegs
    , mainMem : cmm
    }

--Debug functions

--Step function that uses the Timing functions of Debug to compute average
--running times for operations.
stepTime :: forall e. Z80State
         -> Eff (ma :: MemAccess, canvas :: Canvas, timer :: StatTimer | e) Z80State
stepTime state = do
  currOpCode <- rd8 (pc state.mem.regs) state.mem.mainMem
  currImm <- rd8 (pc state.mem.regs + 1) state.mem.mainMem
  let timerIx = if (currOpCode `elem` memModifyOps)
                || (currOpCode == 0xCB && (currImm `elem` cbMemModifyOps))
                  then 1 else 0
  timeIt timerIx (\_ -> step state)
 where
  memModifyOps =
    [ 0x02 ,0x08 ,0x12 ,0x22 ,0x32 ,0x34 ,0x35 ,0x36 ,0x70 ,0x71
    , 0x72 ,0x73 ,0x74 ,0x75 ,0x77 ,0xc4 ,0xc5 ,0xc7 ,0xcc ,0xcd ,0xcf ,0xd4
    , 0xd5 ,0xd7 ,0xd9 ,0xdc ,0xdf ,0xe0 ,0xe2 ,0xe5 ,0xe7 ,0xea ,0xef ,0xf3
    , 0xf5 ,0xf7 ,0xfb ,0xff
    ]
  cbMemModifyOps =
    [ 0x06, 0x0e, 0x16, 0x1e, 0x26, 0x2e, 0x36, 0x3e, 0x86, 0x8e, 0x96, 0x9e
    , 0xa6, 0xae, 0xb6, 0xbe, 0xc6, 0xce, 0xd6, 0xde, 0xe6, 0xee, 0xf6, 0xfe
    ]

--Useful function for tracing various properties of the Z80State,
--every cpu step as long as shldTrc condition is satisfied.
--Commented lines remain for ease of enabling.
traceState :: Z80State -> Z80State
traceState state@{ mem = oldMem@{regs = oldRegs} } =
  condTr (shldTrc state) (\_ -> "totalM: "++show (state.totalM)) $
  {--condTr (shldTrc state) (\_ -> "totalM: "++show (state.totalM - 123958)) $--}

  {--condTr (shldTrc state) (\_ -> tileMap0Str state.mem) $--}
  {--condTr (shldTrc state) (\_ -> tileSet0Str state.mem) $--}

  condTr (shldTrc state) (\_ -> regsStr oldRegs) $
  {--condTr (shldTrc state) (\_ -> pcArea oldMem) $--}
  {--condTr (shldTrc state) (\_ -> spArea oldMem) $--}
  {--condTr shldTrc (\_ -> ioArea oldMem) $--}

  condTr (shldTrc state) (\_ -> "IntF: " ++ toHexStr 2 (getIntF state.mem.mainMem)) $
  condTr (shldTrc state) (\_ -> "IntE: " ++ toHexStr 2 (getIntE state.mem.mainMem)) $
  condTr (shldTrc state) (\_ -> "Ime: " ++ show (getIme state.mem.mainMem)) $

  {--condTr shldTrc (\_ -> "IntBits: " ++ toHexStr 2 intBits) $--}
  {--condTr shldTrc (\_ -> "getOnBit: " ++ show (getOnBit intBits)) $--}
  {--condTr shldTrc (\_ -> "shldHndlIntrr: " ++ show (shldHndlIntrr state)) $--}
  {--condTr shldTrc (\_ -> "intF after interruptop: " ++ toHexStr 2 (getIntF (interruptOp state).mem.mainMem)) $--}

  {--condTr (shldTrc state) (\_ -> "enbCnt: " ++ show (getImeEnableCnt state.mem.mainMem)) $--}

  {--condTr (shldTrc state) (\_ -> rd8RangeStr "FF40" 0xFF40 0xFF40 state.mem) $--}
  {--condTr (shldTrc state) (\_ -> rd8RangeStr "FF44" 0xFF44 0xFF44 state.mem) $--}
  state

shldTrc :: Z80State -> Boolean
{--shldTrc state = state.totalM == 233644--}
shldTrc state = false
{--shldTrc state = state.mem.regs.pc == 0x0405 || state.mem.regs.pc == 0x0371--}


Remove redundant import

Remove redundant import

module Main where

import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
import Data.Either (Either(..))
import Data.Maybe (maybe)
import Data.List (List(Nil), (:), (!!), drop, deleteAt, length, (..), zipWithA, singleton)
import Data.Foreign (unsafeFromForeign)
import Data.Foldable (any)

import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, print)
import Control.Monad.State.Trans (StateT, modify, get, runStateT)
import Control.Monad.Eff.Class (liftEff)

import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import DOM (DOM)
import Ace.Types (ACE())
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as  Range

import Web (exprToJQuery, getPath, makeDiv)
import Parser (parseDefs, parseExpr)
import Evaluator (evalPath1, Env(), Path(), defsToEnv, EvalError(..), MatchingError(..))
import AST (Expr)
import JSHelpers (jqMap, isEnterKey)

main :: DOMEff J.JQuery
main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

type EvalState = { env :: Env, expr :: Expr, history :: List Expr }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue

  case parseExpr input of
    Left err   -> showInfo "Expression" (show err)
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
          showInfo "Definitions" (show err)
          markText (line - 1) column
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: Nil }

markText :: Int -> Int -> DOMEff Unit
markText line column = do
  editor <- Ace.edit "definitions" Ace.ace
  session <- Editor.getSession editor
  rang <- Range.create line column 100000 100000
  void $ Session.addMarker rang "syntaxError" "" false session

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: (List Expr) -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

showHistory :: Expr -> Int -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = maybe es.history id (deleteAt i es.history) }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = maybe es.expr id (es.history !! i) }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ jqMap (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left err -> displayEvalError err jq
      Right _  -> void $ J.addClass "clickable" jq

displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
displayEvalError err jq = case err of
  DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip J.append jq
  NoMatchingFunction _ errs -> if (any missesArguments errs)
    then return unit
    else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip J.append jq
  _         -> return unit
  where
    missesArguments (TooFewArguments _ _) = true
    missesArguments (StrictnessError _ _) = true
    missesArguments _                     = false

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    Left msg    -> liftEff $ showInfo "execution" (show msg)
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import Prelude (class Applicative, Unit, (<$>), bind, show, ($), (>>=), void, unit, return, (++), id, (+), flip, (<<<), (-))
import Data.Either (Either(..))
import Data.Maybe (maybe)
import Data.List (List(Nil), (:), (!!), drop, deleteAt, length, (..), zipWithA, singleton)
import Data.Foreign (unsafeFromForeign)
import Data.Foldable (any)

import Control.Apply ((*>))
import Control.Monad.Eff.JQuery as J
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, print)
import Control.Monad.State.Trans (StateT, modify, get, runStateT)
import Control.Monad.Eff.Class (liftEff)

import Text.Parsing.Parser (ParseError(ParseError))
import Text.Parsing.Parser.Pos (Position(Position))
import DOM (DOM)
import Ace.Types (ACE())
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as  Range

import Web (exprToJQuery, getPath, makeDiv)
import Parser (parseDefs, parseExpr)
import Evaluator (evalPath1, Env(), Path(), defsToEnv, EvalError(..), MatchingError(..))
import AST (Expr)
import JSHelpers (jqMap, isEnterKey)

main :: DOMEff J.JQuery
main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
    >>= J.on "keyup"  (\e _ -> if isEnterKey e then startEvaluation else return unit)
  startEvaluation

type DOMEff = Eff (dom :: DOM, console :: CONSOLE, ace :: ACE)

type EvalState = { env :: Env, expr :: Expr, history :: List Expr }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  editor <- Ace.edit "definitions" Ace.ace
  definitions <- Editor.getValue editor
  input       <- J.select "#input"       >>= getValue

  case parseExpr input of
    Left err   -> showInfo "Expression" (show err)
    Right expr -> do
      case defsToEnv <$> parseDefs definitions of
        Left err@(ParseError { position: (Position { line: line, column: column }) })  -> do
          showInfo "Definitions" (show err)
          markText (line - 1) column
        Right env -> do
          clearInfo
          void $ runStateT showEvaluationState { env: env, expr: expr, history: Nil }

markText :: Int -> Int -> DOMEff Unit
markText line column = do
  editor <- Ace.edit "definitions" Ace.ace
  session <- Editor.getSession editor
  rang <- Range.create line column 100000 100000
  void $ Session.addMarker rang "syntaxError" "" false session

showEvaluationState :: EvalM Unit
showEvaluationState = do
  output <- liftEff $ prepareContainer "output"
  history <- liftEff $ prepareContainer "history"

  { env = env, expr = expr, history = histExprs } <- get :: EvalM EvalState
  liftEff $ print expr

  liftEff $ exprToJQuery expr >>= wrapInDiv "output" >>= flip J.append output
  showHistoryList histExprs >>= liftEff <<< flip J.append history

  liftEff (J.find ".binary, .app, .func, .list, .if" output)
    >>= makeClickable
  liftEff (J.find ".clickable" output)
    >>= addMouseOverListener
    >>= addClickListener
  liftEff (J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver))

  liftEff $ return unit :: DOMEff Unit

forIndex :: forall m a b. (Applicative m) => (List a) -> (a -> Int -> m b) -> m (List b)
forIndex as f = zipWithA f as (0 .. (length as - 1))

showHistoryList :: (List Expr) -> EvalM J.JQuery
showHistoryList exprs = do
  box <- liftEff $ J.create "

" >>= J.addClass "historyBox"
  forIndex exprs $ \expr i -> do
    showHistory expr i >>= liftEff <<< wrapInDiv "vertical" >>= liftEff <<< flip J.append box
  return box

showHistory :: Expr -> Int -> EvalM J.JQuery
showHistory expr i = do
  history <- liftEff $ J.create "

" >>= J.addClass "history"
  liftEff $ exprToJQuery expr >>= flip J.append history
  es <- get :: EvalM EvalState
  let deleteHandler = \_ _ -> do
                        let es' = es { history = maybe es.history id (deleteAt i es.history) }
                        void $ runStateT showEvaluationState es'
  delete <- liftEff $ J.create "<button></button>"
    >>= J.setText "Delete"
    >>= J.addClass "delete"
    >>= J.on "click" deleteHandler
  liftEff $ J.append delete history
  let restoreHandler = \_ _ -> do
                         let es' = es { history = drop (i + 1) es.history, expr = maybe es.expr id (es.history !! i) }
                         void $ runStateT showEvaluationState es'
  restore <- liftEff $ J.create "<button></button>"
    >>= J.setText "Restore"
    >>= J.addClass "restore"
    >>= J.on "click" restoreHandler
  liftEff $ J.append restore history
  return history

showInfo :: String -> String -> DOMEff Unit
showInfo origin msg = do
  info <- J.create "

"
    >>= J.addClass "info"
    >>= J.setText ("Error in " ++ origin ++ " => " ++ msg)
  clearInfo
  J.select "#info"
    >>= J.append info
  return unit

clearInfo :: DOMEff Unit
clearInfo = void $ J.select "#info" >>= J.clear

prepareContainer :: String -> DOMEff J.JQuery
prepareContainer name = do
  J.select ("#" ++ name ++ "-container") >>= J.clear

wrapInDiv :: String -> J.JQuery -> DOMEff J.JQuery
wrapInDiv name jq = do
  J.create "

" >>= J.addClass name >>= J.append jq

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ jqMap (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Left err -> displayEvalError err jq
      Right _  -> void $ J.addClass "clickable" jq

displayEvalError :: EvalError -> J.JQuery -> DOMEff Unit
displayEvalError err jq = case err of
  DivByZero -> void $ makeDiv "Division by zero!" (singleton "evalError") >>= flip J.append jq
  NoMatchingFunction _ errs -> if (any missesArguments errs)
    then return unit
    else void $ makeDiv "No matching function!" (singleton "evalError") >>= flip J.append jq
  _         -> return unit
  where
    missesArguments (TooFewArguments _ _) = true
    missesArguments (StrictnessError _ _) = true
    missesArguments _                     = false

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOver"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  liftEff $ print path
  case evalPath1 env path expr of
    Left msg    -> liftEff $ showInfo "execution" (show msg)
    Right expr' -> do
      modify (\es -> es { expr = expr' })
      modify (\es -> es { history = expr : es.history })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq


Qualified import of Argonaut modules

Qualified import of Argonaut modules

Original commit bff34da92dd934caf334c3e21bfc418723c80347

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp

import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J

import Data.Array as A
import Data.Either (Either(..), either)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Doc.Renderer -> Json -> String
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer

tryRenderFromJsonSchema :: Doc.Renderer -> Json -> Either Error String
tryRenderFromJsonSchema renderer json =
    json
    # J.decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json =
    J.jsonParser json
    >>= (\j ->
        tryRenderFromJsonSchema renderer j
        # either (\_ -> Right $ renderFromJson renderer j) Right)

module Main where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array as A
import Data.Either (Either(..), either)
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema
import Math (round)
import Utils (mapM)

type Error = String

renderers :: Array Doc.Renderer
renderers = [CSharp.renderer, Golang.renderer, JsonSchema.renderer]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure if round n == n then IRInteger else IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Doc.Renderer -> Json -> String
renderFromJson renderer json =
    json
    # makeTypeAndUnify "TopLevel"
    # regatherClassNames
    # Doc.runRenderer renderer

tryRenderFromJsonSchema :: Doc.Renderer -> Json -> Either Error String
tryRenderFromJsonSchema renderer json =
    json
    # decodeJson
    >>= makeTypeFromSchema "TopLevel"
    <#> regatherClassNames
    <#> Doc.runRenderer renderer

renderForUI :: Doc.Renderer -> String -> Either Error String
renderForUI renderer json =
    jsonParser json
    >>= (\j ->
        tryRenderFromJsonSchema renderer j
        # either (\_ -> Right $ renderFromJson renderer j) Right)


Increased jump power

Increased jump power

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)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      , messageBuf    :: [String]
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        , messageBuf: map ((++) "Line" <<< show) (1 .. 4)
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zerop }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zerop }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 20, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

messageBufSize :: Number
messageBufSize = 4

addMsg :: String -> GameState -> GameState
addMsg msg (Game state) | length state.messageBuf >= messageBufSize =
    Game state { messageBuf = drop 1 state.messageBuf ++ [msg] }
addMsg msg (Game state) | otherwise =Game state { messageBuf = state.messageBuf ++ [msg] }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | inFreeFall state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    drawStrings {x: 1, y: 20} "FFFFFF" state.messageBuf
    return g
    where
        drawStrings :: Point -> String -> [String] -> ConsoleEff Unit
        drawStrings p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings {x: p.x, y: p.y + 1} col xs
        drawStrings _  _  []     = return unit

        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console " " "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console (singleton $ fromCharCode 176) "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console (singleton $ fromCharCode 219) "444422" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "666633" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- 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 }

        -- 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 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 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

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 }

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

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

jump :: GameState -> Number -> Creature -> Creature
jump g xdir c = c { 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}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        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 [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | inFreeFall state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ Game state { player = jump g (-1) state.player }
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ Game state { player = jump g 1 state.player }
onKeyPress console g@(Game state) key                      | key == 80       = return $ pickUp (state.player.pos) g
onKeyPress console g@(Game state) 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)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      , messageBuf    :: [String]
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        , messageBuf: map ((++) "Line" <<< show) (1 .. 4)
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zerop }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zerop }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 20, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

messageBufSize :: Number
messageBufSize = 4

addMsg :: String -> GameState -> GameState
addMsg msg (Game state) | length state.messageBuf >= messageBufSize =
    Game state { messageBuf = drop 1 state.messageBuf ++ [msg] }
addMsg msg (Game state) | otherwise =Game state { messageBuf = state.messageBuf ++ [msg] }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | inFreeFall state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    drawStrings {x: 1, y: 20} "FFFFFF" state.messageBuf
    return g
    where
        drawStrings :: Point -> String -> [String] -> ConsoleEff Unit
        drawStrings p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings {x: p.x, y: p.y + 1} col xs
        drawStrings _  _  []     = return unit

        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console " " "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console (singleton $ fromCharCode 176) "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console (singleton $ fromCharCode 219) "444422" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "666633" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "666633" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- 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 }

        -- 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 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 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

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 }

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

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

jump :: GameState -> Number -> Creature -> Creature
jump g xdir c = c { vel = {x: xdir, y: -2} }

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}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        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 [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | inFreeFall state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ Game state { player = jump g (-1) state.player }
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ Game state { player = jump g 1 state.player }
onKeyPress console g@(Game state) key                      | key == 80       = return $ pickUp (state.player.pos) g
onKeyPress console g@(Game state) 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}