home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
p4_25jb.seq
< prev
next >
Wrap
Text File
|
1989-01-24
|
5KB
|
162 lines
\ Original Date: November 4, 1985
\ Last Modified: January 23, 1989
\ Author: Jack W. Brown
\ File name: JBPOLY2.SEQ
\ Function: Computes Area and Perimeter of a Polygon given
\ x and y coordinates of its verticies.
FLOAD JBINPUT.SEQ \ Want #IN
\ See the file JBPOLY1.SEQ for an explanation of the algorithm used to
\ find the area. The version in this file adds the computation of the
\ perimeter and incorporates a new 32-bit square root routine.
\ The theorem of Pythagorous is used to calculate the length of
\ each leg of the polygon.
\ Y
\ | p2 p1 = ( x1,y1 )
\ | /| p2 = ( x2,y2 )
\ | / |
\ | d / | b = y2 - y1
\ | / | b a = x2 - x1
\ | / |
\ | / a | d = [(x2-x1)^2 + (y2-y1)^2]^.5
\ | p1 --------
\ |----------------X
\
\ 32-bit Fixed Point Square Root by Klaxon Suralis
\ From Forth Dimensions Volume 4 Number 9 Page 9 May/June 1982
\ Read the original artical for an explanation of the code.
\ We are just going to use it here, not understand it.
: EASY-BITS ( drem1 partial.root1 count -- drem2 partial.root2 )
0 DO >R D2* D2*
R@ - DUP 0<
IF R@ + R> 2* 1-
ELSE R> 2* 3 +
THEN LOOP ;
: 2'S-BIT ( drem2 proot2 -- drem3 proot3 ) \ get penultimate bit
>R D2* DUP 0<
IF D2* R@ - R> 1+
ELSE D2* R@ 2DUP U<
IF DROP R> 1-
ELSE - R> 1+
THEN THEN ;
\ Get the last bit.
: 1'S-BIT ( drem3 proot3 -- fullroot ) \ remainder lost
>R DUP 0<
IF 2DROP R> 1+
ELSE D2* 32768 R@ DU< 0= R> THEN ;
\ 32-bit unsigned radicand to 16-bit unsigned square root
: SQRT ( ud -- un ) \ un is the 16-bit square root of 32-bit ud.
0 1 8 EASY-BITS ROT DROP 6 EASY-BITS
2'S-BIT 1'S-BIT SWAP DROP ; \ SWAP DROP added to leave 16-bits
\ Display 16-bit number with two decimal places.
\ Don't worry about how this works... It will be explained in a
\ later tutorial lesson.
: I.XX ( 100*n -- )
0 <# # # ASCII . HOLD #S #>
TYPE SPACE ;
\ Display square root on n to 2 decimal places.
\ Number is scaled by 10000 first forming a 32-bit product so
\ that no significance is lost.
: .SQRT ( n -- )
10000 UM* SQRT I.XX ;
\ Polygon Area & Perimeter
CREATE X 102 ALLOT \ Array for x coordinates
CREATE Y 102 ALLOT \ Array for y coordinates
VARIABLE #POINTS \ Number of points in polygon
VARIABLE AREA \ Sum of the x(i)y(i-1) - x(i)y(i+1)
VARIABLE PERIMETER \ Sum of [{x(i)-x(i-1)}^2+{y(i)-y(i-1)}]^.5
\ Fetch ith x component.
: X@ ( i x{i} ) 2* X + @ ;
\ Fetch ith y component.
: Y@ ( i y{i} ) 2* Y + @ ;
\ Store ith x component.
: X! ( x i -- ) 2* X + ! ;
\ Store ith y component.
: Y! ( y i -- ) 2* Y + ! ;
\ Move to the next tab stop.
: TAB ( -- -- )
BEGIN #OUT @ 8 MOD
IF SPACE ELSE EXIT THEN
AGAIN ;
\ Get number from keyboard.
: GET# ( -- n )
ASCII > EMIT SPACE #IN ;
\ Prompt and fetch number of data points.
: GET_#POINTS ( -- )
BEGIN
CR ." Enter number of data points. "
GET# DUP 3 <
WHILE CR ." You need at least 3 data points!"
REPEAT 50 MIN #POINTS ! ;
\ Prompt and fetch all data points.
: GET_DATA ( -- )
CR CR ." Point " TAB ." X" TAB ." Y"
#POINTS @ 1+ 1
DO CR I 3 .R TAB GET# I X!
TAB GET# I Y! LOOP
#POINTS @ DUP X@ 0 X! Y@ 0 Y! ;
\ Sum data points.
: FIND_AREA ( -- )
0 AREA !
#POINTS @ 1+ 1 ( n+1 so we loop n times )
DO I X@ I 1- Y@ * ( X{i}*Y{i-1} )
I 1- X@ I Y@ * ( X{i-1}*Y{i} )
- AREA +!
LOOP ;
\ Calculate the distance between (x1,y1) and (x2,y2)
: DIST ( x2 y2 x1 y1 -- 100*d )
ROT - DUP * \ x2 x1 (y1-y2)^2
-ROT - DUP * \ (y1-y2)^2 (x2-x1)^2
+ 10000 UM* SQRT ; \ 100*d
\ Find the perimeter of the polygon saving result in the
\ Variable PERIMETER
: FIND_PERIMETER ( -- )
0 PERIMETER !
#POINTS @ 1+ 1
DO I X@ I Y@
I 1- X@ I 1- Y@
DIST PERIMETER +!
LOOP ;
\ Display computed area.
: PUT_AREA ( -- )
AREA @ 2 /MOD
CR ." AREA = " 6 .R ASCII . EMIT
IF ASCII 5 EMIT ELSE ASCII 0 EMIT THEN SPACE ;
\ Display computed perimeter.
: PUT_PERIMETER ( -- )
CR ." PERIMETER = "
PERIMETER @ I.XX ;
\ Compute area of polygon.
: POLY ( -- )
GET_#POINTS GET_DATA
FIND_AREA FIND_PERIMETER
PUT_AREA PUT_PERIMETER ;