extra/brainfuck/brainfuck.factor

   1 ! Copyright (C) 2009 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii assocs fry io io.streams.string kernel
   5 macros math peg.ebnf prettyprint 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 n -- brainfuck )
  23     [ get-memory ] dip + 255 bitand set-memory ;
  24
  25 : (-) ( brainfuck n -- brainfuck )
  26     [ get-memory ] dip - 255 bitand set-memory ;
  27
  28 : (?) ( brainfuck -- brainfuck t/f )
  29     get-memory zero? not ;
  30
  31 : (.) ( brainfuck -- brainfuck )
  32     get-memory write1 ;
  33
  34 : (,) ( brainfuck -- brainfuck )
  35     read1 set-memory ;
  36
  37 : (>) ( brainfuck n -- brainfuck )
  38     [ + ] curry change-pointer ;
  39
  40 : (<) ( brainfuck n -- brainfuck )
  41     [ - ] curry change-pointer ;
  42
  43 : (#) ( brainfuck -- brainfuck )
  44     dup
  45     [ "ptr=" write pointer>> pprint ]
  46     [ ",mem=" write memory>> pprint nl ] bi ;
  47
  48 : compose-all ( seq -- quot )
  49     [ ] [ compose ] reduce ;
  50
  51 EBNF: parse-brainfuck
  52
  53 inc-ptr  = (">")+  => [[ length [ (>) ] curry ]]
  54 dec-ptr  = ("<")+  => [[ length [ (<) ] curry ]]
  55 inc-mem  = ("+")+  => [[ length [ (+) ] curry ]]
  56 dec-mem  = ("-")+  => [[ length [ (-) ] curry ]]
  57 output   = "."  => [[ [ (.) ] ]]
  58 input    = ","  => [[ [ (,) ] ]]
  59 debug    = "#"  => [[ [ (#) ] ]]
  60 space    = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]]
  61 unknown  = (.)  => [[ "Invalid input" throw ]]
  62
  63 ops   = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
  64 loop  = "[" {loop|ops}+ "]" => [[ second compose-all [ while ] curry [ (?) ] prefix ]]
  65
  66 code  = (loop|ops|unknown)*  => [[ compose-all ]]
  67
  68 ;EBNF
  69
  70 PRIVATE>
  71
  72 MACRO: run-brainfuck ( code -- )
  73     [ blank? not ] filter parse-brainfuck
  74     '[ <brainfuck> @ drop flush ] ;
  75
  76 : get-brainfuck ( code -- result )
  77     [ run-brainfuck ] with-string-writer ; inline