=== 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 ;