From e4579d02e706f077aa133baced39c2746c2c888f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 5 Jan 2019 14:27:42 -0600
Subject: [PATCH] units: Add exponentiation operator and a d-cube.

---
 extra/units/units-tests.factor |  6 ++++++
 extra/units/units.factor       | 17 ++++++++++++++---
 2 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor
index b5ff1776c1..b191aaf5f1 100644
--- a/extra/units/units-tests.factor
+++ b/extra/units/units-tests.factor
@@ -15,6 +15,12 @@ IN: units.tests
 { t } [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
 { t } [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
 
+{ t } [ 2 m  3 d^  2 m d-cube = ] unit-test
+
+{ t } [ 2 m  3 d^  8 { m m m } { } <dimensioned> = ] unit-test
+{ t } [ 2 m  -3 d^  1/8 { } { m m m } <dimensioned> = ] unit-test
+{ t } [ 2 m  0 d^  1 scalar = ] unit-test
+
 : km/L ( n -- d ) km 1 L d/ ;
 : mpg ( n -- d ) miles 1 gallons d/ ;
 
diff --git a/extra/units/units.factor b/extra/units/units.factor
index 050956109c..f98483d5e5 100644
--- a/extra/units/units.factor
+++ b/extra/units/units.factor
@@ -1,6 +1,5 @@
-USING: accessors arrays io kernel math namespaces splitting
-prettyprint sequences sorting vectors words inverse summary
-shuffle math.functions sets ;
+USING: accessors arrays combinators fry inverse kernel math
+math.functions sequences sets shuffle sorting splitting summary ;
 IN: units
 
 TUPLE: dimensioned value top bot ;
@@ -61,11 +60,23 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
 
 : d-sq ( d -- d ) dup d* ;
 
+: d-cube ( d -- d ) dup dup d* d* ;
+
 : d-recip ( d -- d' )
     >dimensioned< recip dimension-op> ;
 
 : d/ ( d d -- d ) d-recip d* ;
 
+ERROR: dimensioned-power-op-expects-integer d n ;
+
+: d^ ( d n -- d^n )
+    dup integer? [ dimensioned-power-op-expects-integer ] unless
+    {
+        { [ dup 0 > ] [ 1 - over '[ _ d* ] times ] }
+        { [ dup 0 < ] [ 1 - abs over '[ _ d/ ] times ] }
+        { [ dup 0 = ] [ 2drop 1 scalar ] }
+    } cond ;
+
 : comparison-op ( d d -- n n ) 2dup check-dimensions 2values ;
 
 : d< ( d d -- ? ) comparison-op < ;