home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p4_25dc.seq < prev    next >
Encoding:
Text File  |  1990-04-16  |  3.8 KB  |  134 lines
  1. \ Problem 4.25   04/16/90 16:57:15.07
  2.  
  3.  
  4. : #IN       (  -- n )
  5.     QUERY INTERPRET ;
  6.  
  7. : EASY-BITS ( drem1 partial.root1 count --  drem2  partial.root2 )
  8.     0  DO  >R  D2*  D2*
  9.            R@  -  DUP  0<
  10.            IF    R@ + R> 2*  1-
  11.            ELSE       R> 2*  3  +
  12.            THEN  LOOP  ;
  13.  
  14. : 2'S-BIT ( drem2 proot2 --  drem3  proot3 ) \ get penultimate bit
  15.      >R  D2*  DUP  0<
  16.      IF   D2*  R@  -  R>  1+
  17.      ELSE D2*  R@  2DUP  U<
  18.           IF   DROP  R> 1-
  19.           ELSE  -    R> 1+
  20.      THEN THEN ;
  21.  
  22. \ Get the last bit.
  23. : 1'S-BIT   ( drem3 proot3 --  fullroot )  \ remainder lost
  24.      >R  DUP  0<
  25.      IF    2DROP  R>  1+
  26.      ELSE  D2*  32768 R@  DU<  0=  R>  THEN ;
  27.  
  28. \ 32-bit unsigned radicand to 16-bit unsigned square root
  29. : SQRT     ( ud  --   un  )  \ un is the 16-bit square root of 32-bit ud.
  30.         0  1 8 EASY-BITS  ROT  DROP  6 EASY-BITS
  31.         2'S-BIT  1'S-BIT SWAP DROP ;  \ SWAP DROP added to leave 16-bits
  32.  
  33. \ Display 16-bit number with two decimal places.
  34. \ Don't worry about how this works...  It will be explained in a
  35. \ later tutorial lesson.
  36. : I.XX  ( 100*n   -- )
  37.          0 <#  # #  ASCII . HOLD  #S #>
  38.         TYPE  SPACE ;
  39.  
  40. \ Display square root on n to 2 decimal places.
  41. \ Number is scaled by 10000 first forming a 32-bit product so
  42. \ that no significance is lost.
  43. : .SQRT ( n -- )
  44.         10000 UM* SQRT I.XX ;
  45.  
  46. \ Polygon Area & Perimeter
  47. CREATE X  102 ALLOT     \ Array for x coordinates
  48. CREATE Y  102 ALLOT     \ Array for y coordinates
  49. VARIABLE  #POINTS       \ Number of points in polygon
  50. VARIABLE  AREA          \ Sum of the x(i)y(i-1) - x(i)y(i+1)
  51. VARIABLE  PERIMETER     \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5
  52.  
  53. \ Fetch ith x component.
  54. : X@  ( i     x{i} ) 2* X + @ ;
  55. \ Fetch ith y component.
  56. : Y@  ( i     y{i} ) 2* Y + @ ;
  57. \ Store ith x component.
  58. : X!  ( x i     -- ) 2* X + ! ;
  59. \ Store ith y component.
  60. : Y!  ( y i     -- ) 2* Y + ! ;
  61.  
  62.  
  63. \ Move to the next tab stop.
  64. : TAB ( --  -- )
  65.          BEGIN  #OUT @ 8 MOD
  66.                IF SPACE ELSE EXIT THEN
  67.         AGAIN ;
  68.  
  69. \ Get number from keyboard.
  70. : GET#  ( --   n )
  71.          ASCII >  EMIT SPACE  #IN ;
  72.  
  73. \ Prompt and fetch number of data points.
  74. : GET_#POINTS  ( -- )
  75.         BEGIN
  76.         CR ." Enter number of data points. "
  77.         GET#  DUP 3 <
  78.         WHILE  CR ." You need at least 3 data points!"
  79.         REPEAT  50 MIN #POINTS ! ;
  80.  
  81.  
  82. \ Prompt and fetch all data points.
  83. : GET_DATA      (  -- )
  84.         CR CR ." Point " TAB ."   X" TAB ."   Y"
  85.         #POINTS @ 1+ 1
  86.         DO   CR I 3 .R  TAB GET# I X!
  87.              TAB GET# I Y! LOOP
  88.         #POINTS @ DUP X@ 0 X! Y@ 0 Y! ;
  89.  
  90. \ Sum data points.
  91. : FIND_AREA   ( -- )
  92.         0 AREA !
  93.         #POINTS @ 1+  1         ( n+1 so we loop n times )
  94.         DO I    X@ I 1- Y@ *    ( X{i}*Y{i-1} )
  95.            I 1- X@ I    Y@ *    ( X{i-1}*Y{i} )
  96.            - AREA +!
  97.         LOOP  ;
  98.  
  99. \ Calculate the distance between (x1,y1) and (x2,y2)
  100. : DIST  ( x2 y2 x1 y1 -- 100*d )
  101.         ROT - DUP *          \ x2 x1  (y1-y2)^2
  102.        -ROT - DUP *          \ (y1-y2)^2 (x2-x1)^2
  103.         + 10000 UM* SQRT  ;  \ 100*d
  104.  
  105. \ Find the perimeter of the polygon saving result in the
  106. \ Variable PERIMETER
  107. : FIND_PERIMETER ( -- )
  108.         0 PERIMETER !
  109.         #POINTS @ 1+ 1
  110.         DO   I    X@  I    Y@
  111.              I 1- X@  I 1- Y@
  112.              DIST  PERIMETER +!
  113.         LOOP ;
  114.  
  115. \ Display computed area.
  116. : PUT_AREA      (  -- )
  117.         AREA @ 2 /MOD
  118.         CR ." AREA = " 6 .R  ASCII . EMIT
  119.         IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;
  120.  
  121. \ Display computed perimeter.
  122. : PUT_PERIMETER ( -- )
  123.         CR ." PERIMETER = "
  124.         PERIMETER @ I.XX ;
  125.  
  126. \ Compute area of polygon.
  127. : POLY     ( -- )
  128.         GET_#POINTS GET_DATA
  129.         FIND_AREA   FIND_PERIMETER
  130.         PUT_AREA    PUT_PERIMETER ;
  131.  
  132.  
  133.  
  134.