This Euler problem was relatively complicated.
Download names.txt from http://projecteuler.net/index.php?section=problems
.
$PROCESS "string-process"
IFORTH
( c-addr u xt -- )
The counted string described by c-addr and u becomes the temporary
input
buffer during the execution of xt. The following code is equivalent:
CREATE foo 4 ,
S" foo " ' CREATE $PROCESS 4 ,
See also: EVALUATE
$PROCESS is available in Gforth under a name I can never remember.
DLSHIFT "d-l-shift"
IFORTH
( d1 x -- d2 )
Logically shift d1 over x bits to the left, giving the result d2. A 0
bit is inserted at the right end of the value.
DRSHIFT "d-r-shift"
IFORTH
( d1 x -- d2 )
Logically shift d1 over x bits to the right, giving the result d2. A
0
bit is inserted at the left end of the value. Since this bit is also
the
sign bit for signed numbers, the sign bit is cleared by this command.
<WORD> "fast-word"
IFORTH
( c -- c-addr u )
Perform the scanning functions of WORD . However the result is given
as
a character string. In this way the command executes much faster than
WORD .
-marcel
--
--------------------------------------------------------------------------------------
: DOUBLE[] 2* CELLS + ;
: []DOUBLE SWAP 2* CELLS + ;
: CELL[] CELLS + ;
: []CELL SWAP CELLS + ;
(*
Using names.txt, a 46K text file containing over five-thousand first
names,
begin by sorting it into alphabetical order. Then working out the
alphabetical
value for each name, multiply this value by its alphabetical position in
the
list to obtain a name score.
For example, when the list is sorted into alphabetical order, COLIN,
which is
worth 3 + 15 + 12 + 9 + 14 = 53, is the 938th name in the list. So, COLIN
would
obtain a score of 938 * 53 = 49714.
What is the total of all the name scores in the file?
Example output:
FORTH> euler22
The total of all the name scores in the file names.txt is 18,049,839,040
0.005 seconds elapsed. ok
FORTH> .colin
COLIN should be item #938, worth 53, score of 938 * 53 = 49714
COLIN_______is worth 53, score = 49714 ok
FORTH> 0 5 .index
AARON_______ $00000031
ABBEY_______ $00000023
ABBIE_______ $00000013
ABBY________ $0000001E
ABDUL_______ $00000028 ok
*)
0 VALUE #items
CREATE nameindex #6000 2* CELLS ALLOT
CREATE namevals #6000 CELLS ALLOT
CREATE dummy #12 1+ CHARS ALLOT
\ names.txt is quoted, comma-delimited, uppercased and contains no line
feeds.
: fetch-names ( -- addr size )
S" names.txt" R/O BIN OPEN-FILE THROW LOCALS| handle |
PAD #100000 handle READ-FILE THROW
handle CLOSE-FILE THROW
PAD SWAP ;
: SKIP-, ( -- ) BEGIN SOURCE DROP >IN @[EMAIL PROTECTED]
+ C@[EMAIL PROTECTED]
',' = WHILE 1 >IN +!
REPEAT ;
: EOI? ( -- bool ) SOURCE NIP >IN @[EMAIL PROTECTED]
<= ;
: indexed ( c-addr u1 -- )
0. DLOCAL hash
dummy #13 '_' FILL #12 MIN dummy PACK COUNT DROP
#12 0 ?DO C@[EMAIL PROTECTED]
'A' - $1F AND 0 hash 5 DLSHIFT D+ TO hash LOOP DROP
hash nameindex #items DOUBLE[] 2! ;
: PRINT~NAME ( ud -- )
DLOCAL name
CR #12 0 DO name #11 I - 5 * DRSHIFT DROP $1F AND 'A' + EMIT LOOP ;
\ Test 1; print the index. This succeeds in printing names that are 12
characters
\ or shorter. This is however only a side-effect: names are not stored.
: .INDEX ( begin end -- )
2DUP > IF SWAP ENDIF #items MIN SWAP 0 MAX
?DO nameindex I DOUBLE[] 2@[EMAIL PROTECTED]
PRINT~NAME
4 SPACES
namevals I CELL[] @[EMAIL PROTECTED]
H.
LOOP ;
\ 'A' is worth 1 etc.
: alphabeticized ( c-addr u1 -- )
0 -ROT 0 ?DO C@[EMAIL PROTECTED]
'A' - 1+ ROT + SWAP LOOP DROP
namevals #items CELL[] ! ;
\ Test 2. It is defined where COLIN should be.
: .COLIN ( -- )
CR ." COLIN should be item #938, worth 53, score of 938 * 53 = 49714"
nameindex #938 1- DOUBLE[] 2@[EMAIL PROTECTED]
PRINT~NAME
." is worth " namevals #938 1- CELL[] @[EMAIL PROTECTED]
DUP 0 .R ." , score = " #938 * .
;
\ C.A.R Hoare's famous QUICKSORT
: $>= ( ix1 ix2 -- bool ) SWAP nameindex []DOUBLE 2@[EMAIL PROTECTED]
ROT nameindex
[]DOUBLE 2@[EMAIL PROTECTED]
D>= ;
: $> ( ix1 ix2 -- bool ) SWAP nameindex []DOUBLE 2@[EMAIL PROTECTED]
ROT nameindex
[]DOUBLE 2@[EMAIL PROTECTED]
D> ;
: XCHG ( ix1 ix2 -- )
0 0 LOCALS| a2 a1 ix2 ix1 |
nameindex ix1 DOUBLE[] TO a1
nameindex ix2 DOUBLE[] TO a2
a1 2@[EMAIL PROTECTED]
a2 2@[EMAIL PROTECTED]
a1 2! a2 2!
namevals ix1 CELL[] TO a1
namevals ix2 CELL[] TO a2
a1 @[EMAIL PROTECTED]
a2 @[EMAIL PROTECTED]
a1 ! a2 ! ;
\ The newest qsort algorithm (Bentley) integrates 3-way partioning.
: QUICKSORT ( l r -- ) RECURSIVE
2DUP >= IF 2DROP EXIT ENDIF
0 0 0 0 LOCALS| m I J pivot r l |
l 1- TO I r TO J
r l - 3 > IF r l + 2/ TO m ( median-of-three pivot selection )
l m $> IF l m XCHG ENDIF
l r $> IF l r XCHG ELSE
r m $> IF r m XCHG ENDIF ENDIF
ENDIF
r TO pivot ( note that we need a check on J becoming out of bounds )
BEGIN BEGIN 1 +TO I I pivot $>= UNTIL
BEGIN 1 -TO J J pivot $> WHILE J l = UNTIL THEN
I J <
WHILE I J XCHG
REPEAT I r XCHG
l I 1- QUICKSORT
I 1+ r QUICKSORT ;
: INDEXED-SORT ( -- ) 0 #items 1- QUICKSORT ;
: store ( -- )
CLEAR #items
BEGIN
&" <WORD>
2DUP indexed
alphabeticized
1 +TO #items
SKIP-,
EOI?
UNTIL ;
\ index should go from 1 to #items for the purpose of counting.
: NAME-SCORES ( -- ud )
0. #items 0 DO namevals I CELL[] @[EMAIL PROTECTED]
I 1+ * 0 D+ LOOP ;
: Euler22 ( -- )
fetch-names
['] store $PROCESS
INDEXED-SORT
CR ." The total of all the name scores in the file names.txt is "
NAME-SCORES D. ;
: .ABOUT CR ." Euler22 -- What is the total of all the name scores in the
file names.txt?" ;
.ABOUT
|
