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 quotations sequences sequences.private
   6 splitting.monotonic stack-checker strings unicode.case words ;
   7 IN: roman
   8
   9 <PRIVATE
  10
  11 CONSTANT: roman-digits
  12     { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
  13
  14 CONSTANT: roman-values
  15     { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
  16
  17 ERROR: roman-range-error n ;
  18
  19 : roman-range-check ( n -- n )
  20     dup 1 3999 between? [ roman-range-error ] unless ;
  21
  22 : roman-digit-index ( ch -- n )
  23     1string roman-digits index ; inline
  24
  25 : roman>= ( ch1 ch2 -- ? )
  26     [ roman-digit-index ] bi@ >= ;
  27
  28 : roman>n ( ch -- n )
  29     roman-digit-index roman-values nth ;
  30
  31 : (roman>) ( seq -- n )
  32     [ [ roman>n ] map ] [ all-eq? ] bi
  33     [ sum ] [ first2 swap - ] if ;
  34
  35 PRIVATE>
  36
  37 : >roman ( n -- str )
  38     roman-range-check
  39     roman-values roman-digits [
  40         [ /mod swap ] dip <repetition> concat
  41     ] 2map "" concat-as nip ;
  42
  43 : >ROMAN ( n -- str ) >roman >upper ;
  44
  45 : roman> ( str -- n )
  46     >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
  47
  48 <PRIVATE
  49
  50 MACRO: binary-roman-op ( quot -- quot' )
  51     [ infer in>> ] [ ] [ infer out>> ] tri
  52     '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
  53
  54 PRIVATE>
  55
  56 <<
  57
  58 SYNTAX: ROMAN-OP:
  59     scan-word [ name>> "roman" prepend create-in ] keep
  60     1quotation '[ _ binary-roman-op ]
  61     dup infer [ in>> ] [ out>> ] bi
  62     [ "string" <repetition> ] bi@ <effect> define-declared ;
  63
  64 >>
  65
  66 ROMAN-OP: +
  67 ROMAN-OP: -
  68 ROMAN-OP: *
  69 ROMAN-OP: /i
  70 ROMAN-OP: /mod
  71
  72 SYNTAX: ROMAN: scan roman> parsed ;