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 peg.ebnf sequences strings ;
   5
   6 IN: brainfuck
   7
   8 <PRIVATE
   9
  10 TUPLE: brainfuck ptr mem ops ;
  11
  12 : <brainfuck> ( -- brainfuck )
  13     0 H{ } clone 0 brainfuck boa ;
  14
  15 : ops? ( brainfuck -- brainfuck )
  16     [ 1 + ] change-ops
  17     dup ops>> 10000 > [ "Max operations" throw ] when ;
  18
  19 : (get-mem) ( brainfuck -- brainfuck value )
  20     dup [ ptr>> ] [ mem>> ] bi at 0 or ;
  21
  22 : (set-mem) ( brainfuck value -- brainfuck )
  23     over [ ptr>> ] [ mem>> ] bi set-at ;
  24
  25 : mem++ ( brainfuck -- brainfuck )
  26     (get-mem) 1 + 255 bitand (set-mem) ops? ;
  27
  28 : mem-- ( brainfuck -- brainfuck )
  29     (get-mem) 1 - 255 bitand (set-mem) ops? ;
  30
  31 : mem? ( brainfuck -- brainfuck t/f )
  32     ops? (get-mem) 0 = not ;
  33
  34 : out ( brainfuck -- brainfuck )
  35     (get-mem) 1string write ops? ;
  36
  37 : in ( brainfuck -- brainfuck )
  38     read1 (set-mem) ops? ;
  39
  40 : ptr++ ( brainfuck -- brainfuck )
  41     [ 1 + ] change-ptr ops? ;
  42
  43 : ptr-- ( brainfuck -- brainfuck )
  44     [ 1 - ] change-ptr ops? ;
  45
  46 : compose-all ( seq -- quot )
  47     [ ] [ compose ] reduce ;
  48
  49 EBNF: parse-brainfuck
  50
  51 inc-ptr  = ">"  => [[ [ ptr++ ] ]]
  52 dec-ptr  = "<"  => [[ [ ptr-- ] ]]
  53 inc-mem  = "+"  => [[ [ mem++ ] ]]
  54 dec-mem  = "-"  => [[ [ mem-- ] ]]
  55 output   = "."  => [[ [ out ] ]]
  56 input    = ","  => [[ [ in ] ]]
  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 '[ [ mem? ] _ while ] ]]
  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 ] 3append ;
  71
  72 : get-brainfuck ( code -- result )
  73     [ run-brainfuck ] with-string-writer ; inline
  74