File: PXSYMB.SB of Tape: Sources/Other/new-14

(Source file text) 

---

/	SUBROUTINE SYMBOL(ISYMB)

	ENTRY SYMBO

\JPLOT,	COMMN 3000
\JEXTR,	COMMN 2600	/*KLUDGE* \JPLOT REALLY STARTS AT 10000
\JCHRS,	COMMN 1400
\ICOMM,	COMMN 1
\FNAME,	COMMN 3
\IGREC,	COMMN 1
\IGCHR,	COMMN 1
\IDUDS,	COMMN 33
\IDASH,	COMMN 1
\IDSHC,	COMMN 1
\IDSHP,	COMMN 1
\X0,	COMMN 3
\Y0,	COMMN 3
\FAKTX,	COMMN 3
\FAKTY,	COMMN 3
\IFONT,	COMMN 1
\DXW,	COMMN 3
\DYW,	COMMN 3
\DXH,	COMMN 3
\DYH,	COMMN 3

	OPDEF TADI 1400
	LAP
PFONT,	\JCHRS		/ADDRESS OF SYMBOL TABLE
SCHAR,	BLOCK 1		/SYMBOL NUMBER
SPNT,	BLOCK 1		/POINTER TO SYMBOL
SWORD,	BLOCK 1		/CURRENT X,Y PAIR
\ISX,	BLOCK 1		/X SYMBOL VECTOR
\ISY,	BLOCK 1		/Y SYMBOL VECTOR
\IPEN,	BLOCK 1		/PENUP/PENDOWN
\ISXS,	BLOCK 1		/X VECTOR SIGN
\ISYS,	BLOCK 1		/Y VECTOR SIGN

	DUMMY \ISYMB
\ISYMB,	BLOCK 2
SYMBO,	BLOCK 2		/ENTRY SYMBOL
	TAD I SYMBO
	DCA \ISYMB
	INC SYMBO#	/GET ARG
	TAD I SYMBO
	DCA \ISYMB#
	INC SYMBO#
	TAD I \ISYMB
	CMA
	DCA SCHAR	/- SYMBOL -1
	DCA SKLUD	/RESET FLAG
	TAD \IFONT
	SZA CLA		/LOWER CASE FONT11 ?
	JMP SNLOC
	TAD (40
	TAD SCHAR	/LEGAL SYMBOL ?
	SMA
	JMP SBUG	/NO, MAKE BUG
	DCA SCHAR	/SHIFT TO LOWER END
SNLOC,	TAD \IFONT
	SPA SNA CLA	/CENTEREDS FONT3 ?
	JMP SNCENT
	TAD (33
	TAD SCHAR	/LEGAL SYMBOL ?
	SPA CLA
	JMP SBUG
SNCENT,	CLA IAC
	TAD \IFONT	/-1: FONT 1, 0:FONT 11, 1:FONT 3
	TAD PFONT	/SETS COMMON FIELD
	DCA SPNT	/POINTER TO FONT POINTERS
	TADI SPNT	/GET POINTER
	DCA SPNT	/SET POINTER TO FONT X
SFLP,	ISZ SCHAR
	SKP
	JMP SFND	/FOUND SYMBOL POSITION
EFLP,	TADI SPNT	/SCAN FOR END
	ISZ SPNT	/IF END FOUND, POINT AT START OF NEXT
	SMA CLA		/END = 4000
	JMP EFLP	/NOT YET
	JMP SFLP	/FOUND, RIGHT CHAR ?

SFND,	6211		/IN COMMON FIELD
	TADI SPNT	/GET XY ELEMENT
	ISZ SPNT	/AND GO TO NEXT
	DCA SWORD	/KEEP
	TAD SWORD
	TAD (-6000	/SPECIAL CENT.KLUDGE ?
	SZA CLA
	JMP SNKLU
	ISZ SKLUD	/SET FLAG FOR FINAL DOT
	JMP SFND	/AND TO NEXT CHAR
SNKLU,	TAD SWORD
	7002		/BSW
	AND (17
	DCA \ISX	/ABS X-VALUE
	TAD SWORD
	AND (17
	DCA \ISY	/ABS Y-VALUE
	TAD SWORD
	AND (40		/PEN DOWN ?
	SZA CLA
	IAC		/YES MAKE IPEN=3
	TAD (2		/NO  MAKE IPEN=2
	DCA \IPEN
	TAD SWORD
	CLL RTL		/X MINUS ?
	CLA RAR
	DCA \ISXS	/SET X SIGN
	TAD SWORD
	7002		/BSW
	CLL RTL
	CLA RAR
	DCA \ISYS	/SET Y SIGN
	TAD \IFONT
	SMA SZA CLA	/CENTEREDS ?
	JMP SCENT	/YES
	TAD \ISX	/NO, NORMAL SYMBOLS
	SPA		/X NEGATIVE ?
	CIA		/MAKE X POSITIVE ALWAYS
	DCA \ISX
SXPOS,	TAD \ISYS
	SMA CLA		/Y NEGATIVE ?
	JMP SPLOT	/NO, GO TO PLOT
	TAD \ISY
	CIA		/YES, MAKE Y -
	DCA \ISY
	JMP SPLOT
SCENT,	TAD (-7		/CENTS ARE OFFSET TO 07!07
	TAD \ISX
	DCA \ISX
	TAD (-7
	TAD \ISY
	DCA \ISY
	JMP SPLOT

	PAGE
\1000,	5063		/TEST FORMAT STATEMENT
	1165
	5100
]A,	BLOCK 3		/TEMP
IA1,	BLOCK 1
IA2,	BLOCK 1		/ARGS FOR PLOT

SPLOT,	TAD \ISX	/      SX=ISX
	CALL 0,FLOT
	CALL 1,STO
	ARG \SX

	TAD \ISY	/      SY=ISY
	CALL 0,FLOT
	CALL 1,STO
	ARG \SY

	CALL 1,FAD	/      IA1=X0+SX*DXW+SY*DXH
	ARG \DXW
	CALL 1,FMP
	ARG \SX
	CALL 1,STO
	ARG ]A
	CALL 1,FAD
	ARG \DXH
	CALL 1,FMP
	ARG \SY
	CALL 1,FAD
	ARG ]A
	CALL 1,FAD
	ARG \X0
	CALL 0,FIX
	DCA IA1

	CALL 1,FAD	/      IA2=Y0+SX*DYW+SY*DYH
	ARG \DYW
	CALL 1,FMP
	ARG \SX
	CALL 1,STO
	ARG ]A
	CALL 1,FAD
	ARG \DYH
	CALL 1,FMP
	ARG \SY
	CALL 1,FAD
	ARG ]A
	CALL 1,FAD
	ARG \Y0
	CALL 0,FIX
	DCA IA2

/	CALL 2,WRITE	/      WRITE(1,1000) IPEN,IA1,IA2
/	ARG (1
/	ARG \1000
/	CALL 1,IOH
/	ARG \IPEN
/	CALL 1,IOH	/ DEBUG WRITE ROUTINE
/	ARG IA1
/	CALL 1,IOH
/	ARG IA2
/	CALL 1,IOH
/	ARG 0
	JMP SEND
	PAGE
S15,	2047		/FOR MOVE TO NEXT POSITION
	4000
	0000
SKLUD,	0		/CENTER DOT FLAG
\SX,	BLOCK 3
\SY,	BLOCK 3

SEND,	CALL 3,PLOT	/      CALL PLOT(IPEN,IA1,IA2))
	ARG \IPEN
	ARG IA1
	ARG IA2
	TAD SWORD	/END OF SYMBOL ?
	SMA CLA
	JMP SFND	/NO, NEXT X,Y PAIR
	TAD \IFONT
	SPA SNA CLA	/CENTS ?
	JMP SNORM	/NO, ADJUST NORMALS TO NEXT CHAR
	TAD \ISYS	/YES, WAS Y - ?
	SPA CLA
	IAC		/YES, PEN DOWN
SFIN,	TAD (2		/NO, PEN UP FOR FINAL MOVE TO X0,Y0
	DCA \IPEN
	CALL 1,FAD
	ARG \X0
	CALL 0,FIX
	DCA IA1
	CALL 1,FAD
	ARG \Y0
	CALL 0,FIX
	DCA IA2
	CALL 3,PLOT
	ARG \IPEN
	ARG IA1
	ARG IA2
	TAD SKLUD	/FLAG SET ?
	SNA CLA
	JMP SRET
	TAD (3		/YES, MAKE FINAL DOT
	DCA \IPEN
	CALL 3,PLOT
	ARG \IPEN
	ARG IA1
	ARG IA2
SRET,	RETRN SYMBO

SNORM,	CALL 1,FAD	/      X0=X0+FAKTX*DXW
	ARG \DXW
	CALL 1,FMP
	ARG S15
	CALL 1,FAD
	ARG \X0
	CALL 1,STO
	ARG \X0

	CALL 1,FAD	/      Y0=Y0+FAKTY*DYW
	ARG \DYW
	CALL 1,FMP
	ARG S15
	CALL 1,FAD
	ARG \Y0
	CALL 1,STO
	ARG \Y0
	DCA SKLUD	/FORCE PENUP
	JMP SFIN

SBUG,	CLA
	TAD PFONT
	TAD (3		/SPECIAL BUG AT START OF TABLE
	DCA SPNT
	JMP SFND	/DRAW A BUG

	END

---