Jump to content
IGNORED

A circle with SINE and COSINE in the XFORTH


Recommended Posts

Graphics with XFORTH: PLOT, LINE, DRAW.

 

And a circle with SINE and COSINE.

 

HEX

00 VARIABLE DLIST -2 ALLOT
70 C, 70 C, 70 C,
4D C,  9060  ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D , 0D0D ,
0D0D , 0D0D , 0D0D ,  0D C,
42 C,  BF60  ,
0202 , 02 ,
41 C, DLIST ,

DECIMAL
00 VARIABLE SINUSTABELLE -2 ALLOT
0000 ,  0175 ,  0349 ,  0523 ,  0698 ,  0872 ,
1045 ,  1219 ,  1392 ,  1564 ,  1736 ,  1908 ,
2079 ,  2250 ,  2419 ,  2588 ,  2756 ,  2924 ,
3090 ,  3256 ,  3420 ,  3584 ,  3746 ,  3907 ,
4067 ,  4226 ,  4384 ,  4540 ,  4695 ,  4848 ,
5000 ,  5150 ,  5299 ,  5446 ,  5592 ,  5736 ,
5878 ,  6018 ,  6157 ,  6293 ,  6428 ,  6561 ,
6691 ,  6820 ,  6947 ,  7071 ,  7193 ,  7314 ,
7431 ,  7547 ,  7660 ,  7771 ,  7880 ,  7986 ,
8090 ,  8192 ,  8290 ,  8387 ,  8480 ,  8572 ,
8660 ,  8746 ,  8829 ,  8910 ,  8988 ,  9063 ,
9135 ,  9205 ,  9272 ,  9336 ,  9397 ,  9455 ,
9511 ,  9563 ,  9613 ,  9659 ,  9703 ,  9744 ,
9781 ,  9816 ,  9848 ,  9877 ,  9903 ,  9925 ,
9945 ,  9962 ,  9976 ,  9986 ,  9994 ,  9998 ,
10000 ,
HEX

230  CONSTANT SDLSTL
9060 CONSTANT SCREEN0
02C4 CONSTANT COLOR0
02C5 CONSTANT COLOR1
02C6 CONSTANT COLOR2
02C8 CONSTANT COLOR4

00 VARIABLE COL
00 VARIABLE CO0
00 VARIABLE CO1
00 VARIABLE CO2
00 VARIABLE CO3

00 VARIABLE X
00 VARIABLE Y
00 VARIABLE X0
00 VARIABLE Y0
00 VARIABLE X1
00 VARIABLE Y1
00 VARIABLE X2
00 VARIABLE Y2
00 VARIABLE DX
00 VARIABLE DY
00 VARIABLE SX
00 VARIABLE SY
00 VARIABLE ERR
00 VARIABLE E2
00 VARIABLE FAMIX
00 VARIABLE ZW

DECIMAL
: SINUS@ 2 * SINUSTABELLE + @ ;

: SIN ( GRAD -- SINUS )
  DUP 0< >R ABS
  360 MOD
  DUP 180 > IF 180 - -1 >R ELSE 0 >R THEN
  DUP  90 > IF 180 SWAP - THEN
  SINUS@
  R> IF -1 * THEN
  R> IF -1 * THEN ;

: COS 90 + SIN ;
HEX

: GCLS SCREEN0 C80 0 FILL ;

: COLOR
 DUP 0 = IF 0  CO0 !  0 CO1 ! 0 CO2 ! 0 CO3 ! THEN
 DUP 1 = IF 40 CO0 ! 10 CO1 ! 4 CO2 ! 1 CO3 ! THEN
 DUP 2 = IF 80 CO0 ! 20 CO1 ! 8 CO2 ! 2 CO3 ! THEN
  3 = IF C0 CO0 ! 30 CO1 ! C CO2 ! 3 CO3 ! THEN ;

: PLOT
 SWAP 4 /MOD 2 PICK
 DUP 0 = IF CO0 @ COL ! THEN
 DUP 1 = IF CO1 @ COL ! THEN
 DUP 2 = IF CO2 @ COL ! THEN
  3 = IF CO3 @ COL ! THEN
 FAMIX C@ 1 = IF SCREEN0 + SWAP DROP SWAP 28 * + DUP @  COL @ AND SWAP ! THEN
 FAMIX C@ 2 = IF SCREEN0 + SWAP DROP SWAP 28 * + DUP @  COL @ OR SWAP ! THEN
 FAMIX C@ 3 = IF SCREEN0 + SWAP DROP SWAP 28 * + DUP @  COL @ XOR SWAP ! THEN ;

: LINIE
 Y1 ! X1 ! Y0 ! X0 !
 X1 @ X2 ! Y1 @ Y2 !

 X1 @ X0 @ - ABS DX !

 X0 @ X1 @ <
 IF
   1 SX ! Y1 @ Y0 @ - ABS -1 * DY !
 ELSE
  -1 SX ! Y1 @ Y0 @ - ABS -1 * DY !
 THEN

 Y0 @ Y1 @ <
 IF
   1 SY ! DX @ DY @ + ERR !
 ELSE
   -1 SY ! DX @ DY @ + ERR !
 THEN

 X0 @ Y0 @ PLOT

 BEGIN
   X0 @  X1 @ = Y0 @ Y1 @ = AND 0 =
   WHILE
       2 ERR @ * E2 !
       E2 @ DY @ > IF ERR @ DY @ + ERR ! X0 @ SX @ + X0 ! THEN
       E2 @ DX @ < IF ERR @ DX @ + ERR ! Y0 @ SY @ + Y0 ! THEN
       X0 @ Y0 @ PLOT
   REPEAT ;

: DRAW
 Y1 ! X1 !
 X0 @ Y0 @ X1 @ Y1 @ LINIE ;

DECIMAL
: KREIS
 360 0 DO
   I SIN 32 10000 */ X !
   I COS 32 10000 */ Y !
   80 40 X @ 80 + Y @ 40 + LINIE
 10 +LOOP ;
HEX

: INIT
   0C COLOR4 C!
   94 COLOR2 C!
   DLIST SDLSTL !
   4 2BF C!
 2 COLOR
 2 FAMIX C! ;

post-31221-0-71741100-1327441412_thumb.jpg

Edited by funkheld
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...