basis/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
   4 namespaces make quotations sequences splitting.monotonic
   5 sequences.private strings unicode.case lexer parser ;
   6 IN: roman
   7
   8 <PRIVATE
   9
  10 : roman-digits ( -- seq )
  11     { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
  12
  13 : roman-values ( -- seq )
  14     { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
  15
  16 ERROR: roman-range-error n ;
  17
  18 : roman-range-check ( n -- )
  19     dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
  20
  21 : roman<= ( ch1 ch2 -- ? )
  22     [ 1string roman-digits index ] bi@ >= ;
  23
  24 : roman>n ( ch -- n )
  25     1string roman-digits index roman-values nth ;
  26
  27 : (>roman) ( n -- )
  28     roman-values roman-digits [
  29         [ /mod swap ] dip <repetition> concat %
  30     ] 2each drop ;
  31
  32 : (roman>) ( seq -- n )
  33     dup [ roman>n ] map swap all-eq? [
  34         sum
  35     ] [
  36         first2 swap -
  37     ] if ;
  38
  39 PRIVATE>
  40
  41 : >roman ( n -- str )
  42     dup roman-range-check [
  43         (>roman)
  44     ] "" make ;
  45
  46 : >ROMAN ( n -- str ) >roman >upper ;
  47
  48 : roman> ( str -- n )
  49     >lower [ roman<= ] monotonic-split [
  50         (roman>)
  51     ] map sum ;
  52
  53 <PRIVATE
  54
  55 : 2roman> ( str1 str2 -- m n )
  56     [ roman> ] bi@ ;
  57
  58 : binary-roman-op ( str1 str2 quot -- str3 )
  59     [ 2roman> ] dip call >roman ; inline
  60
  61 PRIVATE>
  62
  63 : roman+ ( str1 str2 -- str3 )
  64     [ + ] binary-roman-op ;
  65
  66 : roman- ( str1 str2 -- str3 )
  67     [ - ] binary-roman-op ;
  68
  69 : roman* ( str1 str2 -- str3 )
  70     [ * ] binary-roman-op ;
  71
  72 : roman/i ( str1 str2 -- str3 )
  73     [ /i ] binary-roman-op ;
  74
  75 : roman/mod ( str1 str2 -- str3 str4 )
  76     [ /mod ] binary-roman-op [ >roman ] dip ;
  77
  78 : ROMAN: scan roman> parsed ; parsing