=== EXAMPLES FOR LECTURE #4 === Screen 0 not modified 0 \ EXAMPLES FOR LECTURE #4 15:51JWB04/22/87 1 \ Last change: Screen 000 15:51JWB04/22/87 2 Interval logic. 3 Numeric input. 4 The return stack. 5 Average and Histogram programs. 6 Square root. 7 Area and Hypotenuse of a right triangle. 8 F83 memory map. 9 Memory operators. 10 Variables and constants. 11 Pythagorean triples. 12 Arrays. 13 User stacks. 14 An application for FORTH to Survey Technology. 15 Screen 1 not modified 0 \ Load screen for help system. 15:36JWB04/22/87 1 2 \ The word FROM temporarily redirects the input to the 3 \ indicated block file for ONE screen load only. 4 \ However.... that one screen could specify that others be 5 \ loaded. This is the case with screen one of sample1.blk. 6 \ Go back and check it yourself. 7 8 FROM A:SAMPLE1.BLK 1 LOAD \ Load the HELP system. 9 FROM A:SAMPLE1.BLK 9 LOAD \ Load MQUIT 10 FROM B:SAMPLE3.BLK 28 LOAD \ HEX AND BINARY #PRINT 11 12 13 14 15 Screen 2 not modified 0 \ REVIEW - 1 NUMBER DISPLAY 19:57JWB10/02/85 1 \ Single signed 16bit numbers. -32768 - 32767 2 . ( n -- ) Display signed 16bit # followed by space. 3 .R ( n w -- ) Display # right justified in w wide field. 4 5 \ Single unsigned 16bit numbers. 0 - 65535 6 U. ( u -- ) Display unsigned 16bit # followed by space 7 U.R ( u w -- ) Display # right justified in w wide field. 8 9 \ Double signed 32bit numbers -2,147,483,648 - 2,147,483,647 10 D. ( d -- ) Display signed 32bit # followed by space. 11 D.R ( d w -- ) Display # right justified in w wide field. 12 13 \ Double unsigned 32bit numbers. 0 - 4,294,967,296 14 UD. ( ud -- ) Display unsigned 32bit # followed by space 15 UD.R ( ud w -- ) Display # right justified in w wide field. Screen 3 not modified 0 \ REVIEW - 2 CONDITIONALS 20:28JWB10/02/85 1 tf = -1 = 1111111111111111 binary or base 2 2 ff = 0 = 0000000000000000 binary or base 2 3 TRUE ( -- tf ) Leave true flag on top of data stack. 4 FALSE ( -- ff ) Leave false flag on top of data stack. 5 6 = ( n m flag ) Leave tf if n = m , otherwise ff. 7 <> ( n m flag ) Leave tf if n<> m , otherwise ff. 8 < ( n m flag ) Leave tf if n < m , otherwise ff. 9 > ( n m flag ) Leave tf if n > m , otherwise ff. 10 11 0= ( n flag ) Leave tf if n = 0 , otherwise ff. 12 0<> ( n flag ) Leave tf if n<> 0 , otherwise ff. 13 0< ( n flag ) Leave tf if n < 0 , otherwise ff. 14 0> ( n flag ) Leave tf if n > 0 , otherwise ff. 15 ?DUP ( n n (n) ) Duplicate n if n is non zero. Screen 4 not modified 0 \ REVIEW - 3 CONDITIONALS 14:17JWB10/06/85 1 \ Note: These operators work at the binary bit level!! 2 AND ( f1 f2 flag ) Leave tf only if f1 and f2 are true. 3 OR ( f1 f2 flag ) Leave tf if either f1 or f2 are true. 4 XOR ( f1 f2 flag ) Leave tf if f1=tf or f2=tf but not both. 5 NOT ( f1 not-f1 ) Reverse the flag f1. 6 1100 1100 1100 7 1010 1010 1010 1010 8 ---- ---- ---- ---- 9 AND 1000 OR 1110 XOR 0110 NOT 0101 10 Note: Starting FORTH NOT is the same as F83 0= 11 Starting FORTH NOT is different than F83 NOT 12 F83 NOT operates on each of a numbers 16 bits. 13 F83 NOT leaves a false flag ( zero ) only if it 14 operates on a true flag -1=1111111111111111 binary 15 F83 NOT is not the same as 0= Screen 5 not modified 0 \ REVIEW - 4 Miscellaneous 22:05JWB10/02/85 1 ASCII X ( -- n ) Leave character code of ASCII X 2 CONTROL X ( -- n ) Leave character code of control X 3 ABORT" " ( flg -- ) Abort if flg is true. 4 KEY ( -- n ) Return code n for key pressed. 5 BEEP ( -- -- ) Make a beep. 6 --> ( -- -- ) Load the next screen. 7 THRU ( first last -- ) Load screens first through last. 8 9 \ IF ELSE THEN 10 si = step i ci = condition i 11 \ Do step 2 if condition 1 is true. 12 s1 c1 IF s2 THEN s3 13 \ Do step 2 if condition 1 is true, otherwise do step 3. 14 s1 c1 IF s2 ELSE s3 THEN s4 15 Screen 6 not modified 0 \ REVIEW - 5 Interval Logic 20:41JWB10/02/85 1 \ (IN) leaves a true flag if a < x < b 2 : (IN) ( x a b flag ) 3 2DUP < NOT ABORT" Invalid interval." 4 -ROT OVER < -ROT > AND ; 5 6 \ [IN] leaves a true flag if a <= x <= b , otherwise false. 7 : [IN] ( x a b flag ) 8 1+ SWAP 1- SWAP (IN) ; 9 \ (IN] leaves a true flag if a < x <= b , otherwise false. 10 : (IN] ( x a b flag ) 11 1+ (IN) ; 12 13 \ [IN) leaves a true flag if a <= x < b , otherwise false. 14 : [IN) ( x a b flag ) 15 SWAP 1- SWAP (IN) ; Screen 7 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 ; \ ASCII 0 ASCII 9 [IN] 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 8 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 9 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 10 not modified 0 \ Return Stack 14:14JWB10/06/85 1 \ New Words: >R R> and R@ for accessing the return stack. 2 \ These words are very dangerous!! Do NOT test or execute them 3 \ interactively. They can only be used within colon definitions. 4 \ Note: D) indicates data stack, R) indicates return stack. 5 \ Transfer top data stack item to return stack. 6 \ >R ( n -- D) ( -- n R) 7 \ Transfer top return stack item to data stack. 8 \ R> ( -- n D) ( n -- R) 9 \ Copy top return stack item to data stack. 10 \ R@ ( -- n D) ( n n R) 11 12 \ RULES: 13 \ 1. Each use of >R must be balanced with a corresponding R>. 14 \ 2. Do not use >R R> and R@ within DO ... LOOPs. Loop control 15 \ info is kept on the return stack and could be destroyed. Screen 11 not modified 0 \ Example 1: Average, Problem 1 14:26JWB10/06/85 1 2 : AVERAGE ( x1 x2 ... xn avg ) 3 DEPTH >R R@ 1- 0 4 ?DO + LOOP 5 CR ." The average of the " R@ . ." numbers is " 6 R> / . CR ; 7 \ Problem 0: 8 \ Rewrite AVERAGE without using the return stack. 9 \ Problem 1: 10 \ Rewrite AVERAGE so that it takes number pairs, class mark xi 11 \ and frequency fi . ie average = [ sum xi*fi ]/n n = sum fi 12 13 \ AVERAGE ( x1 f1 x2 f2 ... xk fk -- ) 14 15 Screen 12 not modified 0 \ Problem 1 solution. Histogram, Problem 14:22JWB10/06/85 1 : AVERAGE ( x1 f1 x2 f2 ... xn fn -- ) 2 0 0 DEPTH 2/ 1- 0 3 ?DO 2 PICK + 2SWAP * 4 ROT + SWAP 5 LOOP CR ." The average of the " 6 DUP . ." numbers is " / . CR ; 7 \ Given n frequencies construct histogram or bar chart. 8 : WHITE 177 EMIT ; 9 : HISTOGRAM ( f1 f2 ... fn -- ) 10 CR DEPTH 0 11 ?DO CR DUP 0 ?DO WHITE LOOP SPACE . LOOP CR ; 12 \ Problem 2: 13 \ Modify HISTOGRAM so that the bars come out in the proper order 14 \ ( f1 first). Hint: " ROLL " the stack and display bar. Clean 15 \ the stack when finished printing bars. Screen 13 not modified 0 \ Example - 3 Square Root 21:19JWB10/02/85 1 \ Square root by Newton's Method. 2 \ Theory: Let f(x) = x^2 - n where the root or zero of this 3 \ function is the square root of n. 4 \ Newton's Method: use guess xo to get better guess xn 5 \ according to: xn = xo - f(xo)/f'(xo) 6 \ It can be shown that: xn = ( xo + n/xo )/2 7 8 : XNEW ( n xold n xnew ) 9 2DUP / + 2/ ; 10 : SQRT ( n root ) 11 DUP 0< ABORT" Illegal argument." 12 DUP 1 > 13 IF DUP 2/ ( n n/2 ) 10 0 DO XNEW LOOP NIP 14 THEN ; 15 \ Note: This is not the best or fastest square root algorithm. Screen 14 not modified 0 \ Example 4 Hypotenuse, Problem 3 Area 21:21JWB10/02/85 1 \ Hypotenuse of a right triangle. 2 : HYPO ( a b c ) 3 DUP * SWAP 4 DUP * + 5 SQRT ; 6 7 : TEST 15 1 DO 15 1 DO 8 CR I J 2DUP 4 .R 4 .R HYPO 4 .R 9 LOOP KEY DROP CR LOOP ; 10 11 \ Problem 3: Write a word that calculates the area of a triangle 12 \ using HERO's formula. A = sqrt[ s(s-a)(s-b)(s-c) ] 13 \ where s is the semi perimeter. s = (a+b+c)/2 14 15 Screen 15 not modified 0 \ Solution to problem 3. 22:17JWB10/02/85 1 2 : AREA ( a b c area ) 3 3DUP + + 2/ >R ( a b c ) 4 R@ 3 ROLL - ( b c s-a ) 5 R@ 3 ROLL - ( c s-a s-b ) 6 R@ 3 ROLL - ( s-a s-b s-c ) 7 * * R> * SQRT 8 CR ." Triangle area is " . ; 9 10 \ Warning! You cannot factor the R@ 3 ROLL - out of the 11 \ above definition. All user access to the return stack must 12 \ occur within one word as FORTH uses the return stack to nest 13 \ the calling words return address. 14 15 \ Can you give a solution that does not use the return stack? Screen 16 not modified 0 \ F83 Memory Map 21:21JWB10/02/85 1 F83 Occupies a 64K ( 65535 ) bytes of memory. Each of these 2 bytes of memory has its own unique 16 bit address. Addresses 3 range from 0 through 65535 decimal but are best represented in 4 hexadecimal ( base 16 ) as 0000 throught FFFF . 5 6 HEX ( -- -- ) Set system number BASE to 16 (decimal). 7 DECIMAL ( -- -- ) Set system number BASE to 10 (decimal). 8 ** Use the unsigned print operator to look at addresses.** 9 LIMIT ( -- adr ) Leave address of end of disk buffer area. 10 FIRST ( -- adr ) Leave address of start of disk buffer area. 11 INIT-R0 ( -- adr ) Leave address of top of return stack. 12 TIB ( -- adr ) Leave address of terminal input buffer. 13 PAD ( -- adr ) Leave address of text output buffer. 14 HERE ( -- adr ) Leave address of word buffer. 15 ORIGIN ( -- adr ) Leave address of FORTH cold start. Screen 17 not modified 0 \ Memory Operators 14:28JWB10/06/85 1 2 DUMP ( adr n -- ) Dump n bytes of memory starting at adr. 3 ERASE ( adr n -- ) Erase n bytes of memory starting at adr 4 to zeros. 5 FILL ( adr n m -- ) Fill n bytes of memory starting at adr 6 with low 8 bits of m ( 0 - 255 ). 7 8 ! ( n adr -- ) Store 16b value n at address adr. 9 @ ( adr n ) Fetch 16b value at adr and leave as n. 10 NOTE: 16 bit numbers are stored with the low byte at adr 11 and the high byte at adr+1 ( this is convention for 12 6502 and 8086 CPUs - 68000 is the reverse ). 13 C! ( n adr -- ) Store low 8 bits of n at address adr. 14 C@ ( adr n ) Fetch 8 bit value at adr and leave as n. 15 ? ( adr -- ) Display contents of cell at adr. Screen 18 not modified 0 \ Variables 21:21JWB10/02/85 1 Values which change quite frequently and must be accessed by 2 a number of words are best represented by the use of VARIABLEs. 3 Values represented by variables have the added convenience of 4 reference by name. 5 6 VARIABLE ( -- -- ) Create 16bit data storage 7 called . 8 ( -- adr ) Leave storage address of 9 10 VARIABLE RAIN 11 2 RAIN ! RAIN ? 12 13 : DRIP RAIN @ 1+ RAIN ! ; 14 15 DRIP DRIP DRIP RAIN ? Screen 19 not modified 0 \ Constants 14:30JWB10/06/85 1 \ Values which never change are best represented by CONSTANTs. 2 \ 3 \ CONSTANT ( n -- ) Create a constant whose 4 \ value is n. 5 \ ( -- n ) Leave value of on stack. 6 \ Examples: 7 8 7 CONSTANT D/W \ Days per week. 9 52 CONSTANT W/Y \ Weeks per year. 10 12 CONSTANT M/Y \ Months per year. 11 12 31416 CONSTANT PI 13 : *PI PI 10000 */ ; 14 : AREA ( r area ) 15 DUP * *PI ; Screen 20 not modified 0 \ Random Numbers Problem 4 & 5 21:57JWB10/05/85 1 VARIABLE SEED 1234 SEED ! 2 : (RND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ; 3 : RND ( n r ) \ r is a random number 0 <= r < n 4 (RND) 32767 */ ; 5 6 : DICE ( -- die1 die2 ) 7 6 RND 1+ 6 RND 1+ ; 8 \ Problem 4 Write the word CARD described below. 9 \ CARD draws one card from a deck. When CARD is executed it 10 \ will leave the suit as a number 1 - 4 and the face value as 11 \ 1 - 13. CARD ( -- suit value ) 12 13 \ Problem 5 14 \ Write words SUIT and VALUE that use the result of CARD 15 \ to display card picked as 7 of Harts K of Diamonds etc Screen 21 not modified 0 \ Pythagorean Triples. Problem 6. 21:57JWB10/05/85 1 VARIABLE A VARIABLE B VARIABLE C VARIABLE N 2 VARIABLE AA VARIABLE BB VARIABLE CC 3 : .ABC ( -- -- ) 4 CR A @ 12 .R B @ 12 .R C @ 12 .R ; 5 : TRIPLES ( -- -- ) 6 25 1 DO I A ! I DUP * AA ! 7 25 1 DO I B ! I DUP * BB ! 8 38 1 DO I C ! I DUP * CC ! 9 AA @ BB @ + CC @ = 10 IF .ABC THEN 11 LOOP LOOP 12 KEY? ?LEAVE ( any key escape ) LOOP ; 13 \ Problem 6: Modify to find all triples upto 100. Can you make 14 \ it run faster, using SQRT ? , without using variables? 15 \ Modify so that triples are counted. Screen 22 not modified 0 \ More Memory Operators 14:37JWB10/06/85 1 Note: cell = 2 bytes = 16 bits = 1 word 2 +! ( n adr -- ) Add n to the value found at address adr 3 ON ( adr -- ) Set cell at adr to true or -1. 4 OFF ( adr -- ) Set cell at addr to false or 0. 5 6 CREATE ( -- -- ) Creates a dictionary entry named 7 When executed, leaves the address 8 ( -- adr) of the first memory cell which follows 9 the word name. No memory is allocated. 10 ALLOT ( n -- ) Allocate n bytes of memory in the 11 dictionary. 12 , ( n -- ) Allocate 16 bits ( 2 bytes ) of memory 13 initializing it to the value n. 14 C, ( n -- ) Allocate 8 bits ( 1 byte ) of memory 15 initializing it to low 8 bits of n. Screen 23 not modified 0 \ Tables - arrays by another name. 23:06JWB10/05/85 1 2 CREATE MARBLE 0 , 0 , 0 , 0 , 0 , 0 , 3 4 0 CONSTANT RED 2 CONSTANT BLUE 4 CONSTANT YELLOW 5 6 CONSTANT BLACK 8 CONSTANT WHITE 10 CONSTANT GREEN 6 7 : MARBLES 8 MARBLE + ; 9 10 2 RED MARBLES ! 3 BLUE MARBLES ! 5 YELLOW MARBLES ! 11 8 BLACK MARBLES ! 13 WHITE MARBLES ! 21 GREEN MARBLES ! 12 13 14 15 Screen 24 not modified 0 \ Tables - arrays by another name. 20:39jwb10/06/85 1 CREATE TABLE 0 , 0 , 0 , 0 , 0 , 0 , 2 VARIABLE MODE 3 0 CONSTANT RED 2 CONSTANT BLUE 4 CONSTANT YELLOW 4 6 CONSTANT BLACK 8 CONSTANT WHITE 10 CONSTANT GREEN 5 : LESS -1 MODE ! ; : LESS? MODE @ -1 = ; 6 : SHOW 0 MODE ! ; : SHOW? MODE @ 0= ; 7 : MORE 1 MODE ! ; : MORE? MODE @ 1 = ; 8 : ONLY 2 MODE ! ; ONLY 9 : MARBLES ( {n} color -- ) 10 TABLE + DEPTH 1 = IF SHOW THEN 11 LESS? IF SWAP NEGATE SWAP +! 12 ELSE SHOW? IF @ . 13 ELSE MORE? IF +! 14 ELSE ! 15 THEN THEN THEN ONLY ; : MARBLE MARBLES ; Screen 25 not modified 0 \ Arrays Problem 7. 22:03JWB10/05/85 1 CREATE DATA 20 ALLOT 2 : DATA@ ( i n ) 2* DATA + @ ; 3 : DATA! ( n i -- ) 2* DATA + ! ; 4 \ : CLEAR-DATA 10 0 DO 0 I DATA! LOOP ; 5 : CLEAR-DATA DATA 20 ERASE ; 6 : GET-DATA 7 10 0 DO CR I 3 .R SPACE #IN I DATA! LOOP ; 8 : SHOW-DATA 9 10 0 DO CR ." DATA( " I . ." ) =" I DATA@ 10 .R LOOP ; 10 \ Problem 7: 11 \ Write a word COUNT-DATA ( -- k ) that leaves the number of 12 \ non zero items k in the array DATA on the stack. 13 \ Write SUM-DATA ( -- sum ) that sums the non zero data values. 14 \ Write AVERAGE-DATA ( -- -- ) prints average of non 0 values. 15 \ Be sure to test you words. Screen 26 not modified 0 \ User stacks. 22:51JWB10/05/85 1 CREATE P-STACK 20 ALLOT VARIABLE P-INDEX 2 : P-CLEAR ( -- -- D) ( ?? -- P) 0 P-INDEX ! P-STACK 20 ERASE ; 3 : P-DEPTH ( -- n D) P-INDEX @ 2/ ; 4 : P-INC ( -- -- D) 5 P-INDEX @ 20 = IF ." P-OVERFLOW" P-CLEAR 6 ELSE 2 P-INDEX +! THEN ; 7 : P-DEC ( -- -- D) 8 P-INDEX @ 0= IF ." P-UNDERFLOW" 9 ELSE -2 P-INDEX +! THEN ; 10 11 : >P ( n -- D) ( -- n P) P-INC P-INDEX @ P-STACK + ! ; 12 : P@ ( -- n D) ( n n P) P-INDEX @ P-STACK + @ ; 13 : P> ( -- n D) ( n -- P) P@ P-DEC ; 14 : .P P-DEPTH ?DUP IF 1+ 1 ?DO I 2* P-STACK + @ 8 .R LOOP 15 ELSE ." P-STACK EMPTY" THEN ; Screen 27 not modified 0 \ Problem 8: User stacks. 12:42JWB10/06/85 1 \ Write FORTH words for the following user stack operations. 2 \ The should leave the data stack unchanged!!! 3 : PDUP ; 4 : PDROP ; 5 : PSWAP ; 6 : POVER ; 7 : PROT ; 8 : -PROT ; 9 : PTUCK ; 10 : PNIP ; 11 : 2PDUP ; 12 : 3PDUP ; 13 : 2PSWAP ; 14 : 2PDROP ; 15 : 2POVER ; Screen 28 not modified 0 \ Double Variables and Constants. 23:13JWB10/05/85 1 2 2VARIABLE Creates a 2 cell ( 4 byte ) variable 3 called . 4 ( -- adr ) When is executed it will puse the 5 address of the first cell onto the stack 6 7 2CONSTANT Creates a double constant called 8 ( d -- ) with the initial value of d 9 ( -- d ) When is executed the double 10 number is pushed to the data stack. 11 12 2! ( d adr -- ) Store the double number d at adr. 13 14 2@ ( adr d ) Fetch the double number d from adr. 15 Screen 29 not modified 0 \ Hard copy screen documentation. 13:31JWB01/31/86 1 2 \ Print three screens starting with n on the printer. 3 : HTRIAD ( n -- ) 4 PRINTING ON DUP 3 + SWAP 27 EMIT 69 EMIT 5 DO CR I LIST LOOP PRINTING OFF ; 6 7 \ Send a top of page command to printer. 8 : FFEED 9 PRINTING ON 12 EMIT PRINTING OFF ; 10 11 \ Print screens first through last on printer, three per page. 12 : DOC ( first last -- ) 13 1+ SWAP DO I HTRIAD FFEED 3 +LOOP ; 14 15 Screen 30 not modified 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Screen 31 not modified 0 \ Polygon Area - 1 05:07jwb10/07/85 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 SUM \ Sum of the x(i)y(i-1) - x(i)y(i+1) 5 \ Compute address of ith component. 6 : II ( i adr adr{i} ) 7 SWAP 1- #POINTS @ MOD 1+ 2* + ; 8 \ Fetch ith x component. 9 : X@ ( i x{i} ) X II @ ; 10 \ Fetch ith y component. 11 : Y@ ( i y{i} ) Y II @ ; 12 \ Store ith x component. 13 : X! ( x i -- ) X II ! ; 14 \ Store ith y component. 15 : Y! ( y i -- ) Y II ! ; Screen 32 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 33 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 \ Sum data points. 8 : SUM_DATA ( -- -- ) 9 0 SUM ! 10 #POINTS @ 1+ 1 11 DO I X@ I 1- Y@ * ( X{i}*Y{i-1} ) 12 I X@ I 1+ Y@ * ( X{i}*Y{i+1} ) 13 - SUM +! 14 LOOP ; 15 Screen 34 not modified 0 \ Polygon area - 4 20:55jwb10/06/85 1 \ Display computed area. 2 : PUT_AREA ( -- -- ) 3 SUM @ 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 : AREA_POLY ( -- -- ) 9 GET_#POINTS 10 GET_DATA 11 SUM_DATA 12 PUT_AREA ; 13 14 15