projects:sample4.blk
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" <text>" ( 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 <name> ( -- -- ) Create 16bit data storage
7 called <name>.
8 <name> ( -- adr ) Leave storage address of <name>
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 <name> ( n -- ) Create a constant <name> whose
4 \ value is n.
5 \ <name> ( -- n ) Leave value of <name> 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 <name> ( -- -- ) Creates a dictionary entry named <name>
7 When executed, <name> leaves the address
8 <name> ( -- 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 <name> Creates a 2 cell ( 4 byte ) variable
3 called <name>.
4 <name> ( -- adr ) When <name> is executed it will puse the
5 address of the first cell onto the stack
6
7 2CONSTANT <name> Creates a double constant called <name>
8 ( d -- ) with the initial value of d
9 <name> ( -- d ) When <name> 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
projects/sample4.blk.txt · Zuletzt geändert: 2013-06-06 21:27 von 127.0.0.1