RCSNUSP/Factor

From Rosetta Code
RCSNUSP/Factor is an implementation of SNUSP. Other implementations of SNUSP.
RCSNUSP/Factor is part of RCSNUSP. You may find other members of RCSNUSP at Category:RCSNUSP.

This is a translation of the Go entry [1], and as such consists of core SNUSP, a fixed-size data store, and no bounds checking. It has been made a bit more idiomatic for Factor by splitting the implementation up into several words (functions), and uses a tuple in place of Go's lexical variables.

USING: accessors byte-arrays combinators
combinators.short-circuit fry io kernel math multiline sequences
splitting strings ;
IN: rosetta-code.snusp
 
STRING: sample-program
/++++!/===========?\>++.>+.+++++++..+++\
\+++\ | /+>+++++++>/ /++++++++++<<.++>./
$+++/ | \+++++++++>\ \+++++.>.+++.-----\
\==-<<<<+>+++/ /=.>.+>.--------.-/
;
 
: find-start ( matrix -- r c )
[ CHAR: $ swap member? ] find [ CHAR: $ = ] find drop dup
[ 1 + ] [ 2drop 0 0 ] if ;
 
! Instruction store, data store, instruction pointer row,
! instruction pointer column, data pointer, instruction
! direction
TUPLE: snusp is ds ipr ipc dp id ;
 
: <snusp> ( str n -- snusp )
[ "\n" split ] [ <byte-array> ] bi* over find-start 0 0
snusp boa ;
 
: step ( snusp -- )
1 over id>> [ 2 bitand - ] [ 1 bitand zero? ] bi
[ '[ _ + ] change-ipc ] [ '[ _ + ] change-ipr ] if drop ;
 
: still-running? ( snusp -- ? )
{
[ ipr>> 0 >= ]
[ [ ipr>> ] [ is>> length < ] bi ]
[ ipc>> 0 >= ]
[ [ ipc>> ] [ ipr>> ] [ is>> nth length < ] tri ]
} 1&& ;
 
: data ( snusp -- dp ds ) [ dp>> ] [ ds>> ] bi ;
 
CONSTANT: commands {
{ CHAR: > [ [ 1 + ] change-dp drop ] }
{ CHAR: < [ [ 1 - ] change-dp drop ] }
{ CHAR: + [ data [ 1 + ] change-nth ] }
{ CHAR: - [ data [ 1 - ] change-nth ] }
{ CHAR: . [ data nth 1string write ] }
{ CHAR: , [ read1 swap data set-nth ] }
{ CHAR: / [ [ bitnot ] change-id drop ] }
{ CHAR: \\ [ [ 1 bitxor ] change-id drop ] }
{ CHAR: ! [ step ] }
{ CHAR: ? [ dup data nth zero? [ step ] [ drop ] if ] }
[ 2drop ]
}
 
: curr-instr ( snusp -- n )
[ ipc>> ] [ ipr>> ] [ is>> ] tri nth nth ;
 
: execute-snusp ( snusp -- )
[ dup still-running? ]
[ dup dup curr-instr commands case dup step ] while drop ;
 
: snusp-demo ( -- ) sample-program 5 <snusp> execute-snusp ;
 
MAIN: snusp-demo
 
Output:
Hello World!