The first program prints all the factors of a number. I found this one pretty simple to do.
Code: Select all
\ predicate used to determine if a number is a divisor
: factor? ( n1 n2 - f )
mod 0= ;
\ prints n2 if it is a factor of n1
: .factor ( n1 n2 - )
tuck \ n2 n1 n2
factor? \ n2 f
if
.
else
drop
then ;
\ prints all the numbers less than the number that are factors.
: factors ( n - )
dup 2 \ from 2 to n
do
dup i \ n n i
.factor \ n
loop
drop ;
Code: Select all
\ compute the number with the highest non sign bit set.
1 cell 8 * 2 - lshift
create max_bit 1 cells allot
max_bit !
\ shift "bit" to the highest power of four <= n.
: starting_bit ( n - n start_bit )
max_bit @
begin 2dup <= while \ one > n
2 rshift
repeat ;
\ predicate who's name says it all
: n>=r+b? ( n r b - n r b f )
\ copy n to return stack
rot dup >r -rot
\ compute result + bit
2dup +
\ n >= result + bit
r> swap >= ;
\ round up n2 by one if n1 is greater
: round_up ( n1 n2 - n1 n2 )
2dup > if
1+
then ;
\ Fast integer square root algorithm, with rounding the result to
\ the next greater integer if the fractional part is 0.5 or greater.
\ For example 2->1, 3->2, 4->2, 6->2, 7->3, 9->3
: isqrtr \ ( n - n^1/2 )
\ Throughout the function we'll juggle three numbers on the stack:
\ n (input), bit (computed), and result (output, starts at 0).
starting_bit 0
begin over while \ bit is not zero
n>=r+b? if
2dup + >r \ push result + bit to return stack
rot r> - -rot \ n = n - (result + one)
over 2 * + \ result += 2 * bit;
then
1 rshift swap \ divide result by 2
2 rshift swap \ divide bit by 4.
repeat
\ bit has outlived its usefulness
swap drop
\ Do arithmetic rounding to nearest integer
round_up
\ clean off n to return only result.
swap drop ;
Code: Select all
\ Begin borrowed code from http://www.forth.org/svfig/Len/bits.htm
\ Note: that code had a bug I fixed as indicated below.
\ Bit_array is a defining word that will create a bit array.
\ l is the number of bytes
create masks 128 c, 64 c, 32 c, 16 c, 8 c, 4 c, 2 c, 1 c,
: bit_array \ ( len -- ) ( i -- m a)
create allot does>
swap \ a i
8 \ a i 8
/mod \ a remainder whole
swap \ a whole remainder !MCH bug fix!
masks \ a whole remainder a
+ \ a whole mask_a
c@ \ a whole m
-rot \ m a whole
+ ; \ m a
\ We also need words to store and fetch bits. The words .@ and .!
\ Will fetch and store, respectively, a Boolean flag on the stack to
\ a bit array. (Do not confuse .! with cset or .@ with creset.)
: .! ( f m a -- ) rot if cset else creset then ;
: .@ ( m a -- f ) c@ and 0<> ;
\ Examples
\ 3 bit-array thflag \ Create a bit array for 24 bit-flags
\ 11 thflag ctoggle \ Toggle the 11th bit
\ 10 thFLAG .@ ( -- f) \ Extract the 10th bit and leave as well-formed Boolean flag
\ End of borrowed code.
\ Create a bit vector to hold the sieve.
\ 128 bytes allows for all primes less than 1024.
128 bit_array sieve
\ locates the index of the first non-zero bit in the sieve
\ with an index greater than the input.
: find_one ( n -- n )
1+ dup 1024 swap do
i sieve .@ \ get the bit corresponding to the integer.
if
leave
else
1+
then
loop ;
\ sets bits starting at n.
: set_bits ( n -- )
1024 swap
do
i sieve cset
loop ;
\ clears bits starting at n in steps of n. So n=2 starts at 2
\ and clears every other bit. While n=3 starts at three and
\ clears every third bit. However, it then resets the first
\ bit as that number is prime.
: clear_bits ( n -- )
dup 1024 swap
do
i sieve creset
dup
+loop
sieve cset ;
\ We'll waste two bits for integers 0 and 1 which can't be prime
: do_sieve
2 set_bits \ Assume all numbers 2 or greater are prime.
2 \ Initially, let p equal 2, the first prime number.
begin dup 1024 < while
dup \ n n
clear_bits \ n
find_one \ index of first one > n
repeat ;
\ iterates through the bit vector printing the index of a prime number
: .sieve
." List of primes "
1024 0 do
i sieve .@ \ get the bit corresponding to the integer.
if
i . ." , "
then
loop ;
Code: Select all
\ Helpers used to create cell values, and access portion of the cell.
: makePair 7 lshift + ; ( char value -- array[i] )
: >char 127 and ; ( array[i] -- char )
: >value 7 rshift ; ( array[i] -- value )
\ Create an associative array by left shifting Roman values with the assoicated character
create (arabic)
char M 1000 makePair , \ 128077
char D 500 makePair , \ 64068
char C 100 makePair , \ 12867
char L 50 makePair , \ 6476
char X 10 makePair , \ 1368
char V 5 makePair , \ 726
char I 1 makePair , \ 201
does> ( char addr -- value value )
7 cells \ char addr 7*cell_size
bounds \ char addr+7*cell_size addr
do
i @ \ char array[i]
over over \ char array[i] char array[i]
>char = \ char array[i] f
if \ chars match, then return value
nip >value leave
else
drop \ char
then
1 cells \ increment index one cell.
+loop
dup
;
\ adds the value of char to sum and keeps a copy of its value in digit
: do_digit ( sum digit char -- new_sum new_digit )
(arabic) >r \ sum digit new_digit
over over \ sum digit new_digit digit new_digit
< if
\ old digit is less than new, so subtract it from sum
-rot 2* negate +
swap \ adjusted_sum new_digit
else
nip \ sum new_digit
then
+ r> \ new_sum new_digit
;
\ parses a counted string in roman numeral form.
: >arabic ( addr count - )
0 -rot 0 -rot \ sum digit addr count
begin
over over \ sum digit addr count addr count
while \ count is non-zero
c@ \ load the character at addr
-rot >r >r \ sum digit char
do_digit \ sum digit
r> r> \ sum digit addr count
1 /string \ advance to next character
repeat
\ ( sum digit addr count addr )
2drop \ sum digit addr
2drop \ sum
;
s" MCMLXXXIV" >arabic .
I'd be interested to hear about this - did you just use PEEK & POKE for the linked lists? Because IIRC Commodore BASIC doesn't have any pointer facilities at all...
- but something that might be changed just to be sure.