projects:poly.blk
Polynomial properties application
Screen 0 not modified
0
1 \ Last change: Screen 019 13:55JWB04/15/87
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Screen 2 not modified
0 EXIT Distance between two points.
1
2 Y
3 | p2 p1 = ( x1,y1 )
4 | /| p2 = ( x2,y2 )
5 | / |
6 | d / | b = y2 - y1
7 | / | b a = x2 - x1
8 | / |
9 | / a | d = [(x2-x1)^2 + (y2-y1)^2]^.5
10 | p1 --------
11 |----------------X
12
13
14
15
Screen 3 not modified
0 EXIT Area of a polygon.
1
2 p1 /---------\ p2 p1 = ( x1,y1 )
3 / \ p2 = ( x2,y2 )
4 / \ p3 p3 = ( x3,y3 )
5 / / p4 = ( x4,y4 )
6 p5 /--------------/ p4 p5 = ( x5,y5 )
7
8 AREA OF THE POLYGON =
9 [(x1y5-x5y1)+(x2y1-x1y2)+(x3y2-x2y3)+(x4y3-x3y4)+(x5y4-x4y5)]/2
10
11 In general:
12 i=n
13 AREA = 0.5*SUM [ x(i)y(i-1) - x(i-1)y(i) ]
14 i=1
15 where we define x0 to be x5 and y0 to be y5.
Screen 4 not modified
0 EXIT Sample Calculation.
1
2 X Not drawn to scale!!
3 | p1 = ( 8,4 )
4 | p2 = ( 6,1 )
5 | p4 ----------- p1 p3 = ( 2,1 )
6 | / / p4 = ( 5,4 )
7 | / /
8 | / /
9 | p3 ----------- p2
10 |-----------------------Y
11
12 A = [(8*4-5*4)+(6*4-8*1)+(2*1-6*1)+(5*1-2*4)]/2 = 10.5
13
14
15
Screen 5 not modified
0 \ Polygon Area - 1 05:07jwb10/07/85
1 : #IN ( -- n )
2 QUERY INTERPRET ;
3 CREATE X 102 ALLOT \ Array for x coordinates
4 CREATE Y 102 ALLOT \ Array for y coordinates
5 VARIABLE #POINTS \ Number of points in polygon
6 VARIABLE AREA \ Sum of the x(i)y(i-1) - x(i)y(i+1)
7 \ Fetch ith x component.
8 : X@ ( i x{i} ) 2* X + @ ;
9 \ Fetch ith y component.
10 : Y@ ( i y{i} ) 2* Y + @ ;
11 \ Store ith x component.
12 : X! ( x i -- ) 2* X + ! ;
13 \ Store ith y component.
14 : Y! ( y i -- ) 2* Y + ! ;
15
Screen 6 not modified
0 \ Polygon area - 2 21:11jwb10/06/85
1 \ Move to the next tab stop.
2 : TAB ( -- -- )
3 BEGIN #OUT @ 8 MOD
4 IF SPACE ELSE EXIT THEN
5 AGAIN ;
6 \ Get number from keyboard.
7 : GET# ( -- n )
8 ASCII > EMIT SPACE #IN ;
9 \ Prompt and fetch number of data points.
10 : GET_#POINTS ( -- -- )
11 BEGIN
12 CR ." Enter number of data points. "
13 GET# DUP 3 <
14 WHILE CR ." You need at least 3 data points!"
15 REPEAT 50 MIN #POINTS ! ;
Screen 7 not modified
0 \ Polygon area - 3 21:12jwb10/06/85
1 \ Prompt and fetch all data points.
2 : GET_DATA ( -- -- )
3 CR CR ." Point " TAB ." X" TAB ." Y"
4 #POINTS @ 1+ 1
5 DO CR I 3 .R TAB GET# I X!
6 TAB GET# I Y! LOOP
7 #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;
8 \ Sum data points.
9 : FIND_AREA ( -- -- )
10 0 AREA !
11 #POINTS @ 1+ 1 ( n+1 so we loop n times )
12 DO I X@ I 1- Y@ * ( X{i}*Y{i-1} )
13 I 1- X@ I Y@ * ( X{i-1}*Y{i} )
14 - AREA +!
15 LOOP ;
Screen 8 not modified
0 \ Polygon area - 4 20:55jwb10/06/85
1 \ Display computed area.
2 : PUT_AREA ( -- -- )
3 AREA @ 2 /MOD
4 CR ." AREA = " 6 .R ASCII . EMIT
5 IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;
6
7 \ Compute area of polygon.
8 : POLY ( -- -- )
9 GET_#POINTS
10 GET_DATA
11 FIND_AREA
12 PUT_AREA ;
13
14
15
Screen 9 not modified
0 \ Load screen for enhanced POLY program.
1
2 FORGET PTASK
3
4 : PTASK ;
5
6
7 10 19 THRU
8
9
10
11
12
13
14
15
Screen 10 not modified
0 \ 32 bit square root KS 4TH DIM V4N1P9
1
2 : EASY-BITS ( drem1 partial.root1 count drem2 partial.root2 )
3 0 DO >R D2* D2*
4 R@ - DUP 0<
5 IF R@ + R> 2* 1-
6 ELSE R> 2* 3 +
7 THEN LOOP ;
8
9 : 2'S-BIT ( drem2 proot2 drem3 proot3 ) \ get penultimate bit
10 >R D2* DUP 0<
11 IF D2* R@ - R> 1+
12 ELSE D2* R@ 2DUP U<
13 IF DROP R> 1-
14 ELSE - R> 1+
15 THEN THEN ;
Screen 11 not modified
0 \ 32 bit square root KS 4TH DIM V4N1P9
1 : 1'S-BIT ( drem3 proot3 fullroot ) \ remainder lost
2 >R DUP 0<
3 IF 2DROP R> 1+
4 ELSE D2* 32768 R@ DU< 0= R> THEN ;
5
6 \ 32-bit unsigned radicand to 16-bit unsigned square root
7 : SQRT ( ud u )
8 0 1 8 EASY-BITS ROT DROP 6 EASY-BITS
9 2'S-BIT 1'S-BIT ;
10
11 \ Display 16-bit number with two decimal places.
12 : I.XX ( 100*n -- )
13 0 <# # # ASCII . HOLD #S #>
14 TYPE SPACE ;
15
Screen 12 not modified
0 \ Support for bullet proof #IN 05:31jwb10/07/85
1 : BELL ( -- -- ) 7 EMIT -1 #OUT +! ;
2 : DIGIT? ( n flag ) \ Leave true flag if valid digit.
3 DUP 47 > SWAP 58 < AND ;
4 : RUBOUT ( -- -- ) \ Rub out most recent digit
5 8 EMIT 32 EMIT 8 EMIT -4 #OUT +! ;
6 \ Remove digit from screen and number then dec digit count.
7 : -DIGIT ( cnt n cnt-1 n/10 )
8 RUBOUT SWAP 1- SWAP 10 / ;
9 \ Increment digit count and add in digit.
10 : +DIGIT ( cnt n key cnt+1 10n+key-48)
11 SWAP 10 UM* 2 PICK 48 - 0 D+ 32767. 2OVER DU<
12 IF 10 UM/MOD NIP NIP BELL
13 ELSE DROP SWAP EMIT SWAP 1+ SWAP THEN ;
14 : RESET? ( flg cnt n ff cnt n ) \ Reset sign flag.
15 OVER 0= IF ROT DROP FALSE -ROT THEN ;
Screen 13 not modified
0 \ Support for bullet proof #IN 05:31jwb10/07/85
1 \ Correct an error input.
2 : CORRECT.IT ( flg cnt num key flg cnt num )
3 DROP OVER 0<> \ Is digit count non zero?
4 IF -DIGIT \ Remove most recent digit.
5 ELSE BELL THEN RESET? ; \ Beep and reset if count is 0.
6 \ Process all other keystrokes.
7 : PROCESS.IT ( flg cnt num key flg cnt num )
8 DUP DIGIT? \ Check for digit.
9 IF +DIGIT \ Echo & convert digit, inc count
10 ELSE DROP BELL THEN ; \ Invalid key or overflow.
11 \ Apply sign to number.
12 : APPLY-SIGN ( flg cnt num key num )
13 DROP NIP SWAP \ Drop key, nip cnt, get flg.
14 IF NEGATE THEN ; \ Apply sign to number.
15 : NEGATIVE? ASCII - = 3 PICK 0= AND ; \ Negative number?
Screen 14 not modified
0 \ Bullet proof #IN 21:08JWB10/02/85
1 : SET-FLAG ( flg cnt num key flg cnt num )
2 EMIT ROT DROP TRUE -ROT \ Set sign flag true.
3 SWAP 1+ SWAP ; \ Increment digit count.
4 : #IN ( -- num ) \ flg=sign flag
5 FALSE 0 0 ( flg cnt num ) \ cnt=digit count
6 BEGIN KEY ( flg cnt num key ) \ num=# being formed
7 DUP NEGATIVE? \ Negative number?
8 IF SET-FLAG \ Set -VE flag true.
9 ELSE DUP CONTROL M = \ Return entered?
10 IF APPLY-SIGN EXIT THEN \ Apply sign to number & exit
11 DUP CONTROL H = \ Correct error input?
12 IF CORRECT.IT \ This does it.
13 ELSE PROCESS.IT THEN \ Process all other keys.
14 THEN AGAIN ;
15 \ : TEST BEGIN CR #IN 3 SPACES DUP . 0= UNTIL ;
Screen 15 not modified
0 \ Polygon Area & Perimeter 13:53JWB04/15/87
1 CREATE X 102 ALLOT \ Array for x coordinates
2 CREATE Y 102 ALLOT \ Array for y coordinates
3 VARIABLE #POINTS \ Number of points in polygon
4 VARIABLE AREA \ Sum of the x(i)y(i-1) - x(i)y(i+1)
5 VARIABLE PERIMETER \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5
6
7 \ Fetch ith x component.
8 : X@ ( i x{i} ) 2* X + @ ;
9 \ Fetch ith y component.
10 : Y@ ( i y{i} ) 2* Y + @ ;
11 \ Store ith x component.
12 : X! ( x i -- ) 2* X + ! ;
13 \ Store ith y component.
14 : Y! ( y i -- ) 2* Y + ! ;
15
Screen 16 not modified
0 \ Polygon Area & Perimeter - 2 13:54JWB04/15/87
1 \ Move to the next tab stop.
2 : TAB ( -- -- )
3 BEGIN #OUT @ 8 MOD
4 IF SPACE ELSE EXIT THEN
5 AGAIN ;
6 \ Get number from keyboard.
7 : GET# ( -- n )
8 ASCII > EMIT SPACE #IN ;
9 \ Prompt and fetch number of data points.
10 : GET_#POINTS ( -- -- )
11 BEGIN
12 CR ." Enter number of data points. "
13 GET# DUP 3 <
14 WHILE CR ." You need at least 3 data points!"
15 REPEAT 50 MIN #POINTS ! ;
Screen 17 not modified
0 \ Polygon Area & Perimeter -3 13:54JWB04/15/87
1 \ Prompt and fetch all data points.
2 : GET_DATA ( -- -- )
3 CR CR ." Point " TAB ." X" TAB ." Y"
4 #POINTS @ 1+ 1
5 DO CR I 3 .R TAB GET# I X!
6 TAB GET# I Y! LOOP
7 #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;
8 \ Sum data points.
9 : FIND_AREA ( -- -- )
10 0 AREA !
11 #POINTS @ 1+ 1 ( n+1 so we loop n times )
12 DO I X@ I 1- Y@ * ( X{i}*Y{i-1} )
13 I 1- X@ I Y@ * ( X{i-1}*Y{i} )
14 - AREA +!
15 LOOP ;
Screen 18 not modified
0 \ Polygon Area & Perimeter - 4 13:54JWB04/15/87
1
2 : DIST ( x2 y2 x1 y1 100*d )
3 ROT - DUP * \ x2 x1 (y1-y2)^2
4 -ROT - DUP * \ (y1-y2)^2 (x2-x1)^2
5 + 10000 UM* SQRT ; \ 100*d
6
7 : FIND_PERIMETER ( -- -- )
8 0 PERIMETER !
9 #POINTS @ 1+ 1
10 DO I X@ I Y@
11 I 1- X@ I 1- Y@
12 DIST PERIMETER +!
13 LOOP ;
14
15
Screen 19 not modified
0 \ Polygon Area & Perimeter - 6 13:55JWB04/15/87
1 \ Display computed area.
2 : PUT_AREA ( -- -- )
3 AREA @ 2 /MOD
4 CR ." AREA = " 6 .R ASCII . EMIT
5 IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;
6 \ Display computed perimeter.
7 : PUT_PERIMETER ( -- -- )
8 CR ." PERIMETER = "
9 PERIMETER @ I.XX ;
10
11 \ Compute area of polygon.
12 : POLY ( -- -- )
13 GET_#POINTS GET_DATA
14 FIND_AREA FIND_PERIMETER
15 PUT_AREA PUT_PERIMETER ;
projects/poly.blk.txt · Zuletzt geändert: 2013-06-06 21:27 von 127.0.0.1