utilities and loaders, pe question number to block pehtml*primes*files*doubles*bignums specialize d utilities br tuck dup top below rot rotate third to top -rot push first down to third 2drop drop a pair*2dup dup a pair 2swap swap a pair 2nip nip a pair 2push push a pair*2pop pop a pair 2over over a pair br sq square*tri nth triangular number / sum nats g euclidean iteration gcd greatest common divisor lcm least common multiple br 1@*1! byte address fetch/store a-b*b-a convert between cell and byte addrs n, comma in n bytes from stack br a4 0 pad dict to a multiple of 4 allot allocate n ints, return word address fill0 zero n cells from address allot0 allocate and zero memory		840 list general project euler pe -1 + 2 * 860 + ; pehtml 842 ;*primes 844 ;*files 846 ;*doubles 848 ;*bignums 852 ;*combs 856 ;*divs 858 ; br tuck xy-yxy swap over ; rot xyz-yzx push swap pop swap ; -rot xyz-zxy swap push swap pop ; 2drop p drop drop ;*2dup p-pp over over ; 2swap pq-qp push -rot pop -rot ; 2nip pq-q 2swap 2drop ; macro 2push p push push ;*2pop -p pop pop ; forth 2over pq-pqp 2swap 2dup 2push 2swap 2pop ; br sq n-n dup * ;*tri dup 1 + 2 */ ; g xy-yz swap over mod ; gcd xy-z -1 ? if g gcd ; then drop ; lcm xy-z over over gcd */ ;, macro 1@ 25008A 3, FF , ;*1! a! 288 2, drop ; forth 1@ 1@ ;*1! 1! ;*a-b 2* 2* ;*b-a 2/ 2/ ; n, n -1 + -if drop ;, ..then swap push n, pop 1, ; a4 here 3 ? drop if 0 1, a4 ; then ; allot n-a a4 here b-a swap a-b h +! ; fill0 an 0 -rot fill ; allot0 n-a push i allot dup pop fill0 ;
		842 list - create project euler html br html load 840 load, named pe.html 840 40 pe run
l sieve size sieve address in sieve, in the sieve, 1 is not prime, 0 is prime. 2** raise 2 to the n addrmsk helper, return the address and bitmask notprime mark as not prime oob? out of bounds of prime sieve prime? test if prime, br opt optimize - muls of 2 are already marked fillmuls mark multiples as not prime, , nextprime return next prime greater than n ok? in range sift run sieve		844 list - prime sieve l 2000000, l @ 32 / 1 + allot0*sieve n-a 0 + + ; br macro*2** n-n C031C88B , C8AB0F 3, ; forth addrmsk n-am 32 /mod sieve swap 2** ; notprime n addrmsk over @ +or swap ! ; oob? dup l @ dup u+ / 1 or drop ; prime? oob? if 0 ? ;, ..then dup addrmsk swap @ - and drop ; br opt nn-nn 1 ? if 2 * swap then ; fillmuls n dup opt*f over + l @ less drop, ..if dup notprime f ; then 2drop ; nextprime p-q begin 1 + prime? until ; ok? dup sq l @ less drop drop ; sift p-q nextprime ok? if dup fillmuls sift ;, then ; 0 notprime 1 notprime 0 sift drop
read files ch last char read open byte string name to handle rdch char into ch , returns 1/0 chars read wrch comma from ch into dictionary eof? were 0 bytes read eof write eof into memory. on eof, last char i s written twice.*fc file contents readall read a file into memory dig index in file to digit digs index and num of digits to number br usage example, named i/8.in readall .. 0 dig .. 0 2 digs		846 list - files ch -222 open b-h 0 fnam b-a r/o fopen ; rdch h-n ch a-b swap 1 swap frd ; ,ch ch @ 1, ; eof? n 1 or drop ; eof -1 h @ -1 + 1! ; fc 271687680 readall open here fc !, ..begin dup rdch ,ch eof? until drop eof ;, dig n-n fc @ + 1@ -48 + ; digs nn-n 0 swap for, ..10 * over dig + 1 u+ next nip ;
doubles are big endian, unlike ans forth c! copy eax to ecx n-d single-length to double-length dless is the first less than the second? br d+ add two double-length numbers d* multiply a double-length by a single-length , d/' helper, leaves quot then rem br d/ divide double by single, double quot dmod this and d/ currently break with negs, , , d- complement double*dnegate negate double dmax larger of two double-length dmin you can guess		848 list - double-length numbers macro c! C88B 2, ; n-d 99 1, dup 1689 2, ; dless 84E8B 3, E3B 2, 107F147C , 778C923 ,, ..44639 3, 5EB0972 , 4463B 3, C9310272 , ; d+ dd-d u+ D083 3, u+ ; d* dn-d c! 99 1, drop D88B 2, DAAF0F 3,, ...E1F7 2, EAF0F 3, CB03CA03 , E89 2, ; d/' dn-dn c! 4468B 3, D231 2, F9F7 2, 44689 3, 68B 2, F1F7 2, 689 2, C28B 2, ; d/ dn-d d/' drop ; dmod dn-n d/' nip nip ; forth n-d n-d ;*d-n nip ;*d+ d+ ;*d* d* ; d/ d/ ;*dmod dmod ;*d/mod d/' -rot ; d- - swap - swap ;*dnegate d- 1 n-d d+ ; dmax dless if 2swap then 2drop ; dmin dless if 2drop ; then 2nip ;, 850 load input
usage dbl 4294967296 as text with backtick +dig append a shannon char to a double +digs append 32 shannon bits to a double br newword? is this a new word? pdword parse word into double br untag remove tag from word dbl parse double and compile its two numbers		850 list - double-length input +dig dn-d push 10 d* pop -24 + n-d d+ ; +digs dw-d unpack -1 ?, ..if swap push +dig pop +digs ; then 2drop ; newword? F ? ; pdword dw-d begin +digs 7@+ @ newword? until, ..drop 7dec ; untag FFFFFFF0 and ; macro dbl 0 n-d 7@+ @ untag pdword swap ,lit ,lit ; forth
unsigned numbers up to 2** 2**32-1 ad-n+d add number at address to double sum add from address 1, from address 2, carry acc next addrs, sum, assign, keep carry on top g+' add after setup, doesn't clean up 2copy' copy' both same length, alloc top first maxsize bigger size of 2 bignums g+ add bignums br mul mul from address to n, add carry acc next addr, mul, keep carry on top g*' mul after setup, doesn't clean up g* multiply bignums br div div from address with carry by n acc next addr, div, keep carry on top gna0n yxy0n but middle is last - 1 'g/mod g/mod after setup, doesn't clean up g/mod*g/*gmod bignum division, note that division works from the end, most si gnificant, backwards br gdigsum sum of digits of bignum		852 list - bignums 854 load ad-n+d rot @ n-d' d+ ; sum aan-d n-d' ad-n+d ad-n+d ; acc sdn-sdn dup2nexta sum carry ; g+' gg-g yxy0n for acc next 2drop drop ; 2copy' ggn-gg tuck copy' -rot copy' swap ; maxsize gg-ggn over @ over @ max ; g+ gg-g maxsize 2copy' g+' dup fix ; br mul nac-d push @ n-d' rot d* pop n-d' d+ ; acc nac-nac 1 dupnexta mul carry ; g*' ng-g yxy0n for acc next 2drop drop ; g* gn-g swap dup @ copy' g*' dup fix ; br div nac-d swap @ rot d/mod nip ; acc nac-nac -1 dupnexta div carry ; gna0n ng-gna0n yxy0n rot last 1 + -rot ; 'g/mod ng-cg gna0n for acc next nip nip swap ; g/mod gn-cg swap -g0? if copy 'g/mod dup fix ; ..then nip 0 swap ; g/ gn-g g/mod nip ;*gmod gn-n g/mod drop ; br gdigsum g-n, ..-g0? if 10 g/mod gdigsum + ; then drop 0 ;
first, general helpers -g0? is this bignum not zero last address of last body int -last0? is the last cell needed fixsize remove last cell if not needed free free everything after this bignum fix fixsize and free n-g num to bignum g-n bignum to num, mod 2**31 g-d bignum to double, mod 2**63 gng bignum to bignum,size,newalloc copy copy bignum pad0 allocate and zero cells to pad to length copy' copy and pad zeroes to size + 1, next, math operation helpers n-d' n-d but don't sign-extend dup2nexta calc and dup next addrs of both dupnexta use top as dir to calc next addr, dup carry assign value while keeping carry on top yxy0n n is y's length br bignums are one length byte, then l body bytes . they are little endian, so can expand by all ocating. br g is used in stack effect comments since b is taken		854 list - bignums helpers doubles load -g0? dup @ -1 ? drop ; last g-a dup @ + ; -last0? dup last @ -1 ? drop ; fixsize g -last0? if drop ; then -1 swap +! ; free g last 1 + a-b h ! ; fix g dup fixsize free ; n-g 2 allot push 1 i ! i 1 + ! i fix pop ; g-n 1 + @ 7FFFFFFF and ; g-d 1 + dup g-n swap @ ; gng g-gng dup @ 1 + dup allot ; copy g-g gng push i swap move pop ; pad0 ng @ negate + allot0 drop ; copy' gn-g swap copy 1 u+ 2dup pad0 tuck ! ;, , n-d' 0 swap ; dup2nexta aan-aaaan push 1 1 v+ 2dup pop ; dupnexta nacn-nanac u+ push 2dup pop ; carry acn-ac swap push over ! pop ; yxy0n xy-yxy0n tuck 0 over @ ;
math stuff with bignums fac factorial facdiv divide bignum by factorial k*n-k get k and n-k, note that n-k eats args choose n choose k		856 list - combinatorics bignums load fac n-g 1 max 1 n-g swap for i g* next ; facdiv gn-g for i g/ next ; k kn-k over ;*n-k nkg-gn -rot negate + ; choose nk-g over fac k facdiv n-k facdiv ;
count and sum proper divisors high? higher than sqrt? divd? does top divide second? facsum sum of m/n and m/ m/n acc increment divisor count and add divisors i f divides ccni insert both accumulators, and index -sq? is the top not the sqrt of second back fix double counting the sqrt fix same thing, but only if necessary 'divs compute divsum,ndivs pdivs remove n itself ndivs number of proper divisors +/divs sum of proper divisors br divd? and +/divs would be called divs? and div sum, but those names conflict with div		858 list - divisors high? 2dup sq less 2drop ; divd? 2dup mod 1 less 2drop ; facsum nn-n tuck / + ; acc ccnn-ccnn divd?, ..if 2dup 2push facsum 2 v+ 2pop then ; ccni n-ccni 0 0 rot 1 ; -sq? 2dup sq or drop ; back ccni-cc nip negate -1 v+ ; fix ccni-cc -1 + -sq? if 2drop ; then back ; 'divs ccni begin acc 1 + high? until fix ; pdivs push i 'divs pop negate u+ ; ndivs pdivs nip ; +/divs pdivs drop ;
multiples of 3 or 5 acc updates accumulator if num is valid		860 list - project euler 1 acc cn-c dup 15 gcd -1 + 1 min * + ; pe1 0 999 for i acc next ;
even fibonacci numbers fib from 2 fibs, calculates the next acc update acc if valid ok? num in range?		862 list - project euler 2 fib xy-yz over + swap ; acc nc-nc over 1 ? if 0 * then + ; ok? 4000000 less drop ; pe2 1 0 fib 0 push acc, f ok? if pop acc push fib f ; then 2drop pop ;
largest prime factor -divs? dn-dn does n not divide d reduce divide out power of n br 1? is the double 1		864 list - project euler 3 primes load doubles load -divs? push 2dup i dmod -1 ? drop pop ; reduce dn-d -divs? if drop ;, ..then push i d/ pop reduce ; 1? dbl 2 dless 2drop ; pe3 dbl 600851475143 0, ..begin nextprime push i reduce 1? pop until, ..nip nip ;
palindrome product transfer move a digit br reverse reverse a number br -palin is the number a palindrome? n-prod index to its corresponding product		866 list - project euler 4 transfer x yz - xz y swap 10 * swap, ..10 /mod swap u+ ; reverse n-m 0 swap f -1 ? if transfer f ; then drop ; -palin? dup reverse over or drop ; n-prod i-n 899 /mod 100 100 v+ * ; pe4 0 899 sq, ..for i n-prod -palin? if 0 * then max next ;
smallest multiple		868 list - project euler 5 pe5 1 20 for i lcm next ;
sum square difference sumsq sum of first n squares		870 list - project euler 6 sumsq n-n dup tri swap 2 * 1 + 3 */ ; pe6 100 tri sq 100 sumsq negate + ;
10001st prime		872 list - project euler 7 primes load pe7 0 10001 for nextprime next ;
largest product in a series dig value of this digit acc update product from digit index 13* product of 13 nums from digit index		874 list - project euler 8 doubles load files load, named i/8.in readall acc dn-dn push i dig d* pop ; 13* n-d dbl 1 rot 13 for acc 1 + next drop ; pe8 dbl 0 999 -13 + for i 13* dmax -next ;
special pythagorean triple 3dup -triple? are the top 3 not a triple other add to 1000 pe9 need the 2pop to remove the for loop indic es from the stack after the break br this is the solution i'm least proud of. it is quite ugly, but i can't figure out any better ways to do it. i can't refactor pe9 into more readable words because the control flow requir es it all be in the same word.		876 list - project euler 9 3dup xyz-xyzxyz push 2dup i -rot pop ; -triple? 3dup sq swap sq + swap sq or drop ; other n-n negate 1000 + ; pe9 998 for i i other -1 + for i 2dup + other, ..-triple? if 2drop *next drop *next, ..then 2pop 2drop * * ;
sum of primes under 2 million acc update the accumulator high? more than 2m?		878 list - project euler 10 primes load doubles load acc dn-dn push i n-d d+ pop ; high? 2000000 swap less nip ; pe10 dbl 0 2, ..begin acc nextprime high? until drop ;
largest product in a grid br num nth number in the file oob? less than 0 or greater than 19 oobs? are either of a pair out of bounds n-xy num to coords*xy-n coords to num num' number at coord if on grid, else 0 br np nip push - push 2nd elt 4push' push 4 elts under the top 4pop pop 4 times acc multiply accumulator by num at coords move move cords by dir cnnxy juggle to acc dir,dir x,y line product of line from coords x,y in direct ion dir,dir acc update max with line in this direction lines max line starting from coords br pain. pain. that's all there is here.		880 list - project euler 11 files load, named i/11.in readall num n-n 3 * 2 digs ; oob? dup 20 + 20 / 1 or drop ; oobs? oob? if ; then swap oob? swap ; n-xy 20 /mod ;*xy-n 20 * + ; num' xy-n oobs? if 2drop 0 ; then xy-n num ; b r macro*np swap push ;*4push' np np np np ; 4pop 2pop 2pop ; forth acc cnnxy-cnnxy 2dup num' 4push' * 4pop ; move nnxy-nnxy 2over v+ ; cnnxy xynn-cnnxy 2swap 1 4push' 4pop ; line xynn-n cnnxy, ..4 for acc move next 2drop 2drop ; acc cxynn-cxy 2over 2push line max 2pop ; lines xy-n 0 -rot, ..0 1 acc 1 0 acc 1 1 acc 1 -1 acc 2drop ; pe11 0 19 19 xy-n for i n-xy lines max -next ;
highly divisible triangular number high? smaller than sqrt ? -divs? is top not a factor? acc add 2 divisors to acc if divides cni 0 for acc, number, 1 for index ndivs n-n number of divisors high? ndivs of triangle is over 500? br ndivs doesn't work with squares. if desired, t his could be fixed by checking if the end inde x - 1 is the square root, and decrementing the divisor count if so., however, no triangular number save 1 is a perf ect square.		882 list - project euler 12 divs load high? dup tri ndivs 500 swap less 2drop ; pe12 0 begin 1 + high? until tri ;
large sum br acc add digit to end, update digit index num 50 digit number at this index sum sum of the 100 50 digit numbers prp prepend digit acc remove smallest digit, prepend new first10 get first 10 digits of a bignum		884 list - project euler 13 files load bignums load, named i/13.in readall acc ng-ng 10 g* over dig n-g g+ 1 u+ ; num i-g 51 * 0 n-g 50 for acc next nip ; sum g 0 n-g 99 for i num g+ -next ; prp dn-d push 10 d/ pop n-d 1000000000 d* d+ ; acc dg-dg 10 g/mod push prp pop ; first10 g-d dbl 0 rot, ..begin -g0? while acc end then drop ; pe13 sum first10 ;
longest collatz sequence collatz the next number in the sequence 1? is the dobule 1 clen length of the sequence until 1 ln transform index into len,index keeplonger keep the longer of two len,n pairs		886 list - project euler 14 doubles load collatz d-d 1 ? if 3 d* dbl 1 d+ ; then 2 d/ ; 1? dbl 2 dless 2drop ; clen n n-d*f 1? if d-n ; then collatz f 1 + ; ln n-ln 500000 + dup clen swap ; keeplonger lnln-ln dmax ; pe14 0 0 500000, ..for i len,i keeplonger next nip ;
lattice paths		888 list - project euler 15 combs load pe15 40 20 choose g-d ;
power digit sum		890 list - project euler 16 bignums load pe16 1 n-g 1000 for 2 g* next gdigsum ;
number letter counts br 0-19 length of numbers from zero to nineteen, with zero having length 0 to make eg 30 easier tens length of twenty, thirty etc, with zero a nd ten having length 0, being covered by 0-19 10s length of numbers below 100 w/and add the word and if needed, 100s length of numbers in the hundreds len number of letters in the number		892 list - project euler 17, here 0 3 3 5 4 4 3 5 5 4, 3 6 6 8 8 7 7 9 8 8 20 n,*0-19 n-n 0 + + 1@ ;, here 0 0 6 6 5 5 5 7 6 6 10 n, tens n-n 0 + + 1@ ; 20-99 n 10 /mod tens swap 0-19 + ; 10s n 20 less drop if 0-19 ; then 20-99 ; w/and -1 ? if 3 + then ; 100s n 100 /mod 0-19 7 + swap 10s w/and + ; len n 100 less drop if 10s ; then, ..1000 less drop if 100s ; then drop 11 ; pe17 0 1000 for i len + next ;
maximum path sum i r number of rows of the triangle num row col to num arr index arr of length r 0arr clear arr acc add index to spot in arr, leave row 2arr@ get numbers at array index i, i+1 !max set max of 2 neighbours maxes sliding window max br reduce add new values and calculate new maxes		894 list - project euler 18 files load, named i/18.in readall r 15 num nn-n swap tri + 3 * 2 digs ;, r @ allot*arr n-a 0 + + ; 0arr 0 arr r @ fill0 ; acc nn-n 2dup num swap arr +! ; 2arr@ n-nn dup arr @ swap 1 + arr @ ; !max n dup 2arr@ max swap arr ! ; maxes n -1 ? if -1 + dup maxes !max ;, ..then drop ; reduce n dup for i acc -next maxes ; pe18 0arr r @ -1 + for i reduce -next, ..0 arr @ ;
counting sundays y year*m month ms total num of months mlen' days in month, without leap years -divs? is second not divisible by top -ydivs? does this not divide the year -leap? is it not a leap year -feb? is it not february mlen days in months, works with leap years., the acc takes in numsundays,numdays., for days, sunday is 0, monday is 1 etc acc add days, add 1 to sunday count if sunday month acc and increment the month		896 list - project euler 19 ms 1200 y ms @ 12 / 1901 + ;*m ms @ 12 mod ;, here 31 28 31 30 31 30 31 31 30 31 30 31 12 n, mlen' 0 + m + 1@ ; -divs? n over swap mod -1 ? drop ; -ydivs? n y swap -divs? drop ; -leap? 100 -ydivs? if 4 -ydivs? ;, ..then 400 -ydivs? ; -feb? m 1 or drop ; mlen mlen' -leap? if ;, ..then -feb? if ; then 1 + ; acc cn-cn mlen + 7 -divs? if ; then 1 u+ ; month cn-cn acc 1 ms +! ; pe19 0 ms ! 0 2 1200 for month next drop ;
factorial digit sum		898 list - project euler 20 combs load pe20 100 fac gdigsum ;
amicable numbers +unless add top number unless zf is false -divs? does the top not divide second acc acc,num,factor add factor if divides num d d' special case d for 0 and 1 neq? are the top two not equal lonely? is this number not amicable		900 list - project euler 21 divs load +unless nn-n if 0 * then + ; d' n-n 2 max +/divs ; neq? 2dup or drop ; lonely? dup d' neq? if d' neq? drop ;, ..then -1 ? drop ;, pe21 0 9999 for i lonely? +unless next ;
name scores, bruhhh this problem... getch get the current char from the file eatch move on to the next char eof? end of the file? ,ch comma the current char and eat it quote? is this char quote? name parse a name 1@s 1@ top two elements 1@neq? are 1@ ed top two elements not equal? left*right*data fields in node struct datas datas of top two elements nless? is one node less than the other br l/r go to either left or right branch insert base node - base, insert the new node i nto the binary tree names parse names and create tree, d is node in stack comments since n is taken acc add char value eon? end of name i alphabetical position in list score how much this name is worth br scores recursively score whole tree, nodes are a ptr to array of lptr rptr 0-termin ated string		902 list - project euler 22 files load, named i/22.in readall ff 271734127 getch -ch ff @ 1@ ; eatch 1 ff +! ;*2eatch 2 ff +! ; eof? FE getch less 2drop ;, ,ch getch -64 + 1, eatch ; quote? getch 35 less 2drop ;, name -d 2 allot0 begin ,ch quote? until 0 1, ; 1@s bb-nn 1@ swap 1@ swap ; 1@neq? 2dup 1@s or drop ; left d-a ;*right d-a 1 + ;*data d-b 2 + a-b ; datas data swap data swap ; nless? 2dup datas -1 -1 v+, ..begin 1 1 v+ 1@neq? until 1@s less 2drop ; l/r dd-da nless? if left ; then right ; insert dd-d over f l/r dup @ -1 ? drop if @ f ; then ! ; names -d fc @ 1 + ff ! name, f eatch eof? if ; then 2eatch name insert f ; acc cb-cb dup 1@ u+ ; eon? dup 1@ 1 less 2drop ; i 5163 score d-n data 0 swap, ..begin acc 1 + eon? until drop 1 i +! i @ * ; pe22 0 i ! names scores a-n -1 ? if push 0, ..i left @ scores + i score +, ..pop right @ scores + ; then ;
non-abundant sums arr cache abundant numbers ab? abundant? - not cached ab! mark as abundant abarr populate cache ab? abundant? - cached bothab? are both numbers abundant? other n i - n i n-i absum? is this number the sum of 2 abundant nu mbers? br +unless add unless zf		904 list - project euler 23 divs load, 28124 allot0*arr n-b a-b + ; ab? dup +/divs less drop ; ab! n 1 over arr 1! ; abarr 28124 for i ab? if ab! then drop next ; ab? n dup arr 1@ -1 ? drop ; bothab? ab? if swap ab? swap ; then ; other nn-nnn 2dup negate + ; absum? dup 2 / 1 max, ..for i other bothab? 2drop if pop drop ;, ..then next 0 ? ; +unless cn-c if 0 * then + ; pe23 abarr 0 28124 for i absum? +unless next ;
lexographic permutations arr digits not used yet 0-9 fill arr with all digits use remove digit from arr, , , acc add tos to double accumulator getdig get the perm and digit perm index numdigs - double		906 list - project euler 24 combs load doubles load, 10 allot*arr n-a 0 + + ; 0-9 9 for i i arr ! -next ; use n 9 arr*f 2dup @ or drop, ..if push i -1 + f i @ pop -1 + ! ;, ..then 2drop ; acc dnn-dn 2swap 10 d* rot n-d d+ rot ; getdig nn-nn fac g-n /mod arr @ ; perm nn-d 0-9 dbl 0 2swap -1 -1 v+, ..for i getdig dup use acc -next drop ; pe24 1000000 10 perm ;
1000-digit fibonacci number 1**1**1/ fixed point denom, promote, divide 0,x-a,a acc, x-a, a n n for the sum, from word called inside loop **n inside loop, raise number to the n -1**n+1 either add or subtract acc add to accumulator tayl taylor series for ln x for x near a. does n't add constant term ln a, that needs to be m anually added. br 3/2 fixed point*ln3/2 ln a when a is 3/2 ln' ln that's pretty accurate from 1 to 2 bsr index of highest set bit 2** raise 2 to the x log2' log2 floored decimal decimal part of the answer whole whole part of the answer ln ln estimation phi golden ratio		908 list - project euler 25 1 -n 80000 ;**1 n-n 1 * ;**1/ nn-n 1 swap */ ; 0,x-a,a ax-cya 0 -rot swap dup negate u+ ; n -n 2pop i -rot 2push ; **n n-n 1 n for over 1 */ next nip ; sign n-n n 1 ? drop if ; then negate ; acc cnnn-cnn push rot pop + -rot ; tayl ax-n 0,x-a,a 16, ..for over **n over **n *1/ i / sign acc next, ..2drop ; 3/2 n 3 *1 2 / ;, ln' n-n 3/2 swap tayl 1 3/2 tayl + ;, macro*bsr n-n C0BD0F 3, ; 2** n-n C031C88B , C8AB0F 3, ; forth log2' n-n 1 / bsr ; decimal nn-n 2** / ln' ; whole n-n 2 *1 ln' * ; ln n-n dup log2' push i decimal pop whole + ; phi -n 1 16 for 1 swap *1/ 1 + next ; pe25 5 *1 ln 2 / 10 *1 ln 999 * +, ..phi ln / 1 + ;
reciprocal cycles len look for t such that 10**t-1 mod n is 1 br ok? is this number coprime with 10 and not 1		910 list - project euler 26 doubles load len n-n 1*f 10 * over mod dup 1 or drop, ..if f 1 + ; then 2drop 1 ; ok? n dup 10 gcd 2 less 2drop, ..if 1 or then drop ; pe26 0 0 999, ..for i ok? if i len i dmax then next nip ;
quadratic primes quad abx-n evaluate n*n + an + b prquad? evaluate at tos, is prime? acc update counter numpr from a and b, how many primes?, br i-ab index to a and b n,prod number of primes, product		912 list - project euler 27 primes load doubles load quad nnn-n push swap i * pop sq + + ; prquad? n push 2dup pop quad prime? drop ; acc 2push 1 + 2pop ; numpr nn-n 0 -rot 0 push, ..begin i prquad? while pop 1 + push acc end, ..then pop drop 2drop ; i-ab n-nn 1999 /mod -999 -999 v+ ; n,prod n-nn i-ab 2dup numpr -rot * ; pe27 0 0 1999 sq for i n,prod dmax next nip ;
number spiral diagonals sumsq sum of squares		914 list - project euler 28 sumsq n-n dup tri swap 2 * 1 + 3 */ ; pe28 1, ..500 4 * + 500 tri 4 * + 500 sumsq 16 * + ;
distinct powers @sneq? are the dereferenced values not equal gneq? are two bignums not equal, br set index to address*l cardinality clear reset to empty set set@ 1 indexed index to set element setapp unconditionally append to set eq0? equal to 0 new? is this element not in the set?, br insert add element to set pow bignum result		916 list - project euler 29 bignums load @sneq? over @ over @ or drop ; gneq? 2dup dup @ 1 +, ..for @sneq? if pop drop 2drop ;, ..then 1 1 v+ next 0 ? 2drop ;, 99 sq allot*set n-a 0 + + ; l 9183 clear 0 l ! ; set@ -1 + set @ ; setapp g l @ set ! 1 l +! ; eq0? 1 less drop ; new? l @ eq0? if drop ;, ..then for i set@ gneq? drop if *next -1 ? ;, ..then pop drop 0 ? ; insert g new? if setapp ; then drop ; pow nn-g 1 n-g swap for over g* next nip ; pe29 clear 99 for i 1 + 99 for dup i 1 +, ..pow insert next drop next l @ ;
digit fifth powers **5 raise to the power of 5 dsum sum of the fifth powers of digits br sumneq? is a number not equal to its dsum acc add number if equal to sum of fifth powers of digits br 1 is subtracted at the end because 1**5 isn't a sum		918 list - project euler 30 **5 n-n dup sq sq * ; dsum n-n -1 ?, ..if 10 /mod dsum swap **5 + ; then ; sumneq? dup dup dsum or drop ; acc cn-c sumneq? if 0 * then + ; pe30 0 354293 for i acc next -1 + ;
coin sums br coin index 0-7 to coin value neg? below 0 eq0? equal 0 usec use the current coin in the current way nextc go to the next coin for the current way comb takes in number of cents and highest coin index, computes the number of ways to make tha t many cents using coins of the highest index or lower		920 list - project euler 31, here 1 2 5 10 20 50 100 200 8 n, coin n-n 0 + + 1@ ; neg? 0 less drop ; eq0? 1 less drop ; usec nn-nn dup coin negate u+ ; nextc nn-nn -1 + ; comb nn-n swap neg? if 2drop 0 ;, ..then swap eq0? if 2drop 1 ;, ..then 2dup usec comb -rot nextc comb + ; pe31 200 7 comb ;
		922 list
digit cancelling fractions red reduce fraction f* multiply fractions br fractions are stored with two numbers, as num denom		924 list - project euler 33 red f-f 2dup gcd tuck / push / pop ; f* ff-f push swap push * 2pop * red ; gt1? less if 0 ? ; then -1 ? ; dig1 n-n 10 / ;*dig2 n-n 10 mod ; -x/y- dig1 swap dig2 swap ; x-/-y dig2 swap dig1 swap ; f-n f-n red 100 * + ; -canc? gt1? if ;, ..then 2dup -x/y- or drop if ;, ..then 2dup 2dup x-/-y f-n -rot f-n or drop ; acc cf-c -canc? if 2drop ; then f* ; i-ab n-nn 90 /mod 10 10 v+ ; pe33 1 1 acc 90 sq for i i-ab acc next nip ;
digit factorials fac factorial dsum sum of factorials of digits br sumneq? is a number not equal to its dsum acc add number if equal to sum of fifth powers of digits br 3 is subtracted at the end because 1! and 2! a ren't sums br see also pe 30		926 list - project euler 34 fac n-n -1 ? if dup -1 + fac * ; then drop 1 ; dsum n-n -1 ?, ..if 10 /mod dsum swap fac + ; then ; sumneq? dup dup dsum or drop ; acc cn-c sumneq? if 0 * then + ; pe34 0 2540160 for i acc next -3 + ;
circular primes pmul what to multiply by to prepend a digit pdig prepend top to second number rotd rotate digits neq? not equal? circp? is the number a circular prime? br note that numbers with 0 in them won't rotate correctly. however, the 0 will eventually be i n the 1s place, yielding a number that's divis ible by 10 and not prime.		928 list - project euler 35 primes load pmul n-n 1 begin 10 * less until nip ; pdig nn-n over -1 ? if pmul * + ; then + + ; rotd n-n 10 /mod swap pdig ; neq? 2dup or drop ; circp? dup, ..begin prime? while rotd neq? while end, ..then -1 ? drop ; then 0 ? drop ; acc cn-c circp? drop if 1 + then ; pe35 0 1000000 for i acc next ;
double-base palindromes b base to use when reversing transfer move a digit in base b reverse reverse a number in base b br -palin? is num not palin in base from stack -bothp? is num not palin in both 2 and 10 acc update accumulator		930 list - project euler 36, b 2*transfer x yz - xz y swap b @ * swap, ..b @ /mod swap u+ ; reverse n-m 0 swap f -1 ? if transfer f ; then drop ; -palin? n b ! dup reverse over or drop ; -bothp? 10 -palin? if ; then 2 -palin? ; acc cn-c -bothp? if 0 * then + ; pe36 0 1000000 for i acc next ;
truncatable primes rtr right truncate - remove last digit ltr left truncate - remove first digit ftr holds xt for truncating function to use strp? side truncatable prime - takes xt, is th e number a tr prime in this direction? trp? truncatable prime? nexttrp next truncatable prime		932 list - project euler 37 primes load rtr n-n 10 / ; ftr 271805570 ltr n-n 1 begin 10 * less until 10 / mod ; strp? a ftr ! dup f -1 ? if prime? if ftr @ execute f ;, ..then drop ; then 1 + drop ; trp? ' rtr strp? if ' ltr strp? ; then ; nexttrp n-n begin nextprime trp? until ; pe37 0 7 11 for nexttrp dup u+ next drop ;
		934 list
		936 list