Initial data commit

Task/Truth-table/Factor/truth-table.factor

@@ -0,0 +1,58 @@
+USING: arrays combinators eval formatting io kernel listener
+math.combinatorics prettyprint qw sequences splitting
+vocabs.parser ;
+IN: rosetta-code.truth-table
+
+: prompt ( -- str )
+    "Please enter a boolean expression using 1-long" print
+    "variable names and postfix notation. Available" print
+    "operators are and, or, not, and xor. Example:"  print
+    "> a b and"                                      print nl
+    "> " write readln nl ;
+
+: replace-var ( str -- str' )
+    dup length 1 = [ drop "%s" ] when ;
+
+: replace-vars ( str -- str' )
+    " " split [ replace-var ] map " " join ;
+
+: extract-vars ( str -- seq )
+    " " split [ length 1 = ] filter ;
+
+: count-vars ( str -- n )
+    " " split [ "%s" = ] count ;
+
+: truth-table ( n -- seq )
+    qw{ t f } swap selections ;
+
+: print-row ( seq -- )
+    [ write bl ] each ;
+
+: print-table ( seq -- )
+    [ print-row nl ] each ;
+
+! Adds a column to the end of a two-dimensional array.
+: add-col ( seq col -- seq' )
+    [ flip ] dip 1array append flip ;
+
+: header ( str -- )
+    [ extract-vars ] [ ] bi
+    [ print-row "| " write ] [ print ] bi*
+    "=================" print ;
+
+: solve-expr ( seq str -- ? )
+    vsprintf [ "kernel" use-vocab ( -- x ) (eval) ]
+    with-interactive-vocabs ;
+
+: results ( str -- seq )
+    replace-vars dup count-vars truth-table
+    [ swap solve-expr unparse ] with map ;
+
+: main ( -- )
+    prompt
+    [ header t ]
+    [ replace-vars count-vars truth-table ]
+    [ results [ "| " prepend ] map ] tri
+    add-col print-table drop ;
+
+MAIN: main