perm filename GEOMED.NEW[GEM,BGB]3 blob sn#050728 filedate 1973-06-23 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00041 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00005 00002	TITLE GEOMED  -  GEOMETRIC EDITOR  -  BGB  -  JANUARY 1973.
C00008 00003	START ADDRESS INITIALIZATION-------------------------------------
C00010 00004	NSUBR UNDERFLOW 	ENABLE & SERVICE ARITHMETIC INTERRUPTS.
C00013 00005	NSUBR GEODPY		GEOMED'S DISPLAY REFRESH
C00014 00006	NSUBR STADPY		STATUS DISPLAY
C00016 00007	----- STADPY			TRANSLATION STRENGTH.
C00018 00008	----- STADPY			DISPLAY THE SCRATCH PAD PDL.
C00021 00009	SUBRS NTYPE,JDPY	Node Type number, Display pointer
C00022 00010	TABLES REL,CONTYP,NNAMES,NLETTER	Node Info. Tables
C00025 00011	NSUBR DPYNODE,NODE	DISPLAY CONTENTS OF NODE LOWER RIGHT OF SCREEN.
C00028 00012	NSUBR GEOMED		TELETYPE COMMAND JUMP TABLE
C00030 00013	ASCII 00 TO 37--------------------------------------------------
C00033 00014	ASCII 40 TO 100-------------------------------------------------
C00036 00015	ASCII 101 TO 132 UPPER CASE-------------------------------------
C00039 00016	NSUBR COMHLP
C00040 00017	NSUBR VBODY			1. "V"-COMMAND.  MAKE VERTEX BODY.
C00041 00018	NSUBR MIDPOI			MIDPOINT AN EDGE PROPORTIONAL TO DDEL
C00042 00019	COMMANDS XINVERT,XEVERT		"|","¬"
C00044 00020	NSUBR SWIRE			2. "E"-COMMAND. SWEEP WIRE.
C00045 00021	NSUBR JOINVV			3. "J"-COMMAND. JOIN VERTICES.
C00047 00022	NSUBR EUTRAN			4. ":()-*" COMMANDS. EUCLIDEAN TRANSFORMATION COMMANDS.
C00049 00023	----- EUTRAN			   MAKE REFERENCE FRAME.
C00051 00024	----- EUTRAN			   APPLY THE TRANSFORMATION.
C00052 00025	----- EUTRAN			   WINDOW TRANFORMATION.
C00053 00026	5. SWITCH MODIFYING COMMANDS.	"|@∃=QF"
C00055 00027	6. STACK MODIFYING COMMANDS.	"↔↓↑"
C00057 00028	STRENGTH COMMANDS		"/\0123456789"
C00059 00029	COMMAND XFOCAL
C00060 00030	COMMANDS XTDEL,XDDEL,XRDEL 	"λπ%"
C00062 00031	8. SWEEP COMMANDS.		"SRG"
C00064 00032	NSUBR XKILL			"K"
C00065 00033	NSUBR LINKER			9. LINK FOLLOWING COMANDS.
C00067 00034	----- LINKER			   OTHER LINK COMMANDS.
C00070 00035	COMMANDS XNAME,XBODY		"B","N"
C00074 00036	SUBRS MACRO,ATTDET		"∞","AD"
C00076 00037	COMMANDS XDPY,XCOPY,XIN,XOUT	"_",<ALT>,"C","I","O"
C00079 00038	COMMANDS XBIN,XWMAKE,XPLOTO	"α∩","α∪","¬","W","P"
C00081 00039	COMMAND XTEXT			"T"  MAKE A TEXT NODE
C00084 00040	COMMAND XCONVEX,XRETRY,XARROW
C00087 00041		TAIL
C00088 ENDMK
C⊗;
TITLE GEOMED  -  GEOMETRIC EDITOR  -  BGB  -  JANUARY 1973.

;EDITOR STATUS.

	INTERNAL PDL
	PDL:BLOCK =500		;GEOMED'S INTERNAL STACK.
	PAT:BLOCK 40↔INTERN PAT
	PDLPTR:XWD -100,PADPDL	;GEOMED'S GRAPHICS STACK.
	PADPDL:BLOCK 100
	↓PTR←←16		;PADPDL STACK POINTER AC.

;JUMP TABLE COMMAND SCANNER STATUS.

	DECLARE{CHR,MCBITS,CTRL,META,MTCT,ALPHA,BETA}

;STRENGTH OF EUCLIDEAN TRANSFORMATION.

	TDEL:	1.0	;TRANSLATION DELTA STRENGTH.
	RDEL:	0.785398;ROTATION DELTA STRENGTH.
	DDEL:	0↔0.75	;DILATION DELTA STRENGTH.

	OPERAT:	0	;DEFAULT EUCLIDEAN OPERATION.
	FRAAM:	0	;FRAME OF REFERENCE.
	FRMORG:	0	;USE FRAME OF REFERENCE ORIGIN.
	AXECNT:	1	;NUMBER OF AXES TO USE.
	ITERAT:	0	;NUMBER OF ITERATIONS.

	FLAGL:	-1	;"L" COMMAND SWITCH. LABEL LIGHTS.
	FLAGD:	0	;"∂" NODE DISPLAY.
	DPYFLG:	2	;GEODPY STICKY DISPLAY MODE.
	ODPYFLG: 2	;OLD GEODPY STICKY DISPLAY MODE.

	DDSTA:	0	;DD CHANNEL FOR STATUS
	DDGEO:	0	;DD CHANNEL FOR POLYGON DISPLAY

;IO OPERATIONS
	EXTERN GETCHW	;GET A CHARACTER (IN CHARACTER MODE FOR TTY)
	EXTERN GETCHL	;GET A CHARACTER (IN LINE MODE FOR TTY)
	EXTERN GETCL0,GETCW0	;SAME EXCEPT RETURNS RESULT IN 0 INSTEAD 1.
;WING OPERATIONS.
	EXTERN MKB,MKF,MKE,MKV,MKFRAME
	EXTERN KLB,KLF,KLE,KLV,WING
	EXTERN WING,LINKED
	EXTERN ECW,ECCW,OTHER,OTHER.
	EXTERN BGET,FCW,FCCW,VCW,VCCW
	EXTERN MKY,KLY
;EULER OPERATIONS.
	EXTERN MKEV,MKFE
	INTERN CAMERA↔CAMERA:0
	WORLD:0
	WINDOW:0
	EXTERN KLNODE,UNIVER,OLD44,AVAIL
;DISPLAY
	EXTERN DDSET

	BITDEFS {,PZZ,TMPBIT,JUTBIT,JOTBIT,NORTH,SOUTH,EAST,WEST,,NZZ,FOLDED,VISIBLE,POTENT,VBIT,EBIT,FBIT,BBIT,TBIT1,TBIT2,TBIT3}
;START ADDRESS INITIALIZATION-------------------------------------
SA:	JFCL↔SETOM ALONE#
	SKIPE 1,OLD44↔CORE 1,↔JFCL↔SETZM OLD44
	SKIPA 17,[IOWD =500,PDL]
GEONIT:	SETZM ALONE↔INTERN GEONIT	;GEOMETRIC MODEL INIT.
	CALL(DOINIT)			;DO INITIALIZATION CODE

;CREATE A GEOMED UNIVERSE.
	EXTERN MKWORLD,MKCAMERA,MKWINDOW
	SETZB AVAIL	;...SO THAT @AVAIL IS ZERO.
	SETQ(WORLD,{MKWORLD})
	SETQ(CAMERA,{MKCAMERA})
	SETQ(WINDOW,{MKWINDOW})
	LAC 2,CAMERA↔ALT. 2,1
	LAC 2,WORLD↔ALT2. 2,1

;SETUP STRENGTH OF TRANSFORMATION VALUES.
	LAC[1.0]↔DAC TDEL	;TRANSLATION STRENGTH.
	LAC[0.75]↔DAC DDEL	;DILATION STRENGTH.
	LAC[0.785398]↔DAC RDEL	;ROTATION STRENGTH π/4.
	SETZM FRAAM		;SELECT WORLD FRAME.
	SETZM FRMORG
	SETOM FLAGL		;TURN ON THE LIGHTS.
	LACI 1↔DAC AXECNT	;ONE AXIS SELECT.
	SETZM OPERAT		;TRANSLATION DEFAULT.
	LAC[XWD -100,PADPDL]↔DAC PDLPTR
	SKIPN ALONE↔POP0J

;RE-ENTRY ADDRESS INITIALIZATION----------------------------------
REE:	LACI .↔DAC 124
	LAC 17,[IOWD =500,PDL]
	OPDEF PPIOT[702B8]
	PGIOT 2,		;CLEAR PIECES OF GLASS
	PPIOT 2,-=250↔PPIOT 3,3003
	CALL(CRLF20)
	CALL(UNDERFLOW)
	CALL(GEODPY)
	CALL(GEOMED)
	CALLI 12

;2/4/73-----------------------------------------------------------
NSUBR UNDERFLOW 	;ENABLE & SERVICE ARITHMETIC INTERRUPTS.
	EXTERNAL JOBTPC,JOBAPR

;ENABLE INTERRUPT ROUTINE.

	EXTERNAL TRAPINIT
	JRST TRAPINIT

COMMENT ⊗
	MOVEI 2,10	;17
	JFCL 17,.+1;	CLEAR ANY PREVIOUSLY SET FLAGS
	SUB 17,[1(1)]
	MOVEI 1,FLTOV
	MOVEM 1,JOBAPR
	CALLI 2,16	;SET APR FLAGS
	MOVE 1,1(17)
	TLZ 1,440140	;CLEAR PREV FLAGS
	JRST 2,@1	;JUMP AND REALLY RESET.

;JOB APR USER INTERRUPT ROUTINE.
FLTOV:	MOVEM 1,SAVE1
	MOVE 1,JOBTPC
	TLNN 1,100↔JRST OV	;SKIP ON FLOATING UNDERFLOW.
	MOVE 1,-1(1)	;get opcode which caused it
	TLNN 1,40000	;test for standard flt pt opcode
	TLZ 1,2000	;change for FSC
	DPB 1,[POINT 29,SETZOP,35]	;modify the SETZ 
	MOVE 1,SAVE1	;restore ACs
	XCT SETZOP	;zero ac and/or memory
	MOVEM 1,SAVE1
WO:	MOVE 1,JOBTPC
	TLZ 1,440140	;zero the error bits
	MOVEM 1,JOBTPC
	MOVE 1,SAVE1	
	JRST 2,@JOBTPC	;return
	
OV:	TLNN 1,40000↔GO ZDIV	;SKIP ON FLOATING OVERFLOW.
	MOVE 1,BP2↔JSR NUMOUT
	;OUTSTR  MESS2
	JRST WO

ZDIV:	TLNN 1,40↔GO NOTIN	;SKIP ON ZERO DIVIDE.
	LAC 1,BP4↔JSR NUMOUT
	;OUTSTR  MESS4
	JRST WO

NOTIN:	MOVE 1,BP3
	JSR NUMOUT
	;OUTSTR  MESS3
	JRST WO

NUMOUT:	0
	MOVEM 1,XPTR
	MOVEM 2,SAVE2
	MOVEI 2,6
	MOVE 1,JOBTPC
	HRLZI 1,-1(1)
L1:	ROT 1,3
	IORI 1,60
	IDPB 1,XPTR
	HLRI 1,
	SOJG 2,L1
	MOVE 2,SAVE2
	JRST @NUMOUT

SETZOP:	SETZ 0,
XPTR:	0
SAVE1:	0
SAVE2:	0
BP2:	POINT 7,MESS2+6,13
BP3:	POINT 7,MESS3+4,20
BP4:	POINT 7,MESS4+5,13
MESS2:	ASCIZ/FLOATING OVERFLOW OCCURED, PC = 000000/
MESS3:	ASCIZ/OVERFLOW OCCURED, PC = 000000/
MESS4:	ASCIZ /ZERO DIVIDE OCCURED, PC = 000000/
⊗;
SUBREND UNDERFLOW;
NSUBR GEODPY		;GEOMED'S DISPLAY REFRESH

	EXTERN SHOW1,SHOW2,SHOW3,SHOW4
	LACI 1↔DAC GLASS#
	CALL(DDSET,[DDGEO])
	LAC 1,UNIVERSE
	SON 1,1↔DAC 1,W0↔DAC 1,W
L1:	$TYPE 0,1↔CAIE $WINDOW↔GO L2
	PUSH P,1↔PUSH P,GLASS↔LAC 1,DPYFLG
	PUSHJ P,@[SHOW2↔SHOW3↔SHOW1↔SHOW4](1)
	AOS GLASS
L2:	LAC 1,W↔BRO 1,1↔DAC 1,W
	CAME 1,W0↔GO L1↔POP0J
	DECLARE{W,W0}

SUBREND GEODPY;12-FEB-73(BGB),12-MAR-73(BGB)
NSUBR STADPY		;STATUS DISPLAY
	EXTERN DECDPY,DPYSTR,FDPY,EDPY,VDPY,DTYO,IDPY
	EXTERN AIVECT,AVECT,BUFDPY,FLODPY,DPYOUT,DPYSET
	EXTERN DPYBUF
	CALL(DDSET,[DDSTA])
	LAC 1,BUFDPY
	SKIPE FLAGL↔LAC 1,DPYBUF
	CALL(DPYSET,1)

;STATUS OF FRAME SELECT.
	CALL(AIVECT,[=180],[=500])
	LAC 1,FRAAM
	PUSH P,[
		[ASCIZ/WORLD/]
		[ASCIZ/BODY/]
		[ASCIZ/RELATIVE/]
		[ASCIZ/CAMERA/]](1)
	CALL(DPYSTR)

;STATUS OF FRAME ORIGIN SWITCH.
	LACI[ASCIZ/ FRAME/]
	SKIPE FRMORG
	LACI[ASCIZ/ FRAME */]
	CALL(DPYSTR,0)

;STATUS OF OPERAT SELECT SWITCH.
	CALL(AIVECT,[=390],[=500])
	LAC 1,OPERAT
	PUSH P,[
		[ASCIZ/TRANSLATION/]
		[ASCIZ/ROTATION/]
		[ASCIZ/DILATION/]
		[ASCIZ/REFLECTION/]](1)
	CALL(DPYSTR)
;----- STADPY			;TRANSLATION STRENGTH.
	CALL(AIVECT,[=185],[=480])
	CALL(FLODPY,TDEL,[4])
	CALL(DPYSTR,{[[ASCIZ/ FEET/]]})

;ROTATION STRENGTH IN PI FRACTION.
	CALL(AIVECT,[=185],[=460])
L1:	LAC RDEL↔LAC 1,[3.15]
	CAMLE[6.28]↔GO L2
	CAML[2.0]↔GO[FSC 1,1↔PUSH P,1
		CALL(DTYO,["2"])↔POP P,1
		GO .+1]
	FDVR 1,RDEL↔FIX 1,233000↔PUSH P,1
	CALL(DPYSTR,{[[ASCIZ"π/"]]})
	CALL(DECDPY)
L2:

;ROTATION STRENGTH IN RADIANS.
	CALL(AIVECT,[=400],[=460])
	CALL(FLODPY,RDEL,[3])

;RDEL IN DEGREES, MINUTES AND SECONDS.
	CALL(AIVECT,[=270],[=460])
	LAC 1,RDEL
	FMPR 1,[206264.806]
	FIX 1,233000
	AOS 1
	IDIVI 1,=3600
	IDIVI 2,=60
	PUSH P,3
	PUSH P,2
	PUSH P,1
	CALL(DECDPY)↔CALL(DTYO,[" "])
	CALL(DECDPY)↔CALL(DTYO,[" "])
	CALL(DECDPY)

;DILATION STRENGTH.
	CALL(AIVECT,[=390],[=480])
	LAC DDEL↔FMP[100.0]↔FADR[0.001]
	CALL(FLODPY,0,[2])
	CALL(DTYO,["%"])
	CALL(DTYO,[" "])
	LAC AXECNT↔ADDI 60↔CALL(DTYO,0)
;----- STADPY			DISPLAY THE SCRATCH PAD PDL.
	CALL(AIVECT,[-=511],[=430])
	CDR 16,PDLPTR
	CAILE 16,PADPDL↔GO[
		CALL(IDPY,{(16)})
		CALL(NTYPE,{(16)})
		CAIN 1,$YNODE
		GO $.+3
		CAIG 1,$BODY
		GO NOTFEV
		CALL(DPYSTR,[[ASCIZ/ of /]])
		CALL(BGET,{(16)})
		CALL(IDPY,1)
	NOTFEV:	CALL(DTYO,[15])↔CALL(DTYO,[12])
		SOJA 16,.-1]
	SKIPN FLAGL↔GO L3

;DISPLAY TOP OBJECT OF PADPDL.
	CDR 16,PDLPTR
	CAILE 16,PADPDL↔GO[
;		LAC 1,(16)
;		TESTZ 1,VBIT↔GO[CALL(VDPY,1)↔GO .+1]
;		TESTZ 1,EBIT↔GO[CALL(EDPY,1)↔GO .+1]
;		TESTZ 1,FBIT↔GO[CALL(FDPY,1)↔GO .+1]
		CALL(DPYTOP,{(16)})
		GO .+1]
;DISPLAY THE SECOND OBJECT WHEN APPROPRIATE.
	CDR 16,PDLPTR
	CAILE 16,PADPDL+1↔GO[
		LAC 1,-1(16)↔LAC 2,(16)
		LAC 0,(1)↔IOR 0,(2)↔LDB[POINT 3,0,16]
		CAIE 6↔CAIN 3↔SKIPA↔GO .+1
		CALL(LINKED,1,2)↔JUMPE 1,.+1
		LAC 1,-1(16)
;		TESTZ 1,VBIT↔GO[CALL(VDPY,1)↔GO .+1]
;		TESTZ 1,EBIT↔GO[CALL(EDPY,1)↔GO .+1]
;		TESTZ 1,FBIT↔GO[CALL(FDPY,1)↔GO .+1]
		CALL(DPYTOP,{(16)})
		GO .+1]

L3:	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔GO L4↔LAC 1,(1)
	SKIPE FLAGD↔GO[CALL(DPYNODE,1)↔GO L4]
L4:	CALL(DPYOUT,[0])
	POP0J
SUBREND STADPY;2-FEB-73(BGB),1-DEC,73(BGB)
NSUBR DPYTOP,OBJECT
	CALL NTYPE,OBJECT
	CAIGE 1,$YNODE
	POP1J
	GO @[ POP1J.	;YNODE
	      POP1J.	;ZNODE
	      POP1J.	;BODY
	      FDPY	;FACE
	      EDPY	;EDGE
	      VDPY	;VERTEX
	    ]-$YNODE(1)
SUBREND DPYTOP
;SUBRS NTYPE,JDPY	;Node Type number, Display pointer
;____________________________________________________________________
;
NSUBR NTYPE,NODE		;NODE TYPE NUMBER 0 TO 17.
	LAC 1,@NODE		;TYPE BITS WORD.
	SKIPGE 1↔SETZ 1,	;NEGATIVE BIT.
	TLNE 1,(1B9)↔SETZ 1,	;NORMALIZATION BIT.
	ANDI 1,17↔POP1J
SUBREND NTYPE;25-MAR-73(BGB)
;____________________________________________________________________
;
NSUBR JDPY,NODE
	SKIPN 1,NODE↔GO[CALL(DPYSTR,{[[ASCIZ/NIL/]]})↔POP1J]
	CAMGE 1,UNIVERSE↔GO L
	CAML  1,44↔GO L
	CALL(NTYPE,1)
	CALL(DTYO,{NLETTER(1)})
L:	CALL({OCTDPY+1},NODE)
	POP1J
SUBREND JDPY;25-MAR-73(BGB)
;TABLES REL,CONTYP,NNAMES,NLETTER	;Node Info. Tables
;NODE RELLOCATION BITS.
; 0  1  2| 3  4  5| 6  7  8| 9 10 11|12 13 14|15 16 17|  ← BIT.
; 0  0  0| 0  0  0| 8  7  6| 5  4  3| 2  1  0|-1 -2 -3|	← WORD.
;
	INTERNAL REL

REL:	XWD	0000,	0000	;FRAME.
	XWD	0000,	0001	;EMPTY.
	XWD	0000,	0202	;UNIVERSE.
	XWD	0000,	0000	;LAMP.

	XWD	0600,	1600	;CAMERA.
	XWD	2640,	3660	;WORLD.
	XWD	1600,	1600	;WINDOW.
	XWD	0760,	0760	;IMAGE.

	XWD	0004,	0004	;TEXT.
	XWD	0000,	0000	;XNODE.
	XWD	0000,	0000	;YNODE.
	XWD	0000,	0000	;ZNODE.

	XWD	3760,	3760	;BODY.
	XWD	1020,	1060	;FACE.
	XWD	3760,	3760	;EDGE.
	XWD	0140,	0140	;VERTEX.

;NODE CONTENT TYPES.

CONTYP:	BYTE(9)333,333,333,333	;FRAME.
	BYTE(9)000,000,000,000	;EMPTY.
	BYTE(9)000,040,001,000	;UNIVERSE.
	BYTE(9)000,000,001,000	;LAMP.

	0			;CAMERA.
	0			;WORLD.
	0			;WINDOW.
	0			;IMAGE.

	BYTE(9)000,000,001,000	;TEXT.
	0			;XNODE.
	0			;YNODE.
	0			;ZNODE.

	BYTE(9)044,444,441,220	;BODY.
	BYTE(9)004,033,041,333	;FACE.
	BYTE(9)044,444,441,000	;EDGE.
	BYTE(9)003,334,411,333	;VERTEX.

;NODE NAMES.
	INTERN NNAMES
NNAMES:
   [ASCIZ"FRAME"]↔[ASCIZ"EMPTY"]↔[ASCIZ"UNIVERSE"]↔[ASCIZ"LAMP"]
   [ASCIZ"CAMERA"]↔[ASCIZ"WORLD"]↔[ASCIZ"WINDOW"]↔[ASCIZ"IMAGE"]
   [ASCIZ"TEXT"]↔[ASCIZ"XNODE"]↔[ASCIZ"YNODE"]↔[ASCIZ"ZNODE"]
   [ASCIZ"BODY"]↔[ASCIZ"FACE"]↔[ASCIZ"EDGE"]↔[ASCIZ"VERTEX"]

;NODE INITIALS.
	INTERN NLETTER
NLETTER:
	"R" ↔ "M" ↔ "U" ↔ "L"
	"C" ↔ "W" ↔ "D" ↔ "I"
	"T" ↔ "X" ↔ "Y" ↔ "Z"
	"B" ↔ "F" ↔ "E" ↔ "V"
NSUBR DPYNODE,NODE	;DISPLAY CONTENTS OF NODE LOWER RIGHT OF SCREEN.
	EXTERN AIVECT,AVECT,DPYBIG
	EXTERN DTYO,IDPY,DPYSTR,FLODPY,DECDPY,OCTDPY

	CALL(AIVECT,[=260],[-=70])
	CALL(AVECT,[=260],[-=380])
	CALL(AVECT,[=508],[-=380])
	CALL(AVECT,[=508],[-=70])
	CALL(AVECT,[=260],[-=70])

	CALL(DPYBIG,[1])
	CALL(JDPY,NODE)
	CALL(DPYSTR,{[[ASCIZ"   "]]})
	SETQ(KIND,{NTYPE,NODE})
	LAC [POINT 7,LNKCHR]
	DAC LNKPTR
	CAIN 1,$YNODE
	GO [ MOVE 2,NODE↔MOVE 0,YREL(2)↔GO .+2 ]	;SPECIAL HACK FOR YNODES
	LAC REL(1)↔DAC RELTMP		;RELLOCATION.
	LAC CONTYP(1)↔DAC CONTMP	;CONTENT TYPE.
	LAC NNAMES(1)↔CALL(DPYSTR,0)

	HRREI -3↔DAC WRD
L1:
	LACN WRD↔IMULI =25↔SUBI =170↔DAC Y
	CALL(AIVECT,[=265],Y)
	ILDB 1,LNKPTR		;PICK UP LINK CHARACTERS (LEFT HALF)
	CALL(DTYO,1)
	CALL(DTYO,[" "])	;A SPACE BETWEEN THEM
	ILDB 1,LNKPTR		;(RIGHT HALF)
	CALL(DTYO,1)
	CALL(DTYO,[" "])	;A SPACE BEFORE A NUMBER
	SKIPGE WRD↔GO .+3↔CALL(DTYO,[" "])	;AND ANOTHER IF NOT NEGATIVE
	CALL(DECDPY,WRD)

;FULL WORD.
	CALL(AIVECT,[=345],Y)
	LACN 2,WRD↔LAC CONTMP
	ROT(2)↔ROT(2)↔ROT(2)↔ANDI 7000
	CAIN 3000↔GO[LAC 1,NODE↔ADD 1,WRD
		CALL(FLODPY,{(1)},[4])↔GO L2]

;LEFT HALF.
	CALL(AIVECT,[=345],Y)
	LAC 1,NODE↔ADD 1,WRD↔CAR(1)↔PUSH P,0
	LACN 2,WRD↔CAR RELTMP↔ROT(2)
	TRNE 10↔GO[CALL(JDPY)↔GO .+2]↔CALL({OCTDPY+1})

;RIGHT HALF.
	CALL(AIVECT,[=425],Y)
	LAC 1,NODE↔ADD 1,WRD↔CDR(1)↔PUSH P,0
	LACN 2,WRD↔CDR RELTMP↔ROT(2)
	TRNE 10↔GO[CALL(JDPY)↔GO .+2]↔CALL({OCTDPY+1})

L2:	AOS 1,WRD↔CAIG 1,8↔GO L1
	CALL(DPYBIG,[2])
	POP1J
LNKCHR:	ASCIZ/        <>≤≥∨∧∩∪⊂⊃←→.,/
DECLARE{WRD,X,Y,KIND,RELTMP,CONTMP,LNKPTR}
SUBREND DPYNODE; BGB 25 MARCH 1973

NSUBR SEENODE,NODE
	PUSHACS
	CALL(DPYSET,[DPYBUF])
	CALL(DPYNODE,NODE)
	CALL(DPYOUT,[0])
	POPACS
	POP1J
SUBREND SEENODE;4-MAY-73(TVR)
NSUBR GEOMED		;TELETYPE COMMAND JUMP TABLE
L0:	CRLF
L1:	OUTCHR["*"]
L2:	CALL(STADPY)
	LAC ALPHA↔DAC CTRL↔SETZM ALPHA
	LAC BETA ↔DAC META↔SETZM BETA
	CALL(GETCW0)
	TRZE 200↔SETOM CTRL
	TRZE 400↔SETOM META
;	CAIN 0,40↔GO L2
	CAIN 0,15↔GO[SETZM ITERAT↔GO L2]
	CAIN 0,12↔GO L1
	DAC 0,CHR
	LAC CTRL↔AND META↔DAC MTCT
	SETZ↔SKIPE CTRL↔IORI 1
	SKIPE META↔IORI 2↔DAC MCBITS

;READ JUMP TABLE.
	LAC CHR↔DAC 1
	CAIG 0,140↔GO[CAR 1,A00(1)↔GO L3]
	CAIG 0,172↔GO[CAR 1,A00-40(1)↔GO L3]
	CAR 1,A173-173(1)
L3:	PUSHJ P,(1)	;CALL GEOMED COMMAND CHARACTER SUBR.
	GO L2		;NO-SKIP IMMEDIATE COMMAND.
	GO L0		;SKIP CRLF-STAR COMMAND.
	LIT
SUBREND GEOMED;2/4/73(BGB)

NOP:	OUTCHR CHR↔OUTSTR[ASCIZ/ NO OPERATION./]↔CRLF↔POP0J
QMARK:	CALL(GETCW0)↔DAC 1
	CAIG 0,140↔GO[CDR 1,A00(1)↔GO L4]
	CAIG 0,172↔GO[CDR 1,A00-40(1)↔GO L4]
	CDR 1,A173-173(1)
L4:	CRLF↔OUTCHR["	"]
	OUTSTR(1)	;PRINT GEOMED COMMAND CHARACTER COMMENT.
	CRLF↔OUTCHR["*"]↔POP0J

DEFINE $$(Q,A,B){XWD A,[ASCIZ"B"]}
;ASCII 00 TO 37--------------------------------------------------

A00:	NOP   	;null.
$$("↓",PADPSH,{	↓ COPY PUSH. α↓ ROTATE PUSH.})
$$("α",{[SETOM ALPHA↔POP0J]},{α CONTROL KEY PREFIX.})
$$("β",{[SETOM BETA↔POP0J]},{β META KEY PREFIX.})

$$("∧",LINKER,{	∧ FETCH PVT LINK})
$$("¬",XEVERT,{	¬ BODY EVERT. α¬ BODY SUBTRACTION.})
$$("ε",{[SETOM ALPHA↔SETOM BETA↔POP0J]},{ε META-CONTROL PREFIX.})
$$("π",XRDEL,{	π ACCEPT ROTATION DELTA.})

$$("λ",XTDEL,{	λ ACCEPT TRANSLATION DELTA.})
$$(" ",NOP,{	TAB.})
$$(" ",NOP,{	LF.})
$$(" ",NOP,{	VT.})

$$(" ",NOP,{	FF.})
$$(" ",NOP,{	CR.})
$$("∞",MACRO,{	∞ INSTANT CUBE. α∞ INSTANT TORUS.})
$$("∂",SWCD,{	∂ FLIP NODE DISPLAY SWITCH.})

$$("⊂",LINKER,{	⊂ FETCH BRO LINK.})
$$("⊃",LINKER,{	⊃ FETCH SIS LINK.})
$$("∩",LINKER,{	∩ FETCH DAD LINK, α∩ BODY INTERSECTION.})
$$("∪",LINKER,{	∪ FETCH SON LINK, α∪ BODY UNION.})

$$("∀",XDISBL,{	∀ DISABLE BODY OPERATIONS SWITCH.})
$$("∃",SWC4,{	∃ REFLECTION DEFAULT.})
$$("⊗",LINKER,{	⊗ FETCH UNIVERSE NODE.})
$$("↔",PADSWP,{(1ST ↔ 2ND)(1ST α↔ 3RD)(1ST β↔ LAST)(2ND ε↔ 3RD)})

$$("_",XDPY,{	_ STICKY DISPLAY MODE SWITCH.})
$$("→",LINKER,{	→ FETCH ALT2 LINK.})
$$("~",NOP,{	TILDE})
$$("≠",NOP,{	≠})

$$("≤",LINKER,{	≤ FETCH NED LINK.})
$$("≥",LINKER,{	≥ FETCH PED LINK.})
$$("≡",NOP,{	≡})
$$("∨",LINKER,{	∨ FETCH NVT LINK.})

;----------------------------------------------------------------
;ASCII 40 TO 100-------------------------------------------------

$$(" ",XREDPY,{	SPACE})
$$("!",SWC1,{	! TRANSLATION DEFAULT SWITCH.})
$$(" ",NOP,{	DOUBLE QUOTE.})
$$("#",CRLF20,{	# TWENTY CRLF'S.})

$$("$",XCONVEX,{	MAKE CONVEX.})
$$("%",XDDEL,{	% SET DILATION DELTA STRENGTH.})
$$("&",NOP,{	&})
$$("'",NOP,{	'})

$$("(",EUTRAN,{	EUCLIDEAN TRANSFORMATION -Y.})
$$(" ",EUTRAN,{	EUCLIDEAN TRANSFORMATION +Y.})
$$("*",EUTRAN,{	EUCLIDEAN TRANSFORMATION +Z.})
$$("+",LINKER,{	OTHER LINK.})

$$(" ",LINKER,{	CLOCKWISE LINK.})
$$("-",EUTRAN,{	EUCLIDEAN TRANSFORMATION -Z.})
$$(".",LINKER,{	COUNTER CLOCKWISE LINK.})
$$("/",HALVE ,{	HALVE STRENGTH.})

$$("0",SETDIG,{	SET-DIGIT COMMAND.})
$$("1",SETDIG,{	SET-DIGIT COMMAND.})
$$("2",SETDIG,{	SET-DIGIT COMMAND.})
$$("3",SETDIG,{	SET-DIGIT COMMAND.})
	
$$("4",SETDIG,{	SET-DIGIT COMMAND.})
$$("5",SETDIG,{	SET-DIGIT COMMAND.})
$$("6",SETDIG,{	SET-DIGIT COMMAND.})
$$("7",SETDIG,{	SET-DIGIT COMMAND.})
	
$$("8",SETDIG,{	SET-DIGIT COMMAND.})
$$("9",SETDIG,{	SET-DIGIT COMMAND.})
$$(":",EUTRAN,{	EUCLIDEAN TRANSFORMATION +X.})
$$(";",EUTRAN,{	EUCLIDEAN TRANSFORMATION -X.})
	
$$("<",LINKER,{	FETCH NFACE LINK.})
$$("=",SWC3,{	DILATION DEFAULT SWITCH.})
$$(">",LINKER,{	FETCH PFACE LINK.})
$$("?",QMARK,{	INFORMATION PREFIX.})

$$("@",SWC2,{	ROTATION DEFAULT SWITCH.})

;----------------------------------------------------------------
;ASCII 101 TO 132 UPPER CASE-------------------------------------
;ASCII 141 TO 172 LOWER CASE.
A101:
$$("A",ATTDET,{	A ATTACH, αA ARROW, βAXECNT.})
$$("B",XBODY ,{	B BODY RETRIEVAL.})
$$("C",XCOPY ,{	C COPY})
$$("D",ATTDET,{	D DETACH, αDARKEN, βDUAL, εUNDARKEN.})

$$("E",SWIRE ,{	E SWEEP WIRE.})
$$("F",SWCF,{	F FRAME STEP SWITCH.})
$$("G",XGLUE,{	G GLUE COMMAND.})
$$("H",COMHLP,{	H HELP})

$$("I",XIN,{	I INPUT B3D. αI INPUT CAMERA. βI INPUT CRE. εI INPUT D3D.})
$$("J",JOINVV,{	J JOIN VERTEX-VERTEX.})
$$("K",XKILL,{	K KILL COMMANDS.})
$$("L",SWCL,{	L LABEL LIGHTS SWITCH.})
	
$$("M",MIDPOI,{	M MIDPOINT COMMAND.})
$$("N",XNAME,{	N NAME BODY})
$$("O",XOUT,{	O OUTPUT COMMANDS.})
$$("P",XPLOTO,{	P OUTPUT PLOT FILE})

$$("Q",SWCQ,{	Q FRAME ORIGIN SWITCH.})
$$("R",XROTCM,{	R ROTATION COMPLETION.})
$$("S",XSWEEP,{	S SWEEP COMMANDS.})
$$("T",XTEXT,{	TEXT LABEL.})

$$("U",NOP,{	U})
$$("V",VBODY,{	V MAKE VERTEX BODY.})
$$("W",XWMAKE,{	MAKE: W WORLD. αW WINDOW. βW CAMERA. εW IMAGE.})
$$("X",{[POP P,↔SETZ 1,↔POP0J]},{X EXIT GEOMED.})

$$("Y",NOP,{	Y NOP})
$$("Z",NEWMAC,{	Z MACRO CALL, αZ EDIT MACRO, βZ TAKE COMMANDS FROM FILE.})

;ASCII 133 TO 140.
$$("[",NOP,{	[})
$$("\",DOUBLE,{	\ DOUBLE STRENGTH.})
$$("]",NOP,{	]})
$$("↑",PADPOP,{	↑ PADPDL POP. α↑ ROTATE POP.})
$$("←",LINKER,{	← FETCH ALT LINK.})
$$("`",NOP,{	`})

;ASCII 173 TO 177.
A173:
$$("{",NOP,{	LEFT CURLY.})
$$("|",XINVERT,{	| INVERT EDGE PARITY.})
$$(" ",XDPY,{	ALT OCCULT. αALT FRONT FACE. βALT ALL EDGES.})
$$("}",NOP,{	RIGHT CURLY})
$$(" ",NOP,{	RUBOUT})
;----------------------------------------------------------------
NSUBR COMHLP
	EXTERNAL TVHELP
	CALL(TVHELP,[[SIXBIT/GEOMEDHLP/↔0↔SIXBIT/DOCBGB/]])
	POP0J
SUBREND
NSUBR VBODY			;1. "V"-COMMAND.  MAKE VERTEX BODY.
	LAC PTR,PDLPTR
	SETQ(BNEW,{MKB,WORLD})↔PUSH PTR,1     ;BODY INTO PADPDL
	SKIPE META↔GO L1		;DIABLE FACE & VERTEX.
	CALL(MKF,BNEW)↔PUSH PTR,1	;FACE INTO PADPDL
	CALL(MKV,BNEW)↔PUSH PTR,1	;VERTEX INTO PADPDL
L1:	DAC PTR,PDLPTR
	SKIPE CTRL↔POP0J		;DISABLE MAKE FRAME.
	CALL(MKFRAME)↔LAC 2,BNEW
	FRAME. 1,2
	POP0J
BNEW:	0
SUBREND;2/4/73(BGB)
NSUBR MIDPOI			;MIDPOINT AN EDGE PROPORTIONAL TO DDEL
	EXTERN ESPLIT
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
	LAC 1,(PTR)↔TEST 1,EBIT↔POP0J
	PVT 0,1↔DAC V1#
	NVT 0,1↔DAC V2#
	CALL(ESPLIT,1)↔DAC 1,(PTR)
	LAC 2,V1↔SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
	LAC DDEL↔FMPRM XWC(1)↔FMPRM YWC(1)↔FMPRM ZWC(1)
	LAC 2,V2↔SLACI 3,(1.0)↔FSBR 3,DDEL
	LAC XWC(2)↔FMPR 3↔FADRM XWC(1)
	LAC YWC(2)↔FMPR 3↔FADRM YWC(1)
	LAC ZWC(2)↔FMPR 3↔FADRM ZWC(1)
	CALL(GEODPY)
	POP0J↔VAR
SUBREND MIDPOI;2/8/73(BGB)
;COMMANDS XINVERT,XEVERT		;"|","¬"
XINVERT:;"|" COMMAND.---------------------------------------------
;FLIP THE FACE-VERTEX ORIENTATION OF AN EDGE - BGB - 9 FEB 1973.
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
	LAC 1,(PTR)↔TEST 1,EBIT↔POP0J
	MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
	POP0J
;2/9/73(BGB)------------------------------------------------------

XEVERT:;"¬" COMMAND.----------------------------------------------
	EXTERN EVERT
	SKIPE CTRL↔GO XBIN	;BODY SUBTRACTION "α¬".
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
	LAC 1,(PTR)↔TEST 1,BBIT↔POP0J
	CALL(EVERT,1)↔CALL(GEODPY)↔POP0J
;3/20/73(BGB)-----------------------------------------------------
NSUBR SWIRE			;2. "E"-COMMAND. SWEEP WIRE.
;BGB 14 JANUARY 1973.
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+2↔POP0J;PADPDL EMPTY TEST.
	CALL(LINKED,{-1(PTR)},{(PTR)})	       ;LEGAL ARGS TEST.
	SKIPN 1↔POP0J↔LAC PTR,PDLPTR
	CALL(MKEV,{-1(PTR)},{(PTR)})	       ;MAKE EDGE VERTEX.
	LAC PTR,PDLPTR↔DAC 1,(PTR)↔POP0J       ;NEW TOP OF PADPDL.
SUBREND SWIRE;2/4/73(BGB)
NSUBR JOINVV			;3. "J"-COMMAND. JOIN VERTICES.
	ACCUMULATORS{F,V1,V2,E1,E2}
	LAC PTR,PDLPTR↔CDR 1,PTR
	CAIGE 1,PADPDL+2↔POP0J	    	;2 OR MORE ARGUMENTS.
	LAC V1,(PTR)
	LAC V2,-1(PTR)
	DAC V2,F

	TEST V1,VBIT↔POP0J	;AT LEAST ONE VERTEX.
	TEST F,FBIT↔GO L1

;JOIN ENDS OF WIRE CASE.
	PED E1,F↔PVT V2,E1↔DAC V2,(PTR)
	CALL(MKFE,V2,F,V1)
	CALL(GEODPY)
	POP0J

;JOIN VERTICES ACROSS A FACE.
L1:	TEST V2,VBIT↔POP0J
	PED E1,V1↔DAC E1,E0#
L2:	SETQ(F,{FCCW,E1,V1})
	PED E2,V2↔DAC E2,EE0#
L3:	CALL(FCCW,E2,V2)↔CAMN 1,F↔GO L4		;FACE IN COMMON.
	SETQ(E2,{ECCW,E2,V2})↔CAME E2,EE0↔GO L3
	SETQ(E1,{ECCW,E1,V1})↔CAME E1,E0↔GO L2↔POP0J
L4:	POP PTR,0
	CALL(MKFE,V1,F,V2)
	DAC 1,(PTR)
	DAC PTR,PDLPTR
	CALL(GEODPY)
	POP0J
SUBREND JOINVV;2/5/73(BGB)
NSUBR EUTRAN			;4. ":;()-*" COMMANDS. EUCLIDEAN TRANSFORMATION COMMANDS.
;BGB 15 JANUARY 1973.
	EXTERN BGET,APTRAN,MKFRAME,MKCOPY,KLNODE
	EXTERN TRANSLATE,ROTATE,SHRINK

;GET TOP OBJECT OF PADPDL.
	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
	LAC 2,(1)↔DAC 2,OBJECT
	$TYPE 0,2↔CAIN 0,$WINDOW↔GO WNTRAN
	DZM DEL1↔DZM DEL2↔DZM DEL3

;OPERATION.
	SKIPN 1,MCBITS↔LAC 1,OPERAT↔DAC 1,OP
	LAC 2,[TRANSLATE↔ROTATE↔SHRINK↔SHRINK](1)
	DAP 2,L3

;AXIS CODE.
	LAC 1,CHR↔SETZ 3,
	CAIE 1,";"↔CAIN 1,":"↔IORI 3,1		;X-AXIS.
	CAIE 1,"("↔CAIN 1,")"↔IORI 3,2		;Y-AXIS.
	CAIE 1,"-"↔CAIN 1,"*"↔IORI 3,4		;Z-AXIS.
	LAC 1,OP↔CAILE 1,1↔GO[
	SLACI(1.0)↔DAC DEL1↔DAC DEL2↔DAC DEL3
	LAC AXECNT↔CAIN 2↔TRC 3,7
	CAIN 3↔TRO 3,7↔GO .+1]
	
;DELTA ARGUMENT.
	LAC CHR↔LAC 1,OP
	LAC 2,@[TDEL↔RDEL↔DDEL↔[-1.0]](1)

	CAIN"-"↔MOVNS 2
	CAIN"("↔MOVNS 2
	CAIN";"↔MOVNS 2

	GO@[L1↔L1↔[MOVNS 2↔JUMPGE 2,L1	   ;NEGATIVE DILATION.
	SLACI 2,(1.0)↔FDVR 2,DDEL↔GO L1]   ;POSITIVE DILATION.
	[LAC 2,[-1.0]↔GO L1]](1)	   ;REFLECTION DELTA.

L1:	TRNE 3,1↔DAC 2,DEL1
	TRNE 3,2↔DAC 2,DEL2
	TRNE 3,4↔DAC 2,DEL3
;----- EUTRAN			   ;MAKE REFERENCE FRAME.
	LAC 1,FRAAM↔GO@[[GO .+1]		;WORLD FRAME.
	[CALL(BGET,OBJECT)↔GO .+1]		;BODY FRAME.
	[CALL(BGET,OBJECT)↔DAD 1,1↔GO .+1]	;DADDY'S FRAME.
	[LAC 1,CAMERA↔GO .+1]](1)		;CAMERA FRAME.
	SKIPE 1↔FRAME 1,1
	SKIPE 1↔GO[CALL(MKCOPY,1)↔GO .+1]	;COPY OF REFRAM.
	DIPZ 1,REFRAM				;XWD REFRAM,0

;FRAME ORIGIN SWITCH.
	SKIPN FRMORG↔GO[SKIPN OP↔GO .+1		;NON-TRANSLATION.
	CALL(BGET,OBJECT)↔FRAME 1,1
	JUMPE 1,.+1↔PUSH P,1
	CAR 1,REFRAM↔SKIPN 1↔CALL(MKFRAME)↔DIPZ 1,REFRAM
	LAC 2,1↔POP P,1↔SLACI XWC(1)
	LAPI XWC(2)↔BLT ZWC(2)↔GO .+1]

;MAKE EUCLIDEAN TRANSFORMATION MATRIX.
	CALL(,REFRAM,DEL1,DEL2,DEL3)
L3:	CALL(ROTATE)↔DAC 1,TRAN			;MAKE THE TRANSFORM.	
	SKIPE REFRAM↔GO[CAR REFRAM↔CALL(KLNODE,0)↔GO .+1];FLUSH THE REFRAM.
;----- EUTRAN			   ;APPLY THE TRANSFORMATION.
	LAC ITERAT↔SKIPN↔AOS↔DAC COUNT
L2:	CALL(APTRAN,OBJECT,TRAN)
	CALL(GEODPY)
	SKIPGE COUNT↔GO[
		AOSL COUNT↔GO .+1
		SETZM ITERAT
		CALL(XSWEEP)
		CDR 1,PDLPTR↔LAC(1)↔DAC OBJECT↔GO L2]
	SOSLE COUNT↔GO L2
	SETOM@TRAN
	CALL(KLNODE,TRAN)
	POP0J
	DECLARE{OBJECT,TRAN,REFRAM,COUNT,OP}
	DECLARE{DEL1,DEL2,DEL3}
;----- EUTRAN			   ;WINDOW TRANFORMATION.
WNTRAN:	LAC 1,CHR
	CAIN 1,"-"↔GO[LAC -1(2)↔FMPR DDEL↔DAC -1(2)
		SKIPE CTRL↔GO W2↔GO W1]
	CAIN 1,"*"↔GO[LAC -1(2)↔FDVR DDEL↔DAC -1(2)
		SKIPE CTRL↔GO W2↔GO W1]
	LAC 3,TDEL↔FIXX 3,		;TRANSLATION.
	LACI 4,-2(2)↔SKIPE CTRL↔SOS 4	;ADDRESS.
	CAIN 1,";"↔GO[NIP(4)↔SUB 3↔DIP(4)↔GO W1]
	CAIN 1,":"↔GO[NIP(4)↔ADD 3↔DIP(4)↔GO W1]
	CAIN 1,"("↔GO[NAP(4)↔SUB 3↔DAP(4)↔GO W1]
	CAIN 1,")"↔GO[NAP(4)↔ADD 3↔DAP(4)↔GO W1]
	POP0J
W1:	CALL(CROP,2)↔EXTERN CROP
W2:	CALL(GEODPY)↔POP0J
SUBREND EUTRAN;2/4/73(BGB)
;5. SWITCH MODIFYING COMMANDS.	;"|@∃=QF"
;	!	TRANSLATION DEFAULT.
;	@	ROTATION DEFAULT.
;	∃	REFLECTION DEFAULT.
;	=	DILATION DEFAULT.
;	Q	FLIP FRAME ORIGIN.
;	F	STEP FRAME SELECT SWITCH.

SWC1:	SETZM OPERAT↔POP0J		;"!" TRANSLATION DEFAULT.
SWC2:	LACI 1↔DAC OPERAT↔POP0J		;"@" ROTATION DEFAULT.
SWC3:	LACI 2↔DAC OPERAT↔POP0J		;"=" DILATION DEFAULT.
SWC4:	LACI 3↔DAC OPERAT↔POP0J		;"∃" REFLECTION DEFAULT.

SWCF:	SKIPE CTRL↔GO XFOCAL		;"αF" SET FOCAL.
	AOS 1,FRAAM↔ANDI 1,3
	DAC 1,FRAAM↔POP0J		;FRAME STEP SWITCH.
SWCL:	SETCMM FLAGL↔POP0J		;"L" LABEL LIGHTS SWITCH.
SWCD:	SETCMM FLAGD↔POP0J		;"∂" NODE DISPLAY SWITCH.
SWCQ:	SETCMM FRMORG↔POP0J		;FRAME ORGIN TOGGLE.

CRLF20:	LACI =20↔CRLF↔SOJG .-1↔POP0J	;TWENTY CRLF'S.

XDISBL:	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
	LAC 1,(1)↔TEST 1,BBIT↔POP0J
	LAC 2,MCBITS↔GO@[
	[MARKZ 1,{BDLBIT+BDVBIT+BDPBIT}↔POP0J]	;ENABLE.
	[MARK 1,BDLBIT↔POP0J]		;FRAME DISABLE
	[MARK 1,BDVBIT↔POP0J]		;VERTEX DISABLE
	[MARK 1,BDPBIT↔POP0J]](2)	;PARTS DISABLE
;6. STACK MODIFYING COMMANDS.	;"↔↓↑"

;"↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[2].
;"α↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[3].
;"β↔"	PADPDL SWAP:	PADPDL[2]↔PADPDL[3].
;"ε↔"	PADPDL SWAP:	PADPDL[1]↔PADPDL[N].

PADSWP: LAC PTR,PDLPTR↔CDR PTR
	LACM 1,CTRL↔CAIGE PADPDL+2(1)↔POP0J	;ARG ∃ TEST.
	LAC 1,MCBITS↔GO@[
	[LAC(PTR)↔EXCH -1(PTR)↔DAC(PTR)↔POP0J]	;  1ST & 2ND.
	[LAC(PTR)↔EXCH -2(PTR)↔DAC(PTR)↔POP0J]	;α 1ST & 3RD.
	[LAC(PTR)↔EXCH PADPDL+1↔DAC(PTR)↔POP0J]	;β 1ST & LAST.
	[LAC -1(PTR)↔EXCH -2(PTR)
	 DAC -1(PTR)↔POP0J]			;ε 2ND & 3RD.
	](1)↔LIT

;"↓"	PADPDL COPY PUSH DOWN.
;"↓"	PADPDL ROTATE DOWN.

PADPSH:	LAC PTR,PDLPTR↔CDR PTR
	CAIGE PADPDL+1↔POP0J
	SKIPE CTRL↔GO .+4
	PUSH PTR,(PTR)↔DAC PTR,PDLPTR↔POP0J	;COPY PUSH.
	LAC[XWD PADPDL+1,PADPDL]↔BLT -1(PTR)
	LAC PADPDL↔DAC(PTR)↔POP0J		;ROTATE PUSH.

;"↑"	PADPDL POP UP.
;"α↑"	PADPDL ROTATE UP.

PADPOP:	LAC PTR,PDLPTR↔CDR PTR
	CAIGE PADPDL+1↔POP0J
	SKIPE CTRL↔GO .+4
	POP PTR,↔DAC PTR,PDLPTR↔POP0J		;PAD POP.
	SUBI PADPDL↔POP PTR,1(PTR)↔SOJG .-1	;ROTATE POP
	LAC PTR,PDLPTR↔LAC 1(PTR)↔DAC PADPDL+1
	POP0J
;STRENGTH COMMANDS		;"/\0123456789"
;"/" COMMAND.-----------------------------------------------------
HALVE:	SKIPN 1,MCBITS↔LAC 1,OPERAT	;EUCLIDEAN OPERATION.
	LAC TDEL(1)↔FSC -1↔DAC TDEL(1)	;"/" COMMAND.
	POP0J
;"\" COMMAND.-----------------------------------------------------
DOUBLE:	SKIPN 1,MCBITS↔LAC 1,OPERAT	;EUCLIDEAN OPERATION.
	LAC TDEL(1)↔FSC 1↔DAC TDEL(1)	;"\" COMMAND.
	POP0J
;"0123456789" COMMANDS.-------------------------------------------
SETDIG:	LAC 1,CHR↔ANDI 1,17		;DIGIT.
	SKIPN 2,MCBITS↔LAC 2,OPERAT	;EUCLIDEAN OPERATION.
	GO@[
	[LAC ITERAT↔IMULI 12↔ADD 1	;ITERATION COUNT.
	 CAILE=128↔LACI=128
	 DAC ITERAT↔POP0J]
	[SUBI 1,=10↔LAC[3.1415927]	;ROTATION DELTA.
	 FSC(1)↔DAC RDEL↔POP0J]
	[SKIPN 1↔LACI 1,1↔FLOAT 1,	;DILATION DELTA.
	 FMPR 1,[0.1]↔DAC 1,DDEL↔POP0J]
	[SUBI 1,4↔SLACI(1.0)↔FSC(1)	;TRANSLATION DELTA.
	 DAC TDEL↔POP0J]](2)
;-----------------------------------------------------------------
;COMMAND XFOCAL
XFOCAL:	OUTSTR[ASCIZ/	FOCAL = /]↔CALL(REALIN)
	LAC 1,CAMERA
	FMPR[3.2808E-3]↔HLLM 0,3(1)
	HLLZ 2,1(1)↔CDR 3,1(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-3(1)
	HLLZ 2,2(1)↔CDR 3,2(1)↔FLOAT 3,↔FMPR 3,0↔FDVR 3,2↔DACN 3,-2(1)
	FMPR[100000.0]↔DAC 0,-1(1)
	CALL(GEODPY)↔POP0J
;COMMANDS XTDEL,XDDEL,XRDEL 	;"λπ%"

COMMENT⊗REALIN MOVED TO ARITH.FAI
NSUBR REALIN			; INPUT FROM TTY SMALL REAL NUMBER - BGB - 16 DEC 1972.
;AC-0 INTEGER ACCUMULATION.	AC-0 RETURNS REAL NUMBER.
;AC-1 CHARACTER.		AC-1 RETURNS BREAK CHARACTER.
;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
;AC-3 MINUS SIGN FLAG.
	SETZ↔SETZB 2,3
L1:	CALL(GETCHL)
	CAIN 1,15↔CALL(GETCHL)
	CAIE 1,"-"↔GO .+3↔SETCMM 3↔GO L1
	CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
	CAIL 1,"0"↔CAILE 1,"9"↔GO L2
	JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
	ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
L2:	FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
	SKIPE 3↔MOVNS↔POP0J
SUBREND REALIN;12/16/72(BGB)
⊗;

	EXTERNAL REALIN

XTDEL:	CALL(REALIN)↔CAIN 1,42↔FDVR[12.0]↔DAC TDEL↔POP0J
XDDEL:	CALL(REALIN)↔FMPR[0.01]↔DAC DDEL↔POP0J
XRDEL:	CALL(REALIN)↔CAIN 1,"/"↔GO[
	SKIPN↔SLACI(1.0)↔DAC RDEL	;NUMERATOR.
	CALL(REALIN)↔SKIPN↔SLACI(1.0)	;DENOMINATOR.
	LAC 1,RDEL↔FMPR 1,[3.1415927]
	FDVR 1,0↔DAC 1,RDEL↔POP0J]	;PI FRACTION.
	CAIN 1,"'"↔FMPR[1.74532925E-2]	;DEGREES.
	DAC RDEL↔POP0J			;RADIANS.
;8. SWEEP COMMANDS.		;"SRG"

NSUBR XSWEEP
	EXTERN SWEEP,PYRAMID
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J	   ;ARG EXISTS.
	LAC 1,(PTR)↔TESTZ 1,FBIT↔GO L2
	TEST 1,VBIT↔POP0J
	PED 2,1↔JUMPE 2,.+4
	MOVS 0,1(2)↔CAME 0,1(2)↔GO [ SETOM CTRL↔GO L2A ]
	CALL(SWIRE)↔GO L3			;SWEEP WIRE.
COMMENT ⊗
L2:	SKIPE MTCT↔GO[L2A:
		CALL(PYRAMID,1)↔DAC 1,(PTR)
		CALL(GEODPY)↔POP0J]
	SKIPN 2,META↔LACM 2,CTRL     ;0=PRISM ;α+1=CCW ;β-1=CW.
	CALL(SWEEP,1,2)
⊗;
L2:	LAC CHR
	CAIN "T"
	GO [ SKIPL 2,CTRL
	     LACI 2,1 
	     GO L2B ]
L2A:	SETZ 2,
	SKIPE META
	HRLI 2,-1
	SKIPE CTRL
	GO [ CALL(PYRAMIND,1)↔DAC 1,(PTR)
	     CALL(GEODPY)↔POP0J ]
L2B:	CALL(SWEEP,1,2)
L3:	CALL(GEODPY)
	MOVNS ITERAT
	POP0J
SUBREND;2/10/73(BGB)
XROTCM:	EXTERN ROTCOM
	CDR PTR,PDLPTR↔CAIGE PTR,PADPDL+1↔POP0J
	LAC 1,(PTR)↔TEST 1,FBIT↔POP0J
	CALL(ROTCOM,1)
	CALL(GEODPY)
	POP0J
;____________________________________________________________________
;
XGLUE:	LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+2↔POP0J	;TWO ARGS.
	LAC 1,(PTR)↔LAC 2,-1(PTR)
	EXTERN GLUE
	CALL(GLUE,1,2)↔DAC 1,-1(PTR)
	POP PTR,0↔DAC PTR,PDLPTR
	CALL(GEODPY)
	POP0J
NSUBR XKILL			;"K"
	EXTERN KLEV,KLVE,KLFE,REMOVF,KLBFEV
	LAC PTR,PDLPTR↔CDR PTR↔CAIGE PADPDL+1↔POP0J	;ONE ARG.
	LAC 1,(PTR)
	TEST  1,VBIT↔GO L2
	DAC 1,2↔PED 3,1
	SETQ(4,{ECCW,3,2})
	SETQ(5,{ECCW,4,2})
	DAC 2,1↔CAME 3,5↔GO L1
	CALL(KLEV,1)↔GO L3
L1:	CALL(KLEV,1)↔CALL(KLFE,1)↔GO L3
L2:	TESTZ 1,EBIT↔GO[SKIPE CTRL↔GO[
		CALL(KLVE,1)↔GO L3]
		CALL(KLFE,1)↔GO L3]
	TESTZ 1,FBIT↔GO[CALL(REMOVF,1)↔GO L3]
	TESTZ 1,BBIT↔GO[CALL(KLBFEV,1)↔POP PTR,0
		DAC PTR,PDLPTR↔CALL(GEODPY)↔POP0J]
	POP0J 	
L3:	DAC 1,(PTR)
	CALL(GEODPY)
	POP0J
SUBREND XKILL;2/10/73------------------------------------------------------
NSUBR LINKER			;9. LINK FOLLOWING COMANDS.
	LAC PTR,PDLPTR
	LAC CHR↔CAIN"⊗"↔GO[PUSH PTR,UNIVERSE↔DAC PTR,PDLPTR↔POP0J]
	CDR 1,PTR↔CAIGE 1,PADPDL+1↔POP0J	  ;STACK EMPTY.

	LAC 2,(1)↔LAC CHR
	CAIE"."↔CAIN","↔GO L1		;CLOCK LINK COMMANDS.
	CAIN"+"↔GO L1			;OTHER LINK COMMAND.
	CAIN"∩"↔GO[SKIPE CTRL↔GO XBIN↔TESTZ 2,PBIT↔DAD 2,2↔GO L0]
	CAIN"∪"↔GO[SKIPE CTRL↔GO XBIN↔SON 2,2↔GO L0]
	CAIN"⊂"↔GO[TESTZ 2,PBIT↔BRO 2,2↔GO L0]
	CAIN"⊃"↔GO[TESTZ 2,PBIT↔SIS 2,2↔GO L0]

	CAIE "<"↔CAIN ">"↔ADDI 2,1
	CAIE "≤"↔CAIN "≥"↔ADDI 2,2
	CAIE "∨"↔CAIN "∧"↔ADDI 2,3
	CAIE "←"↔CAIN "→"↔ADDI 2,6

	SKIPE CTRL↔SUBI 2,4	;-3 -2 -1
	SKIPE META↔ADDI 2,5	;6 7 8
	SKIPE MTCT↔ADDI 2,2	;4 5 6

	LAC 2,(2)		;FETCH WORD FROM THE NODE.
	CAIN "≤"↔MOVSS 2
	CAIN "<"↔MOVSS 2
	CAIN "∨"↔MOVSS 2
	CAIN "←"↔MOVSS 2

L0:	CDR 2
	CAML 44↔GO .+3		;LOWER THAN MAX.
	CAML UNIVER↔DAC(1)	;HIGHER THAN MIN.
	POP0J
;----- LINKER			   ;OTHER LINK COMMANDS.
L1:	TESTZ 2,PBIT↔GO[LAC CHR		;OBJECT CLOCK LINKS.
	    CAIN"."↔GO[CCW 2,2↔DAC 2,(1)↔POP0J]	;CCW BODY.
	    CAIN","↔GO[ CW 2,2↔DAC 2,(1)↔POP0J]	; CW BODY.
	    POP0J]
	ANDI 0,17		   ;GET TYPE NUMBER
	CAIN 0,$TEXT
	GO [LAC CHR		   ;SPECIAL HACK FOR TEXT LIST
	    CAIN"."↔GO[TCCW 2,2↔SKIPE 2↔DAC 2,(1)↔POP0J]  ;CCW TEXT
	    CAIN","↔GO[ TCW 2,2↔DAC 2,(1)↔POP0J]	; CW BODY.
	    POP0J]
	CAIGE 1,PADPDL+2↔POP0J		;TWO ARGUMENTS REQUIRED.
	LAC 1,0(PTR)↔LAC 2,-1(PTR)
	CALL(LINKED,1,2)↔SKIPN 1↔POP0J	;WHICH ARE LINKED.
	LAC 1,0(PTR)↔LAC 2,-1(PTR)
	SETZ 3,↔LAC CHR
	CAIN"+"↔GO L2
	CAIE","↔AOS 3			;DISTINGUISH CW & CCW.
	SKIPN CTRL↔ADDI 3,2
	SKIPE CTRL↔ADDI 3,4		;DISTINGUISH OPERATION.

;EDGE IS IN THE FIRST POSITION OF THE STACK.
L2:	TEST 1,EBIT↔GO L3			 ;EDGE.
	TEST 2,FBIT↔GO[TEST 2,VBIT↔POP0J	;FACE OR VERTEX.
		SKIPE CTRL↔ADDI 3,2↔GO .+1]	;CTRL VERTEX.
	PUSH P,1↔PUSH P,2↔PUSHJ P,@L5(3)
	CAIN 3,2↔AOS PTR↔CAIN 3,3↔AOS PTR
	DAC 1,-1(PTR)↔POP0J

;EDGE IS IN THE SECOND POSITION OF THE STACK.
L3:	TEST 2,EBIT↔POP0J
	TEST 1,FBIT↔GO[TEST 1,VBIT↔POP0J
		SKIPE CTRL↔ADDI 3,2↔GO .+1]
	PUSH P,2↔PUSH P,1↔PUSHJ P,@L5(3)
	CAIN 3,2↔SOS PTR↔CAIN 3,3↔SOS PTR
	DAC 1,0(PTR)↔POP0J

L5:	OTHER↔OTHER↔ECW↔ECCW↔VCW↔VCCW↔FCW↔FCCW

SUBREND LINKER;2/9/73(BGB)
;COMMANDS XNAME,XBODY		;"B","N"
NSUBR XNAME		;NAME A BODY
	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
	LAC 1,(1)↔TEST 1,BBIT↔POP0J
	CALL(RDNAME)
	JUMPE 6,[ OUTSTR[ASCIZ/ILLEGAL NAME.
*/]↔		  POP0J]
	CALL(FNDNAME)
	GO [ LAC 1,PDLPTR↔LAC 1,(1)
	     DAC 4,-2(1)↔DAC 5,-1(1)
	     OUTSTR[ASCIZ/*/]↔POP0J ]
	OUTSTR[ASCIZ/NAME ALREADY IN USE.
*/]↔	POP0J
SUBREND XNAME;2/9/73(BGB)
;____________________________________________________________________
;
NSUBR XBODY		;BODY RETRIEVAL - BGB - 20 FEBRUARY 1973.
	LAC PTR,PDLPTR
	SKIPN CTRL↔GO[CDR 1,PTR↔CAIGE 1,PADPDL+1↔GO .+1
		CALL(BGET,{(PTR)})↔DAC 1,(PTR)↔POP0J]
	CALL(RDNAME)↔JUMPN 6,L2

;FETCH BODY BY ITS SERIAL NUMBER.
	LAC 1,WORLD↔CCW 1,1
	CAME 1,WORLD↔SOJG 3,.-2
	CAME 1,WORLD↔GO RET
LOSE:	OUTSTR[ASCIZ/BODY NOT FOUND.
*/]↔	POP0J

;FETCH BODY BY ITS PNAME.
L2:	CALL(FNDNAME)
	GO LOSE
RET:	PUSH PTR,1
	DAC PTR,PDLPTR
	OUTSTR[ASCIZ/*/]↔POP0J
SUBREND XBODY;2/9/73(BGB)

NSUBR RDNAME
	OUTSTR[ASCIZ/	:/]
	LACI 2,=10			;TEN CHARACTERS TO A NAME.
	LAC  1,[POINT 7,4,-1]
	SETZB 3,6			;BODY SERIAL NUMBER.
	SETZB 4,5
L:	CALL(GETCL0)↔CAIN 15↔GO EOL		;END OF LINE.
	IDPB 1↔CAIGE"0"↔GO .+3↔CAIG"9"↔GO[
	IMULI 3,12↔ANDI 0,17↔ADD 3,0↔GO .+2]
	SETOM 6				;NON-NUMERIC CHR SEEN.
	SOJG 2,L
	CALL(GETCL0)↔CAIE 15↔GO .-2
	CRLF
	SKIPA
EOL:	CALL(GETCL0)↔POP0J
SUBREND RDNAME;

NSUBR FNDNAME
;FETCH BODY BY ITS PNAME.
L2:	LAC 1,WORLD↔CCW 1,1
	CAME 1,WORLD
	GO[CAME 4,-2(1)↔GO L2+1
	   CAME 5,-1(1)↔GO L2+1↔GO .+1]
	CAME 1,WORLD↔AOS(P)
	POP0J
SUBREND FNDNAME;2/9/73(BGB)
;SUBRS MACRO,ATTDET		;"∞","AD"
NSUBR(MACRO)
	OPDEF PTO[711440B17]
	MOVE 1,MCBITS
	PTO @[[0↔MACRO0]
	      [0↔MACRO1]
	      [0↔MACRO2]
	      [0↔MACRO3]]  (1)
	POP0J
MACRO0:	ASCIZ"V\:)\E;E(E:J↑/*S--↑/@/:)\!"
MACRO1: ASCIZ"V:7@S*J!↑8/:\@S)↓>G↑:)!"
MACRO2:	ASCIZ"⊗αW↔∪A⊃⊃↔βWA↑βAβAβ/β-λ256
):↔β-);//β\β*(↔β*(λ.25
⊃:↔⊂;\\↑↑βA"
MACRO3:	0
	LIT
SUBREND MACRO;2/9/73(BGB)
;____________________________________________________________________
;
NSUBR ATTDET		;ATTACH-DETACH COMMANDS & FRIENDS.
	EXTERN BDET,BATT,FVDUAL
	LAC 1,CHR
	CAIE 1,"D"↔GO L4

;DETACH, αDARKEN, βDUAL, εUNDARKEN.

	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J	;DETACH.
	LAC 1,(1)↔TEST 1,BBIT↔GO L3
	SKIPE META↔GO[CALL(FVDUAL,1)↔CALL(GEODPY)↔POP0J]
	CALL(BDET,1)↔POP0J
L3:	TEST 1,EBIT↔POP0J
	SLACI 0,(DARKEN)↔IORM(1)↔SKIPE META↔ANDCAM(1)
	CALL(GEODPY)↔POP0J


;ATTACH, αNOP, βAXECNT.
L4:	SKIPE CTRL↔GO XARROW
	SKIPE META↔GO[AOS 1,AXECNT		;STEP AXECNT.
	CAIL 1,4↔LACI 1,1↔DAC 1,AXECNT
	POP0J]
	CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J	;ATTACH.
	LAC 2,-1(1)↔LAC 1,(1)
	CALL(BATT,1,2)↔POP0J

SUBREND ATTDET;2/9/73(BGB)
;COMMANDS XDPY,XCOPY,XIN,XOUT	;"_",<ALT>,"C","I","O"
XDPY: ;-----------------------------------------------------------
	LAC 1,CHR
	CAIN 1,"_"↔GO[LAC MCBITS↔DAC DPYFLG↔CALL(GEODPY)↔POP0J]
	CAIE 1,175↔POP0J
	LAC MCBITS↔PUSH P,DPYFLG↔DAC DPYFLG↔DAC ODPYFLG
	CALL(GEODPY)↔POP P,DPYFLG↔POP0J
XCOPY: ;----------------------------------------------------------
	EXTERN MKCOPY
	SKIPE CTRL↔GO[LAC 1,PDLPTR↔PUSH 1,CAMERA↔DAC 1,PDLPTR↔POP0J]
	LAC 16,PDLPTR↔CDR 1,16
	CAIGE 1,PADPDL+1↔POP0J
	LAC(1)↔CALL(MKCOPY,0)
	PUSH 16,1↔DAC 16,PDLPTR
	LACI 2↔DAC DPYFLG↔CALL(GEODPY)
	POP0J
XIN: ;------------------------------------------------------------
	EXTERN ICAM,INCRE,IFORM0,IFORM1	     ;INPUT FORMAT TYPE-1.
	SKIPE CTRL↔GO[SKIPE META
		      GO [ CALL(IFORM0)↔CALL(GEODPY)↔POP0J]
		      CALL(ICAM)↔POP0J]
	SKIPE META↔GO[CALL(INCRE)↔CALL(GEODPY)↔POP0J]
	CALL(IFORM1)↔SKIPN 1↔POP0J
	LAC 16,PDLPTR↔PUSH 16,1↔DAC 16,PDLPTR
	CALL(GEODPY)
	POP0J
XOUT: ;-----------------------------------------------------------
	EXTERN OCAM,OFORM0,OFORM1	;OUTPUT FORMAT TYPE-1.
	SKIPE CTRL↔GO[SKIPE META
		      GO [ CALL(OFORM0)↔POP0J]
		      CALL(OCAM)↔POP0J]
	CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
	CALL(OFORM1,{(1)})
	POP0J
;COMMANDS XBIN,XWMAKE,XPLOTO	;"α∩","α∪","¬","W","P"
XBIN: ;-----------------------------------------------------------
	EXTERN BIN,BUN,BSUB,KLBFEV,MKCVEX
	CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J
	LAC 2,-1(1)↔LAC 1,(1)↔LAC CHR
	CAIN"∩"↔GO[CALL(BIN,2,1)↔GO .+5]
	CAIN"∪"↔GO[CALL(BUN,2,1)↔GO .+3]
	CAIN"¬"↔GO[CALL(BSUB,2,1)↔GO .+1]
	PUSH P,1↔CALL(GEODPY)↔CALL(MKCVEX,{(P)})
	LAC 1,PDLPTR↔POP 1,2↔DAC 1,PDLPTR
	CALL(KLBFEV,2)↔CDR 1,PDLPTR↔LAC 2,(1)↔POP P,(1)
	CALL(KLBFEV,2)↔CALL(GEODPY)↔POP0J
XWMAKE: ;---------------------------------------------------------
	EXTERN MKWORLD,MKWINDOW,MKCAMERA
	LAC 1,MCBITS
	PUSHJ P,@[MKWORLD↔MKWINDOW↔MKCAMERA↔MKCAMERA](1)
	LAC PTR,PDLPTR↔PUSH PTR,1↔DAC PTR,PDLPTR↔POP0J
XPLOTO:;----------------------------------------------------------
	EXTERN PLOTO
	CALL(PLOTO)↔OUTCHR["*"]↔POP0J
;COMMAND XTEXT			;"T"  MAKE A TEXT NODE
BEGIN XTEXT
	EXTERNAL MKNODE
↑XTEXT:
	ACCUMULATORS{V,TXTPTR,CWNODE,TXTNODE}
	SKIPE META
	GO XSWEEP		;TRIANGULAR SWEEP
	CDR 1,PDLPTR		;GET PDL POINTER
	CAIGE 1,PADPDL+1↔POP0J	;IS THERE ANYTHING?, IF NOT RETURN
	LAC V,(1)		;GET ARG OFF PDL
	TEST V,VBIT↔POP0J	;IF IT ISN'T A VERTEX, RETURN QUICKLY
	CALL(EDTEXT,V)
	JCALL GEODPY

BEND XTEXT;25-APR-73(TVR)

NSUBR NEWMAC
	EXTERNAL MACPTR,MACCNT,MACNOD,IFORM2
↑NEWMAC:SKIPE META
	JCALL IFORM2
	SKIPN CTRL
	GO [ CALL(RDNAME)
	     CALL(FNDNAM)	;Is there a macro by that name?
	     GO [ OUTSTR[ASCIZ/NO SUCH MACRO
*/]				;No, return
		  POP0J ]
	     PVT 1,1		;Get vertex of body
	     JUMPE 1,[FATAL(BODY WITHOUT VERTEX!)]	;Nothing there!
	     PY 1,1
	     JUMPE 1,[NOTMAC: OUTSTR[ASCIZ/NOT A MACRO.
*/]↔			      POP0J]
	     LAC 0,(1)
	     ANDI 0,17
	     CAIE 0,$YNODE
	     GO NOTMAC
	     YCODE 0,1
	     CAIE 0,$TEXTHD
	     GO NOTMAC
	     PTEXT 1,1		;Text of vertex
	     JUMPE 1,NOTMAC
	     OUTSTR[ASCIZ/<ENTERING MACRO>
/]
	     MOVEM 1,MACNOD
	     HRLI 1,000700	;Make a byte pointer
	     MOVEM 1,MACPTR
	     MOVEI 0,5*8-1	;And a count
	     MOVEM 0,MACCNT
	     POP0J ]		;Now, return
	CALL(RDNAME)
	CALL(FNDNAM)
	SKIPA
	GO [ OUTSTR[ASCIZ/Name already in use/]
	     PVT 1,1		;Get vertex of body
	     PTEXT 0,1
	     JUMPN 0,[	OUTSTR[ASCIZ/. Will edit.
/]↔			CALL(EDTEXT,1)
			POP0J ]
	     OUTSTR[ASCIZ/ and not a macro.
*/]↔	     POP0J ]
	PUSHP 4			;Save print name
	PUSHP 5
	SETQ(BNEW,{MKB,WORLD})	;Make a new body
	POPP -1(1)		;Set print name
	POPP -2(1)
	CALL(MKV,BNEW)		;Make a vertex
EDIT:	CALL(EDTEXT,1)		;Put text on it
	POP0J
	
	DECLARE{BNEW}
SUBREND NEWMAC
;COMMAND XCONVEX,XRETRY,XARROW
XCONVEX:CDR 1,PDLPTR
	CAIGE 1,PADPDL+1↔POP0J
	LAC(1)
	EXTERN MKCVEX↔CALL(MKCVEX,0)↔CALL(GEODPY)↔POP0J

XREDPY:	CALL(STADPY)
	PUSH P,DPYFLG
	MOVE ODPYFLG
	MOVEM DPYFLG
	CALL(GEODPY)
	POP P,DPYFLG
	POP0J

BEGIN XARROW:
	ACCUMULATORS{E1,V1,V2,Y1,Y2}
↑XARROW:CDR 1,PDLPTR
	CAIGE 1,PADPDL+1↔POP0J
	LAC E1,(1)
	MOVEI 17
	AND (E1)
	CAIN $EDGE
	GO DOEDGE
	CAIN $YNODE
	GO [ YCODE 0,E1
	     CAIE $ARROW
	     POP0J
	     LAC Y1,E1
	     PARRW Y2,Y1
	     LDB 0,[POINT 3,(Y1),12]
	     GO L2 ]
	CAIN $VERT
	GO [ LAC V1,E1
	     CAIGE 1,PADPDL+3↔POP0J
	     LAC E1,-2(1)
	     MOVEI 17
	     AND (E1)
	     CAIE $EDGE
	     POP0J
	     LAC V2,-1(1)
	     MOVEI 17
	     AND (V2)
	     CAIE $VERT
	     POP0J
	     GO DOVERT ]
	POP0J
DOEDGE:	PVT V1,E1
	NVT V2,E1
DOVERT:	CALL(MKY,V1,[.RLARW])
	DAC 1,Y1
	CALL(MKY,V2,[.RLARW])
	DAC 1,Y2
	LAC 0,1(E1)
	DAC 0,-1(Y1)
	DAC 0,-1(Y2)
	PARRW. Y1,Y2
	PARRW. Y2,Y1
	PVT. V1,Y1
	PVT. V2,Y2
	LAC K6
	DAC OFFSET(Y1)
	DAC OFFSET(Y2)
	MOVEI 0,1
L2:	DPB 0,[POINT 3,(Y1),12]
	DPB 0,[POINT 3,(Y2),12]
	PUSHP 0
	PUSHP Y1
	CALL(GEODPY)
	POPP Y1
	PARRW Y2,Y1
	POPP 0
OKQ:	OUTSTR[ASCIZ/
OK? /]↔	CALL(GETCHW)
	ANDI 1,177
	CAIE 1,"*"
	CAIN 1,"-"
	GO [ CAIN 1,"*"
	     SKIPA 1,K6
	     MOVN 1,K6
	     SKIPGE OFFSET(Y1)
	     MOVN 1,1
      REDO:  FADRM 1,OFFSET(Y1)
	     FADRM 1,OFFSET(Y2)
	     SKIPN OFFSET(Y1)
	     GO REDO
	     GO L2 ]
	CAIE 1,"/"
	CAIN 1,"\"
	GO [ CAIN 1,"/"
	     SKIPA 1,[0.5]
	     MOVSI 1,(2.0)
	     FMPRM 1,OFFSET(Y1)
	     FMPRM 1,OFFSET(Y2)
	     FMPRM 1,K6
	     GO L2 ]
	ANDI 1,137
	CAIN 1,"N"
	GO [ ADDI 0,1
	     CAILE 0,3
	     MOVEI 0,1
	     MOVNS OFFSET(Y1)
	     MOVNS OFFSET(Y2)
	     GO L2 ]
	CAIN 1,"Y"
	GO [ OUTSTR[ASCIZ/
*/]↔	     POP0J ]
	OUTSTR[ASCIZ'Answer Y,n,*,/,\, or -']
	GO OKQ
K6:	10.0
BEND XARROW
	TAIL
END SA