56 lines
1.5 KiB
Forth
56 lines
1.5 KiB
Forth
: sqrt ( u -- sqrt ) ( Babylonian method )
|
|
dup 2/ ( first square root guess is half )
|
|
dup 0= if drop exit then ( sqrt[0]=0, sqrt[1]=1 )
|
|
begin dup >r 2dup / r> + 2/ ( stack: square old-guess new-guess )
|
|
2dup > while ( as long as guess is decreasing )
|
|
nip repeat ( forget old-guess and repeat )
|
|
drop nip ;
|
|
|
|
: ndigits ( n -- n ) 10 / dup 0<> if recurse then 1+ ;
|
|
|
|
: dtally ( n -- n )
|
|
10 /mod
|
|
dup 0<> if recurse then
|
|
swap 6 * 1 swap lshift + ;
|
|
|
|
: ?product ( x a b -- f ) * = ;
|
|
: ?dtally ( x a b -- f ) dtally rot dtally rot dtally rot + = ;
|
|
: ?ndigits ( a b -- f ) ndigits swap ndigits = ;
|
|
: ?0trail ( a b -- f ) 10 mod 0= swap 10 mod 0= and invert ;
|
|
|
|
: ?fang ( x a -- f )
|
|
2dup / 2>r
|
|
dup 2r@ ?product
|
|
swap 2r@ ?dtally and
|
|
2r@ ?ndigits and
|
|
2r> ?0trail and ;
|
|
|
|
: next-fang ( n a -- false | a true )
|
|
over sqrt swap 1+ ?do
|
|
dup i ?fang if drop i true unloop exit then
|
|
loop drop false ;
|
|
|
|
: ?vampire ( n -- false | a true ) 0 next-fang ;
|
|
|
|
: next-vampire ( n -- n a ) begin 1+ dup ?vampire until ;
|
|
|
|
: .product ( n a -- ) dup . ." x " / . ." = " ;
|
|
|
|
: .vampire ( n a -- )
|
|
cr
|
|
begin 2dup .product
|
|
over swap next-fang
|
|
while repeat
|
|
. ;
|
|
|
|
: .fangs ( n -- ) dup ?vampire if .vampire else cr . ." is not vampiric." then ;
|
|
|
|
: vampires ( n -- )
|
|
1 swap
|
|
0 do next-vampire over swap .vampire loop drop ;
|
|
|
|
25 vampires
|
|
16758243290880 .fangs
|
|
24959017348650 .fangs
|
|
14593825548650 .fangs
|