tasks a-s
This commit is contained in:
Ingy döt Net
parent
47bf37c096
commit
b83f433714
12433 changed files with 156208 additions and 123 deletions
169
Task/Pythagorean-triples/Forth/pythagorean-triples.fth
Normal file
169
Task/Pythagorean-triples/Forth/pythagorean-triples.fth
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
\ Two methods to create Pythagorean Triples
|
||||
\ this code has been tested using Win32Forth and gforth
|
||||
|
||||
: pythag_fibo ( f1 f0 -- )
|
||||
\ Create Pythagorean Triples from 4 element Fibonacci series
|
||||
\ this is called with the first two members of a 4 element Fibonacci series
|
||||
\ Price and Burkhart have two good articles about this method
|
||||
\ "Pythagorean Tree: A New Species" and
|
||||
\ "Heron's Formula, Descartes Circles, and Pythagorean Triangles"
|
||||
\ Horadam found out how to compute Pythagorean Triples from Fibonacci series
|
||||
|
||||
\ compute the two other members of the Fibonacci series and put them in
|
||||
\ local variables. I was unable to do this with out using locals
|
||||
2DUP + 2DUP + 2OVER 2DUP + 2DUP +
|
||||
LOCALS| f3 f2 f1 f0 |
|
||||
|
||||
wk_level @ 9 .r f0 8 .r f1 8 .r f2 8 .r f3 8 .r
|
||||
|
||||
\ this block calculates the sides of the Pythagorean Triangle using single precision
|
||||
\ f0 f3 * 14 .r \ side a (always odd)
|
||||
\ 2 f1 * f2 * 10 .r \ side b (a multiple of 4)
|
||||
\ f0 f2 * f1 f3 * + 10 .r \ side c, the hyponenuse, (always odd)
|
||||
|
||||
\ this block calculates double precision values
|
||||
f0 f3 um* 15 d.r \ side a (always odd)
|
||||
2 f1 * f2 um* 15 d.r \ side b (a multiple of 4)
|
||||
f0 f2 um* f1 f3 um* d+ 17 d.r cr \ side c, the hypotenuse, (always odd)
|
||||
|
||||
MAX_LEVEL @ wk_LEVEL @ U> IF \ TRUE if MAX_LEVEL > WK_LEVEL
|
||||
wk_level @ 1+ wk_level !
|
||||
|
||||
\ this creates a teranary tree of Pythagorean triples
|
||||
\ use a two of the members of the Fibonacci series as seeds for the
|
||||
\ next level
|
||||
\ It's the same tree created by Barning or Hall using matrix multiplication
|
||||
f3 f1 recurse
|
||||
f3 f2 recurse
|
||||
f0 f2 recurse
|
||||
|
||||
wk_level @ 1- wk_level !
|
||||
|
||||
else
|
||||
then
|
||||
|
||||
drop drop drop drop ;
|
||||
|
||||
\ implements the Fibonacci series -- Pythagorean triple
|
||||
\ the stack contents sets how many iteration levels there will be
|
||||
: pf_test
|
||||
\ the stack contents set up the maximum level
|
||||
max_level !
|
||||
0 wk_level !
|
||||
cr
|
||||
|
||||
\ call the function with the first two elements of the base Fibonacci series
|
||||
1 1 pythag_fibo ;
|
||||
|
||||
: gcd ( a b -- gcd )
|
||||
begin ?dup while tuck mod repeat ;
|
||||
|
||||
\ this is the classical algorithm, known to Euclid, it is explained in many
|
||||
\ books on Number Theory
|
||||
\ this generates all primitive Pythagorean triples
|
||||
|
||||
\ i -- inner loop index or current loop index
|
||||
\ j -- outer loop index
|
||||
\ stack contents is the upper limit for j
|
||||
\ i and j can not both be odd
|
||||
\ the gcd( i, j ) must be 1
|
||||
\ j is greater than i
|
||||
\ the stack contains the upper limit of the j variable
|
||||
: pythag_ancn ( limit -- )
|
||||
cr
|
||||
1 + 2 do
|
||||
i 1 and if 2 else 1 then
|
||||
\ this sets the start value of the inner loop so that
|
||||
\ if the outer loop index is odd only even inner loop indices happen
|
||||
\ if the outer loop index is even only odd inner loop indices happen
|
||||
i swap do
|
||||
i j gcd 1 - 0> if else \ do this if gcd( i, j ) is 1
|
||||
j 5 .r i 5 .r
|
||||
|
||||
\ j j * i i * - 12 .r \ a side of Pythagorean triangle (always odd)
|
||||
\ i j * 2 * 9 .r \ b side of Pythagorean triangle (multiple of 4)
|
||||
\ i i * j j * + 9 .r \ hypotenuse of Pythagorean triangle (always odd)
|
||||
|
||||
\ this block calculates double precision Pythagorean triple values
|
||||
j j um* i i um* d- 15 d.r \ a side of Pythagorean triangle (always odd)
|
||||
i j um* d2* 15 d.r \ b side of Pythagorean triangle (multiple of 4)
|
||||
i i um* j j um* d+ 17 d.r \ hypotenuse of Pythagorean triangle (always odd)
|
||||
|
||||
cr then 2 +loop \ keep i being all odd or all even
|
||||
loop ;
|
||||
|
||||
|
||||
|
||||
Current directory: C:\Forth ok
|
||||
FLOAD 'C:\Forth\ancien_fibo_pythag.F' ok
|
||||
ok
|
||||
|
||||
ok
|
||||
ok
|
||||
3 pf_test
|
||||
0 1 1 2 3 3 4 5
|
||||
1 3 1 4 5 15 8 17
|
||||
2 5 1 6 7 35 12 37
|
||||
3 7 1 8 9 63 16 65
|
||||
3 7 6 13 19 133 156 205
|
||||
3 5 6 11 17 85 132 157
|
||||
2 5 4 9 13 65 72 97
|
||||
3 13 4 17 21 273 136 305
|
||||
3 13 9 22 31 403 396 565
|
||||
3 5 9 14 23 115 252 277
|
||||
2 3 4 7 11 33 56 65
|
||||
3 11 4 15 19 209 120 241
|
||||
3 11 7 18 25 275 252 373
|
||||
3 3 7 10 17 51 140 149
|
||||
1 3 2 5 7 21 20 29
|
||||
2 7 2 9 11 77 36 85
|
||||
3 11 2 13 15 165 52 173
|
||||
3 11 9 20 29 319 360 481
|
||||
3 7 9 16 25 175 288 337
|
||||
2 7 5 12 17 119 120 169
|
||||
3 17 5 22 27 459 220 509
|
||||
3 17 12 29 41 697 696 985
|
||||
3 7 12 19 31 217 456 505
|
||||
2 3 5 8 13 39 80 89
|
||||
3 13 5 18 23 299 180 349
|
||||
3 13 8 21 29 377 336 505
|
||||
3 3 8 11 19 57 176 185
|
||||
1 1 2 3 5 5 12 13
|
||||
2 5 2 7 9 45 28 53
|
||||
3 9 2 11 13 117 44 125
|
||||
3 9 7 16 23 207 224 305
|
||||
3 5 7 12 19 95 168 193
|
||||
2 5 3 8 11 55 48 73
|
||||
3 11 3 14 17 187 84 205
|
||||
3 11 8 19 27 297 304 425
|
||||
3 5 8 13 21 105 208 233
|
||||
2 1 3 4 7 7 24 25
|
||||
3 7 3 10 13 91 60 109
|
||||
3 7 4 11 15 105 88 137
|
||||
3 1 4 5 9 9 40 41
|
||||
ok
|
||||
ok
|
||||
10 pythag_ancn
|
||||
2 1 3 4 5
|
||||
3 2 5 12 13
|
||||
4 1 15 8 17
|
||||
4 3 7 24 25
|
||||
5 2 21 20 29
|
||||
5 4 9 40 41
|
||||
6 1 35 12 37
|
||||
6 5 11 60 61
|
||||
7 2 45 28 53
|
||||
7 4 33 56 65
|
||||
7 6 13 84 85
|
||||
8 1 63 16 65
|
||||
8 3 55 48 73
|
||||
8 5 39 80 89
|
||||
8 7 15 112 113
|
||||
9 2 77 36 85
|
||||
9 4 65 72 97
|
||||
9 8 17 144 145
|
||||
10 1 99 20 101
|
||||
10 3 91 60 109
|
||||
10 7 51 140 149
|
||||
10 9 19 180 181
|
||||
ok
|
||||
Loading…
Add table
Add a link
Reference in a new issue