C	PROGRAM DRW512.FT
C	----------------
C
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
C	NOV 15, 1977
C	NOV 14, 1977
C
C
C
C	PURPOSE
C	-------
C	*DRW512 - zero BM0,1,2,3. Then listen to the graphpen to
C	draw into a 512x512 frame. The following menu is available
C	from the Class keys:
C
C	Class key	Function
C	---------	--------
C	0		erase all BMs (0 to 3)
C	1		write white instead of black (ie. erase pixel)
C	2		Do a GET/A at the current F&S position.
C	3		UNPOST/A while down
C	11		Exit back to BMON2 (also ^O to do the same thing).
C	OPDEFS
C	------
S	OPDEF	TADI	1400
S	OPDEF	DCAI	3400
C
S	OPDEF	HPL	6360
S	OPDEF	HSL	6361
S	OPDEF	VPL	6362
S	OPDEF	VSL	6363
C
S	OPDEF 	LDXP	6443
S	OPDEF	LDYP	6444
S	OPDEF	DISP1	6435
S	OPDEF	DISP2	6436
C
C
S	OPDEF	SWAB	7431
S	OPDEF	SWBA	7447
C
S	OPDEF   CLAMQ   7621
S	OPDEF	MQA	7501
S	OPDEF	MQL	7421
S	OPDEF	BSW	7002
C
S	OPDEF	READGP	6146
S	SKPDF	GPSKP	6141
S	OPDEF	FBW3	6343
S	OPDEF	FBW12	6352
S	OPDEF	POSTA	6520
S	OPDEF	POSTB	6521
C
C
S	OPDEF	QPROG2	6371
S	OPDEF	QPROG7	6433
C
S	OPDEF	STQMT	6300
S	SKPDF	QMSKP	6301
S	OPDEF	GETA 6522
	DIMENSION IFRAME(4)
C
C	[0] INITIALIZATION
	ET=TIMER(0)
	WRITE(1,995)
	WRITE(3,995)
995	FORMAT(' DRW512 11/15/77 - 4:01PM')
C
	WRITE(1,994)
994	FORMAT(' CLASS KEY MENU',/,' 0 - ERASE ALL BMS',/
     1,' 1 - ERASE PIXELS',/,' 2 - GET/A',
     2/,' 3 - UNPOST/A',/,' 11 - EXIT')
C
C
C	[1] INITIALIZATION
	IXOFFSET=200
	IYOFFSET=150
C
C	DEFINE BMOMNI CALLS
	MLDFS=19
	MRDFS=20
	MWINDOW=7
	MCOLOR=4
C
C
C	SAVE THE F&S
	CALL BMOMNI(0,0, 0,0,0, IFRAME,MRDFS)
C
C
C	SET THE F&S TO 512X512 AT (IXOFFSET,IYOFFSET)
	IBUF1=IXOFFSET
	IBUF1(2)=512
	IBUF1(3)=IYOFFSET
	IBUF1(4)=512
	CALL BMOMNI(0,0, 0,0,0, IBUF1,MLDFS)
C
C	ZERO THE BUFFER
1234	DO 109 IY1=1,512
S	CLA CMA
S	TAD PBUF1
S	CPAGE 5
S	TAD \IY1
S	DCA 25
S	DCAI 25
109	CONTINUE
C
	DO 111 KMEM=1,4
	MEM=KMEM-1
	IBYTE=0
	DO 111 IY1=1,256,3
	IY=IY1-1
111	CALL T3BUF(IBUF1,1)
C
C
C	[1.1] SET THE BMS' TO BE ADJACENT
S	TAD (0017 /ALL BMS 0 TO 3 IN LOW MASK MODE
S	POSTA
S	POSTB
C
C
C
C
C
C	SET BM0-BM3 INSIDE OF THE F&S
	CALL BMOMNI(0,0,IXOFFSET,IYOFFSET,0,JUNK,MWINDOW)
	CALL BMOMNI(1,0,IXOFFSET+256,IYOFFSET,0,JUNK,MWINDOW)
	CALL BMOMNI(2,0,IXOFFSET,IYOFFSET+256,0,JUNK,MWINDOW)
	CALL BMOMNI(3,0,IXOFFSET+256,IYOFFSET+256,0,JUNK,MWINDOW)
C
	CALL BMOMNI(0,1,0,0,0,JUNK,MCOLOR)
	CALL BMOMNI(1,1,0,0,0,JUNK,MCOLOR)
	CALL BMOMNI(2,1,0,0,0,JUNK,MCOLOR)
	CALL BMOMNI(3,1,0,0,0,JUNK,MCOLOR)
C	[2] GET GRAPHPEN (X,Y) DATA AND STORE IN BM.
C		BEGIN "GP START"
200	IZ=255
C
C	TEST IF CLEAR BMS (BIT 0)
S	FBW3
S	AND (4000 /BIT 0
S	SZA CLA
S	JMP \1234 /RESTART
C
C	TEST IF ERASE (BIT 1)
S	FBW3
S	AND (2000
S	SZA CLA
S	DCA \IZ /DRAW ZEROS
C
C	TEST IF GET/A (BIT 12)
S	FBW3
S	AND (1000
S	SNA CLA
S	JMP \233 /NO
C
C		GET THE F&S POSITIONS
	CALL BMOMNI(0,0, 0,0,0,IBUF1,MRDFS)
	IX=IBUF1
	IY=IBUF1(3)
	IXOFFSET=IX
	IYOFFSET=IY
	CALL BMOMNI(0,0,IX,IY,0,JUNK,MWINDOW)
	CALL BMOMNI(1,0,IX+256,IY,0,JUNK,MWINDOW)
	CALL BMOMNI(2,0,IX,IY+256,0,JUNK,MWINDOW)
	CALL BMOMNI(3,0,IX+256,IY+256,0,JUNK,MWINDOW)
C
C	GET THE FRAME
S	TAD (0017
S	GETA
S	STQMT
S QWAIT,	QMSKP
S	JMP QWAIT
	GOTO 200
C
C	TEST IF UNPOST/A (BIT 3)
S \233,	FBW3
S	AND (0400
S	SNA CLA
S	TAD (0017 /POST/A
S	POSTA
C
C	TEST IF EXIT KEY (BIT 11)
S	FBW3
S	AND (0001 /BIT 11
S	SZA CLA
S	JMP \998 /GET OUT
C
S	CPAGE 3
S	JMS TTYCTL
S	JMP \998 /GET OUT
C
C
C	GET GRAPHPEN DATA
S	GPSKP
S	JMP \200
C
S	READGP
S	CLL RAR; RTR /DIVIDE BY 8 SO COVER 0:255
S	AND (777
S	DCA \IX1
C
S	READGP
S	CIA
S	CLL RAR; RTR /DIVIDE BY 16 SO COVER 0:255
S	AND (777
S	DCA \IY1
C
C	LOAD CURSOR
S	TAD \IX1
S	TAD \IXOFFSET
S	LDXP
S	TAD \IY1
S	TAD \IYOFFSET
S	LDYP
C
C	TEST IF PEN TIP DOWN
S	FBW12
S	AND (0001
S	SNA CLA
S	JMP \200 /NOT YET
C
C
C	[2.1] DRAW THE POINT
	IX=IX1
	IY=IY1
C	COMPUTE BMiL
S	CLA CMA
S	TAD \IX
S	AND (400
S	SZA CLA
S	IAC /EITHER 0 OR 2
S	DCA \MEM
S	CLA CMA
S	TAD \IY
S	AND (400
S	SZA CLA
S	TAD (2 /EITHER 2 OR 3
S	TAD \MEM
S	DCA \MEM
C
C
S	TAD \IY1
S	AND (377
S	DCA \IY
C
S	TAD \IX1
S	AND (377
S	DCA \IX
C
	CALL PACK2D
C
	GOTO 200
C		END "GP START";
C
C
C	[999] RETURN
	GOTO 998
999	WRITE(1,996)
996	FORMAT('BAD BM SPECIFICATION!')
C
C	RESTORE POST STATUS
C	RESTORE F&S
998	CALL BMOMNI(0,0, 0,0,0, IFRAME,MLDFS)
C
S	TAD \IPSTA
S	POSTA
S	TAD \IPSTB
S	POSTB
C
C	RSSTORE BM POSITIONS
	DO 990 KMEM=1,4
	MEM=KMEM-1
	IX=LSAVE(13,KMEM)
	IY=LSAVE(14,KMEM)
990	CALL BMOMNI(MEM,0, IX,IY,0,JUNK,MWINDOW)
	ET=TIMER(1)
	CALL CHAIN('BMON2')
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	POINTERS
C	--------
C
C
S PBUF1,	\IBUF1
S PBUF2,	\IBUF2
S PI10,	\I10 /PTR
C
C
	END