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 fry io io.streams.string kernel macros math
   5 peg.ebnf quotations sequences strings ;
   6
   7 IN: brainfuck
   8
   9 <PRIVATE
  10
  11 TUPLE: brainfuck pointer memory ops ;
  12
  13 : <brainfuck> ( -- brainfuck )
  14     0 H{ } clone 0 brainfuck boa ;
  15
  16 : max-ops? ( brainfuck -- brainfuck )
  17     [ 1 + dup 10000 > [ "Max operations" throw ] when ] change-ops ;
  18
  19 : get-memory ( brainfuck -- brainfuck value )
  20     dup [ pointer>> ] [ memory>> ] bi at 0 or ;
  21
  22 : set-memory ( brainfuck value -- brainfuck )
  23     over [ pointer>> ] [ memory>> ] bi set-at ;
  24
  25 : (+) ( brainfuck -- brainfuck )
  26     get-memory 1 + 255 bitand set-memory max-ops? ;
  27
  28 : (-) ( brainfuck -- brainfuck )
  29     get-memory 1 - 255 bitand set-memory max-ops? ;
  30
  31 : (?) ( brainfuck -- brainfuck t/f )
  32     max-ops? get-memory 0 = not ;
  33
  34 : (.) ( brainfuck -- brainfuck )
  35     get-memory 1string write max-ops? ;
  36
  37 : (,) ( brainfuck -- brainfuck )
  38     read1 set-memory max-ops? ;
  39
  40 : (>) ( brainfuck -- brainfuck )
  41     [ 1 + ] change-pointer max-ops? ;
  42
  43 : (<) ( brainfuck -- brainfuck )
  44     [ 1 - ] change-pointer max-ops? ;
  45
  46 : compose-all ( seq -- quot )
  47     [ ] [ compose ] reduce ;
  48
  49 EBNF: parse-brainfuck
  50
  51 inc-ptr  = ">"  => [[ [ (>) ] ]]
  52 dec-ptr  = "<"  => [[ [ (<) ] ]]
  53 inc-mem  = "+"  => [[ [ (+) ] ]]
  54 dec-mem  = "-"  => [[ [ (-) ] ]]
  55 output   = "."  => [[ [ (.) ] ]]
  56 input    = ","  => [[ [ (,) ] ]]
  57 space    = (" "|"\t"|"\r\n"|"\n") => [[ [ ] ]]
  58 unknown  = (.)  => [[ "Invalid input" throw ]]
  59
  60 ops   = inc-ptr | dec-ptr | inc-mem | dec-mem | output | input | space
  61 loop  = "[" {loop|ops}* "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
  62
  63 code  = (loop|ops|unknown)*  => [[ compose-all ]]
  64
  65 ;EBNF
  66
  67 PRIVATE>
  68
  69 MACRO: run-brainfuck ( code -- )
  70     [ <brainfuck> ] swap parse-brainfuck [ drop flush ] 3append ;
  71
  72 : get-brainfuck ( code -- result )
  73     [ run-brainfuck ] with-string-writer ; inline
  74