C	PROGRAM BSET.FT
C	-------------------
C
C
C
	SUBROUTINE BSET(IA,IB,IC,IOPR)
C
C
C	P LEMKIN
C	NIH
C	BETHESDA, MD
C	
C
C	MAY 9, 1977
C	MARCH 31, 1977
C	MARCH 28, 1977
C	MARCH 26, 1977
C	MARCH 16, 1977
C	MARCH 15, 1977
C	MARCH 13, 1977
C	MARCH 12, 1977
C
C	PURPOSE
C	-------
C	PERFORM SET OPERATIONS ON LIST STRUCTURES USING
C	USING THE BNODE/FREEST PACKAGES.
C
C	IOPR	FUNCTION
C	----	--------
C	1	LMEMBER - IF THERE IS A NODE ELEMENT IN LIST IC WITH
C			IB'TH NODE FIELD DATA IA
C				THEN RETURN ITS POINTER==> IB
C				ELSE RETURN -1==>IB;
C
C	2	LUNION - CONSTRUCT A LIST WHICH IS THE SET UNION
C			OF THE DATA OF LISTS IA AND IB AND RETURN IT IN IC.
C			IF IA AND IB ARE NULL THEN SET IC TO -1;
C
C	3	LDIFF - COMPUTE THE ASYMMETRIC SET DIFFERENCE OF
C			THE DATA OF  SETS (IA-IB)
C			AND RETURN THE LIST POINTER TO IT IN IC.
C
C	4	LINTERSECT - COMPUTE THE SET INTERSECTION
C			OF THE DATA OF SETS OF (IA INTERSECT IB)
C			AND RETURN THE SET POINTER TO IT IN IC.
C
C	5	LPUTDATA - IF THERE IS NO NODE ELEMENT OF LIST IC
C			WITH IB'TH NODE FIELD DATA THE SAME AS IA
C			THEN ADD A NODE WITH DATA IA INTO LIST IC.
C			IF IC IS NULL THEN CREATE A SET IC.
C			*** NOTE: IB'TH OPTION NOT IMPLEMENTED YET.
C
C	6	LRMVDATA - IF THERE IS A NODE ELEMENT IN LIST IC
C			WITH IB'TH NODE FIELD DATA IA THEN DELETE IT 
C			(AND RETURN IT TO THE AVAIL LIST).
C			***NOTE: IB'TH OPTION NOT IMPLEMENTED YET.
C
C	7	LPUTXY - IF THERE IS NOT A NODE ELEMENT OF SET IC
C			WITH DATA THE SAME AS X,Y (IA,IB)
C			THEN ADD A NODE WITH XY DATA TO SET IC.
C			IF IC IS NULL THEN CREATE A SET IC.
C
C	8	LRMVXY - IF THERE IS A NODE ELEMENT OF SET IC
C			WITH DATA THE SAME AS X,Y (IA,IB)
C			THEN REMOVE THE NODE FROM SET IC AND RETURN
C			IT TO THE AVAIL LIST.
C
C	9	LSIZE - FIND THE SIZE OF SET IA AND RETURN IT IN IC[1:2].
	DIMENSION ISET1(2),ISET2(2),ISET3(2),ISET4(2),NODE(2,5)
	DIMENSION LIST(2),JPTR(2)
C
	DIMENSION IDATA(2)
C
C	[0] INIT
C	DEFINE DPCVRT CALLS
	LDTOF=-1
	LFTOD=+1
C
C
C	DEFINE BNODE CALLS:
	KAPPENDXY=1
	KDELETEXY=2
	KPRINTLIST=3
	KINITAVAIL=4
	KGETLIST=5
	KFREELIST=6
	KLASTXY=7
	KNEXTXY=8
	KCARXY=9
	KFINDXY=10
	KCOPYLIST=11
	KCONSLIST=12
	KCDRLIST=13
	KSETXY=14
	KCVXYTOI=15
	KCVITOXY=16
	KWRITEINFO=17
	KREADINFO=18
	KSETFREESTORE=19
C
C
C	[0.1] INIT VARIOUS VARIABLES.
C
C	VERIFY OPR RANGE
	MAXOPRS=9
	IF(IOPR-1)99,90,90
90	IF(IOPR-MAXOPRS)91,91,99
99	WRITE(1,998)IOPR
998	FORMAT('ILLEGAL BSET IOPR=',I5)
	CALL EXIT
C
C	DISPATCH
91	GOTO(100,200,300,400,500,600,700,800,900),IOPR
C
C
C	RETURN
S \2047,	CLA
	RETURN
C	[1] LMEMBER - IF THERE IS A NODE IN LIST IC WITH IB'TH NODE
C	FIELD  DATA IA
C	THEN RETURN ITS POINTER IN IB ELSE RETURN -1;
C
100	CONTINUE
	ISET1=IC
S	INC \IC#
S	TAD I \IC
S	DCA \ISET1#
C
C
C	COPY SET PTR 
	JPTR=ISET1
S	TAD \ISET1#
S	DCA \JPTR#
C
C	GET DATA TO MATCH
	IDATA=IA
S	INC \IA#
S	TAD I \IA
S	DCA \IDATA#
C
C
C	IF JPTR=-1
C		THEN RETURN -1
S	TAD \JPTR#
S	SPA CLA
S	JMP \199 /FAILED
C
C
C	[1.1] LOOP THROUGH SET COPYING NODE TO NODE[2,5].
101	CALL BNODE(NODE,0,JPTR,KREADINFO)
C	TEST IF IB'TH FIELD MATCHES
	ID1=NODE(1,IB)
	ID2=NODE(2,IB)
C
C	IF IDi=IDATAi
C		THEN SUCCEED 
S	TAD \IDATA
S	CIA
S	TAD \ID1
S	SZA CLA
S	JMP \102 /NO /SEE IF DONE
C
S	TAD \IDATA#
S	CIA
S	TAD \ID2
S	SNA CLA
S	JMP \199 /SUCCEED, RETURN JPTR
C
C
C	[1.2] GET NEXT NODE PTR AND TEST IF DONE
102	CALL BNODE(IX,IY,JPTR,KNEXTXY)
C
S	TAD \JPTR
S	CIA
S	TAD \ISET1
S	SZA CLA
S	JMP \101
S	TAD \JPTR#
S	CIA
S	TAD \ISET1#
S	SZA CLA
S	JMP \101 /NOT YET
C
C
C	[1.3] RETURN JPTR==>IB
199	IB=JPTR
S	INC \IB#
S	TAD \IB#
S	DCA I \IB
	GOTO 2047
C	[2] LUNION - CONSTRUCT THE LIST WHICH IS THE SET UNION
C	OF LISTS IA AND IB AND RETURN IT IN IC.
C	IF IA AND IB ARE NULL THEN SET IC TO -1;
C
200	CONTINUE
	ISET1=IA
S	INC \IA#
S	TAD I \IA
S	DCA \ISET1#
C
	ISET2=IB
S	INC \IB#
S	TAD I \IB
S	DCA \ISET2#
C
C	[2.1] IF IA=-1 AND IB=-1
C		THEN RETURN -1==>IC;
S	CLA IAC
S	TAD \ISET1#
S	SZA CLA
S	JMP \201 /IA NULL
S	CLA IAC
S	TAD \ISET2#
S	SZA CLA
S	JMP \202 /IB NULL
C
C	BOTH NULL RETURN -1
	IC=-1
S	INC \IC#
	IC=-1
	GOTO 2047
C
C
C	[2.2] IA WAS NULL, SET IC=IB
201	IC=ISET1
S	INC \IC#
S	TAD \ISET1#
S	DCA I \IC
	GOTO 2047
C
C
C	[2.3] IB WAS NULL, SET IC=IA
202	IC=ISET2
S	INC \IC#
S	TAD \ISET2#
S	DCA I \IC
	GOTO 2047
C
C
	GOTO 2047
C
C
C	[2.4] DO UNION AS FOLLOWS:
C	SET3<==COPY(SET1);
	CALL BNODE(ISET1,JKPT,ISET3,KCOPY)
C	SET1<==COPY(SET2);
	CALL BNODE(ISET2,JKPT,ISET1,KCOPY)
C	WHILE SET2 NOT NULL DO
S \204,	CLA IAC
S	TAD \ISET2#
S	SNA CLA
S	JMP \205 /DONE!
C
C		BEGIN "ELEMENT TEST"
C		IF (JPTR<==CAR(SET2)) NOT IN SET3
	CALL BNODE(IX,IY,ISET2,KCARXY)
	JPTR=ISET3
S	TAD \ISET3#
S	DCA \JPTR#
	CALL BNODE(IX,IY,JPTR,KFINDXY)
C			THEN APPEND JPTR TO SET3;
S	CLA IAC
S	TAD \JPTR#
S	SZA CLA
S	JMP \204 /NO
	CALL BNODE(IX,IY,ISET3,KAPPENDXY)
C		SET2<==CDR(SET2);
	CALL BNODE(IX,IY,ISET2,KCDRLIST)
	GOTO 204
C		END "ELEMENT TEST";
C
C
C	[2.5] RETURN ISET3==>IC
205	IC=ISET3
S	INC \IC#
S	TAD \ISET3
S	DCA I \IC
	GOTO 2047
C	[3] LDIFF - COMPUTE THE SET DIFFERENCE OF SETS (IA-IB)
C	AND RETURN THE LIST POINTER TO IT IN IC.
C
300	CONTINUE
C
	ISET1=IA
S	INC \IA#
S	TAD I \IA
S	DCA \ISET1#
C
	ISET2=IB
S	INC \IB#
S	TAD I \IB
S	DCA \ISET2#
C
C	[3.1] IF IA=-1 AND IB=-1
C		THEN RETURN -1==>IC;
S	CLA IAC
S	TAD \ISET1#
S	SZA CLA
S	JMP \301 /IA NULL
S	CLA IAC
S	TAD \ISET2#
S	SZA CLA
S	JMP \302 /IB NULL
C
C	BOTH NULL RETURN -1
	IC=-1
S	INC \IC#
	IC=-1
	GOTO 2047
C
C
C	[3.2] IA WAS NULL, SET IC=IB
301	IC=ISET1
S	INC \IC#
S	TAD \ISET1#
S	DCA I \IC
	GOTO 2047
C
C
C	[3.3] IB WAS NULL, SET IC=IA
302	IC=ISET2
S	INC \IC#
S	TAD \ISET2#
S	DCA I \IC
	GOTO 2047
C
C
	GOTO 2047
C
C
C	[3.4] DO UNION AS FOLLOWS:
C	SET3<==COPY(SET1);
	CALL BNODE(ISET1,JKPT,ISET3,KCOPY)
C	SET1<==COPY(SET2);
	CALL BNODE(ISET2,JKPT,ISET1,KCOPY)
C	WHILE SET2 NOT NULL DO
S \304,	CLA IAC
S	TAD \ISET2#
S	SNA CLA
S	JMP \305 /DONE!
C
C		BEGIN "ELEMENT TEST"
C		IF (JPTR<==CAR(SET2)) IN SET3
	CALL BNODE(IX,IY,ISET2,KCARXY)
	JPTR=ISET3
S	TAD \ISET3#
S	DCA \JPTR#
	CALL BNODE(IX,IY,JPTR,KFINDXY)
C			THEN DELETE JPTR FROM SET3;
S	CLA IAC
S	TAD \JPTR#
S	SZA CLA
S	JMP \304 /NO
	CALL BNODE(IX,IY,ISET3,KDELETEXY)
C		SET2<==CDR(SET2);
	CALL BNODE(IX,IY,ISET2,KCDRLIST)
	GOTO 304
C		END "ELEMENT TEST";
C
C
C	[3.5] RETURN ISET3==>IC
305	IC=ISET3
S	INC \IC#
S	TAD \ISET3
S	DCA I \IC
	GOTO 2047
C	[4] LINTERSECT - COMPUTE THE SET INTERSECTION
C	OF (IA INTERSECT IB) AND RETURN THE
C	SET POINTER TO IT IN IC.
C
400	CONTINUE
	ISET1=IA
S	INC \IA#
S	TAD I \IA
S	DCA \ISET1#
C
	ISET2=IB
S	INC \IB#
S	TAD I \IB
S	DCA \ISET2#
C
C	[4.1] IF IA=-1 AND IB=-1
C		THEN RETURN -1==>IC;
S	CLA IAC
S	TAD \ISET1#
S	SZA CLA
S	JMP \401 /IA NULL
S	CLA IAC
S	TAD \ISET2#
S	SZA CLA
S	JMP \402 /IB NULL
C
C	BOTH NULL RETURN -1
	IC=-1
S	INC \IC#
	IC=-1
	GOTO 2047
C
C
C	[4.2] IA WAS NULL, SET IC=IB
401	IC=ISET1
S	INC \IC#
S	TAD \ISET1#
S	DCA I \IC
	GOTO 2047
C
C
C	[4.3] IB WAS NULL, SET IC=IA
402	IC=ISET2
S	INC \IC#
S	TAD \ISET2#
S	DCA I \IC
	GOTO 2047
C
C
	GOTO 2047
C
C
C	[4.4] DO UNION AS FOLLOWS:
C	SET4<==NIL;
	ISET4=-1
S	CLA CMA
S	DCA \ISET4
C
C	SET3<==COPY(SET1);
	CALL BNODE(ISET1,JKPT,ISET3,KCOPY)
C	SET1<==COPY(SET2);
	CALL BNODE(ISET2,JKPT,ISET1,KCOPY)
C	WHILE SET2 NOT NULL DO
S \404,	CLA IAC
S	TAD \ISET2#
S	SNA CLA
S	JMP \405 /DONE!
C
C		BEGIN "ELEMENT TEST"
C		IF (JPTR<==CAR(SET2)) NOT IN SET3
	CALL BNODE(IX,IY,ISET2,KCARXY)
	JPTR=ISET3
S	TAD \ISET3#
S	DCA \JPTR#
	CALL BNODE(IX,IY,JPTR,KFINDXY)
C			THEN APPEND JPTR TO SET4;
S	CLA IAC
S	TAD \JPTR#
S	SZA CLA
S	JMP \404 /NO
C
C	IF ISET4=NIL 
C		THEN GETNODE ELSE APPENDXY
S	CLA CMA
S	TAD \ISET4
S	SZA CLA
S	JMP \406 /SET NOT NULL
	CALL BNODE(IX,IY,ISET4,KGETNODE)
	GOTO 407
C
406	CALL BNODE(IX,IY,ISET4,KAPPENDXY)
C
C		SET2<==CDR(SET2);
407	CALL BNODE(IX,IY,ISET2,KCDRLIST)
	GOTO 404
C		END "ELEMENT TEST";
C
C
C	[4.5] RETURN ISET4==>IC
405	IC=ISET4
S	INC \IC#
S	TAD \ISET4
S	DCA I \IC
	GOTO 2047
C	[5] LPUTDATA - IF THERE IS NO NODE ELEMENT OF SET IC
C	WITH DATA THE SAME AS IA THEN ADD A NODE WITH
C	DATA IA INTO LIST IC.
C
C
C	[5.1] IF SET IC = NULL
C		 THEN CREATE A SET IC, RETURN PTR==>IC.
C
500	IDATA=IA
S	INC \IA#
S	TAD I \IA
S	DCA \IDATA#
C
	CALL BNODE(IX,IY,IDATA,KCVITOXY)
C
C
C	[5.2] IF FIND(IX,IY) IN SET IC
C			THEN NOP
C			ELSE APPENDSY TO SET IC;
501	ISET3=IC
S	INC \IC#
S	TAD I \IC
S	DCA \ISET3#
C
C
C	IF ISET3=-1
C		THEN CREATE A NODE AND RETURN
S	TAD \ISET3#
S	SMA CLA
S	JMP \502 /OK
C
C	THEN
	CALL BNODE(IX,IY,ISET3,KGETLIST)
C
C	UPDATE IC
S	CLA CMA /-1
S	TAD \IC#
S	DCA \IC#
C
	IC=ISET3
S	INC \IC#
S	TAD \ISET3#
S	DCA I \IC
	GOTO 2047
C
C	ELSE
C	TEST IF THERE
502	CALL BNODE(IDATA,ISET2,ISET3,KFINDXY)
S	CLA IAC
S	TAD \ISET2#
S	SZA CLA
S	JMP \2047 /FOUND, RETURN
C
C
C	[5.2] NOT FOUND! APPENDXY TO IC.
	CALL BNODE(IX,IY,ISET3,KAPPENDXY)
	GOTO 2047
C	[6] LRMVDATA - IF THERE IS A NODE ELEMENT IN LIST IC
C	WITH DATA IA THEN DELETE IT (AND RETURN IT TO 
C	THE AVAIL LIST).
C
600	IDATA=IA
S	INC \IA#
S	TAD I \IA
S	DCA \IDATA#
C
	CALL BNODE(IX,IY,IDATA,KCVITOXY)
C
C
C	[6.1] IF FIND(IX,IY) IN SET IC
C			THEN NOP
C			ELSE APPENDSY TO SET IC;
601	ISET3=IC
S	INC \IC#
S	TAD I \IC
S	DCA \ISET3#
C
C
C
C	TEST IF THERE
	CALL BNODE(IDATA,ISET2,ISET3,KFINDXY)
S	TAD \ISET2#
S	SPA CLA
S	JMP \2047 /NOT FOUND, RETURN
C
C
C	[6.2]  FOUND! DELETEXY FROM IC.
C	NOTE THAT ISET2 POINTS TO THE NODE ITSELF. WE MUST POSITION
C	THE PTR TO THE LIST HEADER SO THAT THE BACK POINTER POINTS 
C	TO THE NODE TO BE DELETED!
	CALL BNODE(IX,IY,ISET2,KNEXTXY)
	CALL BNODE(IX,IY,ISET2,KDELETEXY)
C
C
C	[6.3]  RETURN NEW ISET2 PTR ==>IC
S	CLA CMA
S	TAD \IC#
S	DCA \IC#
	IC=ISET2
S	INC \IC#
S	TAD \ISET2#
S	DCA I \IC
	GOTO 2047
C	[7] LPUTXY - IF THERE IS NOT A NODE ELEMENT OF SET IC
C	WITH DATA THE SAME AS X,Y (IA,IB)
C	THEN ADD A NODE WITH XY DATA TO SET IC.
C
700	IX=IA
	IY=IB
C	GOTO [5.1]
	GOTO 501
C	[8] LRMVXY - IF THERE IS A NODE ELEMENT OF SET IC
C	WITH DATA THE SAME AS X,Y (IA,IB)
C	THEN REMOVE THE NODE FROM SET IC AND RETURN
C	IT TO THE AVAIL LIST.
C
800	IX=IA
	IY=IB
C	GOTO [6.1]
	GOTO 601
C	[9] LSIZE - FIND THE SIZE OF SET IA AND RETURN IT IN IC[1:2].
900	SIZE=0.0
C
C	COPY THE LIST PTR
	ISET1=IA
S	INC \IA#
S	TAD I \IA
S	SPA /TEST IF PTR IS NULL THEN DONT SEARCH
S	JMP \905 /NULL!
S	DCA \ISET1#
C
C
C	COPY WORKING PTR
	JPTR=ISET1
S	TAD \ISET1#
S	DCA \JPTR#
C
C	TRAVERSE SET1
901	SIZE=SIZE+1.0
C
	CALL BNODE(IX,IY,JPTR,KNEXTXY)
C
C	IF ISET1=JPTR
C		THEN DONE
C		ELSE CONTINUE COUNTING AND SEARCHING!
S	TAD \ISET1
S	CIA
S	TAD \JPTR
S	SZA CLA
S	JMP \901 /NOT YET
C
S	TAD \ISET1#
S	CIA
S	TAD \JPTR#
S	SZA CLA
S	JMP \901 /NOT YET
C
C
C	[9.1] DONE, CVT (SIZE)==>IC[1:2].
S\905,	CLA
	CALL DPCVRT(IDATA,SIZE,LFTOD)
C
	IC=IDATA
S	INC \IC#
S	TAD \IDATA#
S	DCA I \IDATA
	GOTO 2047
C
	END