Kinetosis: an esoteric language similar to SICKBAY

beer.kinetosis

0 REM Prints the lyrics of the famous song:
0 REM http://www.99-bottles-of-beer.net/
(0 - 50) REM printing subroutine
(0 - 49) LET rf%(sh%) = (0 - 41)
(0 - 45) PRINT beer%;: PRINT " ";
((0 - 44) * (1 - ((beer% - 1) / (beer% - 1)))) PRINT "bottle";
(0 - 44) PRINT "bottles";
(0 - 42) PRINT " of beer";
10 LET beer% = 99
12 LET loop% = 90
20 LET cf%(sh% + 1) = (0 - 50): LET cf%(sh%) = 21
30 PRINT " on the wall, ";
40 LET cf%(sh% + 1) = (0 - 50): LET cf%(sh%) = 41
50 PRINT ".": PRINT "Take one down and pass it around, ";
60 LET beer% = (beer% - 1)
(70 * (1 - (beer% / beer%))) PRINT "No more bottles of beer";
70 LET cf%(sh% + 1) = (0 - 50): LET cf%(sh%) = 71
80 PRINT ".": PRINT ""
100 PRINT "No more bottles of beer on the wall, no more bottles of beer."
110 PRINT "Go to the store and buy some more, 99 bottles of beer on the wall."
1000 END
(loop% * (beer% / beer%)) LET loop% = 11
rf%(sh%) LET sh% = (sh% - 1)
cf%(sh%) LET rf%(sh%) = cf%(sh%): LET sh% = (sh% + 1)

kinetosis.hs

-- A reference implementation for kinetosis: an esoteric language descended
-- from SICKBAY.

-- My parser library phaser is required to build this program. It can be
-- obtained from https://github.com/quickdudley/phaser or from hackage. At least
-- version 0.2.0.0 is required.

-- A program consists of a series of lines. Each line consists of a line number
-- (which may be an expression containing variables), and one or more statements
-- separated by the ':' character. Valid programs are encoded in ASCII or UTF-8,
-- with Unix or Windows style line separators.

-- Execution begins at the lowest non-negative numbered line. If there are
-- multiple lines with equal line numbers: the earlier line in the program file
-- is always chosen. Execution always proceeds from the current value of the
-- line number of the line just executed; so control flow can be achieved by
-- a line setting variables which are referenced by its line number expression.

-- Variable names consist of a letter, followed by zero or more letters,
-- numbers, or underscores (_), and ended by a '%' character. Each variable is
-- an unbounded array (in this implementation implemented as a map). If
-- referenced without an index: an implicit index of 0 is used. An explicit
-- index is given after the variable name and surrounded in parentheses. for
-- example: a% is the same as a%(0). All values are either 32 or 64 bit
-- integers, depending on the platform.

-- There are four types of integer expressions:
-- Integer constants: non-negative numbers such as 1, 25, etc. Negative numbers
--   can must be created using the subtraction operator
-- Variables: described above
-- Operators: "+", "*", "-", and "/". No operator precedence is applied, and
--   every use of an operator must be surrounded by parentheses. Division is
--   always rounded towards -2147483648 or -9223372036854775808 depending on
--   platform. In subexpressions: rounding is performed immediately; not once
--   the entire expression is complete.
-- Random numbers: rnd$(xyz%) evaluates to a random number between 0 and xyz%

-- There are 5 types of statements: REM, LET, INPUT, PRINT, and END
-- REM is used to hold source code comments, or to block other lines from
--   executing. ':' characters following a REM are counted as part of the
--   comment, so a REM is always the last statement on a line.
-- LET is used to set variables. Syntax example: LET xyz%(3) = (xyz%(2) + 1).
--   Because line numbers may depend on variables: LET statements can also be
--   used for control flow.
-- INPUT reads items from stdin to variables. It has 3 forms:
--   `INPUT xyz%` reads an ASCII integer and parses it, sets xyz% to the result
--   `INPUT chr$xyz%` reads a UTF-8 character and sets xyz% to its unicode
--      codepoint.
--   `INPUT byte$xyz%` reads a byte and sets xyz% to its value.
-- PRINT writes items to stdout. The argument can be a string surrounded by
--   double quote marks, or a variable optionally prefixed with chr$ or byte$.
--   PRINT wites a newline character after writing its argument, which can be
--   prevented by adding a ';' character to the end of the statement.
-- End immediately stops execution of the program.

-- Control flow example:
{-
0 REM The first LET line initially also has line number 0, so is
0 REM coincidentally prevented from executing by these comments. The second LET
0 REM line moves the first one to line 30, and then it moves itself back to line
0 REM 10. Since moving the line being executed changes the control flow: this
0 REM creates an infinite loop.
loop% LET loop% = 10
20 LET loop% = 30
-}

import Data.Char
import Data.Word
import Data.Function
import Data.List (minimumBy)
import Data.IORef
import qualified Data.Map as M
import Control.Applicative
import Control.Monad
import Control.Monad.State

import qualified Codec.Phaser as P
import Codec.Phaser hiding (get,put)
import Codec.Phaser.Common
import Codec.Phaser.Core (beforeStep,extract,toAutomaton)
import Codec.Phaser.UTF8 (utf8_char,utf8_stream)

import qualified Codec.Binary.UTF8.String as UTF8

import System.Environment
import System.IO
import System.Random

data IntExp =
  C Int |
  V (IORef (M.Map Int Int)) IntExp |
  O (Int -> Int -> Int) IntExp IntExp |
  R IntExp

data IOType = IODecimal | IOChar | IOByte

data PrintArg =
  PrintVar IOType IntExp | PrintString String

data Statement =
  REM String |
  LET (IORef (M.Map Int Int)) IntExp IntExp |
  INPUT IOType (IORef (M.Map Int Int)) IntExp |
  PRINT PrintArg Bool |
  END

data Line = Line IntExp [Statement]

evalIntExp (C i) = return i
evalIntExp (V a i) = (\i' m -> case M.lookup i' m of
  Nothing -> 0
  Just x -> x
 ) <$> evalIntExp i <*> readIORef a
evalIntExp (O o a b) = o <$> evalIntExp a <*> evalIntExp b
evalIntExp (R e) = evalIntExp e >>= randomRIO . ((,) 0)

evalStatement (REM _) = return ()
evalStatement (LET t i v) = do
  v' <- evalIntExp v
  i' <- evalIntExp i
  atomicModifyIORef' t (\m -> case v' of
    0 -> (M.delete i' m,())
    _ -> (M.insert i' v' m,())
   )
evalStatement (INPUT y t i) = do
  v <- case y of
    IODecimal -> hParse stdin (-1) (toAutomaton $ munch isSpace >> integer)
    IOChar -> hParse stdin (-1)
      (toAutomaton $ fmap fromEnum (charByte >># utf8_char))
    IOByte -> hParse stdin (-1) (toAutomaton $ fmap fromEnum P.get)
  evalStatement (LET t i (C v))
evalStatement (PRINT a nl) = let
  f = case a of
    PrintVar y v -> do
      v' <- evalIntExp v
      case y of
        IODecimal -> putStr (show v')
        IOChar ->
          putStr $ map (toEnum . fromIntegral) $ UTF8.encode [toEnum v']
        IOByte -> putChar (toEnum v')
    PrintString str -> putStr $ map (toEnum . fromIntegral) $ UTF8.encode str
  in if nl then f else f >> putChar '\n'
evalStatement END = return ()

evalLine (Line _ s) = foldr go (return False) s where
  go END _ = return True
  go a r = evalStatement a >> r

evalProg ls = go (C (-1)) where
  go pcr = do
    pc <- evalIntExp pcr
    ls' <- mapM (\l@(Line e _) -> evalIntExp e >>= \n -> return (n,l)) ls
    case filter ((> pc) . fst) ls' of
      [] -> return ()
      ls'' -> do
        let l@(Line e _) = snd $ minimumBy (compare `on` fst) ls''
        end <- evalLine l
        if end
          then return ()
          else go e

hParse h d = go where
  go p0 = do
    e <- hIsEOF h
    if e
      then case extract () p0 of
        Right [x] -> return x
        _ -> return d
      else do
        c <- hLookAhead h
        let p1 = step p0 c
        case beforeStep p1 of
          Left _ -> case extract () p1 of
            Right [x] -> hGetChar h >> return x
            _ -> case extract () p0 of
              Right [x] -> return x
              _ -> return d
          Right p2 -> hGetChar h >> go p1

charByte :: Phase p Char Word8 ()
charByte =
  ((fmap (fromIntegral . fromEnum) P.get) >>= \c -> yield c >> charByte) <|>
  return ()

getVariable :: String ->
  StateT (M.Map String (IORef (M.Map Int Int))) IO (IORef (M.Map Int Int))
getVariable n = do
  m <- get
  case M.lookup n m of
    Just r -> return r
    Nothing -> do
      r <- lift $ newIORef M.empty
      modify (M.insert n r)
      return r

withinLineSpace = (&&) <$> isSpace <*> (/= '\n')

varname_p = (:) <$>
  satisfy isAlpha <*>
  munch ((||) <$> isAlphaNum <*> (== '_')) <* char '%'

intExp_p :: Phase p Char o
  (StateT (M.Map String (IORef (M.Map Int Int))) IO IntExp)
intExp_p = c <|> v <|> intExp_bracket <|> r where
  c = fmap (return . C) positiveIntegerDecimal
  v = ((<*>) . (V <$>) . getVariable) <$>
    varname_p <*>
    (return (return (C 0)) <|> (munch withinLineSpace >> intExp_bracket))
  r = iString "rnd$" >> ((R <$>) <$> intExp_bracket)

intExp_bracket :: Phase p Char o
  (StateT (M.Map String (IORef (M.Map Int Int))) IO IntExp)
intExp_bracket = char '(' *>
  (flip ($) <$> intExp_p <*>
    (((\o b a -> O <$> pure o <*> a <*> b) <$>
      (munch withinLineSpace *> op) <*>
      (munch withinLineSpace *> intExp_p)) <|>
     pure id)) <*
  ("Mismatched parentheses" <?> char ')')
 where
  op = P.get >>= \c -> case c of
    '+' -> return (+)
    '*' -> return (*)
    '-' -> return (-)
    '/' -> return $ \a b -> case b of
      0 -> 0
      _ -> a `div` b
    _ -> fail "Unknown operator"

statement_p :: Phase p Char o
  (StateT (M.Map String (IORef (M.Map Int Int))) IO Statement)
statement_p = rem_p <|> let_p <|> input_p <|> print_p <|> end_p where
  command n = "Unknown command" <?> iString n
  rem_p = (command "REM") *>
    munch1 withinLineSpace *>
    fmap (return . REM) (munch (/= '\n'))
  let_p = (\v i e -> LET <$> getVariable v <*> i <*> e) <$>
    (command "LET" *> munch1 withinLineSpace *> varname_p) <*>
    (pure (return (C 0)) <|> (munch withinLineSpace *> intExp_bracket)) <*>
    (munch withinLineSpace *>
     char '=' *>
     munch withinLineSpace *>
     intExp_p)
  iotype_p = pure IODecimal <|>
    (string "chr$" *> pure IOChar) <|>
    (string "byte$" *> pure IOByte)
  input_p = (\y v i -> INPUT y <$> getVariable v <*> i) <$>
    (command "INPUT" *> munch1 withinLineSpace *> iotype_p) <*>
    varname_p <*>
    (munch withinLineSpace *> intExp_bracket)
  printArg_p = strlit_p <|> printVar_p
  strlit_p = (pure . PrintString) <$>
    (char '\"' *> munch (/= '\"') <* char '\"')
  printVar_p = (\y e -> PrintVar y <$> e) <$>
    iotype_p <*> intExp_p
  print_p = (\a nl -> PRINT <$> a <*> pure nl) <$>
    (command "PRINT" *> munch1 withinLineSpace *> printArg_p) <*>
    (pure False <|> (munch withinLineSpace *> char ';' *> pure True))
  end_p = pure END <$ command "END"

line_p :: Phase p Char o
  (StateT (M.Map String (IORef (M.Map Int Int))) IO Line)
line_p = (\ln s -> Line <$> ln <*> sequence s) <$>
  intExp_p <*>
  (munch1 withinLineSpace *>
    sepBy statement_p
      (munch withinLineSpace *> char ':' *> munch withinLineSpace))

prog_p :: Phase p Char o (IO [Line])
prog_p = munch isSpace *>
  ((flip evalStateT M.empty . sequence) <$>
    sepBy line_p (munch withinLineSpace *> char '\n' *> munch isSpace)) <*
  munch isSpace

printError :: [(Position,[String])] -> IO ()
printError [] = hPutStrLn stderr "Parser failed with no information"
printError l = forM_ l $ \(pos,es) -> do
  hPutStrLn stderr $ "Error at " ++ show pos
  forM_ es $ \e -> putStr $ '\t' : e

main = forM_ [stdin,stdout] (flip hSetBinaryMode True) >>
 getArgs >>= \args -> case args of
  [sfn] -> do
   pr <- parseFile (utf8_stream >># trackPosition >># prog_p) sfn
   case pr of
     Left e -> printError e
     Right (a:_) -> a >>= evalProg 
     _ -> printError []
  _ -> hPutStrLn stderr "Wrong number of arguments"