C	PROGRAM BMAX4.FT
C	----------------
C
S	ENTRY BMAX4
S	CPAGE 2
S BMAX4,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	NOV 14, 1977 /MOVED FILLPIN TO BMAX3
C	NOV 9, 1977
C	NOV 8, 1977
C	NOV 7, 1977 /CHANGED FROM FETCH/PACK TO T3BUF SINGLE LINE I/O
C	NOV 4, 1977 /FIXED MUL AND DIV
C	MARCH 3, 1977
C	JAN 23, 1977
C	JAN 20, 1977
C	OCT 8, 1976
C	OCT 7, 1976
C	OCT 6, 1976
C	OCT 5, 1976
C	OCT 1, 1976
C	SEPT 28, 1976
C	SEPT 15, 1976
C	SEPT 13, 1976
C	SEPT 11, 1976
C	SEPT 9, 1976
C	SEPT 8, 1976
C	SEPT 7, 1976
C	SEPT 2, 1976
C	SEPT 1, 1976
C	AUG 31, 1976
C	AUG 30, 1976
C	AUG 28, 1976
C	AUG 27, 1976
C	AUG 24, 1976
C
C	PURPOSE
C	-------
C	USE A COMMON PIXEL PROCESSING LOOP TO PROCESS ALL
C	BINARY OPR COMMANDS WITH A CASE STATEMENT FOR THE KERNAL.
C	BMAX4 IS THE PICTURE PROCESSING PACKAGE FOR BMON1
C	IT CONTAINS THE FOLLOWING FUNTIONS:
C	IVAL	FUNCTION
C	----	--------
C	1	ADD
C	2	SUB
C	3	MUL
C	4	DIV
C	5	AND
C	6	OR
C	7	MAX
C	8	MIN
C	9	DIFF
C	10	***NOP***
C	11	CIRCLE
C	12	RECTANGLE
C	13	WHITENOISE
C	14	SHIFT
C	15	NOP (EDGE MOVED TO BMAX3)
C	16	SLICE
C	17	CONTRAST STRETCH
C	18	SCALE <BMi> BY NUM/DENOM +B
C
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
C
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
S	OPDEF	DAD	7443
S	OPDEF	DST	7445
S	OPDEF	DPSZ	7451
S	OPDEF	DCM	7575
S	OPDEF	DPIC	7573
S	OPDEF	MUY	7405
S	OPDEF	DVI	7407
C
S	OPDEF 	CAM	7621
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF	BSW	7002
C
C
C
S	OPDEF	EXADR	6450
S	OPDEF	EXIN	6333

C
C	[1] FIRST SAVE THE /C SWITCH
	KOMP=ISW(3)
C
C	[1.1] SAVE THE 2ND ARG NAME
	K2NDBM=0
S	TAD \SEXT /2ND BM NAME
C	IF <BMI2>[1 FOR 2]="BM"
C		THEN K2NDBM_1 ELSE K2NDBM_0;
S	TAD (-0215 /"BM"
S	SNA CLA
S	IAC /SET THE FLAG
S	DCA \K2NDBM
C
C	[1.2] SAVE CD NUMBERS
C	IF RECTANGLE, THEN GET ARGS FROM 2ND CDSPEC CALL
S	TAD \IVAL
S	TAD (-D12
S	SZA CLA
S	JMP \151
C
S	TAD (4040 /SPACE
S	DCA \CURSYM
	WRITE(1,152)CURSYM,
152	FORMAT(' XC, YC, XS, YS',A1)
	CALL BCDSPEC
151	IC1=ICNUM
S	TAD \ICNUM#
S	DCA \IC2
	IC3=ICNUM(3)
	IC4=ICNUM(4)
C
C
C	GET ILO/IHI FROM ITMPSTK PUT THERE WITH HIST...
	IHI=255
	ILO=ITMPSTK
S	TAD \ITMPSTK#
S	SNA
S	TAD (D255
S	DCA \IHI
C
C
C
C	COMPUTE SIDES/2
S	TAD \IC3
S	CLL RAR
S	DCA \KX
S	TAD \IC4
S	CLL RAR
S	DCA \KY
C
C
C
C	[1.3] SETUP RANDOM NUMBER GENERATOR
S	TAD \FA
S	SZA CLA
S	JMP \104 /OK
	FA=3.1459
	FB=FA
C
C	[2] PROCES LOOP
C
C
104	DO 1099 IY1=KY1,KY2
S	CLA CMA
S	TAD \IY1
S	DCA \IY
C
S	TAD \IY
S	DISP2		/PUT BMY ADDRESS IN RIGHT LED'S
C
C
C
C	TEST FOR TTY EXIT ETC.
S	CPAGE 3
S	JMS TTYCTL	/TEST FOR TTY INPUTS
S	JMP \2047	/ERROR RETURN: ABORT
C
C
C	FILL THE LINE BUFFER(S).
	MEM=IBM1
	IBYTE=IHGH1
C		READ SINGLE LINE
	CALL T3BUF(IBUF1,2)
C
C
C	IF K2NDBM=1
C		THEN READ 2ND <BMI2>==>IBUF2
S	TAD \K2NDBM
S	SNA CLA
S	JMP \106 /NO
	MEM=IBM2
	IBYTE=IHGH2
	CALL T3BUF(IBUF2,2)
C
C	IF /U OR IVAL=14 (SHIFT) OR (KY2-KY1)<255
C		THEN IBUF3<==READ <BMJ> LINE;
S \106,	TAD \IVAL
S	TAD (-D14
S	SNA CLA
S	IAC /MAKE IT FAIL
S	TAD \KY1
S	CIA
S	TAD \KY2
S	TAD (-D255
S	SNA CLA
S	JMP \1055 /NO
	MEM=JBM
	IBYTE=JHGH
	CALL T3BUF(IBUF3,2)
C
C
C
1055	DO 100 IX1=KX1,KX2
C
C	COMPUTE IY AGAIN BECAUSE OF SHIFT!
S	CLA CMA
S	TAD \IY1
S	DCA \IY
C
S	CLA CMA
S	TAD \IX1
S	DCA \IX
S	TAD \IX
S	DISP1		/PUT BMX ADDRESS IN LEFT LED'S
C
C	GET I1 FROM BM1
C	GET FROM <BMI1> INPUT LINE BUFFER
C	I1=IBUF1(IX1)
S	TAD PBUF1
S	CPAGE 5
S	TAD \IX
S	DCA 7
S	TADI 7
S	DCA \I1
C
C	IF K2NDBM=1
C		THEN I2_IBUF2(IX1)
C		ELSE I2_ICNUM;
S	TAD \K2NDBM
S	SNA CLA
S	JMP \105
C
C	GET I2 FROM BM2
C	GET FROM <BMI2> INPUT LINE BUFFER
C	I2=IBUF2(IX2)
S	TAD PBUF2
S	CPAGE 5
S	TAD \IX
S	DCA 7
S	TADI 7
S	DCA \I2
	GOTO 103
C
105	I2=ICNUM
C
C	DISPATCH TO PARTICULAR OPR
103	GOTO(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18),IVAL
C
C	[2.1]  ADD
1	IZ=I1+I2
	GOTO 101
C
C
C	[2.2]  SUB
2	IZ=I1-I2
C	CLIP IT TO 0 SINCE - IS REALLY -
S	TAD \IZ
S	SPA
S	CLA /CLIP
S	DCA \IZ
	GOTO 101
C
C
C	[2.3]  MUL
S \3,	TAD \I1
S	DCA \301
S	TAD \I2
S	MQL
S	SWBA
S	CPAGE 2
S	MUY
S \301,	0
C	IF AC&MQ > 255
C		THEN RETURN (255) ELSE RETURN(MQ);
S	DCA 7 /SAVE HIGH BITS
S	MQA /SET UP ELSE RETURN(MQ)
S	DCA \IZ
C
C	TEST
S	MQA
S	AND (7400 /HIGH BITS > 255
S	TAD 7
S	SNA CLA
S	JMP \101 /IZ LEQ 255, ELSE RETURN(MQ)
C
C	SET TO BLACK
	IZ=255
	GOTO 101
C
C
C
C	[2.4] DIV
S \4,	TAD \I2
S	DCA \401
S	TAD \I1
S	MQL
S	SWBA
S	CPAGE 2
S	DVI
S \401,	0
S	CLA
S	MQA
S	DCA \IZ
	GOTO 101
C
C
C	[2.5]  AND
S \5,	TAD \I1
S	AND \I2
S	DCA \IZ
	GOTO 101
C
C
C	[2.6]  OR
S \6,	TAD \I2
S	MQL
S	TAD \I1
S	MQA
S	DCA \IZ
	GOTO 101
C
C
C	[2.7]  MAX
S \7,	TAD \I1
S	CIA
S	TAD \I2
S	SMA CLA
S	JMP \702
C
	IZ=I1
	GOTO 101
702	IZ=I2
	GOTO 101
C
C
C	[2.8]  MIN
S \8,	TAD \I2
S	CIA
S	TAD \I1
S	SMA CLA
S	JMP \802
C
	IZ=I1
	GOTO 101
802	IZ=I2
	GOTO 101
C
C
C	[2.9]  DIFF
9	I12=I1-I2
S	TAD \I12 /MAKE ABS(I12)
S	SPA
S	CIA
S	DCA \I12
C
C	IF I12>THRESHOLD 
C		THEN IZ=I12 ELSE IZ=0;
	IZ=0
S	TAD \ICNUM
S	CIA
S	TAD \I12
S	SPA CLA
S	JMP \101 /<0
	IZ=I12
	GOTO 101
C
C
C
C
C	[2.10]***NOP***
10	GOTO 2047
C	[2.11] CIRCLE
C	IF (IX,IY) IN THE CIRCLE THEN COPY IZ ELSE IGNORE
C	IF (X+XC-R) GEQ 0 AND (X+XC+R) LEQ 255 AND
C		(Y+YC-R) GEQ 0 AND (Y+ YC+R) LEQ 255
C		THEN 
C		IF (X-XC)**2 + (Y-YC)**2 < R*R
C			THEN PUSH IZ
C		ELSE NOP;
11	IZ=I1
	IF(IX-(IC1-IC3))100,   1100,1100
1100	IF(IX-(IC1+IC3))1101,1101,    100
C
1101	IF(IY-(IC2-IC3))100,   1102,1102
1102	IF(IY-(IC2+IC3))1103,1103,   100
C
1103	KX=IX-IC1
	KY=IY-IC2
C
C	COMPUTE: IX=IABS(IX), IY=IABS(IY)
S	TAD \IX
S	SPA
S	CIA
S	DCA \IX
C
S	TAD \IY
S	SPA
S	CIA
S	DCA \IY
C
C	COMPUTE (KX*KX+KY*KY-RSQ)
C
S	CPAGE 10
S	TAD \KX
S	SWAB /AND MQL
S	MUY
S	\KX
C
S	DST
S	\IVAL
C
S	CAM
S	CPAGE 13
S	TAD \KY
S	SWAB
S	MUY
S	\KY
C
S	DAD
S	\IVAL
C
S	DCM /2'S COMPL
S	DST
S	\IVAL
S	CAM
C
C
C	COMPUTE: -R*R
S	TAD \IC3
S	SWAB
S	CPAGE 2
S	MUY
S	\IC3
C
S	CPAGE 5
S	6211
S	DAD
S	\IVAL
S	JMS 45
S	NOP /RESET TO CURRENT FIELD
C
S	DCM
C
C	IF AC-MQ CONTAINS (X**2+Y**2-R**2) > 0
S	SWBA
S	SPA CLA
S	JMP \101
S	JMP \100
C
C
C	[2.12] RECTANGLE
C	IF (IX,IY) IN THE RECTANGLE THEN COPY IZ ELSE IGNORE
C	IF (X+XC-R) GEQ 0 AND (X+XC+XSIDE/2) LEQ 255 AND
C		(Y+YC-R) GEQ 0 AND (Y+ YC+XSIDE/2) LEQ 255
C		THEN PUSH IZ
C		ELSE NOP;
12	IF(IX-(IC1-KX))100,   1200,1200
1200	IF(IX-(IC1+KX))1201,1201,    100
C
1201	IF(IY-(IC2-KY))100,   1202,1202
1202	IF(IY-(IC2+KY))1203,1203,   100
C
C	YES
1203	IZ=I1
	GOTO 101
C
C
C	[2.13] WHITENOISE
C	SET IZ=MEAN + (IRANDOMDIGIT-6)*STDDEVIATION
C		WHERE: MEAN=IC2
C			STDDEV=IC1
C			IRANDOMDIGIT= (SEED LSH-6) LAND '17 MOD 10
C	THE RANDOM NOISE GENERATOR IS:
C	SEED= IF SEED=0 THEN SEED=PI
C			ELSE SEED*(SEED+SEED);
S \13,	SWAB
S	CPAGE 2
S	DAD
S	\FA
C
C	TEST IF SEED=0
S	DPSZ
S	JMP SOK /NOPE
C	GET RANDOM # FROM REAL TIME CLOCK SECONDS
S	EXADR /0 IS MIN AND SEC
S	EXIN
S	MQL
C
S	CPAGE 2
S	DAD
S	\FB /RESET THE SEED
C
S	CPAGE 2
S SOK,	DAD
S	\FA
C
S	CPAGE 2
S	MUY
S	\FA
C
S	CPAGE 2
S	DST
S	\FA
C
S	SWBA
S	CLA
S	MQA
S	BSW
S	AND (17
S	MQL
S	MQA
S	TAD (-D10 /0:9
S	SMA CLA
S	JMP \13 /NO GOOD, TRY AGAIN
C
C	OK, NOW COMPUTE 
C		IZ=MEAN +(IRANDOM-6)*STDDEV
S	MQA
S	TAD(-6
S	MQL
S	TAD \IC1
S	DCA MSTDEV
S	CPAGE 2
S	MUY
S MSTDEV,	0
S	CLA
S	MQA
S	TAD \IC2
S	DCA \IZ
	GOTO 101
C
C
C	[2.14] SHIFT BY (IC1,IC2) AND TEST IF (IX+IC1,IY+IC2) IN
C		THE RANGE (0:255,0:255).
14	IX=IX+IC1
	IY=IY+IC2
C	DEFINE THE GRAY VALUE
	IZ=I1
C
S	TAD \IX
S	SPA CLA
S	JMP \100 / X<0
C
S	TAD \IX
S	TAD (-D256
S	SMA CLA
S	JMP \100 / X>255
C
S	TAD \IY
S	SPA CLA
S	JMP \100 / Y<0
C
S	TAD \IY
S	TAD (-D256
S	SMA CLA
S	JMP \100 / Y>256
S	JMP \101 /OK, WRITE IT OUT
C
C
C	[2.15] NOP...
C
15	GOTO 2047
C
C
C
C	[2.16] SLICE 
C		IF IC1 LEQ IZ LEQ IC2 THEN IZ ELSE NOP
C	IF IC2=0 THEN IC2=255
16	IZ=I1
C
C	IF BM2I NON-NULL THEN USE IT INSTEAD OF BMI1
S	TAD \SEXT /BMI2
S	SNA CLA
S	JMP \1601
C
C	USE BMI2
	IZ=I2
C
C	CHECK LIMITS
S\1601,	TAD \IC1
S	CIA
S	TAD \I1
S	SPA CLA
S	DCA \IZ /SET IZ==>NOP, IZ < IC1
C
S	TAD \IC2
S	SNA
S	TAD (D255 /FORCE TO MAX
S	CIA
S	TAD \I1
C	IF IZ > IC2
S	SPA SNA CLA
S	SKP /OK, WRITE OUT IZ
S	DCA \IZ /NOP, IZ > IC2
	GOTO 101
C
C
C
C
C	[2.17] CONTRAST STRETCH BY IH[1:512] USING ILO/IHI
C	STORED IN ITMPSTK[1:2]
17	INUMERATOR=255
	IDENOMINATOR=IHI-ILO
C
C	RESCALE BY IZ=(INUMERATOR/IDENOMINATOR)*(IZ-ILO)
	IZ=I1-ILO
C
C	SET OFFSET TO ZERO.
	IC3=0
	GOTO 1800
C
C
C
C
C
C	[2.18] SCALE BY [NUM/DENOM]*G +B
C	WHERE B=ICNUM(3)
C
18	IZ=I1
C
C
C	DO THE SCALING OR CONTRAST STRETCHING
S\1800,	TAD \INUMERATOR
S	DCA NUM18
S	TAD \IDENOMINATOR
S	DCA DENOM18
C
C
S	TAD \IZ
S	MQL
S	CPAGE 2
S	MUY
S NUM18,	\INUMERATOR
S	CPAGE 2
S	DVI
S DENOM18,	\IDENOMINATOR
S	CLA
S	MQA
C
C
C	CLIP TO 2047 BEFORE ADD IC3
S	SMA
S	JMP \1801 /NO CLIPPING
S	CLA
S	TAD (D2047
C
C	ADD "B"
S\1801,	TAD \IC3
S	DCA \IZ
C@C******DEBUG****
C@	WRITE(1,1999)INUMERATOR,IDENOMINATOR,IC3,IZ
C@1999	FORMAT('*',4I5)
C@C**************
	GOTO 101
C
C
C	[3] CLIP THE RESULT
S\101,	CLA
S	TAD \IZ
S	SMA
S	JMP \108 /IT IS <0 ==> >2047 SO MAP TO 255
S	TAD (D255
C
S\108,	TAD (-D255
S	SMA 
S	CLA /CLIP AT 255
S	TAD (D255
S	DCA \IZ
C
C
C	[4] TST IF COMPLEMENT
S	TAD \KOMP
S	SNA CLA
S	JMP \107
	IZ=255-IZ
C
C
C
C	[5] SAVE THE RESULT
S\107,	TAD \IZ
S	AND (377
S	DCA \IZ
C
C	IF IVAL=14 (SHIFT)
C		THEN PACK2D
C		ELSE IBUF3(IX1)<==IZ;
S	TAD \IVAL
S	TAD (-D14
S	SZA CLA
S	JMP \1098 /ELSE PUT INTO BUFFER
C
	MEM=JBM
	IBYTE=JHGH
	CALL PACK2D
	GOTO 100
C
C	PACK IT INTO IBUF3(IX1)<==IZ;
S\1098,	TAD \IX
S	TAD PBUF3
S	DCA 7
S	CPAGE 4
S	TAD \IZ
S	DCAI 7
C
C
100	CONTINUE
C
C
C	[6] WRITE OUT THE LINE==>BMJ
C	IF IVAL=14 THEN DO NOT WRITE OUT BUFFER
S	TAD \IVAL
S	TAD (-D14
S	SNA CLA
S	JMP \1099 /DO NOT WRITE OUT BUFFER
C
	MEM=JBM
	IBYTE=JHGH
	CALL T3BUF(IBUF3,3)
1099	CONTINUE
C
C
C
C	[7] RETURN
S\2047,	RETRN BMAX4

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
C	*********PARAMETERS******
S PBUF1,	\IBUF1
S PBUF2,	\IBUF2
S PBUF3,	\IBUF3
	END