Vocabulary to reduce numbers to more convenient representations

diff --git a/extra/units/reduction/authors.txt b/extra/units/reduction/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/extra/units/reduction/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/extra/units/reduction/reduction-tests.factor b/extra/units/reduction/reduction-tests.factor
new file mode 100644 (file)
index 0000000..001a9d6
--- /dev/null
+++ b/extra/units/reduction/reduction-tests.factor
@@ -0,0 +1,56 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel locals math math.functions
+math.order math.parser sequences tools.test ;
+IN: units.reduction
+
+[ "0Bi" ] [ 0 n>storage ] unit-test
+[ "0B" ] [ 0 n>Storage ] unit-test
+[ "0Bi" ] [ -0 n>storage ] unit-test
+[ "0B" ] [ -0 n>Storage ] unit-test
+[ "1000Bi" ] [ 1,000 n>storage ] unit-test
+[ "1K" ] [ 1,000 n>Storage ] unit-test
+[ "976Ki" ] [ 1,000,000 n>storage ] unit-test
+[ "1Mi" ] [ 2,000,000 n>storage ] unit-test
+[ "190Mi" ] [ 200,000,000 n>storage ] unit-test
+[ "1M" ] [ 1,000,000 n>Storage ] unit-test
+[ "953Mi" ] [ 1,000,000,000 n>storage ] unit-test
+[ "1G" ] [ 1,000,000,000 n>Storage ] unit-test
+[ "931Gi" ] [ 1,000,000,000,000 n>storage ] unit-test
+[ "1T" ] [ 1,000,000,000,000 n>Storage ] unit-test
+[ "909Ti" ] [ 1,000,000,000,000,000 n>storage ] unit-test
+[ "1P" ] [ 1,000,000,000,000,000 n>Storage ] unit-test
+[ "888Pi" ] [ 1,000,000,000,000,000,000 n>storage ] unit-test
+[ "1E" ] [ 1,000,000,000,000,000,000 n>Storage ] unit-test
+[ "-1E" ] [ -1,000,000,000,000,000,000 n>Storage ] unit-test
+
+: test-n>storage ( string -- string ) n>storage storage>n n>storage ;
+: test-n>Storage ( string -- string ) n>Storage storage>n n>Storage ;
+
+[ "0Bi" ] [ 0 test-n>storage ] unit-test
+[ "0B" ] [ 0 test-n>Storage ] unit-test
+[ "0Bi" ] [ -0 test-n>storage ] unit-test
+[ "0B" ] [ -0 test-n>Storage ] unit-test
+[ "1000Bi" ] [ 1,000 test-n>storage ] unit-test
+[ "1K" ] [ 1,000 test-n>Storage ] unit-test
+[ "976Ki" ] [ 1,000,000 test-n>storage ] unit-test
+[ "1Mi" ] [ 2,000,000 test-n>storage ] unit-test
+[ "190Mi" ] [ 200,000,000 test-n>storage ] unit-test
+[ "1M" ] [ 1,000,000 test-n>Storage ] unit-test
+[ "953Mi" ] [ 1,000,000,000 test-n>storage ] unit-test
+[ "1G" ] [ 1,000,000,000 test-n>Storage ] unit-test
+[ "931Gi" ] [ 1,000,000,000,000 test-n>storage ] unit-test
+[ "1T" ] [ 1,000,000,000,000 test-n>Storage ] unit-test
+[ "909Ti" ] [ 1,000,000,000,000,000 test-n>storage ] unit-test
+[ "1P" ] [ 1,000,000,000,000,000 test-n>Storage ] unit-test
+[ "888Pi" ] [ 1,000,000,000,000,000,000 test-n>storage ] unit-test
+[ "1E" ] [ 1,000,000,000,000,000,000 test-n>Storage ] unit-test
+[ "-1E" ] [ -1,000,000,000,000,000,000 test-n>Storage ] unit-test
+
+[ "abc" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "-abc" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "10" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "10b" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "10Mib" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "asdfBi" storage>n ] [ bad-storage-string?  ] must-fail-with
+[ "asdfB" storage>n ] [ bad-storage-string?  ] must-fail-with

diff --git a/extra/units/reduction/reduction.factor b/extra/units/reduction/reduction.factor
new file mode 100644 (file)
index 0000000..5227977
--- /dev/null
+++ b/extra/units/reduction/reduction.factor
@@ -0,0 +1,58 @@
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators continuations fry kernel lexer locals
+math math.functions math.order math.parser sequences splitting ;
+IN: units.reduction
+
+CONSTANT: storage-suffixes { "B" "K" "M" "G" "T" "P" "E" "Z" "Y" }
+
+CONSTANT: unit-suffix-hash H{
+        { CHAR: B 0 } { CHAR: K 1 } { CHAR: M 2 } { CHAR: G 3 }
+        { CHAR: T 4 } { CHAR: P 5 } { CHAR: E 6 } { CHAR: Z 7 }
+        { CHAR: Y 8 }
+    }
+
+: threshhold ( n multiplier base -- x )
+    [ * ] dip swap ^ ; inline
+
+:: find-unit-suffix ( suffixes n multiplier base -- i/f )
+    suffixes length
+    [ [ n ] dip multiplier base threshhold < ] find-integer
+   suffixes length or 1 - 0 max ;
+
+:: reduce-magnitude ( n multiplier base suffixes -- string )
+    n 0 < [
+        n neg multiplier base suffixes reduce-magnitude
+        "-" prepend
+    ] [
+        suffixes n multiplier base find-unit-suffix :> i
+        n multiplier i * base swap ^
+        /i number>string i suffixes nth append
+    ] if ;
+
+: n>storage ( n -- string )
+    10 2 storage-suffixes reduce-magnitude "i" append ;
+
+: n>Storage ( n -- string )
+    3 10 storage-suffixes reduce-magnitude ;
+
+ERROR: bad-storage-string string reason ;
+
+:: (storage>n) ( string multiplier base -- n )
+    string last unit-suffix-hash ?at [
+        :> unit
+        string but-last string>number
+        [ "not a number" throw ] unless*
+        multiplier unit * base swap ^ *
+    ] [
+        "unrecognized unit" throw
+    ] if ;
+
+: storage>n ( string -- n )
+    [ "i" ?tail [ 10 2 (storage>n) ] [ 3 10 (storage>n) ] if ]
+    [ \ bad-storage-string boa rethrow ] recover ;
+
+: n>money ( n -- string )
+    3 10 { "" "K" "M" "B" "T" } reduce-magnitude ;
+
+SYNTAX: STORAGE: scan storage>n suffix! ;

diff --git a/extra/units/reduction/summary.txt b/extra/units/reduction/summary.txt
new file mode 100644 (file)
index 0000000..92de189
--- /dev/null
+++ b/extra/units/reduction/summary.txt
@@ -0,0 +1 @@
+Reduce units to most convenient format