aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

tasks a-s

Browse source
This commit is contained in:
Ingy döt Net 2013-04-10 23:57:08 -07:00
parent 47bf37c096
commit b83f433714
12433 changed files with 156208 additions and 123 deletions
Download patch file Download diff file Expand all files Collapse all files

18
Task/Roman-numerals-Encode/Forth/roman-numerals-encode-1.fth Normal file
View file

@ -0,0 +1,18 @@
: vector create ( n -- ) 0 do , loop does> ( n -- ) swap cells + @ execute ;
\ these are ( numerals -- numerals )
: ,I dup c@ C, ; : ,V dup 1 + c@ C, ; : ,X dup 2 + c@ C, ;
\ these are ( numerals -- )
:noname ,I ,X drop ; :noname ,V ,I ,I ,I drop ; :noname ,V ,I ,I drop ;
:noname ,V ,I drop ; :noname ,V drop ; :noname ,I ,V drop ;
:noname ,I ,I ,I drop ; :noname ,I ,I drop ; :noname ,I drop ;
' drop ( 0 : no output ) 10 vector ,digit
: roman-rec ( numerals n -- ) 10 /mod dup if >r over 2 + r> recurse else drop then ,digit ;
: roman ( n -- c-addr u )
dup 0 4000 within 0= abort" EX LIMITO!"
HERE SWAP s" IVXLCDM" drop swap roman-rec HERE OVER - ;
1999 roman type \ MCMXCIX
25 roman type \ XXV
944 roman type \ CMXLIV

19
Task/Roman-numerals-Encode/Forth/roman-numerals-encode-2.fth Normal file
View file

@ -0,0 +1,19 @@
create romans 0 , 1 , 5 , 21 , 9 , 2 , 6 , 22 , 86 , 13 ,
does> swap cells + @ ;
: roman-digit ( a1 n1 a2 n2 -- a3)
drop >r romans
begin dup while tuck 4 mod 1- chars r@ + c@ over c! char+ swap 4 / repeat
r> drop drop
;
: (split) swap >r /mod r> swap ;
: >roman ( n1 a -- a n2)
tuck 1000 (split) s" M " roman-digit 100 (split) s" CDM" roman-digit
10 (split) s" XLC" roman-digit 1 (split) s" IVX" roman-digit nip over -
;
create (roman) 16 chars allot
1999 (roman) >roman type cr