Forth-eV Wiki

Benutzer-Werkzeuge

Webseiten-Werkzeuge

Sie befinden sich hier: Forth Wiki » papierkorb » EXAMPLES FOR LECTURE #3
Zuletzt angesehen:
papierkorb:sample3.blk

Unterschiede

Hier werden die Unterschiede zwischen zwei Versionen angezeigt.

Link zu dieser Vergleichsansicht

papierkorb:sample3.blk [2025-08-16 17:50] – ↷ Seite von projects:sample3.blk nach papierkorb:sample3.blk verschoben mkapapierkorb:sample3.blk [Unbekanntes Datum] (aktuell) – gelöscht - Externe Bearbeitung (Unbekanntes Datum) 127.0.0.1
Zeile 1: Zeile 1:
-=== EXAMPLES FOR LECTURE #3 === 
  
-<code> 
- 
-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   <name>                                           
- 6                                                                  
- 7 where <name> is the word to be debugged or traced.  When the     
- 8 word <name> 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                                                                  
-</code> 
papierkorb/sample3.blk.1755359401.txt.gz · Zuletzt geändert: 2025-08-16 17:50 von mka