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