when-negative / when-positive

Convenience combinators to encapsulate testing numbers for being negative or positive, followed by call to a true quotation.

Signed-off-by: lorynj <lorynj@gmail.com>

extra/math/combinators/combinators-docs.factor

@@ -0,0 +1,24 @@
+USING: arrays help.markup help.syntax math
+sequences.private vectors strings kernel math.order layouts
+quotations generic.single ;
+IN: math.combinators
+
+HELP: when-negative
+{ $values
+     { "n" "an integer" } { "true" "a quotation" } { "m" "an integer" } }
+{ $description "When the n value is negative, calls the true quotation. The n value is passed to the quotation." }
+{ $examples "The following two lines are equivalent."
+    { $example "-1 [ 1 + ] when-negative\n-1 dup 0 < [ 1 + ] when"
+               "0\n0"
+    }     
+} ;
+
+HELP: when-positive
+{ $values
+     { "n" "an integer" } { "true" "a quotation" } { "m" "an integer" } }
+{ $description "When the n value is positive, calls the true quotation. The n value is passed to the quotation." }
+{ $examples "The following two lines are equivalent."
+    { $example "1 [ 1 + ] when-positive\n1 dup 0 > [ 1 + ] when"
+               "2\n2"
+    }     
+} ;

extra/math/combinators/combinators-tests.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2013 Loryn Jenkins.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.combinators 
+    tools.test ;
+IN: math.combinators.tests
+
+[ 0 ] [ -3 [ drop 0 ] when-negative ] unit-test
+[ -2 ] [ -3 [ 1 + ] when-negative ] unit-test
+[ 2 ] [ 2 [ 0 ] when-negative ] unit-test
+
+[ 0 ] [ 3 [ drop 0 ] when-positive ] unit-test
+[ 4 ] [ 3 [ 1 + ] when-positive ] unit-test
+[ -2 ] [ -2 [ 0 ] when-positive ] unit-test

extra/math/combinators/combinators.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2013 Loryn Jenkins.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math fry ;
+IN: math.combinators
+
+: when-negative ( ..n true: ( ..a -- ..b ) -- ..m )
+    '[ _ dup 0 < [ @ ] when ] call ; inline
+    
+: when-positive ( ..n true: ( ..a -- ..b ) -- ..m )
+    '[ _ dup 0 > [ @ ] when ] call ; inline