extra/roman/roman.factor

   1 ! Copyright (C) 2007 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs kernel math math.order math.vectors namespaces
   4 quotations sequences sequences.lib sequences.private strings unicode.case ;
   5 IN: roman
   6
   7 <PRIVATE
   8 : roman-digits ( -- seq )
   9     { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
  10
  11 : roman-values ( -- seq )
  12     { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
  13
  14 ERROR: roman-range-error n ;
  15
  16 : roman-range-check ( n -- )
  17     dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
  18
  19 : roman<= ( ch1 ch2 -- ? )
  20     [ 1string roman-digits index ] bi@ >= ;
  21
  22 : roman>n ( ch -- n )
  23     1string roman-digits index roman-values nth ;
  24
  25 : (>roman) ( n -- )
  26     roman-values roman-digits [
  27         >r /mod swap r> <repetition> concat %
  28     ] 2each drop ;
  29
  30 : (roman>) ( seq -- n )
  31     dup [ roman>n ] map swap all-eq? [
  32         sum
  33     ] [
  34         first2 swap -
  35     ] if ;
  36 PRIVATE>
  37
  38 : >roman ( n -- str )
  39     dup roman-range-check [
  40         (>roman)
  41     ] "" make ;
  42
  43 : >ROMAN ( n -- str ) >roman >upper ;
  44
  45 : roman> ( str -- n )
  46     >lower [ roman<= ] monotonic-split [
  47         (roman>)
  48     ] map sum ;
  49
  50 <PRIVATE
  51 : 2roman> ( str1 str2 -- m n )
  52     [ roman> ] bi@ ;
  53
  54 : binary-roman-op ( str1 str2 quot -- str3 )
  55     >r 2roman> r> call >roman ; inline
  56 PRIVATE>
  57
  58 : roman+ ( str1 str2 -- str3 )
  59     [ + ] binary-roman-op ;
  60
  61 : roman- ( str1 str2 -- str3 )
  62     [ - ] binary-roman-op ;
  63
  64 : roman* ( str1 str2 -- str3 )
  65     [ * ] binary-roman-op ;
  66
  67 : roman/i ( str1 str2 -- str3 )
  68     [ /i ] binary-roman-op ;
  69
  70 : roman/mod ( str1 str2 -- str3 str4 )
  71     [ /mod ] binary-roman-op >r >roman r> ;