extra/brainfuck/brainfuck.factor

   1 ! Copyright (C) 2009 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors assocs combinators io io.streams.string kernel math
   5 namespaces sequences strings ;
   6
   7 IN: brainfuck
   8
   9 <PRIVATE
  10
  11 TUPLE: brainfuck code cp dp steps memory loop ;
  12
  13 : (set-loop) ( brainfuck in out -- brainfuck )
  14     pick loop>> [ set-at ] [ [ swap ] dip set-at ] 3bi ;
  15
  16 SYMBOL: tmp
  17
  18 : <brainfuck> ( code -- brainfuck )
  19     0 0 0 H{ } clone H{ } clone brainfuck boa
  20     V{ } clone tmp set
  21     dup code>> <enum> [
  22         {
  23             { CHAR: [ [ tmp get push ] }
  24             { CHAR: ] [ tmp get pop (set-loop) ] }
  25             [ 2drop ]
  26         } case
  27     ] assoc-each ;
  28
  29
  30 : (get-memory) ( brainfuck -- brainfuck value )
  31     dup [ dp>> ] [ memory>> ] bi at 0 or ;
  32
  33 : (set-memory) ( intepreter value -- brainfuck )
  34     over [ dp>> ] [ memory>> ] bi set-at ;
  35
  36 : (inc-memory) ( brainfuck -- brainfuck )
  37     (get-memory) 1 + 255 bitand (set-memory) ;
  38
  39 : (dec-memory) ( brainfuck -- brainfuck )
  40     (get-memory) 1 - 255 bitand (set-memory)  ;
  41
  42 : (out-memory) ( brainfuck -- brainfuck )
  43     (get-memory) 1string write ;
  44
  45
  46 : (inc-data) ( brainfuck -- brainfuck )
  47     [ 1 + ] change-dp ;
  48
  49 : (dec-data) ( brainfuck -- brainfuck )
  50     [ 1 - ] change-dp ;
  51
  52
  53 : (loop-start) ( brainfuck -- brainfuck )
  54     (get-memory) 0 = [ dup [ cp>> ] [ loop>> ] bi at >>cp ] when ;
  55
  56 : (loop-end) ( brainfuck -- brainfuck )
  57     dup [ cp>> ] [ loop>> ] bi at 1 - >>cp ;
  58
  59
  60 : (get-input) ( brainfuck -- brainfuck )
  61     read1 (set-memory) ;
  62
  63
  64 : can-step ( brainfuck -- brainfuck t/f )
  65     dup [ steps>> 100000 < ] [ cp>> ] [ code>> length ] tri < and ;
  66
  67 : step ( brainfuck -- brainfuck )
  68     dup [ cp>> ] [ code>> ] bi nth
  69     {
  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) ] }
  78         { CHAR: \s [ ] }
  79         { CHAR: \t [ ] }
  80         { CHAR: \r [ ] }
  81         { CHAR: \n [ ] }
  82         [ "invalid input" throw ]
  83     } case [ 1 + ] change-cp [ 1 + ] change-steps ;
  84
  85 PRIVATE>
  86
  87 : run-brainfuck ( code -- )
  88     <brainfuck> [ can-step ] [ step ] while drop ;
  89
  90 : get-brainfuck ( code -- result )
  91     [ run-brainfuck ] with-string-writer ;
  92
  93