perm filename GEOMED[GEM,BGB] blob sn#032384 filedate 1973-04-01 generic text, type T, neo UTF8
00100	TITLE GEOMED  -  GEOMETRIC EDITOR  -  BGB  -  JANUARY 1973.
00200	
00300	;EDITOR STATUS.
00400	
00500		PDL:BLOCK =500		;GEOMED'S INTERNAL STACK.
00600		PAT:BLOCK 40↔INTERN PAT
00700		PDLPTR:XWD -100,PADPDL	;GEOMED'S GRAPHICS STACK.
00800		PADPDL:BLOCK 100
00900		↓PTR←←16		;PADPDL STACK POINTER AC.
01000	
01100	;JUMP TABLE COMMAND SCANNER STATUS.
01200	
01300		DECLARE{CHR,MCBITS,CTRL,META,MTCT,ALPHA,BETA}
01400	
01500	;STRENGTH OF EUCLIDEAN TRANSFORMATION.
01600	
01700		TDEL:	1.0	;TRANSLATION DELTA STRENGTH.
01800		RDEL:	0.785398;ROTATION DELTA STRENGTH.
01900		DDEL:	0↔0.75	;DILATION DELTA STRENGTH.
02000	
02100		OPERAT:	0	;DEFAULT EUCLIDEAN OPERATION.
02200		FRAAM:	0	;FRAME OF REFERENCE.
02300		FRMORG:	0	;USE FRAME OF REFERENCE ORIGIN.
02400		AXECNT:	1	;NUMBER OF AXES TO USE.
02500		ITERAT:	0	;NUMBER OF ITERATIONS.
02600	
02700		FLAGL:	-1	;"L" COMMAND SWITCH. LABEL LIGHTS.
02800		FLAGD:	0	;"∂" NODE DISPLAY.
02900		DPYFLG:	2	;GEODPY STICKY DISPLAY MODE.
03000	
03600	;WING OPERATIONS.
03700		EXTERN MKB,MKF,MKE,MKV,MKFRAME
03800		EXTERN KLB,KLF,KLE,KLV,WING
03900		EXTERN WING,LINKED
04000		EXTERN ECW,ECCW,OTHER,OTHER.
04100		EXTERN BGET,FCW,FCCW,VCW,VCCW
04200	;EULER OPERATIONS.
04300		EXTERN MKEV,MKFE
04310		INTERN CAMERA↔CAMERA:0
04410		WORLD:0
04510		WINDOW:0
04610		EXTERN KLNODE,UNIVER,OLD44,AVAIL
     

00100	;START ADDRESS INITIALIZATION-------------------------------------
00200	SA:	JFCL↔SETOM ALONE#
00210		SKIPE 1,OLD44↔CORE 1,↔JFCL↔SETZM OLD44
00300		SKIPA 17,[IOWD =500,PDL]
00350	GEONIT:	SETZM ALONE↔INTERN GEONIT	;GEOMETRIC MODEL INIT.
00400	
00500	;CREATE A GEOMED UNIVERSE.
00600		EXTERN MKWORLD,MKCAMERA,MKWINDOW
00700		SETZB AVAIL	;...SO THAT @AVAIL IS ZERO.
00800		SETQ(WORLD,{MKWORLD})
00900		SETQ(CAMERA,{MKCAMERA})
01000		SETQ(WINDOW,{MKWINDOW})
01100		LAC 2,CAMERA↔ALT. 2,1
01200		LAC 2,WORLD↔ALT2. 2,1
01300	
01400	;SETUP STRENGTH OF TRANSFORMATION VALUES.
01500		LAC[1.0]↔DAC TDEL	;TRANSLATION STRENGTH.
01600		LAC[0.75]↔DAC DDEL	;DILATION STRENGTH.
01700		LAC[0.785398]↔DAC RDEL	;ROTATION STRENGTH π/4.
01800		SETZM FRAAM		;SELECT WORLD FRAME.
01900		SETZM FRMORG
02000		SETOM FLAGL		;TURN ON THE LIGHTS.
02100		LACI 1↔DAC AXECNT	;ONE AXIS SELECT.
02200		SETZM OPERAT		;TRANSLATION DEFAULT.
02300		LAC[XWD -100,PADPDL]↔DAC PDLPTR
02350		SKIPN ALONE↔POP0J
02400	
02500	;RE-ENTRY ADDRESS INITIALIZATION----------------------------------
02600	REE:	LACI .↔DAC 124
02700		LAC 17,[IOWD =500,PDL]
02800		OPDEF PPIOT[702B8]
02900		PPIOT 2,-=250↔PPIOT 3,3003
03000		CALL(CRLF20)
03100		CALL(GEODPY)
03150		CALL(UNDERFLOW)
03200		CALL(GEOMED)
03300		CALLI 12
03400	
03500	;2/4/73-----------------------------------------------------------
     

00100	SUBR(UNDERFLOW)---------------------------------------------------
00200	BEGIN "UNDERFLOW"; ENABLE & SERVICE ARITHMETIC INTERRUPTS.
00300		EXTERNAL JOBTPC,JOBAPR
00400	
00500	;ENABLE INTERRUPT ROUTINE.
00600		MOVEI 2,10	;17
00700		JFCL 17,.+1;	CLEAR ANY PREVIOUSLY SET FLAGS
00800		SUB 17,[1(1)]
00900		MOVEI 1,FLTOV
01000		MOVEM 1,JOBAPR
01100		CALLI 2,16	;SET APR FLAGS
01200		MOVE 1,1(17)
01300		TLZ 1,440140	;CLEAR PREV FLAGS
01400		JRST 2,@1	;JUMP AND REALLY RESET.
01500	
01600	;JOB APR USER INTERRUPT ROUTINE.
01700	FLTOV:	MOVEM 1,SAVE1
01800		MOVE 1,JOBTPC
01900		TLNN 1,100↔JRST OV	;SKIP ON FLOATING UNDERFLOW.
02100		MOVE 1,-1(1)	;get opcode which caused it
02200		TLNN 1,40000	;test for standard flt pt opcode
02300		TLZ 1,2000	;change for FSC
02400		DPB 1,[POINT 29,.+2,35]	;modify the SETZ 
02500		MOVE 1,SAVE1	;restore ACs
02600		SETZ 0,		;zero ac and/or memory
02700		MOVEM 1,SAVE1
03300	WO:	MOVE 1,JOBTPC
03400		TLZ 1,440140	;zero the error bits
03500		MOVEM 1,JOBTPC
03600		MOVE 1,SAVE1	
03700		JRST 2,@JOBTPC	;return
03800		
03900	OV:	TLNN 1,40000	;was it a floating overflow?
04000		JRST ZDIV	;no
04300		MOVE 1,BP2
04400		JSR NUMOUT
04500		OUTSTR  MESS2
04600		JRST WO
04700	
04800	ZDIV:	TLNN 1,40	;zero divide?
04900		JRST NOTIN	;no
05200		MOVE 1,BP4
05300		JSR NUMOUT
05400		OUTSTR  MESS4
05500		JRST WO
05600	
05900	NOTIN:	MOVE 1,BP3
06000		JSR NUMOUT
06100	 	OUTSTR  MESS3
06200		JRST WO
06300	
06400	NUMOUT:	0
06500		MOVEM 1,XPTR
06600		MOVEM 2,SAVE2
06700		MOVEI 2,6
06800		MOVE 1,JOBTPC
06900		HRLZI 1,-1(1)
07000	L1:	ROT 1,3
07100		IORI 1,60
07200		IDPB 1,XPTR
07300		HLRI 1,
07400		SOJG 2,L1
07500		MOVE 2,SAVE2
07600		JRST @NUMOUT
07700	
07800	XPTR:	0
08300	SAVE1:	0
08400	SAVE2:	0
08600	BP2:	POINT 7,MESS2+6,13
08700	BP3:	POINT 7,MESS3+4,20
08800	BP4:	POINT 7,MESS4+5,13
09100	MESS2:	ASCIZ/FLOATING OVERFLOW OCCURED, PC = 000000/
09200	MESS3:	ASCIZ/OVERFLOW OCCURED, PC = 000000/
09300	MESS4:	ASCIZ /ZERO DIVIDE OCCURED, PC = 000000/
09400	BEND 
     

00100	SUBR(GEODPY)------------------------------------------------------
00200	BEGIN GEODPY; GEOMED'S DISPLAY REFRESH - BGB - 12 FEBRUARY 1973.
00300	
00400		EXTERN SHOW1,SHOW2,SHOW3,SHOW4
00500		LACI 1↔DAC GLASS#
00600		LAC 1,UNIVERSE
00700		SON 1,1↔DAC 1,W0↔DAC 1,W
00800	L1:	$TYPE 0,1↔CAIE $WINDOW↔GO L2
00900		PUSH P,1↔PUSH P,GLASS↔LAC 1,DPYFLG
01000		PUSHJ P,@[SHOW2↔SHOW3↔SHOW1↔SHOW4](1)
01100		AOS GLASS
01200	L2:	LAC 1,W↔BRO 1,1↔DAC 1,W
01300		CAME 1,W0↔GO L1↔POP0J
01400		DECLARE{W,W0}
01500	
01600	BEND GEODPY; BGB 12 MARCH 1973 -----------------------------------
     

00100	SUBR(STADPY)------------------------------------------------------
00200	BEGIN STADPY;STATUS DISPLAY - BGB - 1/12/73
00300		EXTERN DECDPY,DPYSTR,FDPY,EDPY,VDPY,DTYO,IDPY
00400		EXTERN AIVECT,AVECT,BUFDPY,FLODPY,DPYOUT,DPYSET
00500		EXTERN DPYBUF
00600		LAC 1,BUFDPY
00650		SKIPE FLAGL↔LAC 1,DPYBUF
00700		CALL(DPYSET,1)
00800	
00900	;STATUS OF FRAME SELECT.
01000		CALL(AIVECT,[=180],[=500])
01100		LAC 1,FRAAM
01200		PUSH P,[
01300			[ASCIZ/WORLD/]
01400			[ASCIZ/BODY/]
01500			[ASCIZ/RELATIVE/]
01600			[ASCIZ/CAMERA/]](1)
01700		CALL(DPYSTR)
01800	
01900	;STATUS OF FRAME ORIGIN SWITCH.
02000		LACI[ASCIZ/ FRAME/]
02100		SKIPE FRMORG
02200		LACI[ASCIZ/ FRAME */]
02300		CALL(DPYSTR,0)
02400	
02500	;STATUS OF OPERAT SELECT SWITCH.
02600		CALL(AIVECT,[=390],[=500])
02700		LAC 1,OPERAT
02800		PUSH P,[
02900			[ASCIZ/TRANSLATION/]
03000			[ASCIZ/ROTATION/]
03100			[ASCIZ/DILATION/]
03200			[ASCIZ/REFLECTION/]](1)
03300		CALL(DPYSTR)
03400	
     

00100	;TRANSLATION STRENGTH.
00200		CALL(AIVECT,[=185],[=480])
00300		CALL(FLODPY,TDEL,[4])
00400		CALL(DPYSTR,{[[ASCIZ/ FEET/]]})
00500	
00600	;ROTATION STRENGTH IN PI FRACTION.
00700		CALL(AIVECT,[=185],[=460])
00800	L1:	LAC RDEL↔LAC 1,[3.15]
00900		CAMLE[6.28]↔GO L2
01000		CAML[2.0]↔GO[FSC 1,1↔PUSH P,1
01100			CALL(DTYO,["2"])↔POP P,1
01200			GO .+1]
01300		FDVR 1,RDEL↔FIX 1,233000↔PUSH P,1
01400		CALL(DPYSTR,{[[ASCIZ"π/"]]})
01500		CALL(DECDPY)
01600	L2:
01700	
01800	;ROTATION STRENGTH IN RADIANS.
01900		CALL(AIVECT,[=400],[=460])
02000		CALL(FLODPY,RDEL,[3])
02100	
02200	;RDEL IN DEGREES, MINUTES AND SECONDS.
02300		CALL(AIVECT,[=270],[=460])
02400		LAC 1,RDEL
02500		FMPR 1,[206264.806]
02600		FIX 1,233000
02700		AOS 1
02800		IDIVI 1,=3600
02900		IDIVI 2,=60
03000		PUSH P,3
03100		PUSH P,2
03200		PUSH P,1
03300		CALL(DECDPY)↔CALL(DTYO,[" "])
03400		CALL(DECDPY)↔CALL(DTYO,[" "])
03500		CALL(DECDPY)
03600	
03700	;DILATION STRENGTH.
03800		CALL(AIVECT,[=390],[=480])
03900		LAC DDEL↔FMP[100.0]↔FADR[0.001]
04000		CALL(FLODPY,0,[2])
04100		CALL(DTYO,["%"])
04200		CALL(DTYO,[" "])
04300		LAC AXECNT↔ADDI 60↔CALL(DTYO,0)
     

00100	;DISPLAY THE SCRATCH PAD PDL.
00200		CALL(AIVECT,[-=511],[=430])
00300		CDR 16,PDLPTR
00400		CAILE 16,PADPDL↔GO[
00500			CALL(IDPY,{(16)})
00600			CALL(DTYO,[15])↔CALL(DTYO,[12])
00700			SOJA 16,.-1]
00800		SKIPN FLAGL↔GO L3
00900	
01000	;DISPLAY TOP OBJECT OF PADPDL.
01100		CDR 16,PDLPTR
01200		CAILE 16,PADPDL↔GO[
01300			LAC 1,(16)
01400			TESTZ 1,VBIT↔GO[CALL(VDPY,1)↔GO .+1]
01500			TESTZ 1,EBIT↔GO[CALL(EDPY,1)↔GO .+1]
01600			TESTZ 1,FBIT↔GO[CALL(FDPY,1)↔GO .+1]
01700			GO .+1]
01800	;DISPLAY THE SECOND OBJECT WHEN APPROPRIATE.
01900		CDR 16,PDLPTR
02000		CAILE 16,PADPDL+1↔GO[
02100			LAC 1,-1(16)↔LAC 2,(16)
02200			LAC 0,(1)↔IOR 0,(2)↔LDB[POINT 3,0,16]
02300			CAIE 6↔CAIN 3↔SKIPA↔GO .+1
02400			CALL(LINKED,1,2)↔JUMPE 1,.+1
02500			LAC 1,-1(16)
02600			TESTZ 1,VBIT↔GO[CALL(VDPY,1)↔GO .+1]
02700			TESTZ 1,EBIT↔GO[CALL(EDPY,1)↔GO .+1]
02800			TESTZ 1,FBIT↔GO[CALL(FDPY,1)↔GO .+1]
02900			GO .+1]
03000	
03100	L3:	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔GO L4↔LAC 1,(1)
03200		SKIPE FLAGD↔GO[CALL(DPYNODE,1)↔GO L4]
03300	L4:	CALL(DPYOUT,[0])
03400		POP0J
03500	BEND;2/4/73-------------------------------------------------------
     

00100	SUBR(NTYPE)NODE --------------------------------------------------
00200	;NODE TYPE NUMBER 0 TO 17.
00300		LAC 1,@ARG1		;TYPE BITS WORD.
00400		SKIPGE 1↔SETZ 1,	;NEGATIVE BIT.
00500		TLNE 1,(1B9)↔SETZ 1,	;NORMALIZATION BIT.
00600		ANDI 1,17↔POP1J
00700	;NTYPE BGB 25 MARCH 1973 -----------------------------------------
00800	
00900	NNAMES:↔INTERN NNAMES	;NODE NAMES.
01000	   [ASCIZ"FRAME"]↔[ASCIZ"EMPTY"]↔[ASCIZ"UNIVERSE"]↔[ASCIZ"LAMP"]
01100	   [ASCIZ"CAMERA"]↔[ASCIZ"WORLD"]↔[ASCIZ"WINDOW"]↔[ASCIZ"IMAGE"]
01200	   [ASCIZ"TEXT"]↔[ASCIZ"NODE11"]↔[ASCIZ"NODE12"]↔[ASCIZ"NODE13"]
01300	   [ASCIZ"BODY"]↔[ASCIZ"FACE"]↔[ASCIZ"EDGE"]↔[ASCIZ"VERTEX"]
01400	
01500	NLETTER:	↔INTERN NLETTER		;NODE INITIALS.
01600		"R" ↔ "M" ↔ "U" ↔ "L"
01700		"C" ↔ "W" ↔ "D" ↔ "I"
01800		"T" ↔ "X" ↔ "Y" ↔ "Z"
01900		"B" ↔ "F" ↔ "E" ↔ "V"
02000	
02100	SUBR(JDPY)NODE ---------------------------------------------------
02200	BEGIN
02300		SKIPN 1,ARG1↔GO[CALL(DPYSTR,{[[ASCIZ/NIL/]]})↔POP1J]
02400		CAMGE 1,UNIVERSE↔GO L
02500		CAML  1,44↔GO L
02600		CALL(NTYPE,1)
02700		CALL(DTYO,{NLETTER(1)})
02800	L:	CALL({OCTDPY+1},ARG1)
02900		POP1J
03000	BEND;BGB 25 MARCH 1973 -------------------------------------------
03100	
03200	
     

00100	;NODE RELLOCATION BITS.
00200	; 0  1  2| 3  4  5| 6  7  8| 9 10 11|12 13 14|15 16 17|  ← BIT.
00300	; 0  0  0| 0  0  0| 8  7  6| 5  4  3| 2  1  0|-1 -2 -3|	← WORD.
00400	;
00500	
00600	REL:	XWD	0000,	0000	;FRAME.
00700		XWD	0000,	0001	;EMPTY.
00800		XWD	0000,	0202	;UNIVERSE.
00900		XWD	0000,	0000	;LAMP.
01000	
01100		XWD	0600,	1600	;CAMERA.
01200		XWD	2640,	3660	;WORLD.
01300		XWD	1600,	1600	;WINDOW.
01400		XWD	0760,	0760	;IMAGE.
01500	
01600		XWD	0000,	0000	;TEXT.
01700		XWD	0000,	0000	;XNODE.
01800		XWD	0000,	0000	;YNODE.
01900		XWD	0000,	0000	;ZNODE.
02000	
02100		XWD	3760,	3760	;BODY.
02200		XWD	1020,	1060	;FACE.
02300		XWD	3760,	3760	;EDGE.
02400		XWD	0160,	0160	;VERTEX.
02500	
02600	;NODE CONTENT TYPES.
02700	
02800	CONTYP:	BYTE(9)333,333,333,333	;FRAME.
02900		BYTE(9)000,000,000,000	;EMPTY.
03000		BYTE(9)000,040,001,000	;UNIVERSE.
03100		BYTE(9)000,000,001,000	;LAMP.
03200	
03300		0			;CAMERA.
03400		0			;WORLD.
03500		0			;WINDOW.
03600		0			;IMAGE.
03700	
03800		0			;TEXT.
03900		0			;XNODE.
04000		0			;YNODE.
04100		0			;ZNODE.
04200	
04300		BYTE(9)044,444,441,220	;BODY.
04400		BYTE(9)004,033,041,333	;FACE.
04500		BYTE(9)044,444,441,000	;EDGE.
04600		BYTE(9)003,334,411,333	;VERTEX.
     

00100	SUBR(DPYNODE)NODE ------------------------------------------------
00200	BEGIN DPYNODE; DISPLAY CONTENTS OF NODE LOWER RIGHT OF SCREEN.
00300		EXTERN AIVECT,AVECT,DPYBIG
00400		EXTERN DTYO,IDPY,DPYSTR,FLODPY,DECDPY,OCTDPY
00500	
00600		CALL(AIVECT,[=300],[-=70])
00700		CALL(AVECT,[=300],[-=380])
00800		CALL(AVECT,[=508],[-=380])
00900		CALL(AVECT,[=508],[-=70])
01000		CALL(AVECT,[=300],[-=70])
01100	
01200		CALL(DPYBIG,[1])
01300		CALL(JDPY,ARG1)
01400		CALL(DPYSTR,{[[ASCIZ"   "]]})
01500		SETQ(KIND,{NTYPE,ARG1})
01600		LAC REL(1)↔DAC RELTMP		;RELLOCATION.
01700		LAC CONTYP(1)↔DAC CONTMP	;CONTENT TYPE.
01800		LAC NNAMES(1)↔CALL(DPYSTR,0)
01900	
02000		HRREI -3↔DAC WRD
     

00100	L1:
00200		LACN WRD↔IMULI =25↔SUBI =170↔DAC Y
00300		CALL(AIVECT,[=305],Y)
00400		SKIPGE WRD↔GO .+3↔CALL(DTYO,[" "])
00500		CALL(DECDPY,WRD)
00600	
00700	;FULL WORD.
00800		CALL(AIVECT,[=345],Y)
00900		LACN 2,WRD↔LAC CONTMP
01000		ROT(2)↔ROT(2)↔ROT(2)↔ANDI 7000
01100		CAIN 3000↔GO[LAC 1,ARG1↔ADD 1,WRD
01200			CALL(FLODPY,{(1)},[4])↔GO L2]
01300	
01400	;LEFT HALF.
01500		CALL(AIVECT,[=345],Y)
01600		LAC 1,ARG1↔ADD 1,WRD↔CAR(1)↔PUSH P,0
01700		LACN 2,WRD↔CAR RELTMP↔ROT(2)
01800		TRNE 10↔GO[CALL(JDPY)↔GO .+2]↔CALL({OCTDPY+1})
01900	
02000	;RIGHT HALF.
02100		CALL(AIVECT,[=425],Y)
02200		LAC 1,ARG1↔ADD 1,WRD↔CDR(1)↔PUSH P,0
02300		LACN 2,WRD↔CDR RELTMP↔ROT(2)
02400		TRNE 10↔GO[CALL(JDPY)↔GO .+2]↔CALL({OCTDPY+1})
02500	
02600	L2:	AOS 1,WRD↔CAIG 1,8↔GO L1
02700		CALL(DPYBIG,[2])
02800		POP1J
02900	DECLARE{WRD,X,Y,KIND,RELTMP,CONTMP}
03000	BEND DPYNODE; BGB 25 MARCH 1973 ----------------------------------
     

00100	SUBR(GEOMED)------------------------------------------------------
00200	BEGIN GEOMED; TELETYPE COMMAND JUMP TABLE - BGB - NOVEMBER 1972.
00300	L0:	CRLF
00400	L1:	OUTCHR["*"]
01000	L2:	CALL(STADPY)
01100		LAC ALPHA↔DAC CTRL↔SETZM ALPHA
01200		LAC BETA ↔DAC META↔SETZM BETA
01300		INCHRW
01400		TRZE 200↔SETOM CTRL
01500		TRZE 400↔SETOM META
01600		CAIN 0,40↔GO L2
01700		CAIN 0,15↔GO[SETZM ITERAT↔GO L2]
01800		CAIN 0,12↔GO L1
01900		DAC 0,CHR
02000		LAC CTRL↔AND META↔DAC MTCT
02100		SETZ↔SKIPE CTRL↔IORI 1
02150		SKIPE META↔IORI 2↔DAC MCBITS
02200	
02300	;READ JUMP TABLE.
02400		LAC CHR↔DAC 1
02500		CAIG 0,140↔GO[CAR 1,A00(1)↔GO L3]
02600		CAIG 0,172↔GO[CAR 1,A00-40(1)↔GO L3]
02700		CAR 1,A173-173(1)
02800	L3:	PUSHJ P,(1)	;CALL GEOMED COMMAND CHARACTER SUBR.
02900		GO L2		;NO-SKIP IMMEDIATE COMMAND.
03000		GO L0		;SKIP CRLF-STAR COMMAND.
03100		LIT
03200	BEND;2/4/73-------------------------------------------------------
03300	
03400	NOP:	OUTCHR CHR↔OUTSTR[ASCIZ/ NO OPERATION./]↔CRLF↔POP0J
03500	QMARK:	INCHRW↔DAC 1
03600		CAIG 0,140↔GO[CDR 1,A00(1)↔GO L4]
03700		CAIG 0,172↔GO[CDR 1,A00-40(1)↔GO L4]
03800		CDR 1,A173-173(1)
03900	L4:	CRLF↔OUTCHR["	"]
03950		OUTSTR(1)	;PRINT GEOMED COMMAND CHARACTER COMMENT.
04000		CRLF↔OUTCHR["*"]↔POP0J
04100	
04200	DEFINE $$(Q,A,B){XWD A,[ASCIZ"B"]}
     

00100	;ASCII 00 TO 37--------------------------------------------------
00200	
00300	A00:	NOP   	;null.
00400	$$("↓",PADPSH,{	↓ COPY PUSH. α↓ ROTATE PUSH.})
00500	$$("α",{[SETOM ALPHA↔POP0J]},{α CONTROL KEY PREFIX.})
00600	$$("β",{[SETOM BETA↔POP0J]},{β META KEY PREFIX.})
00700	
00800	$$("∧",LINKER,{	∧ FETCH PVT LINK})
00900	$$("¬",XEVERT,{	¬ BODY EVERT. α¬ BODY SUBTRACTION.})
01000	$$("ε",{[SETOM ALPHA↔SETOM BETA↔POP0J]},{ε META-CONTROL PREFIX.})
01100	$$("π",XRDEL,{	π ACCEPT ROTATION DELTA.})
01200	
01300	$$("λ",XTDEL,{	λ ACCEPT TRANSLATION DELTA.})
01400	$$(" ",NOP,{	TAB.})
01500	$$(" ",NOP,{	LF.})
01600	$$(" ",NOP,{	VT.})
01700	
01800	$$(" ",NOP,{	FF.})
01900	$$(" ",NOP,{	CR.})
02000	$$("∞",MACRO,{	∞ INSTANT CUBE. α∞ INSTANT TORUS.})
02100	$$("∂",SWCD,{	∂ FLIP NODE DISPLAY SWITCH.})
02200	
02300	$$("⊂",LINKER,{	⊂ FETCH BRO LINK.})
02400	$$("⊃",LINKER,{	⊃ FETCH SIS LINK.})
02500	$$("∩",LINKER,{	∩ FETCH DAD LINK, α∩ BODY INTERSECTION.})
02600	$$("∪",LINKER,{	∪ FETCH SON LINK, α∪ BODY UNION.})
02700	
02800	$$("∀",XDISBL,{	∀ DISABLE BODY OPERATIONS SWITCH.})
02900	$$("∃",SWC4,{	∃ REFLECTION DEFAULT.})
03000	$$("⊗",LINKER,{	⊗ FETCH UNIVERSE NODE.})
03100	$$("↔",PADSWP,{(1ST ↔ 2ND)(1ST α↔ 3RD)(1ST β↔ LAST)(2ND ε↔ 3RD)})
03200	
03300	$$("_",XDPY,{	_ STICKY DISPLAY MODE SWITCH.})
03400	$$("→",LINKER,{	→ FETCH ALT2 LINK.})
03500	$$("~",NOP,{	TILDE})
03600	$$("≠",NOP,{	≠})
03700	
03800	$$("≤",LINKER,{	≤ FETCH NED LINK.})
03900	$$("≥",LINKER,{	≥ FETCH PED LINK.})
04000	$$("≡",NOP,{	≡})
04100	$$("∨",LINKER,{	∨ FETCH NVT LINK.})
04200	
04300	;----------------------------------------------------------------
     

00100	;ASCII 40 TO 100-------------------------------------------------
00200	
00300	$$(" ",NOP,{	SPACE})
00400	$$("!",SWC1,{	! TRANSLATION DEFAULT SWITCH.})
00500	$$(" ",NOP,{	DOUBLE QUOTE.})
00600	$$("#",CRLF20,{	# TWENTY CRLF'S.})
00700	
00800	$$("$",XCONVEX,{	MAKE CONVEX.})
00900	$$("%",XDDEL,{	% SET DILATION DELTA STRENGTH.})
01000	$$("&",NOP,{	&})
01100	$$("'",NOP,{	'})
01200	
01300	$$("(",EUTRAN,{	EUCLIDEAN TRANSFORMATION -Y.})
01400	$$(" ",EUTRAN,{	EUCLIDEAN TRANSFORMATION +Y.})
01500	$$("*",EUTRAN,{	EUCLIDEAN TRANSFORMATION +Z.})
01600	$$("+",LINKER,{	OTHER LINK.})
01700	
01800	$$(" ",LINKER,{	CLOCKWISE LINK.})
01900	$$("-",EUTRAN,{	EUCLIDEAN TRANSFORMATION -Z.})
02000	$$(".",LINKER,{	COUNTER CLOCKWISE LINK.})
02100	$$("/",HALVE ,{	HALVE STRENGTH.})
02200	
02300	$$("0",SETDIG,{	SET-DIGIT COMMAND.})
02400	$$("1",SETDIG,{	SET-DIGIT COMMAND.})
02500	$$("2",SETDIG,{	SET-DIGIT COMMAND.})
02600	$$("3",SETDIG,{	SET-DIGIT COMMAND.})
02700		
02800	$$("4",SETDIG,{	SET-DIGIT COMMAND.})
02900	$$("5",SETDIG,{	SET-DIGIT COMMAND.})
03000	$$("6",SETDIG,{	SET-DIGIT COMMAND.})
03100	$$("7",SETDIG,{	SET-DIGIT COMMAND.})
03200		
03300	$$("8",SETDIG,{	SET-DIGIT COMMAND.})
03400	$$("9",SETDIG,{	SET-DIGIT COMMAND.})
03500	$$(":",EUTRAN,{	EUCLIDEAN TRANSFORMATION +X.})
03600	$$(";",EUTRAN,{	EUCLIDEAN TRANSFORMATION -X.})
03700		
03800	$$("<",LINKER,{	FETCH NFACE LINK.})
03900	$$("=",SWC3,{	DILATION DEFAULT SWITCH.})
04000	$$(">",LINKER,{	FETCH PFACE LINK.})
04100	$$("?",QMARK,{	INFORMATION PREFIX.})
04200	
04300	$$("@",SWC2,{	ROTATION DEFAULT SWITCH.})
04400	
04500	;----------------------------------------------------------------
     

00100	;ASCII 101 TO 132 UPPER CASE-------------------------------------
00200	;ASCII 141 TO 172 LOWER CASE.
00300	A101:
00400	$$("A",ATTDET,{	A ATTACH, βAXECNT.})
00500	$$("B",XBODY ,{	B BODY RETRIEVAL.})
00600	$$("C",XCOPY ,{	C COPY})
00700	$$("D",ATTDET,{	D DETACH, αDARKEN, βDUAL, εUNDARKEN.})
00800	
00900	$$("E",SWIRE ,{	E SWEEP WIRE.})
01000	$$("F",SWCF,{	F FRAME STEP SWITCH.})
01100	$$("G",XGLUE,{	G GLUE COMMAND.})
01200	$$("H",NOP,{	H })
01300	
01400	$$("I",XIN,{	I INPUT B3D. αI INPUT CAMERA. βI INPUT CRE.})
01500	$$("J",JOINVV,{	J JOIN VERTEX-VERTEX.})
01600	$$("K",XKILL,{	K KILL COMMANDS.})
01700	$$("L",SWCL,{	L LABEL LIGHTS SWITCH.})
01800		
01900	$$("M",MIDPOI,{	M MIDPOINT COMMAND.})
02000	$$("N",XNAME,{	N NAME BODY})
02100	$$("O",XOUT,{	O OUTPUT COMMANDS.})
02200	$$("P",XPLOTO,{	P OUTPUT PLOT FILE})
02300	
02400	$$("Q",SWCQ,{	Q FRAME ORIGIN SWITCH.})
02500	$$("R",XROTCM,{	R ROTATION COMPLETION.})
02600	$$("S",XSWEEP,{	S SWEEP COMMANDS.})
02700	$$("T",XTEXT,{	TEXT LABEL.})
02800	
02900	$$("U",NOP,{	U})
03000	$$("V",VBODY,{	V MAKE VERTEX BODY.})
03100	$$("W",XWMAKE,{	MAKE: W WORLD. αW WINDOW. βW CAMERA. εW IMAGE.})
03200	$$("X",{[POP P,↔SETZ 1,↔POP0J]},{X EXIT GEOMED.})
03300	
03400	$$("Y",NOP,{	Y NOP})
03500	$$("Z",NOP,{	Z})
03600	
03700	;ASCII 133 TO 140.
03800	$$("[",NOP,{	[})
03900	$$("\",DOUBLE,{	\ DOUBLE STRENGTH.})
04000	$$("]",NOP,{	]})
04100	$$("↑",PADPOP,{	↑ PADPDL POP. α↑ ROTATE POP.})
04200	$$("←",LINKER,{	← FETCH ALT LINK.})
04300	$$("`",NOP,{	`})
04400	
04500	;ASCII 173 TO 177.
04600	A173:
04700	$$("{",NOP,{	LEFT CURLY.})
04800	$$("|",XINVERT,{	| INVERT EDGE PARITY.})
04900	$$(" ",XDPY,{	ALT OCCULT. αALT FRONT FACE. βALT ALL EDGES.})
05000	$$("}",NOP,{	RIGHT CURLY})
05100	$$(" ",NOP,{	RUBOUT})
05200	;----------------------------------------------------------------
     

     

00100	;1. "V"-COMMAND.  MAKE VERTEX BODY.
00200	SUBR(VBODY)-------------------------------------------------------
00300	BEGIN VBODY;BGB 13 JANUARY 1973.
00400		LAC PTR,PDLPTR
00500		SETQ(BNEW,{MKB,WORLD})↔PUSH PTR,1     ;BODY INTO PADPDL
00600		SKIPE META↔GO L1		;DIABLE FACE & VERTEX.
00700		CALL(MKF,BNEW)↔PUSH PTR,1	;FACE INTO PADPDL
00800		CALL(MKV,BNEW)↔PUSH PTR,1	;VERTEX INTO PADPDL
00900	L1:	DAC PTR,PDLPTR
01000		SKIPE CTRL↔POP0J		;DISABLE MAKE FRAME.
01100		CALL(MKFRAME)↔LAC 2,BNEW
01200		FRAME. 1,2
01300		POP0J
01400	BNEW:	0
01500	BEND;2/4/73-------------------------------------------------------
01600	
     

00100	SUBR(MIDPOI)------------------------------------------------------
00200	BEGIN MIDPOI;MIDPOINT AN EDGE PROPORTIONAL TO DDEL - 8 FEB 1973.
00300		EXTERN ESPLIT
00400		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
00500		LAC 1,(PTR)↔TEST 1,EBIT↔POP0J
00600		PVT 0,1↔DAC V1#
00700		NVT 0,1↔DAC V2#
00800		CALL(ESPLIT,1)↔DAC 1,(PTR)
00900		LAC 2,V1↔SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
01000		LAC DDEL↔FMPRM XWC(1)↔FMPRM YWC(1)↔FMPRM ZWC(1)
01100		LAC 2,V2↔SLACI 3,(1.0)↔FSBR 3,DDEL
01200		LAC XWC(2)↔FMPR 3↔FADRM XWC(1)
01300		LAC YWC(2)↔FMPR 3↔FADRM YWC(1)
01400		LAC ZWC(2)↔FMPR 3↔FADRM ZWC(1)
01500		CALL(GEODPY)
01600		POP0J↔VAR
01700	BEND;2/8/73-------------------------------------------------------
01800	
01900	XINVERT:;"|" COMMAND.---------------------------------------------
02000	;FLIP THE FACE-VERTEX ORIENTATION OF AN EDGE - BGB - 9 FEB 1973.
02100		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
02200		LAC 1,(PTR)↔TEST 1,EBIT↔POP0J
02300		MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
02400		POP0J
02500	;2/9/73-----------------------------------------------------------
02600	
02700	XEVERT:;"¬" COMMAND.----------------------------------------------
02800		EXTERN EVERT
02900		SKIPE CTRL↔GO XBIN	;BODY SUBTRACTION "α¬".
03000		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
03100		LAC 1,(PTR)↔TEST 1,BBIT↔POP0J
03200		CALL(EVERT,1)↔CALL(GEODPY)↔POP0J
03300	;3/20/73----------------------------------------------------------
     

00100	;2. "E"-COMMAND. SWEEP WIRE.
00200	SUBR(SWIRE)-------------------------------------------------------
00300	BEGIN SWIRE;BGB 14 JANUARY 1973.
00400		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+2↔POP0J;PADPDL EMPTY TEST.
00500		CALL(LINKED,{-1(PTR)},{(PTR)})	       ;LEGAL ARGS TEST.
00600		SKIPN 1↔POP0J↔LAC PTR,PDLPTR
00700		CALL(MKEV,{-1(PTR)},{(PTR)})	       ;MAKE EDGE VERTEX.
00800		LAC PTR,PDLPTR↔DAC 1,(PTR)↔POP0J       ;NEW TOP OF PADPDL.
00900	BEND;2/4/73------------------------------------------------------
     

00100	;3. "J"-COMMAND. JOIN VERTICES.
00200	SUBR(JOINVV)------------------------------------------------------
00300	BEGIN JOINVV;BGB 5 FEBRUARY 1973.
00400		ACCUMULATORS{F,V1,V2,E1,E2}
00500		LAC PTR,PDLPTR↔CDR 1,PTR
00600		CAIGE 1,PADPDL+2↔POP0J	    	;2 OR MORE ARGUMENTS.
00700		LAC V1,(PTR)
00800		LAC V2,-1(PTR)
00900		DAC V2,F
01000	
01100		TEST V1,VBIT↔POP0J	;AT LEAST ONE VERTEX.
01200		TEST F,FBIT↔GO L1
01300	
01400	;JOIN ENDS OF WIRE CASE.
01500		PED E1,F↔PVT V2,E1↔DAC V2,(PTR)
01600		CALL(MKFE,V2,F,V1)
01700		CALL(GEODPY)
01800		POP0J
01900	
02000	;JOIN VERTICES ACROSS A FACE.
02100	L1:	TEST V2,VBIT↔POP0J
02200		PED E1,V1↔DAC E1,E0#
02300	L2:	SETQ(F,{FCCW,E1,V1})
02400		PED E2,V2↔DAC E2,EE0#
02500	L3:	CALL(FCCW,E2,V2)↔CAMN 1,F↔GO L4		;FACE IN COMMON.
02600		SETQ(E2,{ECCW,E2,V2})↔CAME E2,EE0↔GO L3
02700		SETQ(E1,{ECCW,E1,V1})↔CAME E1,E0↔GO L2↔POP0J
02800	L4:	POP PTR,0
02900		CALL(MKFE,V1,F,V2)
03000		DAC 1,(PTR)
03100		DAC PTR,PDLPTR
03200		CALL(GEODPY)
03300		POP0J
03400	BEND;2/5/73------------------------------------------------------
     

00100	;4. ":;()-*" COMMANDS. EUCLIDEAN TRANSFORMATION COMMANDS.
00200	SUBR(EUTRAN)------------------------------------------------------
00300	BEGIN EUTRAN;BGB 15 JANUARY 1973.
00400		EXTERN BGET,APTRAN,MKFRAME,MKCOPY,KLNODE
00500		EXTERN TRANSLATE,ROTATE,SHRINK
00600	
00700	;GET TOP OBJECT OF PADPDL.
00800		CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
00900		LAC 2,(1)↔DAC 2,OBJECT
01000		$TYPE 0,2↔CAIN 0,$WINDOW↔GO WNTRAN
01100		DZM DEL1↔DZM DEL2↔DZM DEL3
01200	
01300	;OPERATION.
01400		SKIPN 1,MCBITS↔LAC 1,OPERAT↔DAC 1,OP
01500		LAC 2,[TRANSLATE↔ROTATE↔SHRINK↔SHRINK](1)
01600		DAP 2,L3
01700	
01800	;AXIS CODE.
01900		LAC 1,CHR↔SETZ 3,
02000		CAIE 1,";"↔CAIN 1,":"↔IORI 3,1		;X-AXIS.
02100		CAIE 1,"("↔CAIN 1,")"↔IORI 3,2		;Y-AXIS.
02200		CAIE 1,"-"↔CAIN 1,"*"↔IORI 3,4		;Z-AXIS.
02300		LAC 1,OP↔CAILE 1,1↔GO[
02400		SLACI(1.0)↔DAC DEL1↔DAC DEL2↔DAC DEL3
02500		LAC AXECNT↔CAIN 2↔TRC 3,7
02600		CAIN 3↔TRO 3,7↔GO .+1]
02700		
02800	;DELTA ARGUMENT.
02900		LAC CHR↔LAC 1,OP
03000		LAC 2,@[TDEL↔RDEL↔DDEL↔[-1.0]](1)
03100	
03200		CAIN"-"↔MOVNS 2
03300		CAIN"("↔MOVNS 2
03400		CAIN";"↔MOVNS 2
03500	
03600		GO@[L1↔L1↔[MOVNS 2↔JUMPGE 2,L1	   ;NEGATIVE DILATION.
03700		SLACI 2,(1.0)↔FDVR 2,DDEL↔GO L1]   ;POSITIVE DILATION.
03800		[LAC 2,[-1.0]↔GO L1]](1)	   ;REFLECTION DELTA.
03900	
04000	L1:	TRNE 3,1↔DAC 2,DEL1
04100		TRNE 3,2↔DAC 2,DEL2
04200		TRNE 3,4↔DAC 2,DEL3
     

00100	;MAKE REFERENCE FRAME.
00200		LAC 1,FRAAM↔GO@[[GO .+1]		;WORLD FRAME.
00300		[CALL(BGET,OBJECT)↔GO .+1]		;BODY FRAME.
00400		[CALL(BGET,OBJECT)↔DAD 1,1↔GO .+1]	;DADDY'S FRAME.
00500		[LAC 1,CAMERA↔GO .+1]](1)		;CAMERA FRAME.
00600		SKIPE 1↔FRAME 1,1
00700		SKIPE 1↔GO[CALL(MKCOPY,1)↔GO .+1]	;COPY OF REFRAM.
00800		DIPZ 1,REFRAM				;XWD REFRAM,0
00900	
01000	;FRAME ORIGIN SWITCH.
01100		SKIPN FRMORG↔GO[SKIPN OP↔GO .+1		;NON-TRANSLATION.
01200		CALL(BGET,OBJECT)↔FRAME 1,1
01250		JUMPE 1,.+1↔PUSH P,1
01300		CAR 1,REFRAM↔SKIPN 1↔CALL(MKFRAME)↔DIPZ 1,REFRAM
01400		LAC 2,1↔POP P,1↔SLACI XWC(1)
01500		LAPI XWC(2)↔BLT ZWC(2)↔GO .+1]
01700	
01800	;MAKE EUCLIDEAN TRANSFORMATION MATRIX.
01900		CALL(,REFRAM,DEL1,DEL2,DEL3)
02000	L3:	CALL(ROTATE)↔DAC 1,TRAN			;MAKE THE TRANSFORM.	
02100		SKIPE REFRAM↔GO[
02200		CAR REFRAM↔CALL(KLNODE,0)↔GO .+1]	;FLUSH THE REFRAM.
     

00100	;APPLY THE TRANSFORMATION.
00200		LAC ITERAT↔SKIPN↔AOS↔DAC COUNT
00300	L2:	CALL(APTRAN,OBJECT,TRAN)
00400		CALL(GEODPY)
00500		SKIPGE COUNT↔GO[
00600			AOSL COUNT↔GO .+1
00700			SETZM ITERAT
00800			CALL(XSWEEP)
00900			CDR 1,PDLPTR↔LAC(1)↔DAC OBJECT↔GO L2]
01000		SOSLE COUNT↔GO L2
01100		SETOM@TRAN
01200		CALL(KLNODE,TRAN)
01300		POP0J
01500		DECLARE{OBJECT,TRAN,REFRAM,COUNT,OP}
01600		DECLARE{DEL1,DEL2,DEL3}
     

00100	;WINDOW TRANFORMATION.
00200	WNTRAN:	LAC 1,CHR
00300		CAIN 1,"-"↔GO[LAC -1(2)↔FMPR DDEL↔DAC -1(2)
00350			SKIPE CTRL↔GO W2↔GO W1]
00400		CAIN 1,"*"↔GO[LAC -1(2)↔FDVR DDEL↔DAC -1(2)
00450			SKIPE CTRL↔GO W2↔GO W1]
00500		LAC 3,TDEL↔FIXX 3,		;TRANSLATION.
00600		LACI 4,-2(2)↔SKIPE CTRL↔SOS 4	;ADDRESS.
00700		CAIN 1,";"↔GO[NIP(4)↔SUB 3↔DIP(4)↔GO W1]
00800		CAIN 1,":"↔GO[NIP(4)↔ADD 3↔DIP(4)↔GO W1]
00900		CAIN 1,"("↔GO[NAP(4)↔SUB 3↔DAP(4)↔GO W1]
01000		CAIN 1,")"↔GO[NAP(4)↔ADD 3↔DAP(4)↔GO W1]
01100		POP0J
01200	W1:	CALL(CROP,2)↔EXTERN CROP
01300	W2:	CALL(GEODPY)↔POP0J
01400		LIT
01500	BEND;2/4/73-------------------------------------------------------
     

00100	;5. SWITCH MODIFYING COMMANDS.
00200	;	!	TRANSLATION DEFAULT.
00300	;	@	ROTATION DEFAULT.
00400	;	∃	REFLECTION DEFAULT.
00500	;	=	DILATION DEFAULT.
00600	;	Q	FLIP FRAME ORIGIN.
00700	;	F	STEP FRAME SELECT SWITCH.
00800	
00900	SWC1:	SETZM OPERAT↔POP0J		;"!" TRANSLATION DEFAULT.
01000	SWC2:	LACI 1↔DAC OPERAT↔POP0J		;"@" ROTATION DEFAULT.
01100	SWC3:	LACI 2↔DAC OPERAT↔POP0J		;"=" DILATION DEFAULT.
01200	SWC4:	LACI 3↔DAC OPERAT↔POP0J		;"∃" REFLECTION DEFAULT.
01300	
01400	SWCF:	SKIPE CTRL↔GO XFOCAL		;"αF" SET FOCAL.
01500		AOS 1,FRAAM↔ANDI 1,3
01600		DAC 1,FRAAM↔POP0J		;FRAME STEP SWITCH.
01700	SWCL:	SETCMM FLAGL↔POP0J		;"L" LABEL LIGHTS SWITCH.
01710	SWCD:	SETCMM FLAGD↔POP0J		;"∂" NODE DISPLAY SWITCH.
01800	SWCQ:	SETCMM FRMORG↔POP0J		;FRAME ORGIN TOGGLE.
01900	
02000	CRLF20:	LACI =20↔CRLF↔SOJG .-1↔POP0J	;TWENTY CRLF'S.
02100	
02200	XDISBL:	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
02300		LAC 1,(1)↔TEST 1,BBIT↔POP0J
02400		LAC 2,MCBITS↔GO@[
02500		[MARKZ 1,{BDLBIT+BDVBIT+BDPBIT}↔POP0J]	;ENABLE.
02600		[MARK 1,BDLBIT↔POP0J]		;FRAME DISABLE
02700		[MARK 1,BDVBIT↔POP0J]		;VERTEX DISABLE
02800		[MARK 1,BDPBIT↔POP0J]](2)	;PARTS DISABLE
     

00100	;6. STACK MODIFYING COMMANDS.
00200	
00300	;"↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[2].
00400	;"α↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[3].
00500	;"β↔"	PADPDL SWAP:	PADPDL[2]↔PADPDL[3].
00600	;"ε↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[N].
00700	
00800	PADSWP: LAC PTR,PDLPTR↔CDR PTR
00900		LACM 1,CTRL↔CAIGE PADPDL+2(1)↔POP0J	;ARG ∃ TEST.
01000		LAC 1,MCBITS↔GO@[
01100		[LAC(PTR)↔EXCH -1(PTR)↔DAC(PTR)↔POP0J]	;  1ST & 2ND.
01200		[LAC(PTR)↔EXCH -2(PTR)↔DAC(PTR)↔POP0J]	;α 1ST & 3RD.
01300		[LAC(PTR)↔EXCH PADPDL+1↔DAC(PTR)↔POP0J]	;β 1ST & LAST.
01400		[LAC -1(PTR)↔EXCH -2(PTR)
01500		 DAC -1(PTR)↔POP0J]			;ε 2ND & 3RD.
01600		](1)↔LIT
01700	
01800	;"↓"	PADPDL COPY PUSH DOWN.
01900	;"↓"	PADPDL ROTATE DOWN.
02000	
02100	PADPSH:	LAC PTR,PDLPTR↔CDR PTR
02200		CAIGE PADPDL+1↔POP0J
02300		SKIPE CTRL↔GO .+4
02400		PUSH PTR,(PTR)↔DAC PTR,PDLPTR↔POP0J	;COPY PUSH.
02500		LAC[XWD PADPDL+1,PADPDL]↔BLT -1(PTR)
02600		LAC PADPDL↔DAC(PTR)↔POP0J		;ROTATE PUSH.
02700	
02800	;"↑"	PADPDL POP UP.
02900	;"α↑"	PADPDL ROTATE UP.
03000	
03100	PADPOP:	LAC PTR,PDLPTR↔CDR PTR
03200		CAIGE PADPDL+1↔POP0J
03300		SKIPE CTRL↔GO .+4
03400		POP PTR,↔DAC PTR,PDLPTR↔POP0J		;PAD POP.
03500		SUBI PADPDL↔POP PTR,1(PTR)↔SOJG .-1	;ROTATE POP
03600		LAC PTR,PDLPTR↔LAC 1(PTR)↔DAC PADPDL+1
03700		POP0J
     

00100	;"/" COMMAND.-----------------------------------------------------
00200	HALVE:	SKIPN 1,MCBITS↔LAC 1,OPERAT	;EUCLIDEAN OPERATION.
00300		LAC TDEL(1)↔FSC -1↔DAC TDEL(1)	;"/" COMMAND.
00400		POP0J
00500	;"\" COMMAND.-----------------------------------------------------
00600	DOUBLE:	SKIPN 1,MCBITS↔LAC 1,OPERAT	;EUCLIDEAN OPERATION.
00700		LAC TDEL(1)↔FSC 1↔DAC TDEL(1)	;"\" COMMAND.
00800		POP0J
00900	;"0123456789" COMMANDS.-------------------------------------------
01000	SETDIG:	LAC 1,CHR↔ANDI 1,17		;DIGIT.
01100		SKIPN 2,MCBITS↔LAC 2,OPERAT	;EUCLIDEAN OPERATION.
01200		GO@[
01300		[LAC ITERAT↔IMULI 12↔ADD 1	;ITERATION COUNT.
01400		 CAILE=128↔LACI=128
01500		 DAC ITERAT↔POP0J]
01600		[SUBI 1,=10↔LAC[3.1415927]	;ROTATION DELTA.
01700		 FSC(1)↔DAC RDEL↔POP0J]
01800		[SKIPN 1↔LACI 1,1↔FLOAT 1,	;DILATION DELTA.
01900		 FMPR 1,[0.1]↔DAC 1,DDEL↔POP0J]
02000		[SUBI 1,4↔SLACI(1.0)↔FSC(1)	;TRANSLATION DELTA.
02100		 DAC TDEL↔POP0J]](2)
02200	;-----------------------------------------------------------------
     

00100	XFOCAL:	OUTSTR[ASCIZ/	FOCAL = /]↔CALL(REALIN)
00200		LAC 1,CAMERA
00300		FMPR[3.2808E-3]↔HLLM 0,3(1)
00400		HLLZ 2,1(1)↔CDR 3,1(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-3(1)
00500		HLLZ 2,2(1)↔CDR 3,2(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-2(1)
00600		FMPR[100000.0]↔DAC 0,-1(1)
00700		CALL(GEODPY)↔POP0J
     

00100	REALIN: ;---------------------------------------------------------
00200	BEGIN REALIN; INPUT FROM TTY SMALL REAL NUMBER - BGB - 16 DEC 1972.
00300	;AC-0 INTEGER ACCUMULATION.	AC-0 RETURNS REAL NUMBER.
00400	;AC-1 CHARACTER.		AC-1 RETURNS BREAK CHARACTER.
00500	;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
00600	;AC-3 MINUS SIGN FLAG.
00700		SETZ↔SETZB 2,3
00800	L1:	INCHWL 1
00900		CAIE 1,"-"↔GO .+3↔SETCMM 3↔GO L1
01000		CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
01100		CAIL 1,"0"↔CAILE 1,"9"↔GO L2
01200		JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
01300		ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
01400	L2:	FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
01500		SKIPE 3↔MOVNS↔POP0J
01600	BEND;12/16/72-----------------------------------------------------
01700	
01800	XTDEL:	CALL(REALIN)↔CAIN 1,42↔FDVR[12.0]↔DAC TDEL↔POP0J
01900	XDDEL:	CALL(REALIN)↔FMPR[0.01]↔DAC DDEL↔POP0J
02000	XRDEL:	CALL(REALIN)↔CAIN 1,"/"↔GO[
02100		SKIPN↔SLACI(1.0)↔DAC RDEL	;NUMERATOR.
02200		CALL(REALIN)↔SKIPN↔SLACI(1.0)	;DENOMINATOR.
02300		LAC 1,RDEL↔FMPR 1,[3.1415927]
02400		FDVR 1,0↔DAC 1,RDEL↔POP0J]	;PI FRACTION.
02500		CAIN 1,"'"↔FMPR[1.74532925E-2]	;DEGREES.
02600		DAC RDEL↔POP0J			;RADIANS.
     

00100	;8. SWEEP COMMANDS.
00200	
00300	SUBR(XSWEEP)------------------------------------------------------
00400	BEGIN XSWEEP
00500		EXTERN SWEEP,PYRAMID
00600		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J	   ;ARG EXISTS.
00700		LAC 1,(PTR)↔TESTZ 1,FBIT↔GO L2
00800		TEST 1,VBIT↔POP0J
00900		PED 2,1↔JUMPE 2,.+4
01000		MOVS 0,1(2)↔CAME 0,1(2)↔GO L2+1
01100		CALL(SWIRE)↔GO L3			;SWEEP WIRE.
01200	L2:	SKIPE MTCT↔GO[
01300			CALL(PYRAMID,1)↔DAC 1,(PTR)
01400			CALL(GEODPY)↔POP0J]
01500		SKIPN 2,META↔LACM 2,CTRL     ;0=PRISM ;α+1=CCW ;β-1=CW.
01600		CALL(SWEEP,1,2)
01700	L3:	CALL(GEODPY)
01800		MOVNS ITERAT
01900		POP0J
02000	BEND;2/10/73------------------------------------------------------
02100	XROTCM:	EXTERN ROTCOM
02200		CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
02300		LAC 1,(PTR)↔TEST 1,FBIT↔POP0J
02400		CALL(ROTCOM,1)
02500		CALL(GEODPY)
02600		POP0J
02700	;-----------------------------------------------------------------
02800	XGLUE:	LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+2↔POP0J	;TWO ARGS.
02900		LAC 1,(PTR)↔LAC 2,-1(PTR)
03000		EXTERN GLUE
03100		CALL(GLUE,1,2)↔DAC 1,-1(PTR)
03200		POP PTR,0↔DAC PTR,PDLPTR
03300		CALL(GEODPY)
03400		POP0J
     

00100	SUBR(XKILL)-------------------------------------------------------
00200	BEGIN XKILL;BGB - 10 FEBRUARY 1973.
00300		EXTERN KLEV,KLVE,KLFE,REMOVF,KLBFEV
00400		LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+1↔POP0J	;ONE ARG.
00500		LAC 1,(PTR)
00600		TEST  1,VBIT↔GO L2
00700		DAC 1,2↔PED 3,1
00800		SETQ(4,{ECCW,3,2})
00900		SETQ(5,{ECCW,4,2})
01000		DAC 2,1↔CAME 3,5↔GO L1
01100		CALL(KLEV,1)↔GO L3
01200	L1:	CALL(KLEV,1)↔CALL(KLFE,1)↔GO L3
01300	L2:	TESTZ 1,EBIT↔GO[SKIPE CTRL↔GO[
01400			CALL(KLVE,1)↔GO L3]
01500			CALL(KLFE,1)↔GO L3]
01600		TESTZ 1,FBIT↔GO[CALL(REMOVF,1)↔GO L3]
01700		TESTZ 1,BBIT↔GO[CALL(KLBFEV,1)↔POP PTR,0
01800			DAC PTR,PDLPTR↔CALL(GEODPY)↔POP0J]
01900		POP0J 	
02000	L3:	DAC 1,(PTR)
02100		CALL(GEODPY)
02200		POP0J
02300	BEND;2/10/73------------------------------------------------------
     

00100	;9. LINK FOLLOWING COMANDS.
00200	SUBR(LINKER)------------------------------------------------------
00300	BEGIN LINKER
00400		LAC PTR,PDLPTR
00500		LAC CHR↔CAIN"⊗"↔GO[PUSH PTR,UNIVERSE↔DAC PTR,PDLPTR↔POP0J]
00600		CDR 1,PTR↔CAIGE 1,PADPDL+1↔POP0J	  ;STACK EMPTY.
00700	
00800		LAC 2,(1)↔LAC CHR
00900		CAIE"."↔CAIN","↔GO L1		;CLOCK LINK COMMANDS.
01000		CAIN"+"↔GO L1			;OTHER LINK COMMAND.
01100		CAIN"∩"↔GO[SKIPE CTRL↔GO XBIN↔TESTZ 2,PBIT↔DAD 2,2↔GO L0]
01200		CAIN"∪"↔GO[SKIPE CTRL↔GO XBIN↔SON 2,2↔GO L0]
01300		CAIN"⊂"↔GO[TESTZ 2,PBIT↔BRO 2,2↔GO L0]
01400		CAIN"⊃"↔GO[TESTZ 2,PBIT↔SIS 2,2↔GO L0]
01500	
01600		CAIE "<"↔CAIN ">"↔ADDI 2,1
01700		CAIE "≤"↔CAIN "≥"↔ADDI 2,2
01800		CAIE "∨"↔CAIN "∧"↔ADDI 2,3
01850		CAIE "←"↔CAIN "→"↔ADDI 2,6
01900	
02000		SKIPE CTRL↔SUBI 2,4	;-3 -2 -1
02100		SKIPE META↔ADDI 2,5	;6 7 8
02200		SKIPE MTCT↔ADDI 2,2	;4 5 6
02300	
02400		LAC 2,(2)		;FETCH WORD FROM THE NODE.
02500		CAIN "≤"↔MOVSS 2
02600		CAIN "<"↔MOVSS 2
02610		CAIN "∨"↔MOVSS 2
02700		CAIN "←"↔MOVSS 2
02800	
02900	L0:	CDR 2
03000		CAML 44↔GO .+3		;LOWER THAN MAX.
03100		CAML UNIVER↔DAC(1)	;HIGHER THAN MIN.
03200		POP0J
     

00100	;OTHER LINK COMMANDS.
00200	L1:	TESTZ 2,PBIT↔GO[LAC CHR		;OBJECT CLOCK LINKS.
00300		CAIN"."↔GO[CCW 2,2↔DAC 2,(1)↔POP0J]	;CCW BODY.
00400		CAIN","↔GO[ CW 2,2↔DAC 2,(1)↔POP0J]	; CW BODY.
00500		POP0J]
00600		CAIGE 1,PADPDL+2↔POP0J		;TWO ARGUMENTS REQUIRED.
00700		LAC 1,0(PTR)↔LAC 2,-1(PTR)
00800		CALL(LINKED,1,2)↔SKIPN 1↔POP0J	;WHICH ARE LINKED.
00900		LAC 1,0(PTR)↔LAC 2,-1(PTR)
01000		SETZ 3,↔LAC CHR
01100		CAIN"+"↔GO L2
01200		CAIE","↔AOS 3			;DISTINGUISH CW & CCW.
01300		SKIPN CTRL↔ADDI 3,2
01400		SKIPE CTRL↔ADDI 3,4		;DISTINGUISH OPERATION.
01500	
01600	;EDGE IS IN THE FIRST POSITION OF THE STACK.
01700	L2:	TEST 1,EBIT↔GO L3			 ;EDGE.
01800		TEST 2,FBIT↔GO[TEST 2,VBIT↔POP0J	;FACE OR VERTEX.
01900			SKIPE CTRL↔ADDI 3,2↔GO .+1]	;CTRL VERTEX.
02000		PUSH P,1↔PUSH P,2↔PUSHJ P,@L5(3)
02100		CAIN 3,2↔AOS PTR↔CAIN 3,3↔AOS PTR
02200		DAC 1,-1(PTR)↔POP0J
02300	
02400	;EDGE IS IN THE SECOND POSITION OF THE STACK.
02500	L3:	TEST 2,EBIT↔POP0J
02600		TEST 1,FBIT↔GO[TEST 1,VBIT↔POP0J
02700			SKIPE CTRL↔ADDI 3,2↔GO .+1]
02800		PUSH P,2↔PUSH P,1↔PUSHJ P,@L5(3)
02900		CAIN 3,2↔SOS PTR↔CAIN 3,3↔SOS PTR
03000		DAC 1,0(PTR)↔POP0J
03100	
03200	L5:	OTHER↔OTHER↔ECW↔ECCW↔VCW↔VCCW↔FCW↔FCCW
03300	
03400	BEND;2/9/73-------------------------------------------------------
     

00100	SUBR(XNAME) ------------------------------------------------------
00200	BEGIN XNAME; NAME A BODY - BGB - 20 FEBRUARY 1973.
00300		CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
00400		LAC 1,(1)↔TEST 1,BBIT↔POP0J
00500		LACI 3,=10↔LAC 2,[POINT 7,4,-1]↔SETZB 4,5
00600	L:	INCHWL↔CAIN 15↔GO EOL
00700		IDPB 2↔SOJG 3,L
00800		INCHWL↔CAIE 15↔GO .-2
00900		CRLF↔SKIPA
01000	EOL:	INCHWL↔OUTCHR["*"]↔DAC 4,-2(1)↔DAC 5,-1(1)↔POP0J
01100	BEND;2/9/73-------------------------------------------------------
01200	
01300	SUBR(XBODY) ------------------------------------------------------
01400	BEGIN XBODY; BODY RETRIEVAL - BGB - 20 FEBRUARY 1973.
01500	
01600		LAC PTR,PDLPTR
01700		SKIPN CTRL↔GO[CDR 1,PTR↔CAIGE 1,PADPDL+1↔GO .+1
01800			CALL(BGET,{(PTR)})↔DAC 1,(PTR)↔POP0J]
01900	
02000		LACI 2,=10			;TEN CHARACTERS TO A NAME.
02100		LAC  1,[POINT 7,4,-1]
02200		SETZB 3,6			;BODY SERIAL NUMBER.
02300		SETZB 4,5
02400	L:	INCHWL↔CAIN 15↔GO EOL		;END OF LINE.
02500		IDPB 1↔CAIGE"0"↔GO .+3↔CAIG"9"↔GO[
02600		IMULI 3,12↔ANDI 0,17↔ADD 3,0↔GO .+2]
02700		SETOM 6				;NON-NUMERIC CHR SEEN.
02800		SOJG 2,L
02900		INCHWL↔CAIE 15↔GO .-2
03000		CRLF
03100		SKIPA
03200	EOL:	INCHWL↔OUTCHR["*"]↔JUMPN 6,L2
03300	
03400	;FETCH BODY BY ITS SERIAL NUMBER.
03500		LAC 1,WORLD↔CCW 1,1
03600		CAME 1,WORLD↔SOJG 3,.-2
03700		CAME 1,WORLD↔PUSH PTR,1
03800		DAC PTR,PDLPTR↔POP0J
03900	
04000	;FETCH BODY BY ITS PNAME.
04100	L2:	LAC 1,WORLD↔CCW 1,1
04200		CAME 1,WORLD
04300		GO[CAME 4,-2(1)↔GO L2+1
04400		   CAME 5,-1(1)↔GO L2+1↔GO .+1]
04500		CAME 1,WORLD↔PUSH PTR,1
04600		DAC PTR,PDLPTR↔POP0J
04700	BEND;2/9/73-------------------------------------------------------
     

00100	SUBR(MACRO)-------------------------------------------------------
00200	BEGIN MACRO
00300		OPDEF PTO[711440B17]
00400		SKIPE CTRL↔GO L1
00500		PTO[0↔[ASCIZ"V\:)\E;E(E:J↑/*S--↑/@/:)\!"]]↔POP0J
00600	L1:	PTO[0↔[ASCIZ"V:7@S*J!↑8/:\@S)↓>G↑:)!"]]
00700		POP0J
00800		LIT
00900	BEND;2/9/73-------------------------------------------------------
01000	
01100	SUBR(ATTDET)------------------------------------------------------
01200	BEGIN ATTDET; ATTACH-DETACH COMMANDS & FRIENDS.
01300		EXTERN BDET,BATT,FVDUAL
01400		LAC 1,CHR
01500		CAIE 1,"D"↔GO L4
01600	
01700	;DETACH, αDARKEN, βDUAL, εUNDARKEN.
01800	
01900		CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J	;DETACH.
02000		LAC 1,(1)↔TEST 1,BBIT↔GO L3
02100		SKIPE CTRL↔GO[CALL(FVDUAL,1)↔CALL(GEODPY)↔POP0J]
02200		CALL(BDET,1)↔POP0J
02300	L3:	TEST 1,EBIT↔POP0J
02400		SLACI 0,(DARKEN)↔IORM(1)↔SKIPE CTRL↔ANDCAM(1)
02500		CALL(GEODPY)↔POP0J
02600	
02700	
02800	;ATTACH, αNOP, βAXECNT.
02900	L4:	SKIPE META↔GO[AOS 1,AXECNT		;STEP AXECNT.
03000		CAIL 1,4↔LACI 1,1↔DAC 1,AXECNT
03100		POP0J]
03200		CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J	;ATTACH.
03300		LAC 2,-1(1)↔LAC 1,(1)
03400		CALL(BATT,1,2)↔POP0J
03500	
03600	BEND;2/9/73-------------------------------------------------------
     

00100	XDPY: ;-----------------------------------------------------------
00200		LAC 1,CHR
00300		CAIN 1,"_"↔GO[
00400		LAC MCBITS↔DAC DPYFLG↔CALL(GEODPY)↔POP0J]
00500		CAIE 1,175↔POP0J
00600		LAC MCBITS↔PUSH P,DPYFLG↔DAC DPYFLG
00700		CALL(GEODPY)↔POP P,DPYFLG↔POP0J
00800	XCOPY: ;----------------------------------------------------------
00900		EXTERN MKCOPY
01000		SKIPE CTRL↔GO[
01100		LAC 1,PDLPTR↔PUSH 1,CAMERA↔DAC 1,PDLPTR↔POP0J]
01200		LAC 16,PDLPTR↔CDR 1,16
01300		CAIGE 1,PADPDL+1↔POP0J
01400		LAC(1)↔CALL(MKCOPY,0)
01500		PUSH 16,1↔DAC 16,PDLPTR
01600		LACI 2↔DAC DPYFLG↔CALL(GEODPY)
01700		POP0J
01800	XIN: ;------------------------------------------------------------
01900		EXTERN ICAM,INCRE,IFORM1	     ;INPUT FORMAT TYPE-1.
02000		SKIPE CTRL↔GO[CALL(ICAM)↔CALL(GEODPY)↔POP0J]
02100		SKIPE META↔GO[CALL(INCRE)↔CALL(GEODPY)↔POP0J]
02200		CALL(IFORM1)↔SKIPN 1↔POP0J
02300		LAC 16,PDLPTR↔PUSH 16,1↔DAC 16,PDLPTR
02400		CALL(GEODPY)
02500		POP0J
02600	XOUT: ;-----------------------------------------------------------
02700		EXTERN OCAM,OFORM1	;OUTPUT FORMAT TYPE-1.
02800		SKIPE CTRL↔GO[CALL(OCAM)↔POP0J]
02900		CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
03000		CALL(OFORM1,{(1)})
03100		POP0J
     

00100	XBIN: ;-----------------------------------------------------------
00200		EXTERN BIN,BUN,BSUB,KLBFEV,MKCVEX
00300		CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J
00400		LAC 2,-1(1)↔LAC 1,(1)↔LAC CHR
00500		CAIN"∩"↔GO[CALL(BIN,2,1)↔GO .+5]
00600		CAIN"∪"↔GO[CALL(BUN,2,1)↔GO .+3]
00700		CAIN"¬"↔GO[CALL(BSUB,2,1)↔GO .+1]
00800		PUSH P,1↔CALL(GEODPY)↔CALL(MKCVEX,{(P)})
00900		LAC 1,PDLPTR↔POP 1,2↔DAC 1,PDLPTR
01000		CALL(KLBFEV,2)↔CDR 1,PDLPTR↔LAC 2,(1)↔POP P,(1)
01100		CALL(KLBFEV,2)↔CALL(GEODPY)↔POP0J
01200	XWMAKE: ;---------------------------------------------------------
01300		EXTERN MKWORLD,MKWINDOW,MKCAMERA
01400		LAC 1,MCBITS
01500		PUSHJ P,@[MKWORLD↔MKWINDOW↔MKCAMERA↔MKCAMERA](1)
01600		LAC PTR,PDLPTR↔PUSH PTR,1↔DAC PTR,PDLPTR↔POP0J
01700	XPLOTO:;----------------------------------------------------------
01800		EXTERN PLOTO
01900		SKIPE FLAGL↔GO[SETZM FLAGL↔OUTSTR[ASCIZ" FLAG L OFF. "]↔POP0J]
02000		CALL(PLOTO)↔OUTCHR["*"]↔POP0J
02100	;-----------------------------------------------------------------
     

00010	XTEXT:	CDR 1,PDLPTR
00020		CAIGE 1,PADPDL+1↔POP0J
00030		LAC 1,1↔TEST 1,VBIT↔POP0J
00040		POP0J
00100	XCONVEX:CDR 1,PDLPTR
00200		CAIGE 1,PADPDL+1↔POP0J
00300		LAC(1)
00400		EXTERN MKCVEX↔CALL(MKCVEX,0)↔CALL(GEODPY)↔POP0J
00500	END SA