=== EXAMPLES FOR LECTURE #3 === Screen 0 not modified 0 \ EXAMPLES FOR LECTURE #3 11:25JWB01/24/86 1 \ Last change: Screen 001 15:36JWB04/22/87 2 3 Number displaying words. 4 5 Logicals and conditionals. 6 7 Conditional structures. IF ... ELSE ... THEN 8 9 Character and numeric input. 10 11 Return stack. 12 13 Square root. 14 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 11 12 13 14 15 Screen 2 not modified 0 \ REVIEW - 1 DEBUGGER 11:14JWB01/24/86 1 The debugger is designed to let the user single step through 2 the execution sequence of a high level definition. This process 3 is also called tracing. To activate the debugger type: 4 5 DEBUG 6 7 where is the word to be debugged or traced. When the 8 word is next executed you will get a single step trace 9 showing the next word to be executed and the contents of the 10 data stack. Press any key except C F or Q for the next step. 11 Q - Quit debugging process. 12 C - Continue without pausing between steps. 13 F - Return to FORTH to execute other commands. 14 - You must type RESUME to continue debugging. 15 UNBUG - Disconnect the debugger. Screen 3 not modified 0 \ REVIEW - 2 STACK OPERATORS 19:23JWB09/26/85 1 DROP ( n -- ) Drop top number on data stack. 2 SWAP ( n m m n ) Swap top two numbers on data stack. 3 DUP ( n n n ) Duplicate top number on data stack. 4 OVER ( n m n m n ) Make copy of second item to top of stack 5 ROT ( a b c b c a) Rotate third item to the top of stack. 6 -ROT ( a b c c a b) Rotate in opposite direction. 7 PICK ( ? n ? nth) Copy nth item to top of stack (0 based). 8 ROL ( ? n ? nth) Rotate nth item to top (0 based). 9 NIP ( n m m ) Discard second item on data stack. 10 TUCK ( n m m n m) Push copy of top under second item. 11 3DUP ( a b c a b c a b c) Make copy of top 3 items. 12 2DROP ( dn -- ) Drop double number from top. 13 2SWAP ( dn dm dm dn) Swap top two double numbers. 14 2DUP ( dn dn dn) Make another copy of top double number. 15 2OVER ( dn dm dn dm dn) Copy second double number to top. Screen 4 not modified 0 \ REVIEW - 3 19:46JWB09/26/85 1 \ Floored symmetric division. Note that q and r must satisfy 2 \ the equations: m/n = q + r/n or m = nq + r 3 4 / ( m n q ) Leave q , the floor of real quotient. 5 MOD ( m n r ) Leave r , remainder (satisfying above). 6 /MOD ( m n r q ) Leave remainder r and quotient q . 7 Quiz: m n r q Check: n * q + r 8 13 5 5 * 9 -11 5 5 * 10 -2 5 5 * 11 12 13 -5 -5 * 13 -11 -5 -5 * 14 -2 -5 -5 * 15 Screen 5 not modified 0 \ REVIEW - 4 Easy Words 20:03JWB09/26/85 1 1+ ( n n+1 ) Increment top stack item by 1. 2 2+ ( n n+2 ) Increment top stack item by 2. 3 1- ( n n-1 ) Decrement top stack item by 1. 4 2- ( n n-2 ) Decrement top stack item by 2. 5 2* ( n 2n ) Multiply top stack item by 2. 6 2/ ( n n/2 ) Divide top stack item by 2. 7 ABS ( n |n| ) Replace top item by its absolute value. 8 NEGATE ( n -n ) Negatate top stack item. 9 10 \ These may help recover from wierd LOADing errors. 11 HIDE ( -- -- ) Mark last word so it cannot be found. 12 REVEAL ( -- -- ) Mark last word so it can be found. 13 [ Stop compiling and resume interpretation. 14 ] Stop interpreting and resume compilation. 15 Screen 6 not modified 0 \ Number displaying words. 20:26JWB09/26/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 7 not modified 0 \ Logicals and conditionals. 20:52JWB09/26/85 1 \ tf = true flag = -1 ff = false flag = 0 2 \ flag = true flag or false flag. 3 TRUE ( -- tf ) Leave true flag on top of data stack. 4 FALSE ( -- ff ) Leave false flag on top of data stack. 5 = ( n m flag ) Leave tf if n = m , otherwise ff. 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 0= ( n flag ) Leave tf if n = 0 , otherwise ff. 10 0<> ( n flag ) Leave tf if n<> 0 , otherwise ff. 11 0< ( n flag ) Leave tf if n < 0 , otherwise ff. 12 0> ( n flag ) Leave tf if n > 0 , otherwise ff. 13 AND ( f1 f2 flag ) Leave tf only if f1 and f2 are true. 14 OR ( f1 f2 flag ) Leave tf if either f1 or f2 are true. 15 NOT ( f1 not-f1 ) Reverse the flag f1. Screen 8 not modified 0 \ Ex 1 (IN) Prob 1 & Conditional Structur 11:10JWB09/29/85 1 \ (IN) leaves a true flag if a < x < b 2 : (IN) ( x a b flag ) 3 -ROT OVER < -ROT > AND ; 4 \ Problem 1: Write words related to (IN) which do the following. 5 \ [IN] leaves a true flag if a <= x <= b , otherwise false. 6 \ (IN] leaves a true flag if a < x <= b , otherwise false. 7 \ [IN) leaves a true flag if a <= x < b , otherwise false. 8 9 \ CONDITIONAL STRUCTURES ... USE ONLY WITHIN A COLON DEFINITION. 10 \ condition IF do this part only if true 11 \ THEN continue 12 13 \ condition IF do this part only if true 14 \ ELSE do this part only if false 15 \ THEN continue Screen 9 not modified 0 \ Example 2 , Problem 2 & 3 20:20JWB09/28/85 1 : TEST ( n -- ) \ Determine if number is even or odd. 2 CR DUP ." THE NUMBER " . ." IS AN " 3 DUP 2/ 2* = 4 IF ." EVEN " 5 ELSE ." ODD " 6 THEN ." NUMBER" ; 7 \ Problem 2 8 \ Write word similar to TEST , whose output is a sentence 9 \ stating whether the top number on the stack is positive , 10 \ zero or negative. 11 12 \ Problem 3 13 \ Write a word called EVEN ( n flag ) , that takes a stack 14 \ input n and leaves a true flag if n is even and a false flag 15 \ if n is odd. Screen 10 not modified 0 \ Terminating an infinite loop. 20:54JWB09/28/85 1 \ New Word: KEY Wait for user to press key on keyboard and 2 \ KEY ( -- n ) return the keycode n. 3 \ Old Word: EXIT Stops screen compilation when not in a : def 4 \ EXIT ( -- -- ) When compiled in a word, EXIT , will cause 5 \ termination of word execution when encountered. 6 : KEY_TEST 7 BEGIN CR KEY 8 DUP CONTROL M = \ Control M is return key. 9 IF DROP EXIT THEN \ Exit infinite loop if pressed. 10 DUP . EMIT \ Otherwise show key pressed. 11 AGAIN ; 12 \ Return ASCII code and tf or function code and ff. 13 : PCKEY ( -- n flag ) 14 KEY DUP IF TRUE ELSE KEY SWAP THEN ; 15 \ Problem 4 Put this word in a loop and document function keys. Screen 11 not modified 0 \ Example - 3 Super simple numeric input. 23:36JWB09/28/85 1 : #IN QUERY INTERPRET ; 2 3 : GETL ( -- l ) CR ." Enter tank length " #IN ; 4 : GETW ( -- w ) CR ." Enter tank width " #IN ; 5 : GETH ( -- h ) CR ." Enter tank height " #IN ; 6 7 : .VOLUME ( l w h -- ) 8 * * CR ." Volume " . ." cubic feet." ; 9 : .AREA ( l w h -- ) 10 3DUP 5 ROLL * 2* -ROT * 2* + -ROT * 2* + 11 CR ." Surface area " . ." square feet." ; 12 13 : TANK ( -- -- ) 14 GETL GETW GETH 15 3DUP .VOLUME .AREA ; Screen 12 not modified 0 \ Support words for better #IN 21:50JWB09/28/85 1 2 : DIGIT? ( n flag ) 3 DUP 47 > SWAP 58 < AND ; 4 5 : RUBOUT ( -- -- ) 6 8 EMIT 32 EMIT 8 EMIT ; 7 8 : -DIGIT ( n n/10 ) 9 10 / ; 10 11 : +DIGIT ( n c 10n+c-48) 12 48 - SWAP 10 * + ; 13 14 --> 15 Screen 13 not modified 0 \ Better, but not so simple # input. 21:51JWB09/28/85 1 : #IN ( -- num ) 2 0 BEGIN KEY \ Fetch a key press. 3 DUP 13 = IF DROP EXIT THEN \ Exit if done. 4 DUP 8 = IF DROP RUBOUT -DIGIT \ Erase and correct. 5 ELSE DUP DIGIT? \ Was digit pressed? 6 IF DUP EMIT \ Echo digit 7 +DIGIT \ Convert digit. 8 ELSE DROP 7 EMIT \ Invalid key. 9 THEN 10 THEN 11 AGAIN ; 12 13 14 15 Screen 14 not modified 0 \ Support words for best #IN 21:52JWB09/28/85 1 : DIGIT? ( n flag ) \ Leave true flag if valid digit. 2 DUP 47 > SWAP 58 < AND ; 3 : RUBOUT ( -- -- ) \ Rub out most recent digit 4 8 EMIT 32 EMIT 8 EMIT ; 5 \ Note: -DIGIT & +DIGIT are changed from screen 11 !! 6 \ Remove digit from screen and number then dec digit count. 7 : -DIGIT ( cnt n cnt-1 n/10 ) 8 RUBOUT SWAP 1- SWAP 0 10 UM/MOD NIP ; \ Unsigned divide. 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 BEEP 13 ELSE DROP SWAP EMIT SWAP 1+ SWAP THEN ; 14 : RESET ( flg cnt n ff cnt n ) \ Reset sign flag. 15 ROT DROP FALSE -ROT ; --> Screen 15 not modified 0 \ Support words for the best # input. 22:15JWB09/28/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 BEEP RESET THEN ; \ 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 BEEP 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 Screen 16 not modified 0 \ Best #IN - protected field, signed input 22:20JWB09/28/85 1 : #IN ( -- num ) \ flg=sign flag 2 FALSE 0 0 ( flg cnt num ) \ cnt=digit count 3 BEGIN KEY ( flg cnt num key ) \ num=# being formed 4 DUP ASCII - = \ Negative number? 5 IF EMIT ROT DROP TRUE -ROT \ Set sign flag true. 6 SWAP 1+ SWAP \ Increment digit count. 7 ELSE DUP CONTROL M = \ Return entered? 8 IF APPLY_SIGN EXIT \ Apply sign to number & exit 9 THEN 10 DUP CONTROL H = \ Correct error input? 11 IF CORRECT.IT \ This does it. 12 ELSE PROCESS.IT \ Process all other keys. 13 THEN 14 THEN AGAIN ; 15 Screen 17 not modified 0 \ REVIEW - 3 Answers to division quiz. 19:55JWB09/26/85 1 \ Floored symmetric division. Note that q and r must satisfy 2 \ the equations: m/n = q + r/n or m = nq + r 3 4 / ( m n q ) Leave q , the floor of real quotient. 5 MOD ( m n r ) Leave r , remainder (satisfying above). 6 /MOD ( m n r q ) Leave remainder r and quotient q . 7 Quiz: m n r q Check: n * q + r = m? 8 --- --- --- --- --- --- --- --- 9 13 5 3 2 5 * 2 + 3 = 13 10 -11 5 4 -3 5 *-3 + 4 = -11 11 -2 5 3 -1 5 *-1 + 3 = -2 12 13 -5 -2 -3 -5 *-3 + -2 = 13 13 -11 -5 -1 2 -5 * 2 + -1 = -11 14 -2 -5 -2 0 -5 * 0 + -2 = -2 15 Note: Remainder takes sign of divisor!! Screen 18 not modified 0 \ Problem 4 23:13JWB09/28/85 1 \ Program the following number guessing game. 2 \ The computer picks a secret number between 1 and 100. You try 3 \ to guess the number. With each guess the computer responds 4 \ "WARMER" if the guess is closer than the old guess, 5 \ "COLDER" if the guess is it is not closer, 6 \ "HOT!" if the guess is within 2 of the actual number. 7 \ "YOU GOT IT" if the guess is correct. 8 \ Hints: keep game info on the stack ( secret old# new# ) 9 \ Use #IN 10 \ Use the random number generator below. 11 VARIABLE SEED 12 : (RND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ; 13 : RND ( n r ) \ r is a random number 0 <= r < n 14 (RND) 32767 */ ; 15 Screen 19 not modified 0 \ Problem 4 Solution. 10:16JWB09/29/85 1 : WINNER? 2 PICK OVER = ; 2 : HOT? 2 PICK OVER - ABS 3 < ; 3 : WARMER? 2 PICK OVER - ABS 4 3 PICK 3 PICK - ABS < ; 5 6 : GAME 7 100 RND 1+ 0 8 BEGIN CR ." GUESS " #IN SPACE 9 WINNER? IF ." GOT IT" DROP 2DROP EXIT THEN 10 HOT? IF ." HOT " ELSE 11 WARMER? IF ." WARMER" ELSE ." COLDER" THEN 12 THEN NIP 13 AGAIN ; 14 \ Problem: Modify this program so that it keeps track of the 15 \ number of guesses required and reports this at the game end. Screen 20 not modified 0 \ Example 4 Nasty Game. 10:08JWB09/29/85 1 \ A nasty game for the IBM-PC . 2 : WHITE 177 EMIT ; 3 : GAME CR 4 CR ." Press the space bar as hard as you can!" 5 BEGIN CR 6 KEY DROP CR 64 RND 1+ 7 DUP 0 ?DO WHITE LOOP CR 8 DUP 25 < IF ." Press it harder!!" ELSE 9 DUP 50 < IF ." Not bad! Press real hard!" ELSE 10 10 0 DO BEEP LOOP 11 DROP ." You just busted your space bar!" 12 EXIT THEN THEN 13 DROP AGAIN ; 14 \ Problem: Expand on this silly game to give more and better 15 \ responses. Screen 21 not modified 0 \ Return Stack Example 5 Average 09:54JWB09/29/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 \ >R ( n -- ) Transfer top data stack item to return stack. 5 \ R> ( -- n ) Transfer top return stack item to data stack. 6 \ R@ ( -- n ) Copy top return stack item to data stack. 7 \ RULES: 8 \ 1. Each use of >R must be balanced with a corresponding R>. 9 \ 2. Do not use >R R> and R@ within DO ... LOOPs. Loop control 10 \ info is kept on the return stack and could be destroyed. 11 : AVERAGE ( x1 x2 ... xn avg ) 12 DEPTH >R R@ 1- 0 13 ?DO + LOOP 14 CR ." The average of the " R@ . ." numbers is " 15 R> / . CR ; Screen 22 not modified 0 \ Example 6 Histogram, Problems 5 & 6 11:33JWB01/24/86 1 \ Problem 5: 2 \ Rewrite AVERAGE so that it takes number pairs, class mark xi 3 \ and frequency fi . ie average = [ sum xi*fi ]/n n = sum fi 4 \ AVERAGE ( x1 f1 x2 f2 ... xk fk -- ) 5 6 : WHITE 177 EMIT ; 7 8 \ Given n frequencies construct histogram or bar chart. 9 : HISTOGRAM ( f1 f2 ... fn -- ) 10 CR DEPTH 0 11 ?DO CR DUP 0 ?DO WHITE LOOP SPACE . LOOP CR ; 12 \ Problem 6: 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 23 not modified 0 \ Example - 7 Square Root 11:04JWB09/29/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< IF ABORT" Illegal argument" THEN 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 24 not modified 0 \ Example 8 Hypotenuse, Problem 7 Area 19:12jwb09/29/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 7: 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 25 not modified 0 \ Problem 8 Identify. 11:27JWB09/29/85 1 \ Write the word IDENTIFY which takes a key code 0 255 from 2 \ the data stack and prints one of the following descriptive 3 \ phrases identifying the key code. 4 \ Control character , Punctuation character , Lower case letter 5 \ Upper case letter , Numeric Digit , Extended character. 6 \ Hint: 7 : IDENTIFY ( n -- ) 8 DUP CONTROL? IF ." Control character. " ELSE 9 DUP PUNCTUATION? IF ." Punctuation character. " ELSE 10 DUP DIGIT? IF ." Numeric Digit " ELSE 11 ... .. ... .... ... 12 THEN THEN .... THEN DROP ; \ One THEN for every IF 13 : DIGIT? ( n flag ) \ Leave true flag if its a digit. 14 ASCII 0 ASCII 9 [IN] ; 15 \ Modify IDENTIFY to respond intelligently for n <0 and n>255 . Screen 26 not modified 0 \ Hard copy screen documentation. 19:58JWB09/26/85 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 27 not modified 0 \ Solution to problem 5 19:10jwb09/29/85 1 : AVERAGE ( x1 f1 x2 f2 ... xn fn -- ) 2 0 0 DEPTH 2/ 1- 0 3 ?DO 2 PICK + 4 2SWAP * 5 ROT + SWAP 6 LOOP 7 CR ." The average of the " 8 DUP . ." numbers is " / . CR ; 9 10 11 \ 12 13 14 15 Screen 28 not modified 0 \ Binary, decimal and hexadecimal number display. 1 \ The radix of the FORTH system is the number base with which 2 \ all arithmetic is performed. 3 HEX \ Set system radix to base 16 4 DECIMAL \ Set system radix to base 10 5 : BINARY 2 BASE ! ; \ Set system radix to base 2 6 7 : .B BINARY 0 <# # # # # # # # # # # # # # # # # #> 8 TYPE SPACE DECIMAL ; 9 : .H HEX 4 U.R SPACE DECIMAL ; 10 : .D DECIMAL 6 U.R SPACE ; 11 12 : TABLE ( n -- ) 13 CR ." DEC HEX BINARY" 14 1+ 0 ?DO CR I 4 .R I .H I .B LOOP ; 15