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

modernize extra/roman

db4
Doug Coleman 2008-09-09 14:57:23 -05:00
parent aa8c85f010
commit c876388e6a
1 changed files with 2 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
extra/roman/roman.factor
View File

@ -1,26 +1,20 @@
! 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: arrays assocs kernel math math.order math.vectors namespaces USING: arrays assocs kernel math math.order math.vectors namespaces
quotations sequences sequences.lib sequences.private strings unicode.case ; quotations sequences sequences.lib sequences.private strings unicode.case ;
IN: roman IN: roman
<PRIVATE <PRIVATE
: roman-digits ( -- seq ) : roman-digits ( -- seq )
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ; { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
: roman-values ( -- seq ) : roman-values ( -- seq )
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ; { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
TUPLE: roman-range-error n ; ERROR: roman-range-error n ;
: roman-range-check ( n -- ) : roman-range-check ( n -- )
dup 1 3999 between? [ dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
drop
] [
roman-range-error boa throw
] if ;
: roman<= ( ch1 ch2 -- ? ) : roman<= ( ch1 ch2 -- ? )
[ 1string roman-digits index ] bi@ >= ; [ 1string roman-digits index ] bi@ >= ;
@ -39,7 +33,6 @@ TUPLE: roman-range-error n ;
] [ ] [
first2 swap - first2 swap -
] if ; ] if ;
PRIVATE> PRIVATE>
: >roman ( n -- str ) : >roman ( n -- str )
@ -55,13 +48,11 @@ PRIVATE>
] map sum ; ] map sum ;
<PRIVATE <PRIVATE
: 2roman> ( str1 str2 -- m n ) : 2roman> ( str1 str2 -- m n )
[ roman> ] bi@ ; [ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 ) : binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline >r 2roman> r> call >roman ; inline
PRIVATE> PRIVATE>
: roman+ ( str1 str2 -- str3 ) : roman+ ( str1 str2 -- str3 )