Benutzer-Werkzeuge

Webseiten-Werkzeuge


projects:sample5.blk

Examples for lecture number five.

Screen 0 not modified     
 0 \ Examples for lecture number five.            10:03JWB02/07/86 
 1 \ Last change:   Screen  001                   16:23JWB04/22/87 
 2                                                                 
 3                                                                 
 4         Fixed point vs  Floating point.                         
 5         */ and scaling.                                         
 6         Fractions, arithmetic & display.                        
 7         Rounding.                                               
 8         Timing.                                                 
 9         DO ... LOOPs                                            
10         Simple Floating Point.                                  
11         A Fancy Line Editor.  See file LEDIT.BLK                
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 1 not modified     
 0 \  Load screen for help system.                16:23JWB04/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   SAMPLE1.BLK 9 LOAD    \ Load MQUIT               
 9         FROM   LEDIT.BLK 1 LOAD      \ Load the line editor.    
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 2 not modified     
 0 \ Review-1 Return Stack                        19:54JWB10/15/85 
 1 \ Note:   D) indicates data stack,  R) indicates return stack.  
 2 \ Transfer top data stack item to return stack.                 
 3 \ >R  ( n   -- D) ( --   n R)                                   
 4 \ Transfer top return stack item to data stack.                 
 5 \ R>  ( --   n D) ( n   -- R)                                   
 6 \ Copy top return stack item to data stack.                     
 7 \ R@  ( --   n D) ( n   n  R)                                   
 8                                                                 
 9 \ 1. Do not test or execute these words interactively.          
10 \ 2. Only use these words within colon definitions.             
11 \ 3. Each use of >R must be balanced with a corresponding R>.   
12 \ 4. Do not use >R R> and R@ within DO ... LOOPs.  Loop control 
13 \    info is kept on the return stack and could be destroyed.   
14                                                                 
15                                                                 


Screen 3 not modified     
 0 \ Review-2 Memory Operators.                   20:01JWB10/15/85 
 1 HEX     ( --   -- )  Set system number BASE to 16 (decimal).    
 2 DECIMAL ( --   -- )  Set system number BASE to 10 (decimal).    
 3 TIB     ( --  adr )  Leave address of terminal input buffer.    
 4 PAD     ( --  adr )  Leave address of text output buffer.       
 5 HERE    ( --  adr )  Leave address of word buffer.              
 6 DUMP    ( adr n   -- ) Dump n bytes of memory starting at adr.  
 7 ERASE   ( adr n   -- ) Erase n bytes of memory starting at adr  
 8                        to zeros.                                
 9 FILL  ( adr n m   -- ) Fill n bytes of memory starting at adr   
10                        with low 8 bits of m ( 0 - 255 ).        
11   !     ( n adr   -- ) Store 16b value n at address adr.        
12   @     ( adr     n  ) Fetch 16b value at adr and leave as n.   
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 4 not modified     
 0 \ Review-3 Variables and Constants.            20:19JWB10/15/85 
 1                                                                 
 2   VARIABLE  <name>  ( --   -- )  Create 16bit data storage      
 3                                  called <name>.                 
 4   <name>            ( --  adr )  Leave storage address of <name>
 5                                                                 
 6   CONSTANT <name>   ( n    -- )  Create a constant  <name> whose
 7                                  value is specified by n.       
 8   <name>            ( --    n )  Leave value of <name> on stack.
 9                                                                 
10   +!     ( n adr   -- )  Add n to the value found at address adr
11   : DRIP  1 RAIN @ + RAIN ! ;                                   
12   : DRIP  1 RAIN +! ;                                           
13                                                                 
14   ON     ( adr     -- )  Set cell at adr to true or -1.         
15   OFF    ( adr     -- )  Set cell at addr to false or 0.        


Screen 5 not modified     
 0 \ Review-4  Simple tables and arrays.          20:15JWB10/15/85 
 1 CREATE <name> ( --  -- ) Creates a dictionary entry named <name>
 2                         When executed, <name> leaves the address
 3  <name>       ( --  adr) of the first memory cell which follows 
 4                          the word name.  No memory is allocated.
 5 ALLOT         ( n   -- ) Allocate n bytes of memory in the      
 6                          dictionary.                            
 7   ,           ( n   -- ) Allocate 16 bits ( 2 bytes ) of memory 
 8                          initializing it to the value n.        
 9  C,           ( n   -- ) Allocate 8 bits ( 1 byte ) of memory   
10                          initializing it to low 8 bits of n.    
11  CREATE MARBLE  0 , 0 , 0 ,                                     
12  0 CONSTANT RED         2 CONSTANT BLUE     4 CONSTANT YELLOW   
13 : MARBLES MARBLE + ;                                            
14 2 RED   MARBLES !    3 BLUE  MARBLES !     5 YELLOW MARBLES !   
15                                                                 


Screen 6 not modified     
 0 \  Review-5 Double Variables and Constants     20:23JWB10/15/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 7 not modified     
 0 \ Review-6 User stacks.                        20:49JWB10/15/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 8 not modified     
 0 \ Solution to Problem 8.                       20:49JWB10/15/85 
 1 \ Write FORTH words for the following user stack operations.    
 2 \ The should leave the data stack unchanged!!!                  
 3 : PDUP          P@ >P                                   ;       
 4 : PDROP         P> DROP                                 ;       
 5 : PSWAP         P> P> SWAP >P >P                        ;       
 6 : POVER         P> P@ SWAP >P >P                        ;       
 7 : PROT          P> P> P> -ROT >P >P >P                  ;       
 8 : -PROT         PROT PROT                               ;       
 9 : PTUCK         PSWAP POVER                             ;       
10 : PNIP          PSWAP PDROP                             ;       
11 : 2PDUP         POVER POVER                             ;       
12 : 3PDUP         P> 2PDUP DUP >P -PROT >P                ;       
13 : 2PSWAP        PROT P> PROT >P                         ;       
14 : 2PDROP        PDROP PDROP                             ;       
15 : 2POVER        2PSWAP 2PDUP P> P> 2PSWAP >P >P         ;       


Screen 9 not modified     
 0 \ Review-8 Indexed arrays.                     21:02JWB10/15/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 10 not modified     
 0 \ Reasons for using Fixed-point arithmetic     21:50JWB10/15/85 
 1                                                                 
 2    To maximize the computers efficiency:                        
 3    1. by making the program run as fast as possible.            
 4    2. by using as little computer memory as possible.           
 5                                                                 
 6    Applications such as:                                        
 7    Operating systems and utilities;  Process control;           
 8    Graphics; Data base management; Accounting; Simulation;      
 9    Editors; Wordprocessors;  etc.                               
10                                                                 
11    Do not require floating point.                               
12                                                                 
13    Read Brodie  page 113-116                                    
14                                                                 
15                                                                 


Screen 11 not modified     
 0 \ Reasons for using Floating-point.            21:54JWB10/15/85 
 1                                                                 
 2   1. Scientific and Engineering Calculations.                   
 3   2. Programming time is more highly valued than program        
 4      execution time.                                            
 5   3. Application requires numbers with a large dynamic range    
 6      ( greater than -2 billion to +2 billion ).                 
 7   4. Computer has hardware floating-point processor, and        
 8      thus we do not pay speed penalty for using floating-point. 
 9                                                                 
10   To add floating point to F83  see:                            
11   FORTH Tools and Applications  by G. Feierbach and P. Thomas   
12   pages 51-58  for a high-level floating point package          
13   with 16 bit exponent and 32 bit mantissa.                     
14   See screens 40-45 of this file for a floating point package   
15   with 16 bit exponent and 16 bit mantissa.                     


Screen 12 not modified     
 0 \ Star-slash the scaler                        22:56JWB10/15/85 
 1 \ */  ( a b c   ab/c ) Perform multiplication and then division.
 2 \ Star-slash multiplies 16bit  a  and  16bit  b  to form a 32bit
 3 \ intermediate result which is then divided by 16bit c to give a
 4 \ 16bit result.  The 32bit intermediate product ensures accurate
 5 \ results when multiplying by fractions.                        
 6                                                                 
 7 \ We use */  to multiply a  by the fraction b/c                 
 8 \ Examples:                                                     
 9 \  15000   3   4  */      gives   11250     correct answer      
10 \  15000   3   *  4 /     gives   -5134     wrong   answer      
11 \  m is p % of n                                                
12    : %%  ( n p    m )   *  100  /   .  ;                        
13    : %   ( n p    m )   100  */     .  ;                        
14 \  Try   1820 32  %%     and 1820  32 %                         
15                                                                 


Screen 13 not modified     
 0 \ Percentage calculations                      23:07JWB10/15/85 
 1 \ Use % to find        Result      Actual                       
 2 \ 15 % of   220                    33.00                        
 3 \ 15 % of   222                    33.30                        
 4 \ 15 % of   224                    33.60                        
 5                                                                 
 6 \ Rounding.                                                     
 7                                                                 
 8 : %R   10 */  5 +  10 /  . ;                                    
 9                                                                 
10 \  Use  DEBUG to follow the operation of %R on the above        
11 \  examples.                                                    
12                                                                 
13 \  See Brodie pp116-119                                         
14                                                                 
15                                                                 


Screen 14 not modified     
 0 \ Rational approximations. Problem 1.          23:27JWB10/15/85 
 1 \ See Brodie page 122 for more.                                 
 2 : *PI       355     113 */ ;      \  Do problem 3 and 4         
 3 : *SQRT(2)  19601 13860 */ ;      \  in Brodie page 125 .       
 4 : *SQRT(3)  18817 10864 */ ;      \                             
 5 : *E        28667 10546 */ ;      \                             
 6 \ Area of circle                                                
 7 : AREA ( r   a )                                                
 8         DUP * *PI  ;                                            
 9 \ Volume of sphere                                              
10 : VS    ( r   v )                                               
11         DUP DUP * * *PI 4 3 */ ;                                
12 \  Volume of a cone.                                            
13 : VC  ( h r   v )                                               
14         AREA  SWAP 3 */ ;                                       
15 \ Problem 1. Determine the valid ranges for r in above examples.


Screen 15 not modified     
 0 \ Brute force approach to fractions.           09:17JWB10/16/85 
 1 \ Display decimal equivalent of fraction m/n.                   
 2 : .XXX  ( m  n    -- )                                          
 3           2DUP > ABORT" Improper fraction."                     
 4           >R 2000 R>  */   1+  2/   ( Scale and round fraction )
 5           ASCII . EMIT  DUP 10 <                                
 6           IF   ASCII 0 DUP EMIT EMIT                            
 7           ELSE DUP 100 < IF   ASCII 0 EMIT THEN                 
 8           THEN  . ;                                             
 9 \ Print the decimal equivalent of the mixed fraction i+m/n      
10 : I.XXX  ( i m n    -- )                                        
11        ROT . CONTROL H EMIT .XXX ;                              
12 \ Display decimal equivalents of 1/n through  (n-1)/n           
13 : TEST   ( n   -- )                                             
14       CR DUP 1 ?DO CR I OVER  2DUP SWAP                         
15                    . ." /" . ." = "  .XXX  LOOP  DROP ;         


Screen 16 not modified     
 0 \ Star slash mod  */MOD   Problem 2.            00:30JWB10/16/85
 1 \ Compute ab/c with 32bit intermediate product ab  and leave    
 2 \ quotient q and remainder r .  Note:  Forth-83 */MOD uses      
 3 \ signed values  a b c  and uses floored symmetric division.    
 4 \  */MOD  ( a b c   r q )                                       
 5 \ Calculate area of a circle and display to 3 decimal places.   
 6 : AREA   ( r    -- )                                            
 7         DUP *   355 113   \ This is ratio for pi                
 8         */MOD  SWAP 113   \ We need remainder for I.XXX         
 9         ." The area of the circle is "  I.XXX  ;                
10 \ Calculate volume of a sphere and display to 3 decimals.       
11 : VOLUME  ( r   -- )                                            
12         DUP DUP *   SWAP 1420 *   ( r*r  r*1420 )               
13         339  */MOD  SWAP  339                                   
14         ." The volume of the sphere is  "  I.XXX ;              
15 \ Problem 2. Do circle circumference and sphere surface area.   


Screen 17 not modified     
 0 \ Rounding with */MOD                          09:31JWB10/16/85 
 1 \ Example:  The percent calculation.                            
 2 \ Using */ we rounded this way.                                 
 3 : %R1    10 */     5 +            10 /  DROP ;                  
 4 : %R2    50 */     1+             2/    DROP ;                  
 5                                                                 
 6 : %R3   100 */MOD  SWAP 50 +  100 / +   DROP ;                  
 7 : %R4   100 */MOD  SWAP 49 > NEGATE +   DROP ;                  
 8                                                                 
 9 \  Note:  Change the .  to  DROP  when doing the timing tests.  
10 \         Do this using the editor replace function.            
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 18 not modified     
 0 \ Timer module                                 13:13JWB10/16/85 
 1 ONLY EDITOR ALSO FORTH ALSO DEFINITIONS                         
 2   2VARIABLE TICKS                                               
 3 \ Return current time in ticks as a double integer.             
 4 \ ( 18.2 ticks/second ) .                                       
 5   CODE @TICKS ( --  dn )                                        
 6        0 # AH MOV  IP PUSH RP PUSH 26 INT  RP POP IP POP        
 7                           DX PUSH CX PUSH NEXT END-CODE         
 8 \ Save current time in ticks.                                   
 9 : !TIMER ( --  -- )                                             
10         @TICKS TICKS 2! ;                                       
11 \ Fetch elapsed time in ticks.                                  
12 : @TIMER  ( --  dn )                                            
13            @TICKS TICKS 2@ D- ;                                 
14 : TIME.IT ;                                                     
15                                                                 


Screen 19 not modified     
 0 \ Timing Template.                             17:42   10/16/85 
 1 \  @TIMER gives time in ticks, 18.2 ticks/sec so if we perform  
 2 \  1000 passes we can get count in micro-secs for one pass.     
 3 ONLY EDITOR ALSO FORTH DEFINITIONS                              
 4    FORGET TIME.IT                                               
 5 :  TIME.IT                                                      
 6    !TIMER 1000   0 DO                                           
 7              \  blank  loop        ( 0-54 micro-sec )           
 8              \  395  395  2DROP  ( 54-109 micro-sec )           
 9              \  1234  32  %R1      ( 2692 micro-sec )           
10                 1234  32  %R2      ( 1648 micro-sec )           
11              \  1234  32  %R3      ( 2692 micro-sec )           
12              \  1234  32  %R4      ( 1648 micro-sec )           
13    LOOP @TIMER DROP CR                                          
14    5000 91 */   . 230 EMIT ." -seconds for one pass." ;         
15 : TEST CLEARSCREEN  5 0 DO TIME.IT LOOP ;                       


Screen 20 not modified     
 0 \ Infinite Loops.                              19:59JWB10/17/85 
 1 The infinite loop with no exit.  This is recommended only for   
 2   an end user application.  Examples: FORTH's QUIT & MY.OUTER   
 3   step 1 is executed once; step 2 is repeated forever. Note:    
 4   step 3 is never executed.                                     
 5      ... (step 1)  BEGIN   (step2)  AGAIN   (step3) ...         
 6                                                                 
 7 The infinite loop with EXIT  escape hatch.                      
 8   step 1 is executed once; step 2 and step 3 are repeated until 
 9   condition is true.  Note: step 4 will never be executed       
10   because EXIT passes control back to the calling word!!        
11   Examples: See #IN and GAME's in Screens 18-19 of SAMPLE3.BLK  
12    ... (s1) BEGIN (s2)                                          
13                   (condition) IF EXIT THEN                      
14                   (s3)                                          
15             AGAIN (s4) ...                                      


Screen 21 not modified     
 0 \ Indefinite Loops                             20:15JWB10/17/85 
 1 \  In the indefinite loop the main action is repeated until a   
 2 \  condition is true.  Step 1 is executed once, step 2 is       
 3 \  executed and (condition) is tested. If condition is false    
 4 \  step 2 is executed again, if condition is true then step 3   
 5 \  is executed.  Note that step 3 following the loop will be    
 6 \  executed when loop is exited - this is not the case with     
 7 \  the infinite loop with EXIT of previous screen.              
 8 \                                                               
 9 \   ... (s1)  BEGIN   (s2)                                      
10 \                     (condition)                               
11 \             UNTIL   (s3) ...                                  
12                                                                 
13 : COUNT-UP  0 BEGIN 1+ DUP CR . KEY? UNTIL  DROP ." DONE" ;     
14 : COUNT.UP  0 BEGIN 1+ DUP CR .                                 
15                     KEY? IF      EXIT THEN AGAIN ." DONE" ;     


Screen 22 not modified     
 0 \ Indefinite Loops.  Problem 3 & 4             21:10JWB10/17/85 
 1 \ Indefinite loop illustrates incredible integer property.      
 2 : DOIT  ( n   -- )                                              
 3     CR  BEGIN  DUP  2 MOD  ( is n odd? )                        
 4                IF   3 * 1+ ( tripple n and add 1 )              
 5                ELSE   2/   ( half n )                           
 6                THEN                                             
 7                DUP 5 .R  DUP 2 <                                
 8         UNTIL  DROP ;                                           
 9 \ Problem 3.  Modify program to count the number of cycles      
10 \ before termination.  Will this program always end?            
11 \ Hint: Use a variable to save the count.                       
12 \ Problem 4.  Modify the program so the value of the largest    
13 \ number encountered is printed when the program terminates.    
14 \ Is there a limit to the maximum number? Are 16 bit numbers    
15 \ large enough.  Hint: Use a variable to same current maximum.  


Screen 23 not modified     
 0 \ Indefinite Loop - another form. Prob 5.      21:23JWB10/17/85 
 1 \ In this form step 1 is executed once.  Step 2 is executed     
 2 \ if condition is true do step 3 and repeat starting with (s2)  
 3 \ if condition is false leave loop and do step 4.               
 4 \  ... (s1)  BEGIN  (s2)                                        
 5 \                   (condition)                                 
 6 \            WHILE  (s3)                                        
 7 \            REPEAT (s4) ...                                    
 8 \ This word clears the data stack.                              
 9 : CLEAR ( ??   -- )                                             
10         BEGIN   DEPTH                                           
11                 0<>                                             
12         WHILE   DROP                                            
13         REPEAT        ;                                         
14 \ Problem 5. Can you write CLEAR using  BEGIN ... UNTIL  ?      
15                                                                 


Screen 24 not modified     
 0 \ Finite Loops.  Problem 6.                    21:49JWB10/17/85 
 1 \   ... (s1)  l i   DO  (s2)      LOOP  (s3) ...                
 2 \   ... (s1)  l i   DO  (s2)  n  +LOOP  (s3) ...                
 3 \   ... (s1)  l i  ?DO  (s2)      LOOP  (s3) ...                
 4 \   ... (s1)  l i  ?DO  (s2)  n  +LOOP  (s3) ...                
 5 \  Problem 6: Given the following loop testing words:           
 6 :  DOLOOP   DO  CR I .     LOOP ;    \ All of these words take  
 7 :  DO+LOOP  DO  CR I .  2 +LOOP ;    \ the loop limit and the   
 8 :  DO-LOOP  DO  CR I . -2 +LOOP ;    \ initial value on the     
 9 : ?DOLOOP  ?DO  CR I .     LOOP ;    \ stack. ie ( l i   -- )   
10 : ?DO+LOOP ?DO  CR I .  2 +LOOP ;                               
11 : ?DO-LOOP ?DO  CR I . -2 +LOOP ;                               
12 \ Determine the output for the following stack inputs.          
13 \ a) 10 8  b)  10 10  c)  10 12                                 
14 \ Caution:  Think first!  Some may execute a long long time!!   
15 \ DO PROBLEMS 1 THRU 6  PAGE 145 OF STARTING FORTH.             


Screen 25 not modified     
 0 \ Leaving Loops early.                         22:24JWB10/17/85 
 1 \ Execute step 1. Repeat loop as before executing step 2 and    
 2 \ step 4 on each pass - except that if condition is true        
 3 \ before loop is finished execute step 3 and leave loop to      
 4 \ execute step 5.  Note:  step 4 will not be executed if we     
 5 \ leave the loop early.  Note:  EXIT cannot be used in DO LOOPs 
 6 \   (s1)  l i   DO    (s2)                                      
 7 \                     (condition) IF  (s3) LEAVE THEN           
 8 \                     (s4)                                      
 9 \               LOOP  (s5) ...                                  
10 \                                                               
11 \ This is an alternative form if step 3 is not required.        
12 \   (s1)  l i   DO    (s2)                                      
13 \                     (condition) ?LEAVE                        
14 \                     (s4)                                      
15 \               LOOP  (s5) ...                                  


Screen 26 not modified     
 0 \ Example   Problem 7.                         22:24JWB10/17/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 CREATE TABLE 100 ALLOT                                          
 6 : FILL-TABLE     100 0 DO 100 RND TABLE I + C! LOOP ;           
 7 : SEE-TABLE   CR 100 0 DO    TABLE I + C@ 4 .R LOOP ;           
 8 : MATCH  ( n   -- )                                             
 9         100 0 DO TABLE I + C@  OVER =                           
10                  IF CR ." Its in the "  I . ." th cell. "       
11                     LEAVE THEN                                  
12                LOOP DROP  ;                                     
13 \ Problem 7:  Write SIGMA  a word which sums the numbers in     
14 \ in TABLE until a 0 is encountered.  It then prints the        
15 \ number of numbers and the average.                            


Screen 27 not modified     
 0 \ Zen Floating Point Math                      09:39JWB02/07/86 
 1                                                                 
 2 28  31  THRU                                                    
 3                                                                 
 4 EXIT                                                            
 5                                                                 
 6 "Less is more" floating point implementation by Martin Tracy.   
 7 Put in the public domain in 1984 Forml Proceedings.             
 8                                                                 
 9 10-20-85 Modified by JWB for compatibility with F83             
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 28 not modified     
 0 \ ZEN MATH, documentation.                     09:37JWB02/07/86 
 1 EXIT                                                            
 2 Floating-point four-function single-precision match package     
 3 with four significant digits and an unlimited dynamic range.    
 4 Floating-point numbers are represented by a signed mantissa     
 5 and an exponent of ten, with the exponent on top of the stack.  
 6   fixed-number           stack ( top -> )                       
 7       1.        FLOAT ->  1       0                             
 8       3.1415    FLOAT ->  31415  -4                             
 9       -1234500. FLOAT ->  -12345  2                             
10                                                                 
11 Used like   3.1415 FLOAT  12.5 FLOAT  F*  F.                    
12                                                                 
13 FLOAT asumes that a number containing a decimal point is forced 
14 to a double-integer and the number of digits following the      
15 decimal point is stored in the variable DPL.                    


Screen 29 not modified     
 0 \ D10*  TRIM  ZEN MATH                         09:38JWB02/07/86 
 1                                                                 
 2                                                                 
 3 ( d1 --- d2 ; multiplies d1 by 10 )                             
 4 : D10*  D2* 2DUP D2* D2* D+ ;                                   
 5                                                                 
 6 ( trims a double number mantissa and an exponent of ten to )    
 7 ( a reasonable floating point number; dn n --- f )              
 8 : TRIM  >R SWAP OVER DABS                                       
 9         BEGIN  OVER 0< OVER OR                                  
10         WHILE  0 10 UM/MOD >R 10 UM/MOD SWAP DROP R> R> 1+ >R   
11         REPEAT ROT ?DNEGATE DROP R> ;                           
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 30 not modified     
 0 \ F+  FNEGATE  ZEN MATH                        09:38JWB02/07/86 
 1 : F+    ( f1 f2   f1+f2 )                                       
 2         ROT 2DUP - DUP 0<                                       
 3         IF   NEGATE  ROT >R SWAP DROP >R SWAP R>                
 4         ELSE SWAP >R SWAP DROP                                  
 5         THEN >R S>D R> DUP 0                                    
 6         ?DO     >R D10* R> 1- OVER ABS 6553 >                   
 7                 IF  LEAVE THEN                                  
 8         LOOP    R> OVER + >R                                    
 9         IF      ROT DROP                                        
10         ELSE    ROT S>D D+                                      
11         THEN    R> TRIM ;                                       
12                                                                 
13 : FNEGATE  ( f1   -f1 )                                         
14            >R NEGATE R> ;                                       
15                                                                 


Screen 31 not modified     
 0 \ F-  F*   F/   ZEN MATH                       09:38JWB02/07/86 
 1 : F-    ( f1 f2   f1-f2 )                                       
 2         FNEGATE F+ ;                                            
 3 : F*    ( f1 f2   f1*f2 )                                       
 4         ROT + >R                                                
 5         2DUP XOR >R  ABS SWAP ABS  UM*  R> ?DNEGATE R> TRIM ;   
 6                                                                 
 7 : F/    ( f1 f2   f1/f2 )                                       
 8         OVER 0= ABORT" F/ by zero"                              
 9         ROT SWAP - >R  2DUP XOR  ROT ROT                        
10         ABS DUP 6553 MIN   ROT ABS 0                            
11         BEGIN   2DUP D10*  SWAP DROP  3 PICK <                  
12         WHILE   D10* R> 1- >R                                   
13         REPEAT                                                  
14         2SWAP DROP UM/MOD SWAP DROP 0 ROT ?DNEGATE R> TRIM ;    
15                                                                 


Screen 32 not modified     
 0 \ FLOAT  F.  ZEN MATH                          09:25JWB02/07/86 
 1                                                                 
 2 \ Convert a double number to a floating point number.           
 3 : FLOAT ( d    f )                                              
 4         DPL @ NEGATE TRIM ;                                     
 5                                                                 
 6 \ Print a floating point number.                                
 7 : F.    ( f   -- )                                              
 8         2 ?ENOUGH                                               
 9         >R DUP ABS 0                                            
10         <#  R@   0 MAX 0 ?DO  ASCII 0 HOLD  LOOP                
11             R@ 0<                                               
12             IF   R@ NEGATE 0 MAX 0 ?DO  #  LOOP  ASCII . HOLD   
13             THEN R> DROP  #S ROT SIGN                           
14         #>  TYPE SPACE ;                                        
15                                                                 
projects/sample5.blk.txt · Zuletzt geändert: 2013-06-06 21:27 (Externe Bearbeitung)