extra/units/reduction/reduction.factor

   1 ! Copyright (C) 2011 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: assocs combinators continuations kernel lexer
   4 math math.functions math.order math.parser sequences splitting ;
   5 IN: units.reduction
   6
   7 CONSTANT: storage-suffixes { "B" "K" "M" "G" "T" "P" "E" "Z" "Y" }
   8
   9 CONSTANT: unit-suffix-hash H{
  10         { CHAR: B 0 } { CHAR: K 1 } { CHAR: M 2 } { CHAR: G 3 }
  11         { CHAR: T 4 } { CHAR: P 5 } { CHAR: E 6 } { CHAR: Z 7 }
  12         { CHAR: Y 8 }
  13     }
  14
  15 : threshhold ( n multiplier base -- x )
  16     [ * ] dip swap ^ ; inline
  17
  18 :: find-unit-suffix ( suffixes n multiplier base -- i/f )
  19     suffixes length [
  20         [ [ n ] dip multiplier base threshhold < ] find-integer
  21     ] keep or 1 [-] ;
  22
  23 :: reduce-magnitude ( n multiplier base suffixes -- string )
  24     n 0 < [
  25         n neg multiplier base suffixes reduce-magnitude
  26         "-" prepend
  27     ] [
  28         suffixes n multiplier base find-unit-suffix :> i
  29         n multiplier i * base swap ^
  30         /i number>string i suffixes nth append
  31     ] if ;
  32
  33 : n>storage ( n -- string )
  34     10 2 storage-suffixes reduce-magnitude "i" append ;
  35
  36 : n>Storage ( n -- string )
  37     3 10 storage-suffixes reduce-magnitude ;
  38
  39 ERROR: bad-storage-string string reason ;
  40
  41 :: (storage>n) ( string multiplier base -- n )
  42     string last unit-suffix-hash ?at [
  43         :> unit
  44         string but-last string>number
  45         [ "not a number" throw ] unless*
  46         multiplier unit * base swap ^ *
  47     ] [
  48         "unrecognized unit" throw
  49     ] if ;
  50
  51 : storage>n ( string -- n )
  52     [ "i" ?tail [ 10 2 (storage>n) ] [ 3 10 (storage>n) ] if ]
  53     [ \ bad-storage-string boa rethrow ] recover ;
  54
  55 : n>money ( n -- string )
  56     3 10 { "" "K" "M" "B" "T" } reduce-magnitude ;
  57
  58 SYNTAX: STORAGE: scan-token storage>n suffix! ;