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 fry generalizations grouping
   4 kernel lexer macros make math math.order math.vectors
   5 namespaces parser quotations sequences sequences.private
   6 splitting.monotonic stack-checker strings unicode.case
   7 words effects ;
   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 -- )
  21     dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
  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) ( n -- )
  33     roman-values roman-digits [
  34         [ /mod swap ] dip <repetition> concat %
  35     ] 2each drop ;
  36
  37 : (roman>) ( seq -- n )
  38     [ [ roman>n ] map ] [ all-eq? ] bi
  39     [ sum ] [ first2 swap - ] if ;
  40
  41 PRIVATE>
  42
  43 : >roman ( n -- str )
  44     dup roman-range-check [ (>roman) ] "" make ;
  45
  46 : >ROMAN ( n -- str ) >roman >upper ;
  47
  48 : roman> ( str -- n )
  49     >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
  50
  51 <PRIVATE
  52
  53 MACRO: binary-roman-op ( quot -- quot' )
  54     [ infer in>> ] [ ] [ infer out>> ] tri
  55     '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
  56
  57 PRIVATE>
  58
  59 <<
  60 SYNTAX: ROMAN-OP:
  61     scan-word [ name>> "roman" prepend create-in ] keep
  62     1quotation '[ _ binary-roman-op ]
  63     dup infer [ in>> ] [ out>> ] bi
  64     [ "string" <repetition> ] bi@ <effect> define-declared ;
  65 >>
  66
  67 ROMAN-OP: +
  68 ROMAN-OP: -
  69 ROMAN-OP: *
  70 ROMAN-OP: /i
  71 ROMAN-OP: /mod
  72
  73 SYNTAX: ROMAN: scan roman> parsed ;