Forth-eV Wiki

Benutzer-Werkzeuge

Webseiten-Werkzeuge

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

Unterschiede

Hier werden die Unterschiede zwischen zwei Versionen angezeigt.

Link zu dieser Vergleichsansicht

papierkorb:sample4.blk [2025-08-16 17:50] – ↷ Seite von projects:sample4.blk nach papierkorb:sample4.blk verschoben mkapapierkorb:sample4.blk [Unbekanntes Datum] (aktuell) – gelöscht - Externe Bearbeitung (Unbekanntes Datum) 127.0.0.1
Zeile 1: Zeile 1:
-=== EXAMPLES FOR LECTURE #4 === 
-<code> 
-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                                                                  
- 
-</code> 
papierkorb/sample4.blk.1755359401.txt.gz · Zuletzt geändert: 2025-08-16 17:50 von mka