1 ! Copyright (C) 2009 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors assocs combinators io io.streams.string kernel math
5 namespaces sequences strings ;
11 TUPLE: brainfuck code cp dp steps memory loop ;
13 : (set-loop) ( brainfuck in out -- brainfuck )
14 pick loop>> [ set-at ] [ [ swap ] dip set-at ] 3bi ;
18 : <brainfuck> ( code -- brainfuck )
19 0 0 0 H{ } clone H{ } clone brainfuck boa
23 { CHAR: [ [ tmp get push ] }
24 { CHAR: ] [ tmp get pop (set-loop) ] }
30 : (get-memory) ( brainfuck -- brainfuck value )
31 dup [ dp>> ] [ memory>> ] bi at 0 or ;
33 : (set-memory) ( intepreter value -- brainfuck )
34 over [ dp>> ] [ memory>> ] bi set-at ;
36 : (inc-memory) ( brainfuck -- brainfuck )
37 (get-memory) 1 + 255 bitand (set-memory) ;
39 : (dec-memory) ( brainfuck -- brainfuck )
40 (get-memory) 1 - 255 bitand (set-memory) ;
42 : (out-memory) ( brainfuck -- brainfuck )
43 (get-memory) 1string write ;
46 : (inc-data) ( brainfuck -- brainfuck )
49 : (dec-data) ( brainfuck -- brainfuck )
53 : (loop-start) ( brainfuck -- brainfuck )
54 (get-memory) 0 = [ dup [ cp>> ] [ loop>> ] bi at >>cp ] when ;
56 : (loop-end) ( brainfuck -- brainfuck )
57 dup [ cp>> ] [ loop>> ] bi at 1 - >>cp ;
60 : (get-input) ( brainfuck -- brainfuck )
64 : can-step ( brainfuck -- brainfuck t/f )
65 dup [ steps>> 100000 < ] [ cp>> ] [ code>> length ] tri < and ;
67 : step ( brainfuck -- brainfuck )
68 dup [ cp>> ] [ code>> ] bi nth
70 { CHAR: > [ (inc-data) ] }
71 { CHAR: < [ (dec-data) ] }
72 { CHAR: + [ (inc-memory) ] }
73 { CHAR: - [ (dec-memory) ] }
74 { CHAR: . [ (out-memory) ] }
75 { CHAR: , [ (get-input) ] }
76 { CHAR: [ [ (loop-start) ] }
77 { CHAR: ] [ (loop-end) ] }
82 [ "invalid input" throw ]
83 } case [ 1 + ] change-cp [ 1 + ] change-steps ;
87 : run-brainfuck ( code -- )
88 <brainfuck> [ can-step ] [ step ] while drop ;
90 : get-brainfuck ( code -- result )
91 [ run-brainfuck ] with-string-writer ;