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