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 command-line io io.encodings.binary
   5 io.files io.streams.string kernel macros math namespaces
   6 peg.ebnf prettyprint sequences multiline ;
   7
   8 IN: brainfuck
   9
  10 <PRIVATE
  11
  12 TUPLE: brainfuck pointer memory ;
  13
  14 : <brainfuck> ( -- brainfuck )
  15     0 H{ } clone brainfuck boa ;
  16
  17 : get-memory ( brainfuck -- brainfuck value )
  18     dup [ pointer>> ] [ memory>> ] bi at 0 or ;
  19
  20 : set-memory ( brainfuck value -- brainfuck )
  21     over [ pointer>> ] [ memory>> ] bi set-at ;
  22
  23 : (+) ( brainfuck n -- brainfuck )
  24     [ get-memory ] dip + 255 bitand set-memory ;
  25
  26 : (-) ( brainfuck n -- brainfuck )
  27     [ get-memory ] dip - 255 bitand set-memory ;
  28
  29 : (.) ( brainfuck -- brainfuck )
  30     get-memory write1 ;
  31
  32 : (,) ( brainfuck -- brainfuck )
  33     read1 set-memory ;
  34
  35 : (>) ( brainfuck n -- brainfuck )
  36     '[ _ + ] change-pointer ;
  37
  38 : (<) ( brainfuck n -- brainfuck )
  39     '[ _ - ] change-pointer ;
  40
  41 : (#) ( brainfuck -- brainfuck )
  42     dup
  43     [ "ptr=" write pointer>> pprint ]
  44     [ ",mem=" write memory>> pprint nl ] bi ;
  45
  46 : compose-all ( seq -- quot )
  47     [ ] [ compose ] reduce ;
  48
  49 EBNF: parse-brainfuck [=[
  50
  51 inc-ptr  = (">")+  => [[ length '[ _ (>) ] ]]
  52 dec-ptr  = ("<")+  => [[ length '[ _ (<) ] ]]
  53 inc-mem  = ("+")+  => [[ length '[ _ (+) ] ]]
  54 dec-mem  = ("-")+  => [[ length '[ _ (-) ] ]]
  55 output   = "."  => [[ [ (.) ] ]]
  56 input    = ","  => [[ [ (,) ] ]]
  57 debug    = "#"  => [[ [ (#) ] ]]
  58 space    = [ \t\n\r]+ => [[ [ ] ]]
  59 unknown  = (.)  => [[ "Invalid input" throw ]]
  60
  61 ops   = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
  62 loop  = "[" {loop|ops}+ "]" => [[ second compose-all '[ [ get-memory zero? ] _ until ] ]]
  63
  64 code  = (loop|ops|unknown)*  => [[ compose-all ]]
  65
  66 ]=]
  67
  68 PRIVATE>
  69
  70 MACRO: run-brainfuck ( code -- quot )
  71     parse-brainfuck '[ <brainfuck> @ drop flush ] ;
  72
  73 : get-brainfuck ( code -- result )
  74     [ run-brainfuck ] with-string-writer ; inline
  75
  76 <PRIVATE
  77
  78 : (run-brainfuck) ( code -- )
  79     [ <brainfuck> ] dip parse-brainfuck call( x -- x ) drop flush ;
  80
  81 PRIVATE>
  82
  83 : brainfuck-main ( -- )
  84     command-line get [
  85         read-contents (run-brainfuck)
  86     ] [
  87         [ binary file-contents (run-brainfuck) ] each
  88     ] if-empty ;
  89
  90 MAIN: brainfuck-main