Forth-eV Wiki

Benutzer-Werkzeuge

Webseiten-Werkzeuge

Sie befinden sich hier: Forth Wiki » papierkorb » Polynomial properties application
Zuletzt angesehen:
papierkorb:poly.blk

Unterschiede

Hier werden die Unterschiede zwischen zwei Versionen angezeigt.

Link zu dieser Vergleichsansicht

papierkorb:poly.blk [2025-08-16 17:50] – ↷ Seite von projects:poly.blk nach papierkorb:poly.blk verschoben mkapapierkorb:poly.blk [Unbekanntes Datum] (aktuell) – gelöscht - Externe Bearbeitung (Unbekanntes Datum) 127.0.0.1
Zeile 1: Zeile 1:
-=== Polynomial properties application === 
  
-<code> 
-Screen 0 not modified      
- 0                                                                  
- 1 \ Last change:   Screen  019                   13:55JWB04/15/87  
- 2                                                                  
- 3                                                                  
- 4                                                                  
- 5                                                                  
- 6                                                                  
- 7                                                                  
- 8                                                                  
- 9                                                                  
-10                                                                  
-11                                                                  
-12                                                                  
-13                                                                  
-14                                                                  
-15                                                                  
- 
- 
- 
-Screen 2 not modified      
- 0 EXIT  Distance between two points.                               
- 1                                                                  
- 2 Y                                                                
- 3 |           p2            p1 = ( x1,y1 )                         
- 4 |          /|             p2 = ( x2,y2 )                         
- 5 |         / |                                                    
- 6 |     d  /  |             b   = y2 - y1                          
- 7 |       /   | b           a   = x2 - x1                          
- 8 |      /    |                                                    
- 9 |     /  a  |             d  = [(x2-x1)^2 + (y2-y1)^2]^.5        
-10 | p1 --------                                                    
-11 |----------------X                                               
-12                                                                  
-13                                                                  
-14                                                                  
-15                                                                  
- 
- 
-Screen 3 not modified      
- 0 EXIT  Area of a polygon.                                         
- 1                                                                  
- 2     p1 /---------\  p2        p1 = ( x1,y1 )                     
- 3       /           \           p2 = ( x2,y2 )                     
- 4      /             \  p3      p3 = ( x3,y3 )                     
- 5     /              /          p4 = ( x4,y4 )                     
- 6 p5 /--------------/ p4        p5 = ( x5,y5 )                     
- 7                                                                  
- 8 AREA OF THE POLYGON =                                            
- 9 [(x1y5-x5y1)+(x2y1-x1y2)+(x3y2-x2y3)+(x4y3-x3y4)+(x5y4-x4y5)]/2  
-10                                                                  
-11 In general:                                                      
-12            i=n                                                   
-13 AREA = 0.5*SUM [ x(i)y(i-1) - x(i-1)y(i) ]                       
-14            i=1                                                   
-15  where we define x0 to be x5 and y0 to be y5.                    
- 
- 
-Screen 4 not modified      
- 0 EXIT   Sample Calculation.                                       
- 1                                                                  
- 2   X   Not drawn to scale!!                                       
- 3   |                              p1 = ( 8,4 )                    
- 4   |                              p2 = ( 6,1 )                    
- 5   |    p4 ----------- p1         p3 = ( 2,1 )                    
- 6   |      /          /            p4 = ( 5,4 )                    
- 7   |     /          /                                             
- 8   |    /          /                                              
- 9   | p3 -----------  p2                                           
-10   |-----------------------Y                                      
-11                                                                  
-12 A = [(8*4-5*4)+(6*4-8*1)+(2*1-6*1)+(5*1-2*4)]/2 = 10.5           
-13                                                                  
-14                                                                  
-15                                                                  
- 
- 
-Screen 5 not modified      
- 0 \ Polygon Area - 1                             05:07jwb10/07/85  
- 1 : #IN ( --  n )                                                  
- 2       QUERY  INTERPRET ;                                         
- 3 CREATE X  102 ALLOT     \ Array for x coordinates                
- 4 CREATE Y  102 ALLOT     \ Array for y coordinates                
- 5 VARIABLE  #POINTS       \ Number of points in polygon            
- 6 VARIABLE  AREA          \ Sum of the x(i)y(i-1) - x(i)y(i+1)     
- 7 \ Fetch ith x component.                                         
- 8 : X@  ( i     x{i} ) 2* X + @ ;                                  
- 9 \ Fetch ith y component.                                         
-10 : Y@  ( i     y{i} ) 2* Y + @ ;                                  
-11 \ Store ith x component.                                         
-12 : X!  ( x i     -- ) 2* X + ! ;                                  
-13 \ Store ith y component.                                         
-14 : Y!  ( y i     -- ) 2* Y + ! ;                                  
-15                                                                  
- 
- 
-Screen 6 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 7 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         #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;                          
- 8 \ Sum data points.                                               
- 9 : FIND_AREA   ( --   -- )                                        
-10         0 AREA !                                                 
-11         #POINTS @ 1+  1         ( n+1 so we loop n times )       
-12         DO I    X@ I 1- Y@ *    ( X{i}*Y{i-1} )                  
-13            I 1- X@ I    Y@ *    ( X{i-1}*Y{i} )                  
-14            - AREA +!                                             
-15         LOOP  ;                                                  
- 
- 
-Screen 8 not modified      
- 0 \ Polygon area - 4                             20:55jwb10/06/85  
- 1 \ Display computed area.                                         
- 2 : PUT_AREA      ( --  -- )                                       
- 3         AREA @ 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 : POLY     ( --   -- )                                           
- 9         GET_#POINTS                                              
-10         GET_DATA                                                 
-11         FIND_AREA                                                
-12         PUT_AREA ;                                               
-13                                                                  
-14                                                                  
-15                                                                  
- 
- 
-Screen 9 not modified      
- 0 \ Load screen for enhanced POLY program.                         
- 1                                                                  
- 2   FORGET PTASK                                                   
- 3                                                                  
- 4 : PTASK ;                                                        
- 5                                                                  
- 6                                                                  
- 7   10 19 THRU                                                     
- 8                                                                  
- 9                                                                  
-10                                                                  
-11                                                                  
-12                                                                  
-13                                                                  
-14                                                                  
-15                                                                  
- 
- 
-Screen 10 not modified      
- 0 \  32 bit square root KS  4TH DIM V4N1P9                         
- 1                                                                  
- 2 : EASY-BITS ( drem1 partial.root1 count   drem2  partial.root2 ) 
- 3     0  DO  >R  D2*  D2*                                          
- 4            R@  -  DUP  0<                                        
- 5            IF    R@ + R> 2*  1-                                  
- 6            ELSE       R> 2*  3  +                                
- 7            THEN  LOOP  ;                                         
- 8                                                                  
- 9 : 2'S-BIT ( drem2 proot2   drem3  proot3 ) \ get penultimate bit 
-10      >R  D2*  DUP  0<                                            
-11      IF   D2*  R@  -  R>  1+                                     
-12      ELSE D2*  R@  2DUP  U<                                      
-13           IF   DROP  R> 1-                                       
-14           ELSE  -    R> 1+                                       
-15      THEN THEN ;                                                 
- 
- 
-Screen 11 not modified      
- 0 \  32 bit square root KS  4TH DIM V4N1P9                         
- 1 : 1'S-BIT   ( drem3 proot3   fullroot )  \ remainder lost        
- 2      >R  DUP  0<                                                 
- 3      IF    2DROP  R>  1+                                         
- 4      ELSE  D2*  32768 R@  DU<  0=  R>  THEN ;                    
- 5                                                                  
- 6 \ 32-bit unsigned radicand to 16-bit unsigned square root        
- 7 : SQRT     ( ud     u  )                                         
- 8         0  1 8 EASY-BITS  ROT  DROP  6 EASY-BITS                 
- 9         2'S-BIT  1'S-BIT  ;                                      
-10                                                                  
-11 \ Display 16-bit number with two decimal places.                 
-12 : I.XX  ( 100*n   -- )                                           
-13          0 <#  # #  ASCII . HOLD  #S #>                          
-14         TYPE  SPACE ;                                            
-15                                                                  
- 
- 
-Screen 12 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 ;                                 
- 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 13 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 14 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 15 not modified      
- 0 \ Polygon Area & Perimeter                     13:53JWB04/15/87  
- 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  AREA          \ Sum of the x(i)y(i-1) - x(i)y(i+1)     
- 5 VARIABLE  PERIMETER  \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5 
- 6                                                                  
- 7 \ Fetch ith x component.                                         
- 8 : X@  ( i     x{i} ) 2* X + @ ;                                  
- 9 \ Fetch ith y component.                                         
-10 : Y@  ( i     y{i} ) 2* Y + @ ;                                  
-11 \ Store ith x component.                                         
-12 : X!  ( x i     -- ) 2* X + ! ;                                  
-13 \ Store ith y component.                                         
-14 : Y!  ( y i     -- ) 2* Y + ! ;                                  
-15                                                                  
- 
- 
-Screen 16 not modified      
- 0 \ Polygon Area & Perimeter - 2                 13:54JWB04/15/87  
- 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 17 not modified      
- 0 \ Polygon Area & Perimeter -3                  13:54JWB04/15/87  
- 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         #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;                          
- 8 \ Sum data points.                                               
- 9 : FIND_AREA   ( --   -- )                                        
-10         0 AREA !                                                 
-11         #POINTS @ 1+  1         ( n+1 so we loop n times )       
-12         DO I    X@ I 1- Y@ *    ( X{i}*Y{i-1} )                  
-13            I 1- X@ I    Y@ *    ( X{i-1}*Y{i} )                  
-14            - AREA +!                                             
-15         LOOP  ;                                                  
- 
- 
-Screen 18 not modified      
- 0 \ Polygon Area & Perimeter - 4                 13:54JWB04/15/87  
- 1                                                                  
- 2 : DIST  ( x2 y2 x1 y1   100*d )                                  
- 3         ROT - DUP *          \ x2 x1  (y1-y2)^2                  
- 4        -ROT - DUP *          \ (y1-y2)^2 (x2-x1)^2               
- 5         + 10000 UM* SQRT  ;  \ 100*d                             
- 6                                                                  
- 7 : FIND_PERIMETER ( --  -- )                                      
- 8         0 PERIMETER !                                            
- 9         #POINTS @ 1+ 1                                           
-10         DO   I    X@  I    Y@                                    
-11              I 1- X@  I 1- Y@                                    
-12              DIST  PERIMETER +!                                  
-13         LOOP ;                                                   
-14                                                                  
-15                                                                  
- 
- 
-Screen 19 not modified      
- 0 \ Polygon Area & Perimeter - 6                 13:55JWB04/15/87  
- 1 \ Display computed area.                                         
- 2 : PUT_AREA      ( --  -- )                                       
- 3         AREA @ 2 /MOD                                            
- 4         CR ." AREA = " 6 .R  ASCII . EMIT                        
- 5         IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;           
- 6 \ Display computed perimeter.                                    
- 7 : PUT_PERIMETER ( --  -- )                                       
- 8         CR ." PERIMETER = "                                      
- 9         PERIMETER @ I.XX ;                                       
-10                                                                  
-11 \ Compute area of polygon.                                       
-12 : POLY     ( --   -- )                                           
-13         GET_#POINTS GET_DATA                                     
-14         FIND_AREA   FIND_PERIMETER                               
-15         PUT_AREA    PUT_PERIMETER ;                              
- 
-</code> 
papierkorb/poly.blk.1755359401.txt.gz · Zuletzt geändert: 2025-08-16 17:50 von mka