        PROGRAM PHASOR
C               L. R. FORTNEY   1/31/81 on a Z80
C		Working on Atari 10/9/87
C	  This program draws two rotating phasors on the complex plane and
C	displays their x-projection as the phasors rotate.  The amplitude
C	and frequency of one phasor is adjustable using the arrow keys.  The
C	projected display can be of both phasors separately or of their summed
C	signal.  Useful for showing beats.
C	   Works only on hi-res mono displays.
C    
        PARAMETER (KEYLA=Z'004B0000',KEYRA=Z'004D0000',
     1             KEYUA=Z'00480000',KEYDA=Z'00500000',
     2	           KEYTAB=Z'000F0009',KEYCR=Z'001C000D')
	INTEGER*1 BTFLAG,BMASK
        DIMENSION SN(256),CN(256)
	DATA TVMULT,MASK,BMASK/1.0,Z'FF',Z'FF'/
C    
C               DEVELOP SIN COS LISTS
C			SHOW INSTRUCTIONS
	WRITE(9,1000)
 1000	FORMAT(' CONTROL KEYS ARE:'/' TAB = INCREMENT MODE'/
     1	' NUMBER KEY = SET MODE'/
     2	' CR = EXIT PROGRAM'/' OTHER KEY = PAUSE/RESTART')
	WRITE(9,1002)
 1002	FORMAT(//' MODES ARE: 0,1,2,3,0,1 ETC.'/
     1	' 0=TWO PHASORS AROUND ORIGIN'/' 1=TWO PHASORS SUMMED'/
     2	' 2=TWO AND SUM'/' 3=SUM ONLY'//)
	WRITE(9,1003)
 1003	FORMAT(' MAGNITUDE AND FREQUENCY OF INNER PHASOR CHANGEABLE'/
     1	/' USING ARROW KEYS:  LEFT,RIGHT FOR MAG   UP,DOWN FOR FREQ'//
     2  ' CR TO CONTINUE')
C    
	PAUSE
C
	CALL RESETS
C    
        DO 50 I=1,64
	ANG=(I-1)*0.024544
        S=SIN(ANG)
        C=COS(ANG)
        SN(I)=S
        CN(I)=C
        SN(I+64)=C
        CN(I+64)=-S
        SN(I+128)=-S
        CN(I+128)=-C
        SN(I+192)=-C
        CN(I+192)=S
 50     CONTINUE
C    
C               SIN COS LIST HAS FULL CIRCLE IN 256 INC.
 100	AL=80.0
	DAL=5.0
        LAL=AL
	BL=70.0
        LBL=BL
	WA=1.5
	DWA=0.2
	WB=2.0
	IAX=400
	IAY=280
	LOOP=0
	MODE=0
C
200	CALL CLEARS
C		CLEAR VECTOR DRAWN FLAGS IN ARROW SUBROUTINE
	CALL EARROW(11)
C		STOP VECTOR DRAWING ON FIRST POINT
	IASAVE=9999
	IBSAVE=9999
	ISSAVE=9999
C			TITLE THE PLOT
	CALL SCTEXT(4,140,383,'PHASORS')
	CALL COMPR(136,379,228,395)
C		ADD AUTHOR INFO
	CALL SCTEXT(0,100,1,
     1    'L. R. Fortney, Physics Dept, Duke Univ., Genie:DUKEL')
C    
C			RESTART HERE AFTER FULL CIRCLE
C		DRAW AXIES
	IXL=IAX-150
	IXR=IAX+150
	CALL PLOTP(IXL,IAY)
	CALL PLOTV(IXR,IAY)
	IY=IAY-50
	CALL PLOTP(IAX,IY)
	CALL PLOTV(IAX,399)
	CALL SCTEXT(4,IAX+100,IAY-23,'REAL')
	CALL COMPR(IAX+95,IAY-26,IAX+150,IAY-10)
	CALL SCTEXT(6,IAX-8,320,'IMAG')
	CALL COMPR(IAX-20,318,IAX-4,364)
C    
	CALL PLOTP(30,0)
	CALL PLOTV(30,399)
	CALL SCTEXT(6,20,50,'Projection on real axis')
	CALL COMPR(4,48,26,328)
C    
	KIN=KEY(ISTAT)
C     
	CALL CARROW(4)
	CALL PLOTP(30,150)
	CALL PLOTV(599,150)
	CALL CARROW(5)
	CALL PLOTP(IAX,IAY)
	CALL PLOTV(IXR,IAY)
	CALL CARROW(6)
	CALL SCTEXT(4,440,123,'time')
	CALL COMPR(438,120,492,136)
C     
C               START MOVEMENT
	A=0.0
	B=0.0
	IT=30
	BTFLAG=0
C		CONTINUE MOVEMENT AFTER MODE CHANGE
 300	A=A+WA
	B=B+WB
	IA=A
	IB=B
	BTFLAG=BTFLAG.XOR.BMASK
	IF(BTFLAG.EQ.0) IT=IT+1
	IA=1+((IA-1).AND.MASK)
	IB=1+((IB-1).AND.MASK)
	IXA=AL*CN(IA)*TVMULT
	IYA=AL*SN(IA)
	LAL=SQRT(FLOAT(IXA**2)+FLOAT(IYA**2))
	IXB=BL*CN(IB)*TVMULT
	IYB=BL*SN(IB)
	LBL=SQRT(FLOAT(IXB**2)+FLOAT(IYB**2))
	IXS=IXA+IXB
	IYS=IYA+IYB
	IF(BTFLAG.EQ.0) GO TO 530
	IF(IT.GT.599) GO TO 530
C			PLOT ONLY IF IN SEPERATE MODE
 510	IF(MODE.EQ.0) THEN
	  IXAPLOT=IXA+150
	  CALL PLOTP(IT,IXAPLOT)
	  IF(IASAVE.NE.9999) CALL PLOTV(IT-1,IASAVE)
	  IASAVE=IXAPLOT
C
	  IXBPLOT=IXB+150
	  CALL PLOTP(IT,IXBPLOT)
	  IF(IBSAVE.NE.9999) CALL PLOTV(IT-1,IBSAVE)
	  IBSAVE=IXBPLOT
	ELSE
C			PLOT ONLY IN SUMMED MODE
 	  IXSPLOT=IXS+150
	  CALL PLOTP(IT,IXSPLOT)
	  IF(ISSAVE.NE.9999) CALL PLOTV(IT-1,ISSAVE)
	  ISSAVE=IXSPLOT
	ENDIF
C    
C               NOW READY TO PLOT THIS INSTANT
 530	JAX=IAX+IXA
	JAY=IAY+IYA
	IF(MODE.GE.3) GO TO 540
	CALL CARROW(4)
	CALL ARROW(4,IAX,IAY,LAL,JAX,JAY)
 540	IBX=IAX+IXA
	IBY=IAY+IYA
	JBX=IAX+IXS
	JBY=IAY+IYS
	IF(MODE.NE.0) GO TO 550
	CALL CARROW(5)
	IX=IXB+IAX
	IY=IYB+IAY
	CALL ARROW(5,IAX,IAY,LBL,IX,IY)
	GO TO 600
C    
 550	IF(MODE.NE.1 .AND. MODE.NE.2) GO TO 560
	CALL CARROW(5)
	CALL ARROW(5,IBX,IBY,LBL,JBX,JBY)
 560	IF(MODE.LT.2) GO TO 600
	LCL=SQRT(FLOAT(IXS**2) +FLOAT(IYS**2))
	CALL CARROW(6) 
	CALL ARROW(6,IAX,IAY,LCL,JBX,JBY)
C    
C		TEST KEYBOARD WITHIN MAIN LOOP
 600	KIN=KEY(ISTAT)
	IF(ISTAT.EQ.0) GO TO 800
C
	SELECT CASE(KIN)
	  CASE (KEYLA)
C		LEFT ARROW REDUCES A MAGNITUDE
	    AL=AL-DAL
	    IF(AL.LT.10.0) AL=10.0
	    LAL=AL
	  CASE (KEYTAB)
C		TAB CHANGES MODE
	    MODE=(MODE+1).AND.3
	    DO (I=4,6)
	      CALL CARROW(I)
	    ENDDO 
	    IF(MODE.EQ.0) GO TO 200
	  CASE (KEYDA)
C		DOWN ARROW REDUCES WA (A FREQ)
	    WA=WA-DWA
	    IF(WA.LT.1.0) WA=1.0
	  CASE (KEYUA)
C		UP ARROW INCREASES WA
	    WA=WA+DWA
	    IF(WA.GT.10.0) WA=10.0
	  CASE (KEYRA)
C		RIGHT ARROW INCREASES A MAGNITUDE
	    AL=AL+DAL
	    IF(AL.GT.100.0) AL=100.0
	    LAL=AL
	  CASE (KEYCR)
C		CR EXITS THE PROGRAM
	    GO TO 999
	  CASE DEFAULT
C		CHECK FOR NUMBER KEY 0-3 TO SET MODE
	    IF((KIN.AND.Z'000000F0').NE.Z'30') GO TO 690
 	    KEYM=KIN.AND.Z'0000000F'
	    IF(KEYM.GT.3) GO TO 690
	    MODE=KEYM
	    DO (I=4,6)
	      CALL CARROW(I) 
	    ENDDO
	    IF(MODE.EQ.0) GO TO 200
	    GO TO 800
	END SELECT
	GO TO 300
C		OTHER KEY PAUSES AND WAITS FOR SECOND KEY
 690	KIN=KEY(ISTAT)
	IF(ISTAT.EQ.0) GO TO 690
C     
 800	IF(IT.LT.599) GO TO 300
	GO TO 200
C    
 999	END
C
	SUBROUTINE ARROW(K,IX,IY,LNG,IXE,IYE)
	COMMON /ARRPTS/ ISTATE(10),IKX(4,10),IKY(4,10)
C    
C			ERASE AN OLD ARROW WITH EARROW(K)
C			      DRAW NEW ARROW
C			USE "1"OR"2" AS INDEX FOR ARROWS WITH
C			SMALL ARROWHEADS. USE "3" FOR ARROW WITH
C			LARGE ARROWHEAD.  "4"-"10" FOR ARROWHEADS
C			PROPORTIONAL TO LENGTH OF ARROW.
     
	IF(K.GT.0 .AND. K.LE.10) GO TO 60
	WRITE(9,1000)
 1000	FORMAT(10X,'PARAMETER FOR ARROW IS TOO LARGE')
	GO TO 999 
C    
 60	ISTATE(K)=1 
	IDX=IX-IXE
	IDY=IY-IYE
C		THESE SIN COS POINT FROM END TO START
	LONG=LNG
	IF(LONG.LE.0) LONG=1
	ICN=(60*IDX)/LONG
	ISN=(60*IDY)/LONG
	IKX(4,K)=IXE
	IKY(4,K)=IYE
	IKX(1,K)=IX
	IKY(1,K)=IY
	ICUT=LNG/20
	IF(ICUT.LT.5) ICUT=5
	IF(ICUT.GT.7) ICUT=7
	ICNS=25*ICN
	ICNC=25*ICN
	ISNS=25*ISN
	ISNC=25*ISN
	IAX1=((ICNC +ISNS)*ICUT)/3000
	IAY1=((ISNC -ICNS)*ICUT)/3000
	IAX2=((ICNC -ISNS)*ICUT)/3000
	IAY2=((ISNC +ICNS)*ICUT)/3000
	IKX(2,K)=IXE +IAX1
	IKY(2,K)=IYE +IAY1
	IKX(3,K)=IXE +IAX2
	IKY(3,K)=IYE +IAY2
C     
	DO 240 I=1,3
	CALL COMPP(IXE,IYE)
	IXP=IKX(I,K)
	IYP=IKY(I,K)
	CALL COMPV(IXP,IYP)
 240	CONTINUE
 999	RETURN
	END 
C    
C    
	SUBROUTINE EARROW(KV)
C	       ERASE DISPLAY FOR ARROW
	COMMON /ARRPTS/ ISTATE(10),IKX(4,10),IKY(4,10)
C    
C		KV=0 WILL CLEAR ALL STATE FLAGS
C		KV.GT.10 WILL CLEAR ALL FLAGS AND ERASE ALL VECTORS
	K=KV 
	IF(K.GT.0 .AND. K.LE.10) GO TO 50
	DO 8 I=1,10
 8	ISTATE(I)=0
C     
	IF(K.LE.0) GO TO 90
	DO 30 K=1,10
	ISTATE(K)=0
	DO 30 I=1,3
	CALL ERASP(IKX(4,K),IKY(4,K))
 30	CALL ERASV(IKX(I,K),IKY(I,K))
	GO TO 90
C     
 50	DO 60 I=1,3
	CALL ERASP(IKX(4,K),IKY(4,K))
 60	CALL ERASV(IKX(I,K),IKY(I,K))
 90	RETURN
	END 
C    
C    
	SUBROUTINE CARROW(K)
C	       COMPLEMENT DISPLAY FOR ARROW
	COMMON /ARRPTS/ ISTATE(10),IKX(4,10),IKY(4,10)
	IF(K.LT.1 .OR. K.GT.10) GO TO 90
	IF(ISTATE(K).EQ.0) GO TO 90 
	ISTATE(K)=0
C     
	DO 20 I=1,3
	CALL COMPP(IKX(4,K),IKY(4,K))
 20	CALL COMPV(IKX(I,K),IKY(I,K))
 90	RETURN
	END  
C    
C    
	FUNCTION KEY(ISTAT)
C		READ KEYBOARD WITH NO HANG
C		ISTAT=0 AND KEY=-1 IF NO CHARACTER AVAILABLE TO RETURN
C		OTHERWISE
C		ISTAT=-1 AND LOW BYTE OF KEY CONTAINS ASCII CODE
	include \lib\includes\gemdos.inc
	integer*4 atari 
	ISTAT=atari(Cconis)
	IF(ISTAT.EQ.0) THEN
	  KEY=-1
	  RETURN
	ENDIF
	KEY=atari(Cnecin)
	RETURN
	END
