;<DRAW>BODY.FAI.70, 19-NOV-75 19:34:58, EDIT BY HELLIWELL
VERSION(BODY,6)
SUBTTL PIN SWAPPING

PSWAPA:
MD,<	TRZA TFLG
PSWAPB:	TRO TFLG		;PIN NUMBER SWAP ONLY
>;MD
	PUSHJ P,PUSHM		;SET DISPLAY MODE
	PUSHJ P,GETCLS
	JRST POPME
	TLNN M,DSKACT!MACACT
MD,<	OUTSTR[ASCIZ/FIRST PIN ID?/]	>
MPC,<	OUTSTR[ASCIZ/FIRST PIN NAME?/]	>
	PUSHJ P,READP
	JRST POPM		;ALTMODE
	JRST POPME		;ERROR
	JUMPE T,POPM		;LET HIM OUT ON 0
	MOVEM T,N1
	TLNN M,DSKACT!MACACT
MD,<	OUTSTR[ASCIZ/SECOND PIN ID?/]	>
MPC,<	OUTSTR[ASCIZ/SECOND PIN NAME?/]	>
	PUSHJ P,READP
	JRST POPM		;ALTMODE
	JRST POPME		;ERROR
	PUSHJ P,POPM
	JUMPE T,CPOPJ		;LET HIM OUT ON 0
	MOVEM T,N2
	SETZM L1
	SETZM L2
	MOVEM A,CURBOD		;STO BODY POINTER HERE FOR NOW
	MOVEI B,RADDR(A,BLNK,BPLNK)	;PIN LIST OFF OF BODY
	JRST FNDPN2

FNDPN1:	MOVE A,B		;CURRENT POINT
	FETCH(T,B,BPLOC)	;GET PIN-LOC BLOCK IN TYPE
	FETCH(T,T,TPID)		;WE'RE DISPLAYING "REAL" PINIDS
	CAME T,N1
	 JRST NOTN1
MPC,<	SKIPN L1		;SAME PIN MAYBE ON BOTH SIDES
	JRST [	MOVEM A,L1
		JRST FNDPN2]
	HRLM A,L1		;GOTH BOTH POINTS FOR #1
	SKIPN TT,L2
	JRST FNDPN2
	TLNE TT,-1		;ALSO GOT BOTH FOR #2?
	TLNN TT,-1
	JRST FNDPN2
	JRST GOTBOT

NOTN1:	CAME T,N2
	JRST FNDPN2
	SKIPN L2
	JRST [	MOVEM A,L2
		JRST FNDPN2]
	HRLM A,L2
	SKIPN TT,L1
	JRST FNDPN2
	TLNE TT,-1
	TLNN TT,-1
	JRST FNDPN2
	JRST GOTBOT
>;MPC

MD,<	MOVEM A,L1
	SKIPN TT,L2
	JRST FNDPN2
	JRST GOTBOT

NOTN1:	CAME T,N2
	JRST FNDPN2
	MOVEM A,L2
	SKIPN TT,L1
	JRST FNDPN2
	JRST GOTBOT
>;MD

FNDPN2:	FETCH(B,B,BPLNK)
	JUMPN B,FNDPN1
	OUTSTR[ASCIZ/CAN'T FIND BOTH PINS ON THIS BODY!
/]
	POPJ P,

GOTBOT:
MPC,<	HRRZ T,L1
	FETCH(T,T,BPBIT)
	HRRZ TT,L2
	FETCH(TT,TT,BPBIT)
	EQV TT,T
	TRNN TT,FRONT		;IF NOT ON SAME SIDE
	MOVSS L1		;MAKE THEM SUCH
	PUSHJ P,SWPPIN
	MOVSS L1
	MOVSS L2
	PUSHJ P,SWPPIN
	MOVE A,CURBOD
	PUSHJ P,BODFIX		;FIX BODY PINS
	TRO MCHG!NEEDCL
	POPJ P,
>;MPC
SWPPIN:	MOVE T,L1		;FIRST POINT
	FETCH(TT,T,BPPN)
	MOVE TTT,L2		;SECOND POINT
	FETCH(A,TTT,BPPN)
MD,<	TRNE TFLG		;JUST CHANGING NUMBERS?
	 JRST PNCHNG
>;MD
	STORE(A,T,BPPN)
	STORE(TT,TTT,BPPN)	;PIN #'S STAY WITH ID'S IN CASE BUSSED THROUGH
	FETCH(TT,T,BPLOC)
	FETCH(A,TTT,BPLOC)
	STORE(A,T,BPLOC)
	STORE(TT,TTT,BPLOC)
MPC,<	POPJ P,	>
MD,<	MOVE A,CURBOD
	PUSHJ P,BODFIX		;FIX BODY PINS
	MOVE A,L1		;AND MOVE RESULTS
	FETCH(TT,A,BPXY)
	PUSHJ P,PMOVX
	PUSHJ P,PMOVY
	MOVE A,L2
	FETCH(TT,A,BPXY)
	PUSHJ P,PMOVX
	PUSHJ P,PMOVY
	TRO MCHG!NEEDCL
	POPJ P,

PNCHNG:	PUSH P,TT		;NEW NAME FOR PIN #2
	PUSH P,TTT		;PIN #2
	EXCH T,A		;SO THAT T = PIN#1, A = NEW PIN NAME
	PUSHJ P,STPNN1		;SPREAD PIN# OVER NEW ID (SECOND)
	POP P,A
	POP P,T
	TRO MCHG
	JRST STPNN1		;AND FIRST ONE
>;MD
;SAVE AND RESTORE FLAG REGISTER M
PUSHM:	MOVE H,M		;SAVE COPY OF LH M
	HRR H,0			;AND RH 0
MD,<	TLZE M,PINIDS!PLOCS		;TURN OFF PINS
	TRO MCHG
	TLON M,RPINID
	TRO MCHG
>;MD
MPC,<	TLON M,PLOCS		;TURN ON PINS
	TRO MCHG
>;MD
	POPJ P,

POPME:	PUSHJ P,POPM
	JRST PERRET

POPM:
MD,<	TRNN H,TFLG
	TRZA TFLG
	TRO TFLG
	TLNE H,PINIDS
	TLOA M,PINIDS
	CAIA
	TRO MCHG
	TLNE H,PLOCS
	TLOA M,PLOCS
	CAIA
	TRO MCHG
	TLNN H,RPINID
	TLZA M,RPINID
>;MD
MPC,<	TLNN H,PLOCS
	TLZA M,PLOCS
>;MPC
	POPJ P,
	TRO MCHG
	POPJ P,

READP:
MD,<	PUSHJ P,READN	>
MPC,<	MOVE C,[PUSHJ P,GETLCH]
	MOVEM C,GTCHRX
	PUSHJ P,RPNAM
	JRST CPOPJ1
>;MPC
	CAIE C,12
	JRST SCARF
	MOVE B,T
	JRST CPOPJ2
SUBTTL PLACE A BODY
BODPLC:	TRNE INMOV
	JRST PERRET
MD,<	MOVEI T,[ASCIZ/TYPE BODY NAME
/]	>
	PUSHJ P,BODYGT	;GET BODY NAME & POINTER
	POPJ P,		;ALTMODE
	POPJ P,		;NULL
	JRST OOPS1	;NX
	TRZ INMOV
	MOVEM A,CURBOD	;SAVE POINTER TO TYPE
	SETZM CURORT	;ZERO ORIENTATION
	PUSHJ P,BPYES	;PLANT BODY
	MOVE T,LSTBOD
	PUSHJ P,SCLOSE
	MOVE A,CLOSES
	JRST BMOVEP	;START MOVING NEW BODY

;BPYES - PLANT BODY
;CURBOD = TYPE
;HSHFLG = 1 IF IN HASH BUCKET, ELSE JUST ON LIST

BPYESF:	AOSA HSHFLG
BPYES:	SETZM HSHFLG
	MOVE A,CURBOD		;GET POINTER TO TYPE
	MOVEI T,BODM
	PUSHJ P,CHNGMD		;GO BACK TO BODY MODE
	TRO MCHG
	PUSHJ P,MAKBDY		;GET BODY BLOCK IN B
	MOVEM B,LSTBOD		;SAVE POINTER
	AOS F,BID		;GET A UNIQUE BODY ID
	SKIPE HSHFLG
	 JRST BPYES1
	MOVEI D,DBODPN
	HRLM D,LSTBOD		;FOR CONSISTANCY SAKE
	MOVE D,DBODPN		;GET BODY LIST POINTER
	STORE (D,B,BNXT)	;PUT  NEW ONE IN THE LIST
	MOVEM B,DBODPN		;...
BPYES1:	MOVE T,CURSE		;GET CURSOR POSITION
	TDZ T,[1,,1]		;FOO ON INPUT!
	STORE (T,B,BXY)		;STORE AS CENTER OF BODY
	STORE (F,B,BID)
	STORE (A,B,BTYP)	;DEPOSIT POINTER TO TYPE DEFINITION
	MOVE F,CURORT		;GET ORIENTAION
MD,<	ANDI F,7	>
MPC,<	ANDI F,3	>
	STORE (F,B,BORI)	;STORE ORIENTATION
;Now create all the POINTS on the BODY
MD,<
	FETCH (A,A,TPIN)	;GET PIN/LOC LIST FROM TYPE
	JUMPE A,CPOPJ
	MOVEI C,RADDR(B,BLNK,BPLNK)	;LINK IN HERE
	HRLI B,ISPIN
BLOPP1:	FETCH(T,A,TPXY)		;POINT X,Y IN DEF
	PUSHJ P,ORIENT
	ADJUST(ADD,T,CURSE)	;TO BODY CENTER
	PUSH P,T
	PUSHJ P,PUTPNT		;CREATE THE POINT
	POP P,T
	STORE(T,D,BPXY)		;SET X,Y
	STORE(D,C,BPLNK)	;ADD TO BODY POINT LIST
	MOVE C,D
	FETCH(A,A,TPNX)		;GET TO NEXT PIN
	JUMPN A,BLOPP1		;LOOP  IF SOME LEFT
	POPJ P,
>;MD
MPC,<
	FETCH (A,A,TPIN)	;GET POINTER TO PINS
	MOVEI C,RADDR(B,BLNK,BPLNK)
	PUSH P,A
	PUSHJ P,BLOPP2
	SWITCH
	POP P,A
	PUSHJ P,BLOPP2
	SWITCH
	MOVEI T,ANGLPG
	JRST HYDPOG

BLOPP2:	JUMPE A,CPOPJ	;NONE?
	HRLI B,ISPIN		;ISPIN,,BODY
BLOPP1:	FETCH(T,A,TPXY)
	PUSHJ P,ORIENT
	ADJUST(ADD,T,CURSE)	;TO BODY CENTER
	PUSH P,T
	PUSHJ P,PUTPNT		;CREATE THE POINT (TYPIN IN A)
	POP P,T
	STORE(T,D,BPXY)		;SET X,Y
	FETCH(TT,A,TPID)	;PIN # FROM DEF
	MOVEI T,1		;INITIALLY USE NORMAL PAD FOR PIN
	CAIN TT,1		;PIN 1?
	 MOVEI T,3		;MAKE IT END UP PAD TYPE 3 (SQUARE)
	STORE(T,D,BPPN)
	STORE(D,C,BPLNK)	;LINK ONTO END OF BODY'S POINTS
	MOVE C,D
	FETCH(A,A,TPNX)
	JUMPN A,BLOPP1		;LOOP  IF SOME LEFT
	POPJ P,
>;MPC
SUBTTL MAKE BODY

;CONSTRUCT A BODY BLOCK, RETURN POINTER IN B

MAKBDY:	PUSH P,A
	GETBLK (B,BODY)
	BCLEAR (A,B,BODY)	;JUST TO MAKE SURE
	MOVEI A,V.BORI(B)		;SETUP DUMMY POINTERS
	STORE (A,B,BOD1)
	MOVEI A,V.BID(B)
	STORE (A,B,BOD2)
MD,<	MOVEI A,V.BBRS(B)
	STORE(A,B,BOD3)
>;MD
	JRST POPAJ

SUBTTL BODY AND DIP NAME STUFF SUBRS
MD,<
STODIP:	PUSHJ P,GETCLS
	 JRST PERRET
	FETCH(A,A,BTYP)
STTDIP:	PUSHJ P,FNDIPT
	 TDZA T,T
	FETCH(T,T,TXVAL)
	JRST STODEF

STONAM:	PUSHJ P,GETCLS
	 JRST PERRET
	FETCH(A,A,BTYP)
STTNAM:	FETCH(T,A,TNAM)
STODEF:	PUSHJ P,SETTT
	JUMPE T,ITSTUF
	JRST STOTX0
>;MD
MPC,<
STODIP:	PUSHJ P,GETCLS
	 JRST PERRET
	FETCH(T,A,BNAM)		;DIP TYPE POINTER
STODEF:	PUSHJ P,SETTT
	JUMPE T,ITSTUF
	JRST STOTX0

STONAM:	PUSHJ P,GETCLS
	 JRST PERRET
	FETCH(D,A,BTYP)
	PUSHJ P,SETTT
	PUSHJ P,STFNAM
	JRST ITSTUF

STFNAM:	FETCH(B,D,TNAM)		;# OF PADS
	PUSHJ P,PUTTTN
	FETCH(T,D,TNAM)
	CAIE T,2		;2 PIN DIP?
	 POPJ P,
	PUTBYT 12		;YES, GIVE SEPARATION
	FETCH(T,D,TPIN)
	FETCH(B,T,TPY)		;Y OF PIN1
	FETCH(T,T,TPNX)
	FETCH(C,T,TPY)		;Y OF PIN2
	SUB B,C
	MOVMS B
	IMULI B,5		;5 MILS PER POINT
	ASH B,-1
	JRST PUTTTN
>;MPC
SUBTTL COPY PINIDS TO PIN #'S -- TRANSPOSE -- BROT -- BODFIX
MD,<
BPINS:	PUSHJ P,GETCLS
	 JRST PERRET
BPINS0:	FETCH(A,A,BLNK)		;DEFAULT ALL PINS ON BODY
	JUMPE A,CPOPJ
	TLNE M,PLOCS
	 TRO MCHG
BPINS1:	FETCH(B,A,BPLOC)	;PIN IN TYPE DEF
	FETCH(T,B,TPNAM)	;DEFAULT PIN NAME
	STORE(T,A,BPPN)
	FETCH(A,A,BPLNK)
	JUMPN A,BPINS1
	POPJ P,

;SET ALL DIP PIN NUMBERS (SETPINS)
BPINSA:	SKIPN C,DBODPN
	 JRST PERRET
BPNSA1:	MOVE A,C
	PUSHJ P,BPINS0
	FETCH(C,C,BNXT)
	JUMPN C,BPNSA1
	POPJ P,

;CLEAR ALL DIP PIN NUMBERS  (-SETPINS)
PINZ:	SKIPN A,PONPNT
	 POPJ P,
	TRO MCHG
PINZ1:	FETCH(T,A,BPBIT)
	TRNE T,ISPIN
	 CLEAR(A,BPPN)
	FETCH(A,A,BPNXT)
	JUMPN A,PINZ1
	POPJ P,

NIL,<
;TRANSPOSE PIN NUMBERS FROM 14 PIN DIP TO 16 PIN SOCKET
;FOR "L" 12,1415	FOR "R" 11,1416
TRANSPOSE:
	PUSHJ P,GETCLS
	JRST PERRET
	PUSHJ P,GETLR
	JRST PERRET
GOTPOF:	HLRZ B,(A)
	HLRZ B,1(B)
	MOVE T,1(B)
	TLZ T,L1416!R1416
	TDO T,C
	MOVEM T,1(B)
	TRO MCHG
	POPJ P,

GETLR:	TLNN M,DSKACT!MACACT
	OUTSTR[ASCIZ/L, R, OR <CR>?/]
	PUSHJ P,GETCHR
	TLNN M,DSKACT!MACACT
	OUTSTR[ASCIZ/
/]
	CAIE C,"L"
	JRST CKR
	MOVSI C,L1416
	JRST CPOPJ1

CKR:	CAIE C,"R"
	JRST CHKCR
	MOVSI C,R1416
	JRST CPOPJ1

CHKCR:	CAIE C,12
	POPJ P,
	SETZ C,			;LET HIM CLEAR BITS
	JRST CPOPJ1
>;NIL
;TRANSPOSE ALL BODIES OF A CERTAIN NAME
NIL,<
TRANALL:
	MOVEI T,[ASCIZ/NAME OF BODY TO TRANSPOSE?/]
	PUSHJ P,BODYGT
	POPJ P,		;ALTMODE
	POPJ P,		;NULL
	JRST OOPS1
	PUSHJ P,GETLR
	JRST PERRET
	MOVEM A,DY1	;STUFF AWAY HERE FOR NOW
	SKIPN A,DBODPN
	POPJ P,		;NOTHING TO DO
TRANA1:	HLRZ T,(A)
	HRRZ T,1(T)
	CAMN T,DY1	;SAME BODY?
	PUSHJ P,GOTPOF	;YES
	HRRZ A,(A)
	JUMPN A,TRANA1
	POPJ P,
>;NIL
>;MD

BROT:	TRNE INMOV
	JRST [	MOVE A,CLOSES
		JRST BROTA]
	PUSHJ P,GETCLS
	 JRST PERRET
BROTA:	FETCH(T,A,BORI)
	ADDI T,1
MD,<	ANDI T,7	>
MPC,<	ANDI T,3	>
	STORE(T,A,BORI)
	TRO MCHG
MD,<	FETCH(B,A,BLOC)		;ANY LOC SET ?
	JUMPE B,BROTB
	MOVE F,BLCROT(T)	;GET PROPER ROTATION NUMBER FROM TABLE
	FETCH(T,A,BLXY)
	PUSHJ P,ORIENT
	STORE(T,A,BLXY)
BROTB:
>;MD
	PUSHJ P,BODFIX
MD,<	JRST STRAIGHTEN	;GO FIX THE WORLD NOW>
MPC,<	POPJ P,>

MD,<
BLCROT:	7	;7 - 0
	1	;0 - 1
	1	;1 - 2
	1	;2 - 3
	7	;3 - 4
	1	;4 - 5
	1	;5 - 6
	1	;6 - 7
>;MD

;CALL WITH POINTER TO BODY IN A
BODFIX:	FETCH(B,A,BLNK)
	JUMPE B,CPOPJ
	FETCH(D,A,BXY)
	FETCH(F,A,BORI)
BODFX2:	FETCH(T,B,BPLOC)
	FETCH(T,T,TPXY)
	PUSHJ P,ORIENT
	ADJUST(ADD,T,D)
MPC,<	STORE(T,B,BPXY) >
MD,<	PUSH P,A
	PUSH P,F
	MOVE A,B		;POINTER TO POINT MUST BE IN A
	PUSHJ P,PMOVRL
	POP P,F
	POP P,A
>;MD
BODFX1:	FETCH(B,B,BPLNK)
	JUMPN B,BODFX2
	POPJ P,
;GET PIN #'S FROM DIP DEF FILE
MD,<
SETSEC:	PUSHJ P,GETCLS
	 JRST PERRET
	PUSHJ P,GETDEF		;GET DEFINITION FROM DIPS.DIP
	 POPJ P,			;LOSE
SECAGN:	TLNE M,DSKACT!MACACT
	 JRST SETSCP
	OUTSTR[ASCIZ/SECTION # (0-/]
	FETCH(T,H,DDMAX)	;GET # OF SECTIONS
	PUSHJ P,DECOUT
	OUTSTR[ASCIZ/)?/]
SETSCP:	PUSHJ P,READN
	CAIN C,ALTMOD
	 POPJ P,		;LET HIM OUT ON ALTMODE
	CAIE C,12
	JRST [	PUSHJ P,INNERR
		JRST SECAGN]
;Enter here with sec# in T after having called GETDEF
;FALLS THRU
SETSCN:	FETCH(TT,H,DDMAX)
	CAMLE T,TT
	 JRST [	OUTSTR[ASCIZ/SECTION # TOO LARGE!
/]
		JRST SECAGN]
	MOVE B,T			;SAVE SEC #
	MOVE T,[OUTCHR TTT]
	MOVEM T,PUTCHR			;WHERE TO OUTPUT PIN NAME
	MOVE D,TYPE			;BODY
	MOVEI D,RADDR(D,BLNK,BPLNK)
	JRST SETSC4

SETSC7:	FETCH(A,D,BPLOC)
	FETCH(A,A,TPNAM)
	MOVEI TTT,RADDR(H,DDNXT,DPNXT)	;PREPARE TO SEARCH DEF LIST
STSC10:	FETCH(TTT,TTT,DPNXT)		;DEFINITION MAKER MADE SURE THERE WERE ENOUGH PINS
	JUMPE TTT,[STORE(A,D,BPPN)	;USE DEFAULT PIN NAME
		TRO MCHG
		TLNE M,DSKACT!MACACT
		 JRST SETSC4
		OUTSTR[ASCIZ/DEFAULT PIN /]
		PUSHJ P,BPINPN		;PRINT AS BODY PIN
		OUTSTR[ASCIZ/ DOES NOT EXIST ON THIS DIP.
WILL USE DEFAULT PIN NAME.
/]
		JRST SETSC4]
	FETCH(T,TTT,DPNM)
	CAME T,A			;CORRECT PIN NAME?
	 JRST STSC10			;NO, KEEP LOOKING
	FETCH(T,TTT,DPPIN)		;SECTION PIN NAME
	JUMPE T,[STORE(A,D,BPPN)	;USE DEFAULT PIN NAME
		TRO MCHG
		TLNE M,DSKACT!MACACT
		 JRST SETSC4
		OUTSTR[ASCIZ/DEFAULT PIN /]
		PUSHJ P,BPINPN		;PRINT AS BODY PIN
		OUTSTR[ASCIZ/, NO SECTION INFO, USING AS PIN #.
/]
		JRST SETSC4]
	FETCH(E,H,DDNXT)		;NOW FIND SAME PIN SECT # WITH CORRECT SECT BITS
SETSC5:	FETCH(TTT,E,DPPIN)		;GET SECT PIN #
	CAME T,TTT			;SAME AS OURS?
	 JRST SETSC6			;NO
	MOVN TTT,B			;GET NEG OF DESIRED SECTION
	MOVEI TT,400000			;GET BIT FOR SECTION 0
	LSH TT,(TTT)			;POSITION TO CORRECT SECTION
	FETCH(TTT,E,DPSEC)		;IN THIS SECTION?
	TDNE TT,TTT			;TEST FOR THAT SECTION ON THIS PIN
	 JRST [	FETCH(TT,E,DPNM)	;YES, GET PIN NAME
		STORE(TT,D,BPPN)	;AND STORE FOR THIS PIN
		TRO MCHG		;THIS CHANGES THINGS
		JRST SETSC4]		;TRY ANOTHER PIN
SETSC6:	FETCH(E,E,DPNXT)
	JUMPN E,SETSC5
	OUTSTR[ASCIZ/DEFAULT PIN /]
	PUSHJ P,BPINPN		;PRINT AS BODY PIN
	OUTSTR[ASCIZ/, NOT IN THIS SECTION.
/]
SETSC4:	FETCH(D,D,BPLNK)
	JUMPN D,SETSC7
	POPJ P,

;GETDEF - GET BODY DEF FROM DIPS.DIP FILE

SKPBDY:	PUSHJ P,SKPBD2		;SKIP PROPERTIES
SKPBD1:	PUSHJ P,WORDIN		;SKIP PIN NAME
	PUSHJ P,SKPSOM		;SKIP REG STUFF
	PUSHJ P,WORDIN		;SKIP SECTS,,SECT PIN #
	SOJG D,SKPBD1		;SKIP THEM ALL
	JRST SETSC1

SKPBD2:	PUSHJ P,SKPSTR		;SKIP PACKAGE NAME
	 JFCL
SKPBD3:	PUSHJ P,SKPSTR		;SKIP ALL PROPERTY NAMES
	CAIA
	JRST SKPBD3

; NOW SKIP RECURSIVELY NESTED <PROP-VAL,SUB-PROP-VAL,...>

	MOVEI A,1		;DEPTH
SKPTRE:	PUSHJ P,SKPSTR
	JRST [	SOJG A,SKPTRE
		POPJ P,]
	PUSHJ P,WORDIN		;SKIP VALUE BITS
	AOJA A,SKPTRE

SKPSOM:	PUSHJ P,WORDIN		;BITS,,PS#
	PUSHJ P,WORDIN		;HI,,LOW LOADING
	JRST WORDIN		;USE

;GETDEF - GET DIPDEF LIST FROM DIPS.DIP FILE
;A = BODY POINTER 
;SETS UP DIP DEF TABLE, SKIP RETURNS IF ALL OK
;H = DIPDEF LIST PTR

GETDEF:	HRRZM A,TYPE		;STORE BODY POINTER HERE
GETDF1:	FETCH(H,A,BDEF)		;ALREADY IN?
	JUMPN H,CPOPJ1
	FETCH(H,A,BTYP)		;MAYBE ON TYPE
	FETCH(H,H,TDEF)
	JUMPN H,CPOPJ1
	PUSHJ P,FNDDIP
	 JRST [OUTSTR [ASCIZ /NO DIPTYPE ON BODY!!
/]
		POPJ P,]
	GETBLK(H,GETDIP)	;PUT THIS BODY ON INPUT LIST
	CLEAR(H,GNXT)
	STORE(A,H,GBDY)
	CLEAR(H,GFLAG)		;MARK AS BODY
	JUMPGE T,GETDF2		;DIPTYPE WAS ON BODY
	FETCH(A,A,BTYP)		;FOUND DIPTYPE ON TYPE?
	STORE(A,H,GBDY)
	STOREL(T,H,GFLAG)	;THIS STUFF IS FOR TYPE
GETDF2:	FETCH(T,T,TXVAL)	;VALUE OF "DIPTYPE"
	STORE(T,H,GDIP)
	MOVEM H,GETLST
	PUSHJ P,DIPIN		;READ DIPDEF AND PACKAGE PROPS
	 JFCL
	MOVE A,TYPE
	FETCH(H,A,BDEF)		;ALREADY IN?
	JUMPN H,CPOPJ1
	FETCH(H,A,BTYP)		;MAYBE ON TYPE
	FETCH(H,H,TDEF)
	JUMPN H,CPOPJ1
	POPJ P,

;INDIP - READIN PACKAGE AND DIPDEF STUFF FOR ALL TYPES

INDIP:	SETZ H,			;LIST OF TYPES TO READIN
	SKIPN G,BODPNT		;BODIES
	 POPJ P,
INDIP1:	FETCH(T,G,TYP1)		;USED?
	JUMPE T,INDIP9
	MOVE A,G
	PUSHJ P,FNDIPT		;ANY DIPTYPE?
	 JRST INDIP9
	FETCH(T,T,TXVAL)	;THE DIPTYPE
	FETCH(TT,T,TSASC)
	CAMN TT,[ASCII /*/]	;FLUSH COMMENT DIPS
	 JRST INDIP9
	GETBLK(A,GETDIP)
	STORE(G,A,GBDY)
	STORE(T,A,GDIP)
	MOVEI T,400000
	STORE(T,A,GFLAG)	;FLAG AS FROM TYPE
	STORE(H,A,GNXT)
	MOVE H,A
INDIP9:	FETCH(G,G,TNXT)
	JUMPN G,INDIP1
	MOVEM H,GETLST
	PUSHJ P,DIPIN
	 JFCL
	POPJ P,

;DIPIN - READ DIPDEF AND PACKAGE STUFF FOR THIS LIST OF BODIES
;GETLST - LIST OF BODIES/TYPES TO GET FOR
;SKIPS IF GOT ALL THE BODIES
; (RECLAIMS GETLST AS IT GOES)
; PUTS DIPDEF LIST, PACKAGE CODE ON BODY IF IT HAD DIPTYPE,
; ELSE PUTS STUFF ON TYPE, COMPLAINS ABOUT UPDATING PACKAGE CODE
; ON LIBRARY TYPE.

DIPIN:	PUSHJ P,PUSHIT
	PUSHJ P,DIPRED
	 JFCL
DIPIN3:	SKIPN G,GETLST
	 JRST [	PUSHJ P,POPIT
		JRST CPOPJ1]
	OUTSTR [ASCIZ /NOT ALL DIPS FOUND! /]
DIPIN4:	FETCH(T,G,GDIP)
	PUSHJ P,OUTTXT
	OUTSTR [ASCIZ /, /]
	FETCH(G,G,GNXT)
	JUMPN G,DIPIN4
	OUTSTR [ASCIZ /
/]
	MOVE B,GETLST
	PUSHJ P,PUTFS
	PUSHJ P,POPIT
	POPJ P,

;DIPMAP - SET THE NAME OF THE DIPS.DIP FILE TO USE

STORAGE(IMPURE)
DIPFNM:	0
DIPEXT:	0
DIPPPN:	0
STORAGE(PURE)

CLRDPF:	SETZM DIPFNM
	POPJ P,

SETDIP:	TLNN M,DSKACT!MACACT
	 OUTSTR[ASCIZ/New DIPs /]
	MOVSI T,EXTDIP
	PUSHJ P,SETNAM
	 POPJ P,
	ENTPPN
	MOVE B,FILNAM
	MOVEM B,DIPFNM
	HLLZ C,FILEXT
	MOVEM C,DIPEXT
	MOVE D,FILPPN
	MOVEM D,DIPPPN
	POPJ P,

;DIPRED - READ A DIP DEF LIST FROM DIPS.DIP FILE
;GETLST = LIST OF BODIES/TYPES (AND THEIR DIPTYPES) TO SEARCH FOR
;SKIPS IF DIPS.DIP FILE FOUND OK
; (REMOVES ENTRIES ON GETLST AS IT FINDS THEM)
; (CHECKS FOR UPDATING PACKAGE CODE ON LIBRARY TYPES)

DIPRED:	MOVEM P,PERRSAV		;RETURN UP FROM HERE
	INIT DAT,10
	 'DSK   '
	 IOHD
	 JRST [	OUTSTR [ASCIZ/CAN'T GET DISK!
/]
		JRST SECLEV]
	MOVEI T,IOBUF		;USE COMPILED IN BUFFER
	EXCH T,.JBFF
	INBUF DAT,2
	MOVEM T,.JBFF
	SKIPN T,DIPFNM		;ANY MAPPING SET?
	 MOVE T,['NDIPS ']	;NO, USE DEFAULT
	MOVEM T,FILNAM
	MOVSI T,EXTDIP
	SKIPE DIPFNM
	 HLLZ T,DIPEXT
	MOVEM T,FILEXT
	SETZB T,FILDAT
NODEC,<
NOSTAN,<
	DSKPPN T,		;TRY HIS PPN FIRST
	TLOA A,400000
>;NOSTAN
>;NODEC
	SKIPE DIPFNM
	 MOVE T,DIPPPN
DIPRD2:	MOVE T,LIBPPN
	MOVEM T,FILPPN
DIPRD:	TLNE M,DSKACT!MACACT
	 JRST DIPRD1
	OUTSTR [ASCIZ/READING /]
	PUSH P,A
	HRRI A,FILNAM
	JSR FPRINT
	POP P,A
	OUTSTR[ASCIZ/
/]
DIPRD1:	MOVE T,FILPPN
	LOOKUP DAT,FILNAM
	JRST [	PUSHJ P,LOOKER
NODEC,<		TLZE A,400000		;WAS THIS LIBRARY?
		 JRST DIPRD2		;NO, TRY LIBRARY
>;NODEC
		OUTSTR[ASCIZ/TRY ANOTHER DIPS.DIP FILE /]
		MOVSI T,EXTDIP
		PUSHJ P,SETNAM
		 JRST SECLEV
		SETZ A,
		JRST DIPRD]
DEC,<	JSR DAT,LOOKCK	>
	MOVEM T,FILPPN
	PUSHJ P,WORDIN
	MOVN TTT,TTT
	CAIE TTT,DIPVER		;CORRECT VERSION?
	 JRST [	OUTSTR[ASCIZ/WRONG VERSION DIP DEFINITION FILE.
/]
		JRST SECLEV]
;Scan thru file, inputing dips on GETLST
SETSC1:	SKIPN G,GETLST		;STUFF TO GET FOR
	 JRST SECWIN
	PUSHJ P,WORDIN
	JUMPE TTT,SECWIN	;DONE!
	MOVE D,TTT		;SAVE # OF PINS HERE
	PUSHJ P,RSTR		;NEXT DIP NAME
	 JFCL
	MOVEM T,TYPNAM
SETSE2:	MOVE A,TYPNAM
	FETCH(B,G,GDIP)
	JUMPE B,SETSE1		;DIDN'T HAVE DIPTYPE
	PUSHJ P,TXTMAT
	 CAIA
	 JRST SETSC0		;THIS IS THE DIP WE'RE GETTING FOR
SETSE1:	FETCH(G,G,GNXT)
	JUMPN G,SETSE2
	MOVE B,TYPNAM		;THIS ISN'T ONE WE'RE LOOKING FOR
	PUSHJ P,PUTFS		;RETURN DIP TYPE
	JRST SKPBDY		; SKIP THIS ONE

SETSC0:	GETBLK(H,DDEF)
	STORE(D,H,DDNPN)	;SAVE # PINS DEFINED
	CLEAR(H,DDMAX)		;MAX SEC #
	PUSHJ P,RSTR		;GET PACKAGE NAME
	 JFCL
	MOVEM T,PKGTEM
	MOVEI E,RADDR(H,DDNXT,DPNXT)
	PUSHJ P,SKPBD3		;SKIP PROP STUFF
SETSC2:	PUSHJ P,WORDIN		;PIN NAME
	PUSH P,TTT
	PUSHJ P,SKPSOM		;SKIP BORING STUFF
	PUSHJ P,WORDIN		;SECT BITS,,SECT PIN #
	GETBLK(T,DIPDEF)
	STORE(T,E,DPNXT)
	CLEAR(T,DPNXT)
	MOVE E,T
	POP P,T
	STORE(T,E,DPNM)
	STORE(TTT,E,DPPIN)
	HLRZ T,TTT
	STORE(T,E,DPSEC)
	HLLZS TT,TTT
	SUBI TT,1
	XOR TT,TTT
	JFFO TT,SETSC8		;THIS FINDS RIGHTMOST BIT FROM TTT
	JRST SETSC3		;NO BITS

SETSC8:	FETCH(T,H,DDMAX)
	CAMLE TTT,T
	STORE(TTT,H,DDMAX)	;STORE MAX SO FAR!
SETSC3:	SOJG D,SETSC2
	MOVEM H,DEFLST
	SETZM PKGCOD
	SKIPN T,PKGTEM		;ANY PACKAGE PROP?
	 JRST SECPT1
	PUSHJ P,MATPAK		;LOOKUP PACKAGE TYPE
	 JRST [	OUTSTR [ASCIZ /PACKAGE TYPE I DON'T KNOW ABOUT!! /]
		MOVE T,PKGTEM
		PUSHJ P,OUTTCR
		JRST SECPT1]
	MOVEM A,PKGCOD
SECPT1:	MOVEI G,GETLST-V.GNXT
SECPT0:	MOVE H,G		;SAVE BACK POINTER
	FETCH(G,G,GNXT)
	JUMPE G,SECPT9
	FETCH(A,G,GDIP)		;UPDATE ALL TYPES/BODIES WITH THIS DIPTYPE
	MOVE B,TYPNAM
	PUSHJ P,TXTMAT
	 JRST SECPT0
;store DIPDEF list on TYPE/BODY, check package code
	FETCH(A,G,GFBDY)	;FLAG AND BODY/TYPE POINTER
	MOVE B,DEFLST		;SETUP DIP DEF LIST IN ALL
	MOVE C,PKGCOD
	JUMPL A,SECPTT		;STUFF GOES ON TYPE
	PUSHJ P,COPDEF		;MAKE COPY OF DIPDEF LIST
	STORE(B,A,BDEF)
	FETCH(T,A,BPAK)
	CAMN C,T		;CHANGE PACKAGE?
	 JRST SECPT2		;THIS GETLST ENTRY SATISFIED, DELETE
	STORE(C,A,BPAK)
	MOVEI T,CPAKAG
	PUSHJ P,RECMPB		;YES, BUT MIGHT BE SUPERCEEDED BY EXPLICIT PROP
	TRO MCHG
	JRST SECPT2		;THIS GETLST ENTRY SATISFIED, DELETE

SECPTT:	PUSHJ P,COPDEF
	STORE(B,A,TDEF)
	FETCH(T,A,TPAK)
	CAMN C,T		;CHANGE PACKAGE?
	 JRST SECPT2
	FETCH(TT,A,TLIB)	;LIBRARY BODY?
	SKIPN MODLIB
	 JUMPN TT,[OUTSTR [ASCIZ /PACKAGE WRONG ON LIBRARY BODY!  /]
		FETCH(T,A,TNAM)
		PUSHJ P,OUTTCR
		JRST SECPT2]
	STORE(C,A,TPAK)
	MOVEI T,CPAKAG
	PUSHJ P,RECMPT		;BUT MIGHT HAVE EXPLICIT PACKAGE
	TRO MCHG
	FETCH(T,A,TPAK)
	CAMN T,C
	 JRST SECPT2
	OUTSTR [ASCIZ /TYPE HAS DIFFERENT PACKAGE THAN DIPS.DIP! /]
	FETCH(T,A,TNAM)
	PUSHJ P,OUTTXT
SECPT2:	FETCH(T,G,GNXT)
	STORE(T,H,GNXT)
	RETBLK(G,GETDIP)
	MOVE G,H		;BACKUP
	JRST SECPT0

SECPT9:	MOVE B,TYPNAM
	PUSHJ P,PUTFS
	MOVE B,PKGTEM
	PUSHJ P,PUTFS
	MOVE B,DEFLST
	PUSHJ P,PUTFS
	JRST SETSC1		;GET SOME MORE DIPS

SECWIN:	RELEASE DAT,		;RELEASE DEF FILE
	JRST CPOPJ1		;GIVE WIN RETURN

SECLEV:	RELEASE DAT,
	POPJ P,
;DDFREL - RECLAIM DIP DEF LIST
;C = DIP DEF LIST

DDFREL:	JUMPE C,CPOPJ
	FETCH(T,C,DDNXT)
	RETBLK(C,DDEF)
DDFRL1:	JUMPE T,CPOPJ
	MOVE C,T
	FETCH(T,T,DPNXT)
	RETBLK(C,DIPDEF)
	JRST DDFRL1

;COPDEF - COPY DIPDEF LIST
;B = LIST

COPDEF:	JUMPE B,CPOPJ
	PUSH P,C
	PUSH P,D
	GETBLK(C,DDEF)
	FETCH(T,B,DDNPN)
	 STORE(T,C,DDNPN)
	FETCH(T,B,DDMAX)
	 STORE(T,C,DDMAX)
	MOVEI D,RADDR(C,DDNXT,DPNXT)
COPDF1:	FETCH(B,B,DPNXT)
	JUMPE B,COPDF2
	MOVE T,D
	GETBLK(D,DIPDEF)
	STORE(D,T,DPNXT)
	FOR I IN (DPNM,DPSEC,DPPIN)
<	FETCH(T,B,I)
	 STORE(T,D,I)
>
	JRST COPDF1

COPDF2:	CLEAR(D,DPNXT)
	MOVE B,C
	POP P,D
	POP P,C
	POPJ P,

>;MD
SUBTTL SET BODY LOCATION
BNUMS:	PUSHJ P,GETCLS
	 JRST PERRET
	MOVEM A,CURBOD
	MOVE T,[PUSHJ P,GETLCH]
	MOVEM T,GTCHRX
	TLNE M,DSKACT!MACACT
	 JRST BNUMS1
	OUTSTR [ASCIZ / Body location as "/]
	OUTSTR @BODCUE
	OUTSTR [ASCIZ /"? /]
BNUMS1:	PUSHJ P,GTSLTL
	 JRST INNERR
	 JRST [	CAIE C,12
		 JRST INNERR
MPC,<		MOVE A,CURBOD
		CLEAR(A,BLN)	;CLEAR LOCN
		TRO MCHG
		POPJ P,	]
>;MPC
MD,<		MOVE A,CURBOD
		FETCH(B,A,BLOC)
		JUMPE B,CPOPJ
		CLEAR(A,BLOC)
		FETCH (T,A,BBIT)
		TRO T,FIXLOC!FIXBLO
		STORE (T,A,BBIT)
		TLNE M,BLOCS
		 TRO MCHG
		TRNE TMOVE!LMOVE	;IF WE WERE MOVING OFFSET,
		TRZN INMOV		;THEN STOP AND FIND CLOSEST AGAIN
		POPJ P,
		TRO NEEDCL
		POPJ P,	]
MD,<	JFCL	>		;WE DON'T CARE IF THERE WAS A BRS OR NOT
	SETO T,			;ASSUME NO SEC STUFF
	CAIE C,"-"		;SETTING SECTION #?
	 JRST SECNUM
	PUSHJ P,GETLIN		;YES, GET IT
	CAIL C,"A"
	CAILE C,"Z"
	JRST [	CAIL C,"0"	;ACCEPT NUMERIC SECTIONS TOO!
		CAILE C,"9"
		JRST INNERR
		PUSHJ P,CREADN
		JRST SECNUM ]
	MOVEI T,-"A"(C)
	PUSHJ P,GETLIN
SECNUM:	MOVEM T,NUMBER		;SAVE SECTION # HERE
>;MD
	CAIE C,12		;NOW IT MUST BE A LF
	 JRST INNERR
MD,<	MOVE TT,LETTER
	TLNE TT,-1
	SKIPN T,CRDLOC
	JRST NOGLOB
	XOR T,TT
	TLNE T,-1
	JRST [	OUTSTR[ASCIZ/SORRY, CAN'T CHANGE CARD LOC WHILE GLOBAL CARD LOC IS IN FORCE!
/]
		JRST CHKSCN]	;GO CHECK SECTION ANYWAY
	HRRZS LETTER
NOGLOB:
>;MD
;FALLS THRU - PC

MPC,<	MOVE T,LETTER
	STORE(T,A,BLN)		;STORE IT
>;MPC
MD,<	FETCH(B,A,BLOC)
	JUMPN B,GTNMBK		;DO WE HAVE A BLOCK ALREADY?
	MOVEI B,-1+ADDR(A,BLXY)	;NO
	STORE(B,A,BLOC)		;MARK AS LOCN SET
	CLEAR(A,BLO)		;CLEAR CHARACTER OFFSET
	FETCH(TT,A,BBIT)
	TRO TT,FIXBLO		;DEFAULT IS RECENTER LOCATION TEXT
	STORE(TT,A,BBIT)
	PUSHJ P,STLCOF		;SET LOCATION OFFSET FROM TYPE DEF
GTNMBK:	HLRZ T,LETTER
	STORE(T,A,BBRS)		;SET BAY-RACK-SLOT
	HRRZ T,LETTER
	STORE(T,A,BSOC)		;SET SOCKET
	MOVE T,CURBOD		;SETUP T FOR OFFBLO
	PUSHJ P,OFFBLO		;CHECK FOR RECALC CHAR OFFSET
>;MD
	TLNE M,BLOCS
	TRO MCHG
MPC,<	POPJ P,	>
MD,<
CHKSCN:	SKIPGE NUMBER		;ANY SECTION #?
	 POPJ P,
	MOVE A,CURBOD
	PUSHJ P,GETDEF
	 POPJ P,		;LOSE
	MOVE T,NUMBER
	JRST SETSCN		;TRY TO SET SECTION!

;OFFSET BODY LOCNS

OFFLOC:	SKIPN H,DBODPN
	POPJ P,
OFFLC1:	HRRZ A,H
	FETCH(B,A,BLOC)		;ANY LOC SET??
	JUMPE B,OFFLC2		;ANY?
	PUSHJ P,STLCOF		;YES, SET TO FOLLOW DEFINITION
	SETBIT(FIXBLO,TT,H,BBIT)	;CAUSE LOC TEXT TO BE AUTO CENTERED
	MOVE T,H
	PUSHJ P,OFFBLO		;OFFSET TEXT MAYBE
OFFLC2:	HRRZ H,(H)
	JUMPN H,OFFLC1
	TLNE M,BLOCS
	TRO MCHG
	POPJ P,

;RESET LOCATION OFFSET OF CLOSEST BODY TO DEFAULT
BLCOFF:	PUSHJ P,GETCLS
	JRST PERRET
	MOVEM A,CURBOD		;SAVE BODY HERE FOR OFFBLO
	FETCH(B,A,BLOC)		;ANY LOCN SET?
	JUMPE B,CPOPJ		;LEAVE IF NONE
	TLNE M,BLOCS
	 TRO MCHG
	PUSHJ P,STLCOF		;SET OFFSET
	HRRZ T,CURBOD
	SETBIT(FIXBLO,TT,T,BBIT)	;AND DEFAULT IS AUTO CENTER
	JRST OFFBLO

;STLCOF - SET LOCN TEXT POSITION FROM TYPE DEFINITION
; A = BODY PTR
STLCOF:	PUSH P,T
	PUSH P,TT
	FETCH(TT,A,BTYP)	;TYPE
	FETCH(T,TT,TXY)		;DEFAULT LOCN TEXT X,Y
	FETCH(F,A,BORI)		;ORIENTATION
	PUSHJ P,ORIENT		;ADJUST T FOR ROTATION IN F
	STORE(T,A,BLXY)		;SET LOCN TEXT X,Y
	FETCH(T,A,BBIT)
	TRO T,FIXLOC		;CONTINUE FIXING OFFSET LOCN
	STORE(T,A,BBIT)
	POP P,TT
	POP P,T
	POPJ P,

>;MD

STOBLC:	PUSHJ P,GETCLS
	JRST PERRET
	MOVE B,A
	PUSHJ P,SETTT
MD,<	FETCH(D,B,BLOC)		;ANY LOC SET?
	JUMPE D,ITSTUF
	PUSH P,A
	FETCH(A,B,BRSLOC)
>;MD
MPC,<	FETCH(D,B,BLN)
	JUMPE D,ITSTUF
	PUSH P,A
	MOVE A,D
>;MPC
	PUSHJ P,SLTLPN
	POP P,A
	JRST ITSTUF

;BODY LOCATION OFFSET (D)

MD,<
;RESET LOCATION OFFSET OF CLOSEST BODY TO DEFAULT
BLOOFF:	PUSHJ P,GETCLS
	 JRST PERRET
	FETCH(B,A,BLOC)		;ANY LOC SET?
	JUMPE B,CPOPJ		;LEAVE IF NONE
	SETBIT(FIXBLO,TT,A,BBIT)
	MOVE T,A
;FALLS THRU
;OFFBLO - CHAR OFFSET FOR BODY LOCN TEXT
;T = POINTER TO BODY

OFFBLO:	FETCHL(TT,T,BBIT)
	TLNN TT,FIXBLO
	 POPJ P,		;NOT BEING FIXED
	TLNE M,BLOCS
	 TRO MCHG
	TLNN TT,FIXLOC		;DON'T FOLLOW BODY DEF OFFSET UNLESS FOLLOWING BODY DEF LOC
	 JRST OFFBL1
	FETCH(TT,T,BTYP)
	FETCH(TTT,TT,TYP3)	;CHARACTER OFFSET IN TYPE DEF?
	JUMPE TTT,OFFBL1	; NO
	FETCH(TTT,TT,TOXY)
	STORE(TTT,T,BLO)	;YES, USE IT
	POPJ P,

OFFBL1:	SETZM CHRCNT
	PUSH P,PUTCHR
	PUSH P,T
	MOVE TTT,[AOS CHRCNT]
	MOVEM TTT,PUTCHR
	FETCH(A,T,BRSLOC)	;B-R-S,,BSOC
	PUSHJ P,SLTLPN
	POP P,T
	POP P,PUTCHR
	MOVN A,CHRCNT
	MOVE TTT,STDBIG
	IMUL A,VIRPTX(TTT)
	ASH A,-1
	STORE(A,T,BLOX)		;X PART OF OFFSET
	MOVN A,VIRPTY(TTT)
	ASH A,-1
	STORE(A,T,BLOY)
	POPJ P,
>;MD
SUBTTL DELETE BODY
C2BDEL:	SETOM PINLEV
	PUSHJ P,GETCLS
	 POPJ P,
	MOVE B,CLAST
	TRO NEEDCL
	JRST BCLR1

BODDEL:	PUSHJ P,GETCLS	;ANY TO DELETE?
	 JRST PERRET	;NO
	MOVE B,CLAST
	TRO NEEDCL
BDELET:	SETZM PINLEV
BCLR1:	PUSH P,B		;SAVE LAST
	TRZE INMOV		;TURN OFF MOVING
	TRO NEEDCL
ROUTE,<MPC,<TLZ M,%ROUTE>>	;MAKE HIM ROUTE AGAIN
	PUSHJ P,REMBOD		;REMOVE BODY FROM ANY SETS
	TRO TFLG!MCHG		;DELETE PINS
	PUSH P,A		;SAVE THIS
	SKIPN PINLEV		;LEAVING PINS AS POINTS?
	 JRST [	MOVEI B,PONPNT	;NO, DELETING
		PUSHJ P,BODDLP	;DELETE ALL PINS WHICH POINT TO THIS BODY
	MPC,<	MOVEI B,PONPN2
		PUSHJ P,BODDLP
	>;MPC
		JRST BODDLE]	;NOW GIVE BACK BODY
	FETCH(B,A,BLNK)
	JUMPE B,BODDLE
BODDL2:	FETCH(A,B,BPLNK)
	PUSHJ P,PINPNT		;CHANGE BPIN INTO POINT !!!
	MOVE B,A
BODDL1:	JUMPN B,BODDL2
BODDLE:	POP P,A			;HERE WE GIVE BACK THE BODY
	FETCH(F,A,BNXT)		;GET POINTER TO NEXT BODY
	POP P,B			;RESTORE LAST POINTER
	STORE(F,B,BNXT)		;LINK AROUND
MD,<	FETCH(C,A,BTXT)
	PUSHJ P,TXTREL		;RELEASE PROPERTIES
	FETCH(C,A,BDEF)
	PUSHJ P,DDFREL
>;MD
	RETBLK(A,BODY)
	POPJ P,

BODDLQ:	FETCHL(T,B,PBIT)
	TLNN T,ISPIN
	 JRST BODDLP
	FETCH(T,B,BBODY)
	CAME T,-1(P)	;THIS IS WHERE BODY POINTER WAS STORED
	 JRST BODDLP	;TRY ANOTHER
	PUSH P,A	;SAVE LAST POINTER
	TRO TFLG	;ALLOW DELETE PIN
	PUSHJ P,DELPNT	;DELETE (CURRENT AND LAST ALREADY SETUP)
	POP P,B
BODDLP:	MOVE A,B	;SAVE LAST
	FETCH(B,B,PNXT)
	JUMPN B,BODDLQ
	POPJ P,


SUBTTL BODY RENAME
MD,<
BODREN:	MOVEI T,[ASCIZ/TYPE BODY NAME.
/]
	PUSHJ P,BODYGT
	 POPJ P,		;ALTMODE
	 POPJ P,		;NULL
	 JRST OOPS1		;NX
	SKIPE MODLIB		;ALLOW MODIFICATION?
	 JRST RENOK
	FETCH(T,A,TLIB)
	JUMPE T,RENOK
	OUTSTR[ASCIZ/CAN'T RENAME LIBRARY BODY!
/]
	POPJ P,

RENOK:	MOVEI T,[ASCIZ/TYPE NEW BODY NAME.
/]
	PUSH P,A
	PUSHJ P,BODYGT
	 JRST RENOKB		;ALTMODE
	 JRST RENOKB		;NULL
	 JRST RENOKA		;NX
	OUTSTR[ASCIZ/NAME ALREADY IN USE!!!
/]
RENOKB:	POP P,(P)
	POPJ P,

RENOKA:	POP P,C			;BODY TO RENAME
	MOVE D,B
	FETCH(B,C,TNAM)
	PUSHJ P,PUTFS
	STORE(D,C,TNAM)
	TLNE M,%IDENT		;DISPLAYING NAMES?
	TRO MCHG		;YES, REFRESH
	POPJ P,
>;MD
SUBTTL GET BODY
;BODYGT - FIND BODY USER ASKS FOR
;T = PROMPT STRING
;RETURNS
;	Alt
;	Null string
;	Not found
;	Body found
;A = POINTER TO TYPE (previous in LH)
;(B = NAME STRING IF BODY NOT FOUND)

MD,<
BODYGT:	TLNN M,DSKACT!MACACT
	OUTSTR (T)
	SETZ A,			;IN CASE NO NAME
	PUSHJ P,TREADU		;READ IN THE TEXT FOR THE BODY NAME
	 POPJ P,		;ALTMODE
	 JRST CPOPJ1		;NULL STRING
	AOS (P)
	AOS (P)			;AT LEAST 2 SKIPS
	MOVEI A,BODPNT-V.TNXT
	JRST BLOP2

BLOP1:	PUSH P,A
	PUSH P,B		;BODY'S NAME
	FETCH(A,A,TNAM)		;GET POINTER TO STRING
	PUSHJ P,TXTMAT
	 JRST BLOP3		;NO MATCH
	POP P,B
	POP P,A
	PUSHJ P,PUTFS		;RETURN STRING
	FETCH(T,A,TYP1)		;NON-ZERO IF BODY IN
	JUMPE T,BDYGET		;GET BODY FROM LIBRARY IF NOT ALL IN
	HRRZS A			;CLEAR PREVIOUS LINK
	JRST CPOPJ1		;FOUND

BLOP3:	POP P,B			;YES, MATCH, RESTORE B
	POP P,A			;RESTORE A, THE POINTER TO THE FOUND BODY
BLOP2:	MOVE T,A
	FETCH(A,A,TNXT)		;GO TO NEXT BODY
	HRL A,T			;SAVE OLD IN LH FOR BDYGET
	TRNE A,-1
	JRST BLOP1		;LOOP IF ANY LEFT TO COMPARE WITH
	POPJ P,			;ELSE LEAVE
>;MD

MPC,<
BODYGT:	TLNN M,DSKACT!MACACT
	OUTSTR [ASCIZ /NO. OF PINS?
/]
	SETZ A,		;THIS IS "NO" ANSWER
	PUSHJ P,READN	;READ IN THE TEXT FOR THE BODY NAME
	CAIN C,ALTMOD
	POPJ P,
	JUMPE T,[	CAIN C,12		;JUST BLANK?
			JRST CPOPJ1		;LET HIM OUT
			CAIN C,"R"
			MOVEI T,=400/5
			CAIN C,"C"
			MOVEI T,=300/5
			CAIN C,"T"
			MOVEI T,3
			PUSHJ P,GETLIN
			CAIE C,12
			JRST INNERR
			JUMPE T,INNERR
			CAIE T,3		;3 PIN DIP?
			JRST IS2PIN		;NO, 2 PIN AND WE HAVE SEPERATION
			JRST BLOP0]
	CAIE C,12
	JRST INNERR
	CAIN T,2	;2 PIN DIP?
	JRST ASKWID
BLOP0:	MOVE A,BODPNT	;GET POINTER TO THE STRING OF BODIES
	AOS (P)
	AOS (P)
BLOP1:	JUMPE A,CPOPJ	;DOESN'T EXIST
	FETCH(TT,A,TNAM)
	CAIN TT,(T)
	 JRST CPOPJ1	;EXISTS
	FETCH(A,A,TNXT)
	JRST BLOP1


ASKWID:	TLNN M,DSKACT!MACACT
	OUTSTR[ASCIZ/PIN SEPERATION IN MILS (DIVISIBLE BY 10)?/]
	PUSHJ P,READNC
	IDIVI T,=10
	JUMPE T,INNERR
	JUMPN TT,INNERR
	ASH T,1
IS2PIN:	AOS (P)
	AOS (P)
	AOS (P)		;ALWAYS EXISTS
G2PIN:	SKIPN A,BODPNT
	JRST MAKE2D
B2LOP:	FETCH(TT,A,TNAM)
	CAIE TT,2
	JRST B2LOP1
	FETCH(TT,A,TPIN)
	FETCH(TT,TT,TPY)	;HRRE?
	CAIN TT,(T)
	POPJ P,
B2LOP1:	HRRZ A,(A)
	JUMPN A,B2LOP
MAKE2D:	PUSHJ P,MAKTYP
	MOVE A,TT
	MOVE TT,BODPNT
	STORE(TT,A,TNXT)
	MOVEM A,BODPNT
	MOVEI TT,2		;2 PIN DIP
	STORE(TT,A,TNAM)
	PUSHJ P,MAKTPN
	STORE(T,TT,TPY)
	STORE(TT,A,TPIN)
	MOVEI TTT,1		;PIN 1
	STORE(TTT,TT,TPID)
	PUSH P,B
	MOVE B,TT
	PUSHJ P,MAKTPN
	STORE(TT,B,TPNX)
	MOVEI TTT,2		;PIN 2
	STORE(TTT,TT,TPID)
	MOVNS T
	STORE(T,TT,TPY)
	JRST POPBJ


;SET DIP TYPE
SETDIP:	PUSHJ P,GETCLS
	JRST PERRET
	TLNN M,DSKACT!MACACT
	OUTSTR[ASCIZ/TYPE DIP TYPE
/]
	PUSHJ P,TREADU
	POPJ P,			;ALTMODE
	SETZ B,			;NULL
	TLNE M,%IDENT
	TRO MCHG
	MOVE TT,B
	FETCH(B,A,BNAM)
	STORE(TT,A,BNAM)
	JUMPN B,PUTFS
	POPJ P,
>;MPC

OOPS1:	OUTSTR[ASCIZ/NO SUCH BODY, CHARLY
/]
MD,<	JRST PUTFS	;PUT NON-EX NAME BACK IN FREE STORAGE	>
MPC,<	POPJ P,							>

SUBTTL ASSOCIATIVE BODY SET
;PUT THE BODY AND ALL LOOSE STUFF CONNECTED TO IT IN A SET

ASSET:	PUSHJ P,GETCLS
	 JRST PERRET
	TRZE INMOV
	 TRO NEEDCL
	GETFS(T)		;MAKE A NEW SET
	HRLZM A,1(T)		;STARTING WITH THIS BODY
	SETZM (T)
	GETFS(TT)
	HRLM T,(TT)
	SETZM 1(TT)
	EXCH TT,SETPNT
	HRRM TT,@SETPNT
	MOVE H,T		;SET LIST
	MOVE G,H		;END OF THIS SET LIST
	MOVEM A,TRCBDY
	FETCH(A,A,BLNK)		;TRACE FROM ALL OF THIS BODY'S PINS
	JRST ASSET5

ASSET2:	PUSHJ P,ASSTRC		;TRACE FROM THIS POINT
ASSET1:	FETCH(A,A,BPLNK)
ASSET5:	JUMPN A,ASSET2
	MOVEI T,SETM
	PUSHJ P,CHNGMD		;GO INTO SET MODE
	MOVE A,SETPNT
	PUSHJ P,RECNTR		;CALC CENTER
	MOVE A,SETPNT
	MOVE T,1(A)		;LOC OF CENTER
	JRST CHKON

;TRACE FROM POINT (A) AND ADD TO SET (H,G)
;(ALL OF WIRE FAILS IF IT TERMINATES IN ANOTHER BODY)

ASSTRC:	TRZ TFLG		;WIRE FAILS IF TRACED TO BODY
	HRLM G,(P)		;CURRENT END OF SET LIST
	PUSHJ P,ASSTR1
	TRNN TFLG		;RAN INTO SOMETHING?
	 POPJ P,
	HLRZ G,(P)		;FLUSH THOSE ADDED POINTS
	HRRZ B,(G)
	HLLZS (G)
	JRST PUTFS

ASSTR1:	JUMPE A,CPOPJ		;TRACE LINES FROM THIS POINT
	HRLM A,(P)
MD,<	FOR @' I IN (D,U,L,R)
<	FETCH(C,A,PN'I)
	PUSHJ P,ASSPUT
	HLRZ A,(P)
>
>;MD
MPC,<	FETCH(B,A,PNEB)
	JUMPE B,CPOPJ
ASSET3:	MOVEI D,2
ASSET4:	XCT (D)[HLRZ C,(B)
		HRRZ C,1(B)
		HLRZ C,1(B)]
	PUSH P,B
	HRLM D,(P)
	PUSHJ P,ASSPUT
	HLRZ D,(P)
	POP P,B
	SOJGE D,ASSET4
	HRRZ B,(B)
	JUMPN B,ASSET3
	HLRZ A,(P)
>;MPC
	POPJ P,

ASSPUT:	TRNE TFLG		;ALREADY FAILED?
	 POPJ P,
	JUMPE C,CPOPJ
	FETCH(T,C,BPBIT)
MPC,<	TRNN T,CPIN		;CAN'T PICKUP WIRE TO CONNECTOR
	 JRST ASSPT4
>;MPC	
	TRNN T,ISPIN		;STOP HERE?
	 JRST ASSPT3
	FETCH(T,C,BBODY)
	CAME T,TRCBDY		;RAN INTO OURSELF?
ASSPT4:	 TRO TFLG		;THIS WIRE ISN'T LOOSE!
	POPJ P,

ASSPT3:	MOVE T,H		;ALREADY IN SET?
ASSPT1:	HRRZ TT,1(T)
	CAMN TT,C
	 POPJ P,		;ALREADY IN, SKIP IT
	MOVE TT,T
	HRRZ T,(T)
	JUMPN T,ASSPT1
	GETFS(T)
	HRRM T,(TT)
	SETZM (T)
	SETZM 1(T)
	MOVE G,T		;NEW END OF LIST
ASSPT2:	HRRM C,1(T)
	HRRZ A,C
	JRST ASSTR1		;RECURSE