perm filename ARROW.FAI[GEM,BGB] blob sn#046303 filedate 1973-06-06 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	NSUBR DPYARW,NODE
C00005 00003	----- DPYARW continued.
C00008 00004		END
C00009 ENDMK
C⊗;
NSUBR DPYARW,NODE
	ACCUMULATORS{FLG,N,V1,V2,DX1,DY1,DX2,DY2,X1,Y1}
	LAC N,NODE		;FETCH NODE IN QUESTION
	TESTZ N,NSEW↔POP1J	;MAKE SURE IT'S NOT OFF SCREEN
	PARROW V2,N		;AND THE OTHER END
	TEST V1,TBIT1		;HAVE WE BEEN HERE YET?
	GO [ MARK N,TBIT1↔POP1J];NO, MARK OUR PLACE AND RETURN
	TESTZ V2,NSEW↔POP1J	;CHECK FOR OFF SCREEN
	PVT V2,V2		;NOW GET SECOND VERTEX
	TESTZ V2,NSEW↔POP1J	;CHECK FOR OFF SCREEN
	PVT V1,N		;AND LASTLY THE FIRST VERTEX
	TESTZ V1,NSEW↔POP1J	;CHECK FOR OFF SCREEN
	XDC DX1,N		;Fetch coordinates of V1'
	YDC DY1,N
	XDC DX2,V2		;Fetch coordinates of V2
	YDC DY2,V2
	XDC 0,V1		;Fetch coordinates of V1
	YDC DY2,V1		;	   -→
	FSBR DX1,0		;Calculate E1
	FSBR DY1,1		;	   -→
	FSBR DX2,0		;Calculate E2
	FSBR DY2,1		;	-→
	FSC DX1,-1		;Divide E1 by 2.0
	FSC DY1,-1
	FADR 0,DX1		;This is the bisector of V1' and V2'
	FADR 1,DY1
	FADR 0,DX2
	FADR 1,DY2
	DAC 0,XCEN		;Save somewhere
	DAC 1,YCEN
	LAC 0,DX1		;Normalize
	LAC 1,DY1
	CALL DIST
	FDVR DX1,1
	FDVR DY1,1
	LAC 0,DX2		;Normalize
	LAC 1,DY2
	CALL DIST
	FDVR DX2,1
	FDVR DY2,1
	MOVN 0,DX2
	MOVN 1,DY2
	FMPR 0,K4
	FMPR 1,K4
	FADRM 0,XCEN
	FADRM 1,YCEN
	CALL HALF		;Do first half of arrow
	MOVN DX1,DX1		;		-→
	MOVN DX2,DX2		;Change sign of E1
	EXCH V1,V2		;Switch vertices
	PARROW N,N		;And Ynodes
	CALL HALF
	POP1J
;----- DPYARW continued.
DIST:	FMPR 0,0		;Calculate length of vector
	FMPR 1,1
	FADR 1,0
	CALL SQRT↑,1
	POP0J

HALF:	LAC X1,V1		;Draw extension
	LACI Y1,DX2
	LAC 0,K5
	CALL OFFAI
	LAC X1,N
	SETZ 0,
	CALL OFFAV
	LAC X1,N		;Upper wing of arrow
	LACI Y1,DX2
	LAC 0,K4
	CALL OFFAI
	PUSHP X1		;Save start of arrow
	PUSHP Y1
	LAC 0,DX1
	LAC 1,DY1
	FMPR 0,K1
	FMPR 1,K1
	LAC X1,DX2
	LAC Y1,DY2
	FMPR X1,K2
	FMPR Y1,K2
	FADR 0,X1
	FADR 1,Y1
	FIX 0,233000
	FIX 1,233000
	CALL RVECT,0,1
	MOVN 0,X1		;Now the lower wing
	MOVN 0,Y1
	FIX 0,232000		;(Doubles)
	FIX 1,232000
	CALL RIVECT,0,1
	CALL AVECT		;(With arguments saved above)
	MOVN X1,DX1		;The main line of arrow
	MOVN Y1,DY1
	FMPR X1,K3
	FMPR Y1,K3
	FADR X1,YCEN
	FADR Y1,YCEN
	SETO FLG
	GO FAV
OFFAI:	TDZA FLG,FLG
OFFAV:	SETO FLG,
	LAC 1,0
	JUMPE 0,.+4
	FMPR 0,(Y1)
	FMPR 0,1(Y1)
	YDC Y1,X1
	XDC X1,X1
	FADR X1,0
	FADR Y1,1
FAV:	FIX X1,233000
	FIX Y1,233000
	JUMPE FLG,[CALL AIVECT,X1,Y1
		   POP0J]
	CALL AVECT↑,X1,Y1
	POP0J
K1:	12.0
K2:	5.0
K3:	3.0
K4:	10.0
K5:	2.0
	DECLARE{XCEN,YCEN}
SUBREND DPYARW
	END