Execute SNUSP/Haskell

Execute SNUSP/Haskell is an implementation of SNUSP. Other implementations of SNUSP.

Execute SNUSP/Haskell is part of RCSNUSP. You may find other members of RCSNUSP at Category:RCSNUSP.

This Haskell implementation supports commands from all the three SNUSP variants, as described on the Esolang SNUSP page.

Threads and 2D-data makes a purely functional implementation difficult, so most of the code works in the IO-Monad. There is an immutable array c for the code, a global mutable hashtable d for the data, and each thread has an instruction pointer ip, a memory pointer mp, and a call stack stack.

Design decisions (not covered by SNUSP specification):

• Decrementing a zero memory cell sets it to zero.
• The data area is infinite.
• Threads block during read if no input is available, while other threads continue (as one of the examples requires).
• As the SNUSP variants differ in the number of dimensions in data and code, make it easy to add even more dimensions.

The interpreter has been tested with the echo, thread, multiplication and multi-digit print examples.

The Haskell code starts with lots of imports:

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

import Control.Monad

import Data.Char
import Data.List
import Data.Maybe
import Data.Array

import qualified Data.HashTable as H

Use a list as an index into an array:

type Index = [Int]

instance Ix a => Ix [a] where
  index ([],[]) []            = 0
  index (l:ls, u:us) (i:is)   = index (l,u) i + 
                                index (ls,us) is * rangeSize (l,u)
  range ([],[])               = [[]]
  range (l:ls, u:us)          = [i:is | is <- range (ls,us), i <- range (l,u)]
  inRange ([],[])      []     = True
  inRange (l:ls, u:us) (i:is) = inRange (l,u) i && inRange (ls,us) is
  rangeSize (ls,us)           = product $ map rangeSize $ zip ls us

or into an hashtable (the hash function could probably be improved):

cmpList :: Index -> Index -> Bool
cmpList []     []     = True
cmpList (x:xs) []     = x == 0 && cmpList xs []
cmpList []     (y:ys) = y == 0 && cmpList [] ys
cmpList (x:xs) (y:ys) = x == y && cmpList xs ys

hashList xs = H.hashInt $ foldr combine 0 xs

combine :: Int -> Int -> Int
combine x 0 = x
combine x y = z * (z+1) `div` 2 + x where z = x + y

Here it's important that index lists with trailing zeroes are treated just like this list without the zeroes, so we can handle any number of dimensions. We want the same flexibility when adding index lists:

(<+>) :: Index -> Index -> Index
[]     <+> ys     = ys
xs     <+> []     = xs
(x:xs) <+> (y:ys) = (x+y) : (xs <+> ys)

Some helper functions:

data Thread a = T {mp::a, ip::a, dir::a, stack::[(a,a)]} deriving Show

modify d t f = do
  let i = mp t
  x <- H.lookup d i
  let x' = fromMaybe 0 x
  H.delete d i
  H.insert d i (f x') -- H.update 
  return [t]

moveMp d t delta = return [t {mp=(mp t) <+> delta}]

readMp d t = H.lookup d (mp t) >>= return . fromMaybe 0

step t = t {ip=(ip t) <+> (dir t)}

dec :: Integer -> Integer
dec 0 = 0
dec x = x-1

toChar   = chr . fromInteger
fromChar = toInteger . ord

Now, the commands. Given a thread, return a list of threads valid after one simulation step. In that way, exec can handle forks and thread termination on errors.

-- Core SNUSP

exec '+'  d t = modify d t (+1)  
exec '-'  d t = modify d t (dec) 
exec '<'  d t = moveMp d t [-1] 
exec '>'  d t = moveMp d t [ 1]
exec ','  d t = getChar >>= modify d t . const . fromChar
exec '.'  d t = readMp d t >>= putChar . toChar >> return [t]
exec '\\' d t = return [t {dir=( d2:  d1:ds)}] where d1:d2:ds = dir t <+> [0,0]
exec '/'  d t = return [t {dir=(-d2: -d1:ds)}] where d1:d2:ds = dir t <+> [0,0]
exec '!'  d t = return [step t]
exec '?'  d t = readMp d t >>= \x -> return [if x == 0 then step t else t]

-- Modular SNUSP

exec '@'  d t = return [t {stack=(ip t, dir t):(stack t)}]
exec '#'  d   T{stack=[]}         = return []
exec '#'  d t@T{stack=(ip,dir):s} = return [step $ t {ip=ip, dir=dir, stack=s}]
   
-- Bloated SNUSP

exec ':'  d t = moveMp d t [0,-1]
exec ';'  d t = moveMp d t [0, 1]
exec '&'  d t = return [step t, t {stack=[]}]
exec '%'  d t = readMp d t >>= \x -> randomRIO (0,x) >>= modify d t . const

-- NOOP

exec _    d t = return [t]

The scheduler manages a list ts of active threads, and a list ks of threads waiting for input. If there are no more threads in either list, stop. If input is available, one blocked thread is executed. If no input is available and all threads are blocked, we block the interpreter, too (so the OS can do something else). Otherwise, try to execute one of the unblocked threads, first checking if it's still inside the code array.

start c = maybe (fst $ bounds $ c) fst $ find (\(_,x) -> x == '$') $ assocs c 

run c d = schedule [thread] [] False where 
  thread = T {mp=[1,1], ip=start c, dir=[1], stack=[]}
  exec' x d t = exec x d t >>= \ts -> return (ts,[])
  schedule' ts ks (ts',ks') = hReady stdin >>= schedule (ts++ts') (ks++ks')
  schedule [] []     _     = return ()
  schedule [] ks     False = hLookAhead stdin >> schedule' [] ks ([],[])
  schedule ts (k:ks) True  = exec' ',' d k  >>= schedule' ts ks
  schedule (t:ts) ks _     = check (step t) >>= schedule' ts ks 
  check t 
    | not $ bounds c `inRange` (ip t) = return ([],[])
    | x == ','                        = return ([],[t])
    | otherwise                       = exec' x d t 
    where x = c ! (ip t)

Finally, routines to run code from a string or a file, and the main program.

runString y s = do
  d <- H.new cmpList hashList
  let x = length s `div` y
  run (listArray ([1,1],[x,y]) s) d

runFile name = do
  s <- readFile name
  d <- H.new cmpList hashList
  let l = lines s
  let y = length l
  let x = maximum $ map length $ l
  let m = [([i,j],c) | (j,v) <- zip [1..] l, (i,c) <- zip [1..] v]
  let c = listArray ([1,1],[x,y]) (repeat ' ') // m
  run c d

main = do
  hSetBuffering stdin NoBuffering
  [s] <- getArgs
  runFile s

Extension

To demonstrate the ease of introducing even more dimensions, let's implement commands ( and ) to move the data pointer along the z-axis, and a command ^ to rotate the IP direction around the (1,1,1) axis (i.e., left becomes up, up becomes "farther" on the z-axis, "farther" becomes left, etc.).

exec '(' d t = moveMp d t [0,0,-1]
exec ')' d t = moveMp d t [0,0, 1]
exec '^' d t = return [t {dir=(d3:d1:d2:ds)}] where d1:d2:d3:ds = dir t <+> [0,0,0]