home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / tutor / l4p170 < prev    next >
Text File  |  1990-07-15  |  3KB  |  101 lines
  1.        ╔════════════════════════════════════════════════════╗
  2.        ║ Lesson 4 Part 170  F-PC 3.5 Tutorial by Jack Brown ║
  3.        ╚════════════════════════════════════════════════════╝
  4.  
  5. ╓──────────────╖
  6. ║ Problem 4.25 ║
  7. ╙──────────────╜
  8. Modify the poly program so that it also calculates the perimeter
  9. of the polygon.  To do this we will need a better square root
  10. algorithm.  One which appeared in Forth Dimensions is given below.
  11.  
  12. We give only the skeleton of the solution below.  The only new words you
  13. need to code and add are DIST ,  FIND_PERIMETER , and PUT_PERIMETER
  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. \ 32-bit Fixed Point Square Root by Klaxon Suralis
  29. \ From Forth Dimensions Volume 4 Number 9 Page 9 May/June 1982
  30. \ Read the original artical for an explanation of the code.
  31. \ We are just going to use it here, not understand it.
  32.  
  33. : EASY-BITS ( drem1 partial.root1 count --  drem2  partial.root2 )
  34.     0  DO  >R  D2*  D2*
  35.            R@  -  DUP  0<
  36.            IF    R@ + R> 2*  1-
  37.            ELSE       R> 2*  3  +
  38.            THEN  LOOP  ;
  39.  
  40. : 2'S-BIT ( drem2 proot2 --  drem3  proot3 ) \ get penultimate bit
  41.      >R  D2*  DUP  0<
  42.      IF   D2*  R@  -  R>  1+
  43.      ELSE D2*  R@  2DUP  U<
  44.           IF   DROP  R> 1-
  45.           ELSE  -    R> 1+
  46.      THEN THEN ;
  47.  
  48. \ Get the last bit.
  49. : 1'S-BIT   ( drem3 proot3 --  fullroot )  \ remainder lost
  50.      >R  DUP  0<
  51.      IF    2DROP  R>  1+
  52.      ELSE  D2*  32768 R@  DU<  0=  R>  THEN ;
  53.  
  54. \ 32-bit unsigned radicand to 16-bit unsigned square root
  55. : SQRT     ( ud  --   un  )  \ un is the 16-bit square root of 32-bit ud.
  56.         0  1 8 EASY-BITS  ROT  DROP  6 EASY-BITS
  57.         2'S-BIT  1'S-BIT SWAP DROP ;  \ SWAP DROP added to leave 16-bits
  58.  
  59. \ Display 16-bit number with two decimal places.
  60. \ Don't worry about how this works...  It will be explained in a
  61. \ later tutorial lesson.
  62. : I.XX  ( 100*n   -- )
  63.          0 <#  # #  ASCII . HOLD  #S #>
  64.         TYPE  SPACE ;
  65.  
  66. \ Display square root on n to 2 decimal places.
  67. \ Number is scaled by 10000 first forming a 32-bit product so
  68. \ that no significance is lost.
  69. : .SQRT ( n -- )
  70.         10000 UM* SQRT I.XX ;
  71.  
  72. \ Polygon Area & Perimeter
  73. \ ***** Add one new variable to the variable list  ****
  74. VARIABLE  PERIMETER     \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5
  75.  
  76. \ **** This is a new defintion that you must make.
  77. \ Calculate the distance between (x1,y1) and (x2,y2)
  78. \ and leave it scaled by a factor of 100.
  79. : DIST  ( x2 y2 x1 y1 -- 100*d )
  80.  
  81. \ **** This is a new definition that you must make.
  82. \ Find the perimeter of the polygon saving result in the
  83. \ Variable PERIMETER
  84. : FIND_PERIMETER ( -- )
  85.  
  86. \ **** This is a new definition that you must make.
  87. \ Display computed perimeter.
  88. : PUT_PERIMETER ( -- )
  89.  
  90. \ Compute area of polygon.
  91. : POLY     ( -- )
  92.         GET_#POINTS GET_DATA
  93.         FIND_AREA   FIND_PERIMETER
  94.         PUT_AREA    PUT_PERIMETER ;
  95.  
  96. \ Good luck!
  97.  
  98.  ┌───────────────────────────────────┐
  99.  │  Please move to Lesson 4 Part 180 │
  100.  └───────────────────────────────────┘
  101.