C	PROGRAM SEGB2.FT
C	----------------
C
S	ENTRY SEGB2
S	CPAGE 2
S SEGB2,BLOCK 2
C
C	PETER LEMKIN
C	IMAGE PROCESSING UNIT, DCBD
C	NATIONAL CANCER INSTITUTE
C	NATIONAL INSTITUTES OF HEALTH
C	9000 ROCKVILLE PIKE
C	BETHESDA, MD. 20014
C
C	JUNE 24, 1977
C	JUNE 16, 1977
C	JUNE 11, 1977
C	JUNE 10, 1977
C	JUNE 8, 1977
C	JUNE 7, 1977
C	JUNE 4, 1977
C	JUNE 3, 1977
C	JUNE 2, 1977
C	MAY 27, 1977
C	MAY 24, 1977
C	MAY 19, 1977
C	MAY 17, 1977
C	MAY 16, 1977
C	MAY 13, 1977
C	MAY 11, 1977
C	MAY 10, 1977
C	APRIL 14, 1977
C	APRIL 12, 1977
C	APRIL 11, 1977
C	APRIL 4, 1977
C	MARCH 30, 1977
C	MARCH 29, 1977
C	MARCH 28, 1977
C	MARCH 26, 1977
C	MARCH 25, 1977
C	MARCH 24, 1977
C	MARCH 18, 1977
C	MARCH 17, 1977 /RENAMED FROM BMAX8, PUT FOLL==>BFOLLOW.FT
C
C	PURPOSE
C	-------
C	SEGB2 COMPUTES THE BOUNDARY FOLLOWED SEGMENTATION.
C
C	IVAL	FUNCTION
C	----	--------
C	1	INIT THE FOLLOW SEGMENT COUNTER NC<==1;
C		QRC<==0;
C
C	2	FOLLOW THE CURVE AT (IX,IY). PUT BOUNDARY DESCRIPTORS
C		INTO THE LIST POINTED TO BY QR[Z].
C		IT RETURNS WITH A TERMINATION CONDITION IN "LSNUM"
C
C		LSNUM	CONDITION
C		----	---------
C		1	NORMAL RETURN
C		2	ISOLATED PIXEL
C		3	COMPONENT GOT LOST
C		4	> 253 COMPONENTS
C
C		BOUNDARY DESCRIPTOR LIST FORMAT
C		-------------------------------
C
C
C		   Q-registers Y:Z
C				|
C				|
C			       \|/
C			[BACK PTR]<---NEXT DESCR.<---NEXT DESCR.<---
C			[FWD PTR]--->NEXT DESCR.--->NEXT DESCR.--->
C		--------[PTR TO PROP LIST]
C		|	[CONECT. CMP#]
C		|	[PTR TO BOUNDARY LIST].
C		|			|
C		|		       \|/
C		|			[XY1]<==>...[XYn];
C		|
C	       \|/
C		PROP LIST:
C		NODE 1<==>NODE 2<==>NODE 3
C
C
C		NODE 1
C		------
C	right ptr: #B.P.
C	datum 1: true perimeter
C	datum 2: area under RLM
C
C		NODE 2
C		------
C	right ptr: area FILLED under RLM
C	datum 1: horizontal position
C	datum 2: vertical position
C
C		NODE 3
C		------
C	right ptr: ---
C	datum 1: horizontal size
C	datum 2: vertical size
C
C	DEBUG SWITCHES
C	---------------
C	FBW4	FUNCTION
C	----	--------
C@C	0400	SEGB2[7] LIST, BKPTR, IX,IY
C	2000	SEGB2 PRINT RLM AFTER IT IS COMPUTED IN FILL
C@C	4000	SEGB2[2] TRUE NON-ISOLATED POINT CC COUNTER
C
C
C	COMMON VARIABLES USED
C	----------------------
C	FILE	- AREA
C	EXT	- DENSITY
C	CURSYM	- TRUE PERIMETER
C	FC	- # FILLED AREA
C	FA	- HOR SIZE OF ENCLOSING RECTANGLE
C	FB	- VERT SIZE ENCL RECT
C	MODEE	- # BOUNDARY POINTS
C
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
C
S	OPDEF 	LDXP	6443
S	OPDEF	LDYP	6444
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF	BSW	7002
C
S	OPDEF CLAMQ 7621 /CLA MQL
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
S	OPDEF	DAD	7443
S	OPDEF	DST	7445
C
	DIMENSION IPTR(2),LIST(2),NODE(2,3)
C	[0] DISPATCH
C	DEFINE BNODE CALLS:
C@	KAPPENDXY=1
C@	KINITAVAIL=4
C@	KGETLIST=5
C@	KFREELIST=6
C@	KLASTXY=7
C@	KNEXTXY=8
C@	KCARXY=9
C@	KFINDXY=10
C@	KCVXYTOI=15
C@	KCVITOXY=16
C@	LPUTDATA=5
C
C
C	DISPATCH
	GOTO (1,2), IVAL
C
C	[SEGB2-1] INIT THE FOLLOW SEGMENT COUNTER
1	CONTINUE
	NC=1
C	ZERO THE TRUE CC COUNTER
	IERRNUM=0
C
C
C	GET THE CONVERSION FACTORS TO BE USED FOR COMPUTING THE
C	WINDOW SIZE AND PERIMTER IN MICRONS.
C	COPY BMAP PARAMETERS PUT IN COMMON BY BMON2 BEFORE CHAIN
C	IN BMAX2[16].
C@	LENS=IA
C@	ZOOM=FA
	PUC=FB
	UNAME=FC
C
S \2047,	RETRN SEGB2
C
C	[SEGB2-2] FOLLOW CURVE STARTING AT (IX,IY)
C	FOLLOW THE OUTSIDE BORDER AND SEGMENT IT
2	CONTINUE
C
C
C	[1] INIT THE TERMINATION SWITCH TO NORMAL EXIT
	LSNUM=1
C
C	[1.1] INIT THE BOUNDARY LENGTH COUNTER
	MODEEBNDCNT=1
C
C
C
C	[2] TEST IF ISOLATED PIXEL
C
C	GET FRESH NEIGHBORHOOD
	CALL GETNGH
C
	IZ=I10+I11+I12+I13+I14+I15+I16+I17
S	TAD \IZ
S	SNA CLA
S	JMP \902 /ISO. ERROR
C
C@C	*******DEBUG*********
C@S	6344
C@S	AND (4000
C@S	SNA CLA
C@S	JMP \900 /NO
C@	WRITE(3,945)IERRNUM
C@945	FORMAT(' TCC=',I5)
C@C	***********************
	GOTO 900
C
C
C	[2.1] ISOLATED POINT ERROR HANDLER!
902	CONTINUE
C
C@	WRITE(1,901)IX,IY
C@901	FORMAT(' ISOLATED PIXEL AT (X,Y)=',2I5)
C
C	ZERO THE PIXEL
	IZ=0
	CALL PACK2D
C	SET TERMINATION SWITCH
	LSNUM=2
	GOTO 2047
C
C
C	[3] NOT ISOLATED PIXEL, SO IS COMPONENT
900	NC=NC+1
C	INCREMENT THE TRUE CC NUMBER
	IERRNUM=IERRNUM+1
C
S	TAD \NC
S	CIA
S	TAD (D255
S	SMA CLA
S	JMP \903
C
	WRITE(3,905)
905	FORMAT(' > 255 CC')
C	SET TERMINATION SWITCH
	LSNUM=4
	GOTO 2047
C
C
C	OK, SAVE THE POSITION AND CREATE A BOUNDARY LIST
C	KGETLIST=5
903	CALL BNODE(IX,IY,LIST,5)
C
C	SETUP THE BFOLLOW ROUTINE
C	DEFINE THE MEM,IBYTE
	CALL BFOLLOW(MEM,IBYTE,1)
C
C	INIT THE SEGMENT COUNTER
	CALL BFOLLOW(0,NC,2)
C
C	INIT THE FIRST POINTS OF THE BOUNDARY
	CALL BFOLLOW(IX,IY,3)
C
C
C	[4] TRACE THE BOUNDARY
906	CONTINUE
C
C	TEST IF EXIT
S	CPAGE 3
S	JMS TTYCTL
S	JMP \2046 /RETURN TO SEGBND.FT
C
C	LOAD DISPLAYS
S	TAD \IX
S	DISP1
S	TAD \IY
S	DISP2
C
C	LOAD CURSOR OVER BMJ
S	TAD \KODTN
S	TAD \IX
S	LDXP
C
S	TAD \KODTM
S	TAD \IY
S	LDYP
C
C
C	[4.1] IF /T SWITCH THEN WRITE OUT BLACK INTO 
C	(MEM,IBYTE',IX,IY)
S	TAD \LSUMSK
S	SNA CLA
S	JMP \907 /NO SWITCH
C	WRITE IT OUT
	IBYTE=1-IBYTE
	IZ=255
	CALL PACK2D
	IBYTE=1-IBYTE
C
C
C	[4.2] SET THE PIXEL TO THE NEW COMPONENT NUMBER
907	IZ=NC
	CALL PACK2D
C
C
C	[4.3] GET NEXT POINT
C	SAVE OLD X,Y INCASE OF LOSING CC.
	IXX=IX
	IYY=IY
	CALL BFOLLOW(IX,IY,4)
C	[5] DISPATCH IF IX < 0
S	TAD \IX
S	SMA CLA
S	JMP \496 /IX GEQ 0, CONTINUE AT [7]
C
	IX=-IX
C	CASE:
C	[-1]==>GOTO [8] "DONE!, NOTE: PERIMETER RETURNED IN IY";
C	[-2]==>GOTO [2] "ISOLATED PIXEL";
C	[-3]==>GOTO [6] "COMPONENT GOT LOST";
	GOTO(491,902,483),IX
C
C
C
C	[6] GOT LOST CONTINUE ANYWAYS
483	LSNEW=1
	LSPAL=1+IOUTSPOOL
	DO 484 INDEX=1,LSPAL
C	NOTE: ISOLATED POINTS ARE NOT TRUE CC'S
	WRITE(LSNEW,482)NC,IERRNUM,IXX,IYY
482	FORMAT(' LOST CC#',I4,' TCC#',I4,', IX=',I4,', IY=',I4)
484	LSNEW=3
C
C	SET TERMINATION CONDITION
	LSNUM=3
C
C	GO FILL, TRASH AND RETURN AT [14.1]
	GOTO 485
C
C
C	[7] NOT DONE, ADD POINT TO BOUNDARY LIST
C	SAVE THE CHAIN CODE OF PREVIOUS POINT
S \496,	JMS CHAINCODE
C
C	KAPPENDIX=1
	CALL BNODE(IX,IY,LIST,1)
C
C	INCREMENT THE BOUNDARY LENGTH CTR
	MODEEBNDCNT=MODEEBNDCNT+1
C
C@C*****DEBUG****
C@S	6344 /FBW4
C@S	AND (0400 /BIT 3
C@S	SNA CLA
C@S	JMP \906
C@	CALL DPCVRT(LIST,FA,-1)
C@	IP=LIST
C@S	TAD \LIST#
C@S	DCA \IP#
C@	CALL BNODE(IXX,IYY,IP,7)
C@	CALL DPCVRT(IP,FB,-1)
C@	WRITE(3,1990)FA,FB,IXX,IYY
C@1990	FORMAT(' SB2[7] LST=',F7.0,', BK=',F7.0,' IX,IY=',2I5)
C@C*********************
	GOTO 906
C
C
C	[8] DONE WITH TRACE. CLOSE OFF THE SEGMENT.
C	GENERATE THE RLM.
C	IF /H THEN FILL IN HOLES WITH 1'S.
C	CVT PERIMETER TO MICRONS
491	CURSYM=FLOAT(IY)*PUC
C
C	GET THE LAST POINT'S CHAIN CODE
C	BACKUP THE BOUNDARY FOLLOWER AND GET IT
	CALL BFOLLOW(IXX,IYY,3)
	CALL BFOLLOW(IX,IY,4)
C	SAVE CHAIN CODE
S	JMS CHAINCODE
C
C
C	TRY TO FILL.
C	TURN OFF THE (X,Y) /B DUMP SWITCH FOR NOW
	IDUMP=0
C	DON'T ERASE BOUNDARY POINTS YET
	LSSAVE=1
C
S	JMS FILL
C
C	CVT HOR/VERT SIZES TO MICRONS
	FA=FLOAT(KX2+1-KX1)*PUC
	FB=FLOAT(KY2+1-KY1)*PUC
C
C
C	[9] PROPAGATE '1S INSIDE OF BOUNDARY TO CC#'S (NC)
S	JMS PROP
C
C
C	[10] SIZE THE CC.
C	CVT AREA TO SQ MICRONS
	FILE=FILE*PUC*PUC
C
C	CVT FILLED AREA TO MICRONS
	CALL DPCVRT(IMONR,FC,-1)
	FC=FC*PUC*PUC
C
C
C	[10.1] SELECT FEATURE FOR BOOLEAN EXPR.
C	IF BOOLEAN SIZE EXPR TRUE
C		THEN "KEEP IT" LSSAV_TRUE
C		ELSE "TRASH IT" LSSAV_FALSE;
	IVAL=2
	CALL SEGB3
C	NOTE: SEGB3 RETURNS THE NUMBER OF TOUCHING EDGES IN IVAL
C
C
C	[11] SAVE SEGMENT CHARACTERISTICS IF LEGAL
	LSNEW=ISW(3)
S	TAD \LSNEW
S	SNA CLA /COMPLEMENT LSSAVE IF /C
S	JMP \470
	LSSAVE=1-LSSAVE
C
C
C	[12] IF LSSAVE 
C		THEN PRINT THE COMPONENT 
C		ELSE FREE THE NODE, GOTO [14]
470	CONTINUE
S	TAD \LSSAVE
S	SNA CLA
S	JMP \486 /NO
C
C
	IVAL=3
	CALL SEGB3
C
487	CONTINUE
C
C	[13] UPDATE THE PROP LIST
C	SAVE BOUNDARY DESCRIPTOR LIST
C	MEETS LIMITS, PUT NODEINFO[1:3]([CC#],[PERIM],[BND PTR])==>SET;
C		CREATE THE DESCRIPTOR! GET A NODE
C	IF QR[Z]=PHI THEN QR[Z]_GETNODE;
	IVAL=ITMPSTK(26)
	IZ=IQREG(26)
S	TAD \IZ
S	DCA \IVAL#
C
C	IF QRZ=NIL
C		THEN QRZ_IB_NEW(LIST)
C		ELSE IB_APPENDXY TO QRZ;
C
S	TAD \IVAL#
S	SMA CLA
S	JMP \499 /LIST, EXISTS, APPEND IT;
C	KGETLIST=5
	CALL BNODE(0,0,IVAL,5)
C	COPY POINTER BACK
	IB=IVAL
S	TAD \IVAL#
S	DCA \IB#
C
	ITMPSTK(26)=IVAL
S	TAD \IVAL#
S	DCA \IZ
	IQREG(26)=IZ
	GOTO 497
C
C
C	[13.1] APPEND NODE TO IVAL LIST AND GET ITS PTR INTO IB.
C	KAPPENDXY=1
499	CALL BNODE(0,0,IVAL,1)
C	GET THE POINTER TO THE NEW NODE (BK PTR) DO
C	KLASTXY=7
C	NOTE: IP IS TRASH VARIABLE!
	CALL BNODE(IP,IP,IVAL,7)
	IB=IVAL
S	TAD \IVAL#
S	DCA \IB#
C
C
C	[13.2] UPDATE Q-REGISTER CC# COUNTER
C	QRC<==NC
497	ITMPSTK(3)=NC
C
C
C	[13.3] INSTANTIATE THE PROP LIST
	CALL STPROP(IB,IMONR,MODEEBNDCNT,FILE,CURSYM,EXT,KX1
     1,KX2,KY1,KY2,NC,LIST)
C	RETURN CC#
	IZ=NC
C
C
C	[13.4] FREE THE RLM
C***==>BUG<===***	CALL BRUN(0,0,KBRK,12)
C
C
C	[13.5] IF /B THEN DUMP THE BOUNDARY
	IDUMP=1
S	TAD \LSDUMP
S	SZA CLA
S	JMS FILL
	GOTO 2047
C
C
C	[14] ELSE FREE THE LIST AND TRASH CC#
C	ERASE TRACE AND CC
486	LSSAVE=0
	IDUMP=0
S	JMS PROP /ERASE <BMJ>
S	JMS FILL /ERASE <BMJ'>
C
C
C	[14.1] LOST CC, EXIT
485	CONTINUE
C***==>BUG<===***	CALL BNODE(0,0,LIST,6)
C	BACKUP THE CC COUNTER
	NC=NC-1
C	RETURN NC IN IZ
	IZ=NC
C
C
C	[14.2] FREE THE RLM
C***==>BUG<===***	CALL BRUN(0,0,KBRK,12)
C
	GOTO 2047
C	*******************************************************
C	*SUBROUTINE      F I L L
C	*******************************************************
C
C
C	COMPUTE RLM FROM BOUNDARY IN LIST. THEN IF /H (LSFILL=1) THEN
C	FILL IN JBM HOLES WITH NC GRAY VALUE SUCH THAT A HOLE
C	IS DEFINED TO BE A 0 PIXEL INSIDE OF A BOUNDARY DEFINED
C	 BY A NC GRAY VALUE BOUNDARY PIXEL.
C	LSUMSK=1 FOR DRAWING MASK (/T) IN (MEM,1-IBYTE)
C
S	CPAGE 3
S RFILL,	JMP I FILL
S FILL,	0 /ENTRY
C	[FILL.1] ZERO THE RLM AND ENTER LOOKAHEAD(X,Y) FOR 1ST POINT
	MEM=JBM
	IBYTE=JHGH
C
	IA=LIST
S	TAD \LIST#
S	DCA \IA#
C	KCAR=9
	CALL BNODE(IX,IY,IA,9)
C
C	SAVE THE FIRST COORDINATES FOR USE WITH LAST POINT
	IXBACK=IX
	IYBACK=IY
	LASTY=IY
C
C
C	[FILL.1.0.1] ZERO FIRST PIXEL IN <BMJ> AND
C	IF /T  AND (IDUMP=0)
C		 THEN WRITE OUT ZERO ==> <BMJ'>.
S	TAD \IDUMP
S	SZA CLA
S	JMP \140 /GOTO [FILL.1.1]
C
	IZ=0
	CALL PACK2D
C
S	TAD \LSUMSK
S	SNA CLA
S	JMP \139 /NO SWITCH
C	WRITE IT OUT
	IBYTE=1-IBYTE
	IZ=0
	CALL PACK2D
	IBYTE=1-IBYTE
C
C
C	ZERO THE RLM AND ENTER LA.
139	CALL BRUN(IX,IY,KBRK,1)
	GOTO 142
C
C
C
C	[FILL.1.1]  IFDUMP=1
C			THEN DUMP FIRST (IX,IY)
C	WRITE OUT (IX,IY,CHAIN CODE, BPSEMANTICS) OF LIST[1:2] NODE
140	IB=LIST
S	TAD \LIST#
S	DCA \IB#
S	JMS DMP4TUPLE
C
C
C	[FILL.2]  TRACE BOUNDARY AND ENTER POINTS INTO RLM.
C	COPY CURRENT LIST HEADER PTR
142	IB=IA
S	TAD \IA#
S	DCA \IB#
C
C	GET THE XY FROM THE HEADER NODE.
C	KNEXTXY=8
	CALL BNODE(IX,IY,IB,8)
C
C	ENTER (IX,IY)==>RLM
C	IF IDUMP=0
C		IF LSSAVE=0
C		THEN GOTO [FILL.2.2];
C	NOTE: NODE[1:3] A6 CONTAINS "DID" VARIABLE
S\137,	TAD \IDUMP
S	SZA CLA
S	JMP \143 /ELSE DUMP
C
S	TAD \LSSAVE
S	SNA CLA
S	JMP \144 /GOTO [FILL.2.2]
C
	CALL BRUN(IX,IY,NODE,2)
C
C	SAVE THE SEMANTICS ON THE "DID" VARIABLE
C	AS THE SUM HASH OF NODD[1:3] MODE 2**12 IN THE LOW
C	12 BITS OF THE POINT RIGHT POINTER FIELD.
S	JMS BPSEMANTICS
	GOTO 144
C
C
C	[FILL.2.1]  ELSE  DUMP (IX,IY,CHAIN CODE, BPSEMANTICS)
C	GET CHAIN CODE AND BPSEMANTICS FROM THE RIGHT PTR FIELD
S\143,	JMS DMP4TUPLE
C
C
C	[FILL.2.2] LOAD DISPLAYS
S \144,	TAD \IX
S	DISP1
S	TAD \IY
S	DISP2
C
C	LOAD CURSOR OVER BMJ
S	TAD \KODTN
S	TAD \IX
S	LDXP
C
S	TAD \KODTM
S	TAD \IY
S	LDYP
C
C
C	[FILL.2.3] IF LSSAVE=0
C		 THEN WRITE 0==><BMJ'> BOUNDARY TRACE
S	TAD \LSSAVE
S	SZA CLA
S	JMP \138 /NOT TRASHING
C
C
C	[FILL.2.3.1] ZERO PIXEL IN <BMJ> AND
C	IF /T SWITCH THEN WRITE OUT ZERO ==> <BMJ'>.
	IZ=0
	CALL PACK2D
C
S	TAD \LSUMSK
S	SNA CLA
S	JMP \138 /NO SWITCH
C	WRITE IT OUT
	IBYTE=1-IBYTE
	IZ=0
	CALL PACK2D
	IBYTE=1-IBYTE
C
C
C	[FILL.2.4] TEST IF GET OUT!
S	CPAGE 3
S\138,	JMS TTYCTL
S	JMP \2046 /RETURN TO SEGBND.FT
C
C
C	[FILL.2.5] SAVE THIS POINT AS LASTY
	LASTY=IY
C
C
C	[FILL.2.6] LOOP TO FIND STARTING POINT
C	FIRST BACKUP THE LIST PTR FOR BPSEMANTICS IN [FILL.2]
	LIST=IB
S	TAD \IB#
S	DCA \LIST#
C	KNEXTXY=8
	CALL BNODE(IX,IY,IB,8)
C
C
C	[FILL.2.7] TEST IF DONE.
C	IF (IA[1:2]=IB[1:2])
C		THEN "DONE" GOTO [FILL.2.8]
C		ELSE GOTO [FILL.2];
S	TAD \IA
S	CIA
S	TAD \IB
S	SZA CLA
S	JMP \137 /NOT DONE, GOTO [FILL.2]
C
S	TAD \IA#
S	CIA
S	TAD \IB#
S	SZA CLA
S	JMP \137 /NOT DONE, GOTO [FILL.2]
C
C
C
C	[FILL.2.8] DONE!
C	IF IDUMP=1
C		THEN OUTPUT (-1,0)
S	TAD \IDUMP
S	SNA CLA
S	JMP \170 /GOTO [FILL.2.9]
S	CLA CMA 
S	DCA \IVAL
S	DCA \IVAL#
	WRITE(4,1401)IVAL
S	JMP RFILL /RETURN
C
C
C
C	[FILL.2.9] IF LSSAVE=1 
C		THEN CLOSE THE RLM WITH LAST POINT=FIRST POINT.
C		ELSE RETURN
S \170,	TAD \LSSAVE
S	SNA CLA
S	JMP RFILL /ELSE RETURN;
C
C	THEN
	CALL BRUN(IXBACK,IYBACK,KBRK,6)
C*************DEBUG******
S	6344
S	AND (2000 /BIT 1
S	SNA CLA
S	JMP \1977 /NO
	KBRK=3
	CALL BRUN(KY1,KY2,KBRK,3)
	CALL BRUN(KY1,KY2,KBRK,7)
1977	CONTINUE
C**************************
C
C
C	[FILL.3] GET WINDOW
	CALL BRUN(KY1,KY2,KBRK,3)
	CALL BRUN(KX1,KX2,KBRK,4)
C
C	LOAD (X,Y) OFFSETS OF MEM.
	CALL BWINDOW(KODTN,0,KODTM,0,8)
C	LOAD WINDOW INTO F&S
	CALL BWINDOW(KX1,KX2,KY1,KY2, 2)
C
C	ADD 1 FOR DO LOOPS
	KY1=KY1+1
	KY2=KY2+1
C
C	ZERO AREA COUNTER FOR FILLED HOLES
	IMONR=0
S	DCA \IMONR#
C
C
C	[FILL.4] IF LSFILL=0 OR LSSAVE=0
C		THEN "DON'T FILL", RETURN
C		ELSE GET RUNS AND COPY PIXELS
S	TAD \LSFILL
S	SNA CLA
S	JMP \145 /DON'T FILL
C
S	TAD \LSSAVE
S	SNA CLA
S	JMP \145 /DON'T FILL
C
	DO 141 IY1=KY1,KY2
	IY=IY1-1
C
S	CPAGE 3
S	JMS TTYCTL
S	JMP \2046 /RETURN TO SEGBND.FT /GET OUT
C
C
C	[FILL.4.1] TEST IF ANY RUNS
	CALL BRUN(0,IY,LCNT,8)
S	TAD \LCNT
S	SNA CLA
S	JMP \141 /NO RUNS
C
C
C	[FILL.4.2] COPY THIS RUN
C	PASS LINE # IN KY ARG, RUN # IN KX ARG
	DO 141 KWC=1,LCNT
	KX1=KWC
	KX2=IY
	CALL BRUN(KX1,KX2,KBRK,9)
C	NOTE: THE RUNS ARE IN [0:255] AND NEED TO BE MAPPED TO [1:256].
	KX1=KX1+1
	KX2=KX2+1
C
	DO 141 IX1=KX1,KX2
	IY=IY1-1
	IX=IX1-1
C
C	LOAD DISPLAYS
S	TAD \IX
S	DISP1
S	TAD \IY
S	DISP2
C
C	LOAD CURSOR OVER BMJ
S	TAD \KODTN
S	TAD \IX
S	LDXP
C
S	TAD \KODTM
S	TAD \IY
S	LDYP
C
C	IF IZ(IX,IY)=0
C		THEN IZ=NC
	CALL FETCH2D
S	TAD \IZ
S	SZA CLA
S	JMP \141 /OK
	IZ=NC
	CALL PACK2D
C
C	COLOR IN <BMJ'> IZ=70
	IZ=70
	IBYTE=1-IBYTE
	CALL PACK2D
	IBYTE=1-IBYTE
C	INCREMENT THE FILLED AREA FOR HOLES
S	ISZ \IMONR
S	SKP
S	ISZ \IMONR#
S	CLA
C
141	CONTINUE
C
C
C	[FILL.5] UPDATE THE WINDOW FOR USE IN PRINTING THE HEADER
145	CALL BRUN(KX1,KX2,KBRK,4)
	KX1=KX1+1
	KX2=KX2+1
S	JMP RFILL /RETURN
C
C
C	*******************************************************
C	*SUBROUTINE      P R O P
C	*******************************************************
C	PROPAGATE 1'S INSIDE THE RLM TI NC'S.
C
C		FOR (ALL X,Y) IN RLM DO
C			IF LSSAVE=1
C				THEN IF IZ(IX,IY)=1 
C					THEN IZ(IX,IY)<==NC
C				ELSE IZ(IX,IY)<==0;
C
S	CPAGE 3
SRPROP, 	JMP I PROP
S PROP,	0 /ENTRY
C
C
C	[1] INIT
C	ZERO DENSITY
	EXT=0.0
C	ZERO AREA
	FILE=0.0
C
C
C	[2] SCAN THROUGH THE IMAGE
	DO 1600 IY1=KY1,KY2
	IY=IY1-1
C
S	CPAGE 3
S	JMS TTYCTL
S	JMP \2046 /RETURN TO SEGBND.FT
C
C	GET THE MAX # OF RUNS FOR LINE IY
	CALL BRUN(0,IY,LCNT,8)
C
C
C	GET THE RANGE OF BOUNDARY
	DO 1600 KWC=1,LCNT
	KX1=KWC
	KX2=IY
	CALL BRUN(KX1,KX2,KBRK,9)
C
C	COMPUTE AREA AS THE SUM OF CHORDS (RUNS)
	FILE=FILE+FLOAT(1+KX2-KX1)
C
C	DO NOT DO EDGE OF BOUNDARY
	KX1=KX1+2
	KX2=KX2
C
	DO 1600 IX1=KX1,KX2
	IY=IY1-1
	IX=IX1-1
C
C	LOAD DISPLAYS
S	TAD \IX
S	DISP1
S	TAD \IY
S	DISP2
C
C	LOAD CURSOR OVER BMJ
S	TAD \KODTN
S	TAD \IX
S	LDXP
C
S	TAD \KODTM
S	TAD \IY
S	LDYP
C
C
C	GET THE PIXEL IF BMI2 EXISTS
C		ELSE GET IT FROM IBM1
	MEM=IBM1
	IBYTE=IHGH1
C
S	TAD \SEXT /BMI2 COPY
S	TAD (-0215 /"BM"
S	SZA CLA
S	JMP \1601
C
C	COMPUTE DENSITY
	MEM=IBM2
	IBYTE=IHGH2
C
1601	CALL FETCH2D
C	D.P. ADD
S	CPAGE 10
S	TAD \IZ
S	SWAB
C
S	DAD
S	\EXT
C
S	DST
S	\EXT
S	SWBA
S	CLAMQ
C
C	RESET MEM
	MEM=JBM
C
C
C	IF LSSAVE=0
C		THEN IZ(IX,IY)<==0, IZ'(IX,IY)<==0;
S	TAD \LSSAVE
S	SZA CLA
S	JMP \1603
	IZ=0
	IBYTE=1-JHGH
	CALL PACK2D
	GOTO 1602
C
C
C	GET BMJ PIXEL DENSITY
1603	IBYTE=JHGH
	CALL FETCH2D
C				ELSE PROP;
C	IF IZ=1
C		THEN  IZ_NC;
S	CLA CMA
S	TAD \IZ
S	SZA CLA
S	JMP \1600 /DO NOT TEST IF PROP
C
C	YES,PROPAGATE
	IZ=NC
C
C	WRITE OUT IZ(IX,IY) INTO <BMJ>.
1602	IBYTE=JHGH
	CALL PACK2D
C
1600	CONTINUE
C
C	RETURN
C	FIRST CVT DENSITY FROM D.P. TO F.P.
	CALL DPCVRT(EXT,EXT,-1)
S	JMP RPROP
C
C	************************************************************
C	SUBROUTINE:	T T Y C T L	(INTERNAL)
C	************************************************************
C
S	CPAGE 3
S RTTYC,	JMP I TTYCTL
S TTYCTL,	0000		/ENTRY
C
S	KSF		/ANYTHING TYPED
S	JMP NORMAL	/NO, RETURN NORMALLY
S	KRB		/GET TYPED CHARACTER
S	AND (0177	/TAKE CARE OF PARITY PROBLEMS
S	TAD (-17	/TEST FOR CTRL/O
S	SNA		/SKIP IF NOT CTRL/O
S	JMP RTTYC	/ABORT CALLING ROUTINE (ERROR RETURN)
S	TAD (-4		/TEST FOR CTRL/S [-17-4=-23(OCTAL)]
S	SZA CLA		/SKIP IF CTRL/S
S	JMP NORMAL	/NOT CTRL/O OR CTRL/S SO RETURN NORMALLY
C
S SLEEP,KSF		/WAIT FOR CTRL/Q
S	JMP SLEEP	/KEEP WAITING
S	KRB		/READ CHARACTER
S	AND (0177
S	TAD (-17	/IS IT A CTRL/O?
S	SNA		/SKIP IF NOT
S	JMP RTTYC	/YES, ABORT
S	TAD (-2		/TEST FOR CTRL/Q (-17-2=-21(OCTAL))
S	SZA CLA		/SKIP IF SO
S	JMP SLEEP	/NOPE, KEEP SLEEPING
C
S NORMAL,INC TTYCTL	/INCREMENT RETURN ADDRESS FOR NORMAL RETURN
S	CLA		/SAFETY VALVE
S	JMP RTTYC	/RETURN
C	*****************************************************
C	*SUBROUTINE    C H A I N C O D E
C	*****************************************************
C	ADD THE DIRECTION CHAIN CODE CONTAINED IN THE MQ[9:11]
C	TO THE HIGH 4 BITS OF 16-BIT RIGHT PTR
C	OF LAST POINT POINTED TO BY "LIST[1:2]".
S	CPAGE 3
S RCHAINCODE,	JMP I CHAINCODE
S CHAINCODE,	0
S	MQA
S	DCA \IZ /SAVE CHAIN CODE
C
C	GET THE REAR OF THE LIST
	IPTR=LIST
S	TAD \LIST#
S	DCA \IPTR#
C	KLASTXY=7
	CALL BNODE(NODE,NODE,IPTR,7)
C
C	KREADINFO=18
	CALL BNODE(NODE,0,IPTR,18)
C
C	SET HIGH RIGHT PTR<==C(MQ)
S	TAD \IZ
S	DCA \NODE# /NODE(2,1)
C
C	KWRITEINFO=17
	CALL BNODE(NODE,0,IPTR,17)
S	JMP RCHAINCODE
C	*****************************************************
C	*SUBROUTINE    B P S E M A N T I C S
C	*****************************************************
C	ADD THE HASH OF THE BOUNDARY POINT SEMANTIC "DID"
C	VARIABLE OBTAINED FROM THE BRUN PROCEDURE.
C	TO THE LOW 12 BITS OF 16-BIT RIGHT PTR
C	OF THE LIST POINTED TO BY LIST[1:2].
S	CPAGE 3
S RBPSEMANTICS,	JMP I BPSEMANTICS
S BPSEMANTICS,	0
C	COMPUTE THE HASH SUM OF NODE[1:3].
S	CLA CMA
S	TAD PNODE
S	DCA 11
S	TAD I 11
S	TAD I 11
S	TAD I 11
S	DCA \IZ
C
C	KREADINFO=18
	CALL BNODE(NODE,0,LIST,18)
C
C	SET HIGH RIGHT PTR<==C(MQ)
	NODE=IZ
C
C	KWRITEINFO=17
	CALL BNODE(NODE,0,LIST,17)
S	JMP RBPSEMANTICS
C	*****************************************************
C	*SUBROUTINE    D M P 4 T U P L E
C	*****************************************************
C	DUMP (IX,IY,CHAIN CODE, BPSEMANTICS) NODE POINTED TO BY IB[1:2]
C	IN 4I5 FORMAT ON
C	THE FORTRAN II GENERAL I/O CHANNEL IN ASCII.
C
S	CPAGE 3
S RDMP4TUPLE,	JMP I DMP4TUPLE
S DMP4TUPLE,	0
C	DUMP (IX,IY,CHAIN CODE, BPSEMANTICS)
C	GET CHAIN CODE AND BPSEMANTICS FROM THE RIGHT PTR FIELD
C	KREADINFO=18
	CALL BNODE(IBUF1,0,IB,18)
C	GET CHAIN CODE
S	TAD \IBUF1#
S	DCA \IXX
C	GET THE BPSEMANTICS HASH CODE
	IYY=IBUF1
C
C	IF /X
	IF(ISW(24))1402,1403,1402
C
C	THEN DUMP 4-TUPLE
1402	WRITE(4,1401)IX,IY,IXX,IYY
1401	FORMAT(4I5)
S	JMP RDMP4TUPLE
C
C	ELSE WRITE JUST ,Y
1403	WRITE(4,1401)IX,IY
S	JMP RDMP4TUPLE
C	POINTERS
C	--------
C	RETURN TO SEGBND.FT VIA RETURN STATEMENT
S \2046, RETRN SEGB1
C
C
C
S PI10,	\I10 /PTR
S PNODE,	\NODE /PTR
C
C
	END