perm filename CMANDS[GEM,BGB] blob
sn#030950 filedate 1973-03-25 generic text, type T, neo UTF8
00100 ;GEOMETRIC EDITOR COMMAND EXECUTION.
00200 ;WING OPERATIONS.
00300 EXTERN MKB,MKF,MKE,MKV,MKLOCOR
00400 EXTERN KLB,KLF,KLE,KLV,WING
00500 EXTERN WING,LINKED
00600 EXTERN ECW,ECCW,OTHER,OTHER.
00700 EXTERN BGET,FCW,FCCW,VCW,VCCW
00800 ;EULER OPERATIONS.
00900 EXTERN MKEV,MKFE
01000
01100
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 LOCOR.
01100 CALL(MKLOCOR)↔LAC 2,BNEW
01200 LOCOR. 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,MKTRAN,ROTATE
00500 ;GET TOP OBJECT OF PADPDL.
00600 CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
00700 LAC 2,(1)↔DAC 2,OBJECT
00800 $TYPE 0,2↔CAIN 0,$WINDOW↔GO WNTRAN
00900
01000 ;OPERATION CODE. ;0 - TRANSLATION.
01100 SKIPN 1,METCON↔LAC 1,OPERAT ;1 - ROTATION.
01200 DAC 1,OP ;2 - DILATION.
01300 ;3 - REFLECTION.
01400 ;AXIS CODE.
01500 LAC 0,OP↔LSH 0,6↔LAC 1,CHR
01600 CAIE 1,";"↔CAIN 1,":"↔IORI 010 ;X-AXIS.
01700 CAIE 1,"("↔CAIN 1,")"↔IORI 020 ;Y-AXIS.
01800 CAIE 1,"-"↔CAIN 1,"*"↔IORI 030 ;Z-AXIS.
01900 IOR 0,AXECNT↔DAC 0,OPAXCNT ;AXIS MODIFIER.
02000
02100 ;DELTA ARGUMENT.
02200 LAC CHR↔LAC 1,OP↔LAC 2,@[TDEL↔RDEL↔DDEL↔[-1.0]](1)
02300 CAIE"-"↔CAIN"("↔MOVNS 2↔CAIN";"↔MOVNS 2
02400 GO@[L1↔L1↔[MOVNS 2↔JUMPGE 2,L1 ;NEGATIVE DILATION.
02500 SLACI 2,(1.0)↔FDVR 2,DDEL↔GO L1] ;POSITIVE DILATION.
02600 [LAC 2,[-1.0]↔GO L1]](1) ;REFLECTION DELTA.
02700 L1: DAC 2,DELTA
02800
02900 ;GET REFERENCE FRAME.
03000 LAC 1,FRAME↔GO@[
03100 [LAC 1,WORLD↔GO .+1]
03200 [CALL(BGET,OBJECT)↔GO .+1]
03300 [CALL(BGET,OBJECT)↔DAD 1,1↔GO .+1]
03400 [LAC 1,CAMERA↔GO .+1]](1)
03500 SKIPN 1↔LAC 1,WORLD
03600 LOCOR 1,1
03700 DAC 1,REFRAM
03800
03900 ;MAKE EUCLIDEAN TRANSFORMATION MATRIX.
04000 SETQ(TRAN,{MKTRAN,REFRAM,OPAXCNT,DELTA})
04100
04200 ;FRAME ORIGIN SWITCH.
04300 SKIPN FRMORG↔GO[SKIPN OP↔GO .+1 ;NON-ROTATION.
04400 CALL(BGET,OBJECT)
04500 LOCOR 1,1↔JUMPE 1,.+1
04600 LAC 2,TRAN
04700 SLACI XWC(1)↔LAPI XWC(2)↔BLT ZWC(2)
04800 GO .+1]
00100 ;APPLY THE TRANSFORMATION.
00200 LAC ITERAT↔SKIPN↔AOS↔DAC COUNT
00300 L2: CALL(ROTATE,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,OPAXCNT,DELTA,COUNT,OP}
01510
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,FRAME↔ANDI 1,3
01600 DAC 1,FRAME↔POP0J ;FRAME STEP SWITCH.
01700 SWCL: SETCMM FLAGL↔POP0J ;"L" LABEL LIGHTS 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,METCON↔GO@[
02500 [MARKZ 1,{BDLBIT+BDVBIT+BDPBIT}↔POP0J] ;ENABLE.
02600 [MARK 1,BDLBIT↔POP0J] ;LOCOR 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,METCON↔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,METCON↔LAC 1,OPERAT ;EUCLIDEAN OPERATION.
00300 LAC TDEL(1)↔FSC -1↔DAC TDEL(1) ;"/" COMMAND.
00400 POP0J
00500 ;"\" COMMAND.-----------------------------------------------------
00600 DOUBLE: SKIPN 1,METCON↔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,METCON↔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 TESTZ 1,VBIT↔GO[CALL(KLEV,1)↔GO L3]
00700 TESTZ 1,EBIT↔GO[SKIPE CTRL↔GO[
00800 CALL(KLVE,1)↔GO L3]
00900 CALL(KLFE,1)↔GO L3]
01000 TESTZ 1,FBIT↔GO[CALL(REMOVF,1)↔GO L3]
01100 TESTZ 1,BBIT↔GO[CALL(KLBFEV,1)↔POP PTR,0
01200 DAC PTR,PDLPTR↔CALL(GEODPY)↔POP0J]
01300 POP0J
01400 L3: DAC 1,(PTR)
01500 CALL(GEODPY)
01600 POP0J
01700 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,OBIT↔DAD 2,2↔GO L0]
01200 CAIN"∪"↔GO[SKIPE CTRL↔GO XBIN↔SON 2,2↔GO L0]
01300 CAIN"⊂"↔GO[TESTZ 2,OBIT↔BRO 2,2↔GO L0]
01400 CAIN"⊃"↔GO[TESTZ 2,OBIT↔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,OBIT↔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,4(1)↔DAC 5,5(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,4(1)↔GO L2+1
04400 CAME 5,5(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 METCON↔DAC DPYFLG↔CALL(GEODPY)↔POP0J]
00500 CAIE 1,175↔POP0J
00600 LAC METCON↔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]
02010 SKIPE META↔GO[CALL(INCRE)↔CALL(GEODPY)↔POP0J]
02100 CALL(IFORM1)↔SKIPN 1↔POP0J
02200 LAC 16,PDLPTR↔PUSH 16,1↔DAC 16,PDLPTR
02300 CALL(GEODPY)
02400 POP0J
02500 XOUT: ;-----------------------------------------------------------
02600 EXTERN OCAM,OFORM1 ;OUTPUT FORMAT TYPE-1.
02700 SKIPE CTRL↔GO[CALL(OCAM)↔POP0J]
02800 CDR 1,PDLPTR↔CAIGE 1,PADPDL+1↔POP0J
02900 CALL(OFORM1,{(1)})
03000 POP0J
03100 XBIN: ;-----------------------------------------------------------
03200 EXTERN BIN,BUN,BSUB
03300 CDR 1,PDLPTR↔CAIGE 1,PADPDL+2↔POP0J
03400 LAC 2,-1(1)↔LAC 1,(1)
03500 LAC CHR
03600 CAIN"∩"↔GO[CALL(BIN,2,1)↔CALL(GEODPY)↔POP0J]
03700 CAIN"∪"↔GO[CALL(BUN,2,1)↔CALL(GEODPY)↔POP0J]
03800 CAIN"¬"↔GO[CALL(BSUB,2,1)↔CALL(GEODPY)↔POP0J]
03900 XWMAKE: ;---------------------------------------------------------
04000 EXTERN MKWORLD,MKWINDOW,MKCAMERA
04100 LAC 1,METCON
04200 PUSHJ P,@[MKWORLD↔MKWINDOW↔MKCAMERA↔MKCAMERA](1)
04300 LAC PTR,PDLPTR↔PUSH PTR,1↔DAC PTR,PDLPTR↔POP0J
04400 ;-----------------------------------------------------------------