home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p4_25jb.seq < prev    next >
Encoding:
Text File  |  1989-01-24  |  4.8 KB  |  162 lines
  1.  
  2. \ Original Date: November 4, 1985
  3. \ Last Modified: January 23, 1989
  4. \ Author:        Jack W. Brown
  5. \ File name:     JBPOLY2.SEQ
  6. \ Function:      Computes Area and Perimeter of a Polygon given
  7. \                x and y coordinates of its verticies.
  8.  
  9. FLOAD JBINPUT.SEQ   \ Want #IN
  10.  
  11. \ See the file JBPOLY1.SEQ for an explanation of the algorithm used to
  12. \ find the area.  The version in this file adds the computation of the
  13. \ perimeter and incorporates a new 32-bit square root routine.
  14.  
  15. \   The theorem of Pythagorous is used to calculate the length of
  16. \   each leg of the polygon.
  17. \ Y
  18. \ |           p2            p1 = ( x1,y1 )
  19. \ |          /|             p2 = ( x2,y2 )
  20. \ |         / |
  21. \ |     d  /  |             b   = y2 - y1
  22. \ |       /   | b           a   = x2 - x1
  23. \ |      /    |
  24. \ |     /  a  |             d  = [(x2-x1)^2 + (y2-y1)^2]^.5
  25. \ | p1 --------
  26. \ |----------------X
  27. \
  28.  
  29.  
  30. \ 32-bit Fixed Point Square Root by Klaxon Suralis
  31. \ From Forth Dimensions Volume 4 Number 9 Page 9 May/June 1982
  32. \ Read the original artical for an explanation of the code.
  33. \ We are just going to use it here, not understand it.
  34.  
  35. : EASY-BITS ( drem1 partial.root1 count --  drem2  partial.root2 )
  36.     0  DO  >R  D2*  D2*
  37.            R@  -  DUP  0<
  38.            IF    R@ + R> 2*  1-
  39.            ELSE       R> 2*  3  +
  40.            THEN  LOOP  ;
  41.  
  42. : 2'S-BIT ( drem2 proot2 --  drem3  proot3 ) \ get penultimate bit
  43.      >R  D2*  DUP  0<
  44.      IF   D2*  R@  -  R>  1+
  45.      ELSE D2*  R@  2DUP  U<
  46.           IF   DROP  R> 1-
  47.           ELSE  -    R> 1+
  48.      THEN THEN ;
  49.  
  50. \ Get the last bit.
  51. : 1'S-BIT   ( drem3 proot3 --  fullroot )  \ remainder lost
  52.      >R  DUP  0<
  53.      IF    2DROP  R>  1+
  54.      ELSE  D2*  32768 R@  DU<  0=  R>  THEN ;
  55.  
  56. \ 32-bit unsigned radicand to 16-bit unsigned square root
  57. : SQRT     ( ud  --   un  )  \ un is the 16-bit square root of 32-bit ud.
  58.         0  1 8 EASY-BITS  ROT  DROP  6 EASY-BITS
  59.         2'S-BIT  1'S-BIT SWAP DROP ;  \ SWAP DROP added to leave 16-bits
  60.  
  61. \ Display 16-bit number with two decimal places.
  62. \ Don't worry about how this works...  It will be explained in a
  63. \ later tutorial lesson.
  64. : I.XX  ( 100*n   -- )
  65.          0 <#  # #  ASCII . HOLD  #S #>
  66.         TYPE  SPACE ;
  67.  
  68. \ Display square root on n to 2 decimal places.
  69. \ Number is scaled by 10000 first forming a 32-bit product so
  70. \ that no significance is lost.
  71. : .SQRT ( n -- )
  72.         10000 UM* SQRT I.XX ;
  73.  
  74. \ Polygon Area & Perimeter
  75. CREATE X  102 ALLOT     \ Array for x coordinates
  76. CREATE Y  102 ALLOT     \ Array for y coordinates
  77. VARIABLE  #POINTS       \ Number of points in polygon
  78. VARIABLE  AREA          \ Sum of the x(i)y(i-1) - x(i)y(i+1)
  79. VARIABLE  PERIMETER     \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5
  80.  
  81. \ Fetch ith x component.
  82. : X@  ( i     x{i} ) 2* X + @ ;
  83. \ Fetch ith y component.
  84. : Y@  ( i     y{i} ) 2* Y + @ ;
  85. \ Store ith x component.
  86. : X!  ( x i     -- ) 2* X + ! ;
  87. \ Store ith y component.
  88. : Y!  ( y i     -- ) 2* Y + ! ;
  89.  
  90.  
  91. \ Move to the next tab stop.
  92. : TAB ( --  -- )
  93.          BEGIN  #OUT @ 8 MOD
  94.                IF SPACE ELSE EXIT THEN
  95.         AGAIN ;
  96.  
  97. \ Get number from keyboard.
  98. : GET#  ( --   n )
  99.          ASCII >  EMIT SPACE  #IN ;
  100.  
  101. \ Prompt and fetch number of data points.
  102. : GET_#POINTS  ( -- )
  103.         BEGIN
  104.         CR ." Enter number of data points. "
  105.         GET#  DUP 3 <
  106.         WHILE  CR ." You need at least 3 data points!"
  107.         REPEAT  50 MIN #POINTS ! ;
  108.  
  109.  
  110. \ Prompt and fetch all data points.
  111. : GET_DATA      (  -- )
  112.         CR CR ." Point " TAB ."   X" TAB ."   Y"
  113.         #POINTS @ 1+ 1
  114.         DO   CR I 3 .R  TAB GET# I X!
  115.              TAB GET# I Y! LOOP
  116.         #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;
  117.  
  118. \ Sum data points.
  119. : FIND_AREA   ( -- )
  120.         0 AREA !
  121.         #POINTS @ 1+  1         ( n+1 so we loop n times )
  122.         DO I    X@ I 1- Y@ *    ( X{i}*Y{i-1} )
  123.            I 1- X@ I    Y@ *    ( X{i-1}*Y{i} )
  124.            - AREA +!
  125.         LOOP  ;
  126.  
  127. \ Calculate the distance between (x1,y1) and (x2,y2)
  128. : DIST  ( x2 y2 x1 y1 -- 100*d )
  129.         ROT - DUP *          \ x2 x1  (y1-y2)^2
  130.        -ROT - DUP *          \ (y1-y2)^2 (x2-x1)^2
  131.         + 10000 UM* SQRT  ;  \ 100*d
  132.  
  133. \ Find the perimeter of the polygon saving result in the
  134. \ Variable PERIMETER
  135. : FIND_PERIMETER ( -- )
  136.         0 PERIMETER !
  137.         #POINTS @ 1+ 1
  138.         DO   I    X@  I    Y@
  139.              I 1- X@  I 1- Y@
  140.              DIST  PERIMETER +!
  141.         LOOP ;
  142.  
  143. \ Display computed area.
  144. : PUT_AREA      (  -- )
  145.         AREA @ 2 /MOD
  146.         CR ." AREA = " 6 .R  ASCII . EMIT
  147.         IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;
  148.  
  149. \ Display computed perimeter.
  150. : PUT_PERIMETER ( -- )
  151.         CR ." PERIMETER = "
  152.         PERIMETER @ I.XX ;
  153.  
  154. \ Compute area of polygon.
  155. : POLY     ( -- )
  156.         GET_#POINTS GET_DATA
  157.         FIND_AREA   FIND_PERIMETER
  158.         PUT_AREA    PUT_PERIMETER ;
  159.  
  160.  
  161.  
  162.