steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

minor cleanup

db4
Doug Coleman 2009-06-18 17:32:10 -05:00
parent 97f0a24e45
commit 801366df98
1 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/roman/roman.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry generalizations grouping USING: accessors arrays assocs effects fry generalizations
kernel lexer macros make math math.order math.vectors grouping kernel lexer macros math math.order math.vectors
namespaces parser quotations sequences sequences.private namespaces parser quotations sequences sequences.private
splitting.monotonic stack-checker strings unicode.case splitting.monotonic stack-checker strings unicode.case words ;
words effects ;
IN: roman IN: roman
<PRIVATE <PRIVATE
@ -17,23 +16,18 @@ CONSTANT: roman-values
ERROR: roman-range-error n ; ERROR: roman-range-error n ;
: roman-range-check ( n -- ) : roman-range-check ( n -- n )
dup 1 3999 between? [ drop ] [ roman-range-error ] if ; dup 1 3999 between? [ roman-range-error ] unless ;
: roman-digit-index ( ch -- n ) : roman-digit-index ( ch -- n )
1string roman-digits index ; inline 1string roman-digits index ; inline
: roman<= ( ch1 ch2 -- ? ) : roman>= ( ch1 ch2 -- ? )
[ roman-digit-index ] bi@ >= ; [ roman-digit-index ] bi@ >= ;
: roman>n ( ch -- n ) : roman>n ( ch -- n )
roman-digit-index roman-values nth ; roman-digit-index roman-values nth ;
: (>roman) ( n -- )
roman-values roman-digits [
[ /mod swap ] dip <repetition> concat %
] 2each drop ;
: (roman>) ( seq -- n ) : (roman>) ( seq -- n )
[ [ roman>n ] map ] [ all-eq? ] bi [ [ roman>n ] map ] [ all-eq? ] bi
[ sum ] [ first2 swap - ] if ; [ sum ] [ first2 swap - ] if ;
@ -41,12 +35,15 @@ ERROR: roman-range-error n ;
PRIVATE> PRIVATE>
: >roman ( n -- str ) : >roman ( n -- str )
dup roman-range-check [ (>roman) ] "" make ; roman-range-check
roman-values roman-digits [
[ /mod swap ] dip <repetition> concat
] 2map "" concat-as nip ;
: >ROMAN ( n -- str ) >roman >upper ; : >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n ) : roman> ( str -- n )
>lower [ roman<= ] monotonic-split [ (roman>) ] sigma ; >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
<PRIVATE <PRIVATE
@ -57,11 +54,13 @@ MACRO: binary-roman-op ( quot -- quot' )
PRIVATE> PRIVATE>
<< <<
SYNTAX: ROMAN-OP: SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ] 1quotation '[ _ binary-roman-op ]
dup infer [ in>> ] [ out>> ] bi dup infer [ in>> ] [ out>> ] bi
[ "string" <repetition> ] bi@ <effect> define-declared ; [ "string" <repetition> ] bi@ <effect> define-declared ;
>> >>
ROMAN-OP: + ROMAN-OP: +