basis/roman/roman.factor

   1 ! Copyright (C) 2007 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs effects fry generalizations
   4 grouping kernel lexer macros math math.order math.vectors
   5 namespaces parser effects.parser quotations sequences
   6 sequences.private splitting.monotonic stack-checker strings
   7 unicode.case words ;
   8 IN: roman
   9
  10 <PRIVATE
  11
  12 CONSTANT: roman-digits
  13     { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
  14
  15 CONSTANT: roman-values
  16     { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
  17
  18 ERROR: roman-range-error n ;
  19
  20 : roman-range-check ( n -- n )
  21     dup 1 10000 between? [ roman-range-error ] unless ;
  22
  23 : roman-digit-index ( ch -- n )
  24     1string roman-digits index ; inline
  25
  26 : roman>= ( ch1 ch2 -- ? )
  27     [ roman-digit-index ] bi@ >= ;
  28
  29 : roman>n ( ch -- n )
  30     roman-digit-index roman-values nth ;
  31
  32 : (roman>) ( seq -- n )
  33     [ [ roman>n ] map ] [ all-eq? ] bi
  34     [ sum ] [ first2 swap - ] if ;
  35
  36 PRIVATE>
  37
  38 : >roman ( n -- str )
  39     roman-range-check
  40     roman-values roman-digits [
  41         [ /mod swap ] dip <repetition> concat
  42     ] 2map "" concat-as nip ;
  43
  44 : >ROMAN ( n -- str ) >roman >upper ;
  45
  46 : roman> ( str -- n )
  47     >lower [ roman>= ] monotonic-split [ (roman>) ] map-sum ;
  48
  49 <PRIVATE
  50
  51 MACRO: binary-roman-op ( quot -- quot' )
  52     [ inputs ] [ ] [ outputs ] tri
  53     '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
  54
  55 PRIVATE>
  56
  57 <<
  58
  59 SYNTAX: ROMAN-OP:
  60     scan-word [ name>> "roman" prepend create-in ] keep
  61     1quotation '[ _ binary-roman-op ]
  62     complete-effect define-declared ;
  63
  64 >>
  65
  66 ROMAN-OP: + ( x y -- z )
  67 ROMAN-OP: - ( x y -- z )
  68 ROMAN-OP: * ( x y -- z )
  69 ROMAN-OP: /i ( x y -- z )
  70 ROMAN-OP: /mod ( x y -- z w )
  71
  72 SYNTAX: ROMAN: scan roman> suffix! ;