# Forth-eV Wiki

### Webseiten-Werkzeuge

projects:poly.blk

#### Polynomial properties application

```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
3
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 ;
```
projects/poly.blk.txt · Zuletzt geändert: 2013-06-06 21:27 (Externe Bearbeitung)