! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors assocs combinators io io.streams.string kernel math
-namespaces sequences strings ;
+USING: accessors assocs command-line io io.encodings.binary
+io.files io.streams.string kernel macros math namespaces
+peg.ebnf prettyprint sequences multiline ;
IN: brainfuck
<PRIVATE
-TUPLE: brainfuck code cp dp steps memory loop ;
+TUPLE: brainfuck pointer memory ;
-: (set-loop) ( brainfuck in out -- brainfuck )
- pick loop>> [ set-at ] [ [ swap ] dip set-at ] 3bi ;
+: <brainfuck> ( -- brainfuck )
+ 0 H{ } clone brainfuck boa ;
-SYMBOL: tmp
+: get-memory ( brainfuck -- brainfuck value )
+ dup [ pointer>> ] [ memory>> ] bi at 0 or ;
-: <brainfuck> ( code -- brainfuck )
- 0 0 0 H{ } clone H{ } clone brainfuck boa
- V{ } clone tmp set
- dup code>> <enum> [
- {
- { CHAR: [ [ tmp get push ] }
- { CHAR: ] [ tmp get pop (set-loop) ] }
- [ 2drop ]
- } case
- ] assoc-each ;
+: set-memory ( brainfuck value -- brainfuck )
+ over [ pointer>> ] [ memory>> ] bi set-at ;
+: (+) ( brainfuck n -- brainfuck )
+ [ get-memory ] dip + 255 bitand set-memory ;
-: (get-memory) ( brainfuck -- brainfuck value )
- dup [ dp>> ] [ memory>> ] bi at 0 or ;
+: (-) ( brainfuck n -- brainfuck )
+ [ get-memory ] dip - 255 bitand set-memory ;
-: (set-memory) ( intepreter value -- brainfuck )
- over [ dp>> ] [ memory>> ] bi set-at ;
+: (.) ( brainfuck -- brainfuck )
+ get-memory write1 ;
-: (inc-memory) ( brainfuck -- brainfuck )
- (get-memory) 1 + 255 bitand (set-memory) ;
+: (,) ( brainfuck -- brainfuck )
+ read1 set-memory ;
-: (dec-memory) ( brainfuck -- brainfuck )
- (get-memory) 1 - 255 bitand (set-memory) ;
+: (>) ( brainfuck n -- brainfuck )
+ '[ _ + ] change-pointer ;
-: (out-memory) ( brainfuck -- brainfuck )
- (get-memory) 1string write ;
+: (<) ( brainfuck n -- brainfuck )
+ '[ _ - ] change-pointer ;
+: (#) ( brainfuck -- brainfuck )
+ dup
+ [ "ptr=" write pointer>> pprint ]
+ [ ",mem=" write memory>> pprint nl ] bi ;
-: (inc-data) ( brainfuck -- brainfuck )
- [ 1 + ] change-dp ;
+: compose-all ( seq -- quot )
+ [ ] [ compose ] reduce ;
-: (dec-data) ( brainfuck -- brainfuck )
- [ 1 - ] change-dp ;
+EBNF: parse-brainfuck [=[
+inc-ptr = (">")+ => [[ length '[ _ (>) ] ]]
+dec-ptr = ("<")+ => [[ length '[ _ (<) ] ]]
+inc-mem = ("+")+ => [[ length '[ _ (+) ] ]]
+dec-mem = ("-")+ => [[ length '[ _ (-) ] ]]
+output = "." => [[ [ (.) ] ]]
+input = "," => [[ [ (,) ] ]]
+debug = "#" => [[ [ (#) ] ]]
+space = [ \t\n\r]+ => [[ [ ] ]]
+unknown = (.) => [[ "Invalid input" throw ]]
-: (loop-start) ( brainfuck -- brainfuck )
- (get-memory) 0 = [ dup [ cp>> ] [ loop>> ] bi at >>cp ] when ;
+ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
+loop = "[" {loop|ops}+ "]" => [[ second compose-all '[ [ get-memory zero? ] _ until ] ]]
-: (loop-end) ( brainfuck -- brainfuck )
- dup [ cp>> ] [ loop>> ] bi at 1 - >>cp ;
+code = (loop|ops|unknown)* => [[ compose-all ]]
+]=]
-: (get-input) ( brainfuck -- brainfuck )
- read1 (set-memory) ;
-
+PRIVATE>
-: can-step ( brainfuck -- brainfuck t/f )
- dup [ steps>> 100000 < ] [ cp>> ] [ code>> length ] tri < and ;
+MACRO: run-brainfuck ( code -- quot )
+ parse-brainfuck '[ <brainfuck> @ drop flush ] ;
-: step ( brainfuck -- brainfuck )
- dup [ cp>> ] [ code>> ] bi nth
- {
- { CHAR: > [ (inc-data) ] }
- { CHAR: < [ (dec-data) ] }
- { CHAR: + [ (inc-memory) ] }
- { CHAR: - [ (dec-memory) ] }
- { CHAR: . [ (out-memory) ] }
- { CHAR: , [ (get-input) ] }
- { CHAR: [ [ (loop-start) ] }
- { CHAR: ] [ (loop-end) ] }
- { CHAR: \s [ ] }
- { CHAR: \t [ ] }
- { CHAR: \r [ ] }
- { CHAR: \n [ ] }
- [ "invalid input" throw ]
- } case [ 1 + ] change-cp [ 1 + ] change-steps ;
+: get-brainfuck ( code -- result )
+ [ run-brainfuck ] with-string-writer ; inline
-PRIVATE>
+<PRIVATE
-: run-brainfuck ( code -- )
- <brainfuck> [ can-step ] [ step ] while drop ;
+: (run-brainfuck) ( code -- )
+ [ <brainfuck> ] dip parse-brainfuck call( x -- x ) drop flush ;
-: get-brainfuck ( code -- result )
- [ run-brainfuck ] with-string-writer ;
+PRIVATE>
+: brainfuck-main ( -- )
+ command-line get [
+ read-contents (run-brainfuck)
+ ] [
+ [ binary file-contents (run-brainfuck) ] each
+ ] if-empty ;
+MAIN: brainfuck-main