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