Re: [colorforth] Euler Project Problems.
- Subject: Re: [colorforth] Euler Project Problems.
- From: "Ray St. Marie" <ray.stmarie@xxxxxxxxx>
- Date: Mon, 19 May 2008 22:42:13 -0600
Dear John. Albert,
Ray here...
> my guess is 0 constant U>D
>
>>
> -John Rible
Thank you, John! That starts to make sense now.
Even after my attempts to fix this application, the example
" FACTORISE 123456" returns the "Not a decimal number" abort.
I was hoping, nay praying, that one of you fine gentilemen might be
able to just 'SEE' the problem ( in the post script below) and hint me
into the proper direction.
Still looking, myself.
Thanks in advance
Ray
--
Raymond St. Marie ii,
colorforthray.info
( * The van der Horst Algoritme in Forth. * )
( The "van der Horst" algorithme is a small example program that )
( finds a factorization of numbers. )
( The input number can be very large indeed, large enough that the )
( algorithm becomes totally impractical. [State of the art factoring )
( uses elliptic curves or quadratic polynomial sieves] )
( It is based on a very well known base conversion routine and the )
( observation that if you have given a number in base ``b'', its )
( divisibility by ``b'' can be established by inspecting the last )
( digit of the number.
( Example : is 97321087 divisible by 10? Answer : no. )
( The base conversion rewrites the number from one base to the next )
( and so on with only a small number of additions. )
( Some lack of modesty is needed to call this combination a new )
( algorithm and put your name on it. )
( Author : Albert van der Horst/Adrie Bos/Marcel Hendrix )
( Rewritten as a pure ANSI forth example by Albert van der Horst )
DECIMAL
MARKER -horst \ " versie 5.0 --- ANSI version (LC infinite precision)"
1 VALUE PRECISION \ Digit length. How many cells is one digit?
0 CONSTANT U>D \ Added for ANS compatability by RAS 080519.
( This is a special array )
( By adjusting PRECISION we can change the length of the elements )
( A digit is big-endian, a is the array of digits little-endian )
: LARGE-NUMBER ( number of elements --- )
CREATE CELLS ALLOT ( Make it )
DOES> ( Usage: index array.address --> element.address )
SWAP PRECISION * CELLS +
;
\ 48 CONSTANT &0 \ Ascii value of '0'
30 CONSTANT &0 \ real ASCII VALUE OF '0' RAS
51 CONSTANT &Q \ ADDED by RAS 080519 fixes .N below
( DATA STRUCTURES )
1000 CONSTANT MAX.BITS \ Maximum number of bits handled
( ################# tools ######################################## )
( Increment the multiple precision digit at A, big-endian! )
: increment.digit ( addr A -- )
BEGIN
1 OVER +!
DUP @ 0= WHILE
1 CELLS +
REPEAT
DROP
;
( Decrement the multiple precision digit at A, big-endian! )
: decrement.digit ( addr A -- )
BEGIN
-1 OVER +!
DUP @ -1 = WHILE
1 CELLS +
REPEAT
DROP
;
( Returns "the multiple precision digit at A is zero", big-endian! )
: DIGIT=0? ( addr A -- flag )
PRECISION CELLS BOUNDS DO
I @ IF UNLOOP FALSE EXIT THEN
1 CELLS +LOOP
TRUE
;
\ Subtract more significant digit at addres S from the one at D
\ with borrow (in B1)
\ Leave the borrow B2.
: subtract.digit ( borrow B1, addr S, addr D - borrow B2 )
\ LOCAL dst Changed for ANS compatablility
\ LOCAL src
LOCALS| dst src |
PRECISION 0 DO
S>D \ Borrow
dst @ U>D D+ \ Add
src @ U>D D- \ Subtract
SWAP dst ! \ Store l.s word, leave borrow
1 CELLS +TO dst
1 CELLS +TO src
LOOP
;
\ Add digit at addres S to the one at D.
: add.digit ( addr S, addr D - )
\ LOCAL dst Changed for ANS compatablility
\ LOCAL src
LOCALS| dst src |
0
PRECISION 0 DO
U>D \ Carry
dst @ U>D D+ \ Add
src @ U>D D+ \ Add
SWAP dst ! \ Store l.s word, leave carry
\ cr ." leaving a carry of " DUP .
1 CELLS +TO dst
1 CELLS +TO src
LOOP
DROP \ Carry
;
\ Copy digit from addres S to address D.
\ Copying starting at higher addresses, because otherwise sometimes
\ there will be overlaps.
: copy.digit ( addr S, addr D - )
LOCALS| dst src |
PRECISION CELLS + TO dst \ LOCAL dst Changed for ANS compatablility
PRECISION CELLS + TO src \ LOCAL src
PRECISION 0 DO
-1 CELLS +TO dst
-1 CELLS +TO src
src @ dst !
LOOP
;
\ Store the number N as a digit at address A.
: digit! ( int N, addr A - )
SWAP OVER !
PRECISION 1 ?DO
0 OVER I CELLS + !
LOOP
DROP
;
( The number to be factored is represented as follows : )
\ num = sum(i from 0 to length-1 : num[i]*current.base^(len-1-i) )
( or in more mundane parlance : )
( the lowest `length' cells of `num' represent digits in base )
( `current.base', lowest are the most significant digits )
CREATE current.base MAX.BITS ALLOT
VARIABLE length
MAX.BITS LARGE-NUMBER num
\ Detect trouble: the guard bit of the base is incremented, so the
\ current precision is no longer sufficient.
: trouble? ( -- flag F)
current.base PRECISION CELLS + @
;
\ Change the way a digit is represented by adding one more cell
\ for each digit in `current.base' as well as `num'
: increase.precision ( -- )
\ Copy digits up in memory, starting at high addresses (!)
0 LENGTH @ 1- DO
I num DUP I CELLS + copy.digit
-1 +LOOP
1 +TO PRECISION
\ Initialise the extra cell to each digit to zero
LENGTH @ 0 DO
0 I num PRECISION 1- CELLS + !
LOOP
\ And the guard cell in current.base
0 current.base PRECISION CELLS + !
;
( Print the current base. This is done, whenever a last digit is zero, )
( such that the current base is factored out. )
: ?current.base
PRECISION 1 = IF
current.base @ U.
ELSE PRECISION 2 = IF
current.base 2@ SWAP UD.
ELSE \ We have no easy means to print a 3-CELL number, so...
." HEX "
PRECISION 0 DO current.base I CELLS + @ H. LOOP
THEN THEN
;
: .N
KEY? IF
CR ." base " ?current.base
CR ." length " length @ . ." Digits : "
length @ 0 ?DO I num @ . LOOP
\ BREAK? IF THEN
KEY &Q = ABORT" Terminated by user"
CR ." Continuing"
THEN
;
( Before and after HORST the number represented by `num' is the same. )
( Only `current.base' is one higher than before. )
( At point one `num' is in a "mixed base" representation with the )
( I left most digits in the new base and the remainder still in the )
( old base, throughout representing the same number. )
( See also Knuth: The art of computer programming page 306 : )
( a "Hand calculation" for going from octal to decimal. )
( Only ours is even simpler because our bases differ by 1 not by 2 )
: HORST ( --- )
.N
current.base increment.digit \ Next number base
trouble? IF increase.precision THEN
length @ 1 ?DO ( point one )
0 \ Borrow
1 I DO
I 1 - num I num subtract.digit \ with borrow !
DUP IF \ Borrow? Also leave it
current.base I num add.digit
THEN
-1 +LOOP
( Last borrow ) IF
0 num decrement.digit
THEN
LOOP
\ .S
;
( Simplifies the number by eliminating leading zero digits )
: SIMPLIFY ( --- )
BEGIN
length @ 1 > \ Prevent wrap around loop for length 1 or 0
0 num DIGIT=0?
AND
WHILE
length @ 1 DO \ Shift to the right
I num I 1- num copy.digit
LOOP
-1 length +! \ One shorter now
REPEAT
;
( Convert the number to the next higher base )
: NEXT.FACTOR ( --- )
HORST
SIMPLIFY
;
( Store the 4 bits of <word> at 4 successive lower addresses beneath )
( <adr1>. The last address used is returned. )
( Least significant bit is stored highest. )
: SPLIT4 ( adr1 word --- adr2 )
SWAP
4 0 DO \ For all 4 bits: )
1- >R \ Decrement and store index)
2 /MOD SWAP \ Split off right most bit )
R@ num digit! \ Store it )
R> \ Get index back
LOOP
SWAP DROP \ Drop the remainder
;
( Convert the decimal number as given to binary. )
( Apply HORST 6 times for base 16. )
( Then each digit contains 4 bits of the number, )
( split them over 4 cells. )
: DECIMAL.TO.BINARY ( --- )
6 0 DO NEXT.FACTOR LOOP \ Now in HEX
length @ 4 * \ Point after last cell of binary representation
0 length @ 1- DO \ From the end to prevent overwrites
I num @ \ Hex digit I
SPLIT4 \ distribute the bits
-1 +LOOP
length @ 4 *
length ! \ 4 times as much digits
2 current.base digit! \ `num' is binary now
SIMPLIFY \ Rid of leading zero's
length @ 1 = \ But not of the last one,
0 num DIGIT=0? \ because of looping finesses
AND ABORT" Zero cannot be factored"
;
: ASCII->BINARY ( char --- double )
( Convert a character digit to a binary representation )
&0 -
DUP 0< OVER 9 > OR ABORT" Not a decimal number"
;
: READ.DECIMAL.NUMBER \ ( --- >> "number.string" )
1 TO PRECISION \ Reset precision
BL WORD \ get from input
COUNT \ String.address length
DUP 0= ABORT" Please input a number"
DUP length ! \ Remember!
0 DO \ Convert each digit
C@ \ C@+ is this a typing error? RAS 080519
ASCII->BINARY
I num digit! \ to binary in number.
LOOP DROP \ Drop string address.
10 current.base digit! \ Start with decimal
0 current.base CELL+ ! \ Guard decimal for the overflow
;
( Print the remaining factor. )
( Depending on the circumstances the number may have 1 or 2 )
( digits. It is always prime, because smaller numbers have been )
( factored out. If it is 1 it is not printed, of course. )
: LAST.FACTOR ( --- )
length @ 1 = IF
\ The single digit must be 1 in this case
0 num @ DUP 1 <> ABORT" Unexpected remainder"
ELSE
PRECISION 1 = IF
( Calculate the number represented by `num' )
( Double precision is sufficient )
0 num @ current.base @ UM*
1 num @ U>D D+
CR ." Factor: " UD.
ELSE
CR ." Factor: too large too print"
THEN
THEN
;
( It is well known that we need not look for factors in a number )
( that are larger than its square root. )
( In the representation choosen this means that it need less than 2 )
( digits to be represented. The flag indicates there may be factors to )
( be found. )
: NOT.PAST.SQUARE.ROOT ( --- flag )
2 length @ <
;
( The number `num' is divisable by base if the last digit is zero )
( The flag indicates whether `num' is divisable by `current.base' )
: ?DIVISABLE ( --- flag )
length @ 1- num DIGIT=0?
;
( And finally ...... )
( `FACTORISE' accepts a string in the input stream with decimal digits )
( and factorises it. )
: FACTORISE
READ.DECIMAL.NUMBER
DECIMAL.TO.BINARY
BEGIN
NOT.PAST.SQUARE.ROOT WHILE
BEGIN
?DIVISABLE WHILE
CR ." Factor: " ?current.base
-1 length +! \ This divides by factor, scrap the last 0
REPEAT
NEXT.FACTOR \ Base conversion
REPEAT
LAST.FACTOR \ Print the last factor
;
: .HELP ." USAGE : FACTORISE 123456 <Return> " ;
---------------------------------------------------------------------
To unsubscribe, e-mail: colorforth-unsubscribe@xxxxxxxxxxxxxxxxxx
For additional commands, e-mail: colorforth-help@xxxxxxxxxxxxxxxxxx
Main web page - http://www.colorforth.com
