perm filename CEMAKE[CAR,BGB] blob sn#018298 filedate 1973-01-02 generic text, type T, neo UTF8
00100	;-----------------------------------------------------------------
00200	INTERN OLD44,FILM,BLKCNT,AVAIL
00300		OLD44:	0
00400		FILM:	0
00500		BLKCNT: 0
00600		AVAIL:	0
00700		REMAINDER:0
00800	SUBR(MORCOR);-----------------------------------------------------
00900	BEGIN MORCOR; - GET MORE CORE - BGB - 4 DEC 1972.
01000	
01100	;INITIALIZE FILM BLOCK POINTERS WHEN NECESSARY.
01200		SKIPE OLD44↔GO L1
01300		LAC 1,44↔DAC 1,OLD44
01400		AOS 1↔DAC 1,FILM
01500		ADDI 1,3↔DAC 1,AVAIL
01600		AOS 1↔DAC 1,BLKCNT
01700		SETZM REMAINDER
01800	
01900	;FOUR MORE K !
02000	L1:	LAC 1,44↔LAC 0,1↔ADDI 0,10000
02100		CALLI 11↔GO[FATAL(NO MORE CORE.)]
02200		AOS 1↔SUB 1,REMAINDER↔DAC 2,AC2#↔LAC 2,44
02300		SETZM(1)↔LIPI(1)↔LAPI(1)1↔BLT(2)
02400	
02500	;MAKE AVAIL LIST.
02600		DIP 1,1↔ADD 1,[6B17]
02700		SKIPE@BLKCNT↔GO .+3
02800		ADD 1,[XWD 6,6]↔AOS@BLKCNT
02900		DAPZ 1,@AVAIL
03000	L2:	HLRZM 1,(1)↔ADD 1,[XWD 6,6]
03100		CAILE 2,6+5(1)↔GO L2
03200		SUBI 2,5(1)↔DAC 2,REMAINDER
03300		LACI 10000↔ADDM @FILM
03400		LAC 1,@AVAIL
03500		LAC 2,AC2↔POP0J
03600	BEND;16/12/72-----------------------------------------------------
     

00100	SUBR(GETBLK);-----------------------------------------------------
00200	BEGIN GETBLK; - ALLOCATE A BLOCK OF 6 WORDS - BGB - 4 DEC 1972.
00300		SKIPN 1,@AVAIL
00400		CALL(MORCOR)
00500		CDR(1)↔DAP @AVAIL
00600		SETZM(1)↔AOS @BLKCNT
00700		POP0J
00800	BEND;17/12/72-----------------------------------------------------
00900	
01000	SUBR(RELBLK);-----------------------------------------------------
01100	BEGIN RELBLK;(PTR) - RELEASE  BLOCK OF 6 WORDS - BGB - 4 DEC 1972.
01200		LAC 1,ARG1↔SOS @BLKCNT
01300		SETZM(1)1↔SETZM(1)2↔SETZM(1)3↔SETZM(1)4↔SETZM(1)5
01400		LAC 2,@AVAIL↔DAPZ 2,(1)↔DAPZ 1,@AVAIL
01500		POP1J
01600	BEND;17/12/72-----------------------------------------------------
01700	
01800	SUBR(RINGIN)------------------------------------------------------
01900	BEGIN RINGIN;(PART,WHOLE) RING PART INTO A WHOLE -BGB- 6 DEC 1972.
02000		LAC 1,ARG2
02100		LAC 3,ARG1
02200		HEAD 2,3
02300		JUMPE 2,[HEAD. 1,3↔DIP 1,(1)↔DAP 1,(1)↔POP2J]
02400		CAR 3,(2)
02500		DIP 3,(1)↔DAP 1,(3)
02600		DAP 2,(1)↔DIP 1,(2)
02700		POP2J↔LIT
02800	BEND;6/12/72------------------------------------------------------
     

00100	SUBR(MKPGON)------------------------------------------------------
00200	BEGIN MKPGON; MAKE FRAME POLYGON - BGB - 4 DEC 1972.
00300		ACCUMULATORS{R,C,N,S,E,W,M}
00400		LACI R,=216⊗6↔LACI C,=288⊗6
00500		SETQ(M,{GETBLK})
00600	;VERTEX-POLYGON FRAME.
00700		SETQ(W,{GETBLK})↔MARK W,SOUBIT↔PGON. M,W
00800		SETQ(S,{GETBLK})↔MARK S,EASBIT↔PGON. M,S↔ROW. R,S
00900		SETQ(E,{GETBLK})↔MARK E,NORBIT↔PGON. M,E↔ROW. R,E↔COL. C,E
01000		SETQ(N,{GETBLK})↔MARK N,WESBIT↔PGON. M,N↔COL. C,N
01100		MARK M,PBIT
01200		MARK W,VBIT↔MARK S,VBIT
01300		MARK E,VBIT↔MARK N,VBIT
01400		CW.  N,W ↔ CW.  E,N ↔ CW.  S,E ↔ CW.  W,S
01500		CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
01600		HEAD. W,M
01700		LAC 1,M↔SKIPN FLGKRK↔POP0J
01800	
01900	;MAKE THAT BIG ARRAY UP THERE IN THE SKY.
02000	L1:	DETSEG
02100		LACI =217*=289
02200		CALLI 400015
02300		GO[FATAL(AIN'T NO MORE CORE UP YONDER.)]
02400		LAC[SIXBIT/SKYSEG/]↔CALLI 400036↔JFCL
02500		SETZ↔SEGNUM↔DAC SKYSEG
02600	
02700	;PUT THE FRAME UP IN THE SKY.
02800		LAC[XWD $,$+1]↔SETZM $↔BLT $+=217*=289-1
02900	L2:	SETZ C,↔LACI R,=216
03000		DAC W,@SKY(R)↔SOJGE R,.-1	;WEST SIDE.
03100		LACI R,=216↔LACI C,=288
03200		DAC S,@SKY(R)↔SOJGE C,.-1	;SOUTH SIDE.
03300		LACI C,=288
03400		DAC E,@SKY(R)↔SOJGE R,.-1	;EAST  SIDE.
03500		SETZ R,↔LACI C,=288
03600		DAC N,@SKY(R)↔SOJGE C,.-1	;NORTH SIDE.
03700	;ARC-POLYGON FRAME.
03800		LACI R,=216⊗6↔LACI C,=288⊗6
03900		CALL(GETBLK)↔ARC. 1,W↔ARC. W,1↔LAC W,1
04000		CALL(GETBLK)↔ARC. 1,S↔ARC. S,1↔LAC S,1↔ROW. R,S
04100		CALL(GETBLK)↔ARC. 1,E↔ARC. E,1↔LAC E,1↔ROW. R,E↔COL. C,E
04200		CALL(GETBLK)↔ARC. 1,N↔ARC. N,1↔LAC N,1↔COL. C,N
04300		PGON. M,W↔PGON. M,S↔PGON. M,E↔PGON. M,N
04400		MARK W,VBIT↔MARK S,VBIT↔MARK E,VBIT↔MARK N,VBIT
04500		CW.  N,W ↔ CW.  E,N ↔ CW.  S,E ↔ CW.  W,S
04600		CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
04700		ARC. W,M
04800	L3:	LAC 1,M↔POP0J
04900	BEND;31/12/72-----------------------------------------------------
05000	
05100	;POINTERS TO SKY ROWS - COLUMN ACCUMULATOR-3.
05200	SKY:	FOR I←0,=216{
05300		1B18+=289*I(3)}
     

00100	SUBR(INTREE)PGON--------------------------------------------------
00200	BEGIN INTREE - PUT A POLY IN THE KRAKAUER TREE - BGB 11 DEC 1972.
00300		ACCUMULATORS{R,C,E,P1,P2,P3}
00400		LAC P1,ARG1
00500		HEAD E,P1↔JUMPE E,POP1J.
00600		LAC RC(E)↔ADD[XWD 40,40]
00700		CAR R,↔LSH R,-6
00800		CDR C,↔LSH C,-6
00900	
01000	;FIND THE VERTICAL EDGE DUE EAST OF HERE.
01100	L0:	SKIPN 1,@SKY(R)↔SOJA C,L0
01200		TRNN  1,-1↔SOJA C,L0
01300		PGON P2,1↔CAMN P2,P1↔SOJA C,L0
01400		TEST  1,SOUBIT
01500		GO L1
01600	
01700	;SOUTHBOUND VERTICAL - THE POLYGON IS MY EXO-POLYGON.
01800		EXO. P2,P1
01900		ENDO P3,P2
02000		JUMPE P3,[ENDO. P1,P2↔CIS. P1,P1↔PGON. P1,P1↔POP1J]
02100		CIS  P2,P3
02200		GO L2
02300	
02400	;NORTHBOUND VERTICAL - THE POLYGON IS A CO-POLYGON OF MINE.
02500	L1:	EXO 0,P2
02600		EXO. 0,P1
02700		PGON P3,P2
02800	L2:	PGON. P1,P2
02900		CIS.  P1,P3
03000		CIS.  P2,P1
03100		PGON. P3,P1
03200		POP1J
03300	BEND;11/12/72-----------------------------------------------------
03400	
     

00100	SUBR(KRAKAUER)LEVEL-----------------------------------------------
00200	BEGIN KRAKAUER;MAKE KRAKAUER TREE STRUCTURE USING SKY ARRAY.
00300	;BGB - 19 DECEMBER 1972.
00400		SKIPN FLGKRK↔POP1J
00500		DETSEG↔LAC SKYSEG
00600		ATTSEG↔GO[FATAL(SKYSEG ATTACH FAILURE IN MKIMAG.)]
00700	
00800	;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
00900		LAC 1,ARG1↔HEAD 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
01000	L1:	CALL(INTREE,POLYGON)
01100		CALL(INSKY,POLYGON)
01200		LAC 1,POLYGON
01300		CCW 1,1
01400		DAC 1,POLYGON
01500		CAME 1,PG0↔GO L1
01600	
01700	;HOLE POLYGONS OF THE PREVIOUS LEVEL MUST NOW BE RE'TREE'ED.
01800		LAC 1,ARG1↔CW 1,1↔NCNT 0,1↔JUMPL 0,L4
01900		HEAD 1,1↔DAC 1,PG0↔DAC 1,POLYGON
02000	L2:	TEST 1,HOLBIT↔GO L3
02100		CIS 2,1↔PGON 3,1↔PGON. 3,2↔CIS. 2,3	;RINGO THE HOLE.
02200		CAMN 1,3↔SETZ 3,		;ZIP A ONE HOLE RING.
02300		EXO 2,1↔ENDO 0,2	;DOES MY EXO POINT AT ME.
02400		CAMN 0,1↔ENDO. 3,2	;ALTER THE HOLE'S EXO.
02500		CALL(INTREE,POLYGON)
02600	L3:	LAC 1,POLYGON
02700		CCW 1,1
02800		DAC 1,POLYGON
02900		CAME 1,PG0↔GO L2
03000	
03100	L4:	DETSEG↔POP1J
03200	BEND;28/12/72-----------------------------------------------------
     

00100	SUBR(INSKY)PGON---------------------------------------------------
00200	BEGIN INSKY; PLACE A POLYGON IN THE SKY - BGB - 7 DEC 1972.
00300		ACCUMULATORS{R,C,R2,C2,E,E2}
00400		;XWD HORIZONTAL,,VERTICAL.
00500		LAC 1,ARG1↔HEAD E,1↔DAC E,E0#↔JUMPE E,POP1J.
00600	DEFINE ADVANCE{
00700		LAC E,E2↔LAC R,R2↔LAC C,C2
00800		CCW E2,E2↔LAC RC(E2)↔ADD[XWD 40,40]
00900		CAR R2,↔LSH R2,-6
01000		CDR C2,↔LSH C2,-6}
01100		CW E2,E↔ADVANCE↔ADVANCE↔GO SSA
01200	
01300	;SOUTH ↓ BOUND.
01400	S0:	CAMN E,E0↔POP1J
01500	SSA:	CDR 1,@SKY(R)↔EXO. 1,E
01600	S1:	CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
01700		ROW 0,1↔ADDI 40↔LSH -6↔CAMN 0,R↔ENDO. E,1
01800		CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
01900		TEST E,EASBIT↔GO W0↔GO EE0
02000	
02100	;NORTH ↑ BOUND.
02200	N0:	SOS R↔CDR 1,@SKY(R)↔EXO. 1,E
02300	N1:	CDR 1,@SKY(R)↔DAP E,@SKY(R)↔JUMPE 1,.+6
02400		ROW 0,1↔ADDI 40↔LSH -6↔	CAIN 0,(R)1↔ENDO. E,0
02500		CAME R,R2↔SOJA R,N1↔ADVANCE
02600		TEST E,EASBIT↔GO W0↔GO EE0
02700	
02800	;EASTBOUND→.
02900	EE0:	CAR 1,@SKY(R)↔EXO. 1,E
03000	EE1:	CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03100		COL 0,1↔ADDI 40↔LSH -6↔CAMN 0,C↔ENDO. E,1
03200		CAIE C2,(C)1↔AOJA C,EE1↔ADVANCE
03300		TEST E,NORBIT↔GO S0↔GO N0
03400	
03500	;←WESTBOUND.
03600	W0:	SOS C↔CAR 1,@SKY(R)↔EXO. 1,E
03700	W1:	CAR 1,@SKY(R)↔DIP E,@SKY(R)↔JUMPE 1,.+6
03800		COL 0,1↔ADDI 40↔LSH -6↔CAIN 0,(C)1↔ENDO. E,1
03900		CAME C,C2↔SOJA C,W1↔ADVANCE
04000		TEST E,NORBIT↔GO S0↔GO N0
04100	
04200	BEND;13/12/72-----------------------------------------------------
     

00100	SUBR(MKIMAG)------------------------------------------------------
00200	BEGIN MKIMAG;(Q1,Q2) - MAKE IMAGE - BGB - 6 DEC 1972.
00300		LAC 1,ARG2↔DAC 1,Q0#
00400		LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1#
00500		SETZM CUT#
00600	
00700	;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
00800		SETQ(IMAGE,{GETBLK})↔MARK 1,IBIT
00900		CALL(RINGIN,IMAGE,FILM)
01000		LAC 1,IMAGE↔LAC 2,FILM↔HEAD. 1,2
01100		LIPI 1,(1)↔DAC 1,3(1)↔DAC 1,4(1)↔DAC 1,5(1)    ;FEV-RINGS.
01200		SETQ(LEVEL,{GETBLK})↔WIP(1)1↔MARK 1,LBIT
01300		CALL(RINGIN,LEVEL,IMAGE)
01400		SETQ(POLYGON,{MKPGON})↔MARK 1,PBIT
01500		CALL(RINGIN,POLYGON,LEVEL)
01600		CALL(SEGTV)
01700	
01800	;FIND AN INTENSITY CONTOUR ENABLE BIT OR EXIT.
01900	L0:	LAC 0,Q0↔LAC 1,Q1
02000	L1:	AOS 2,CUT↔LSHC 0,1↔JUMPL L2
02100		SKIPE 0↔GO L1↔SKIPE 1↔GO L1
02200		SETZ↔SKIPE FLGKRK↔CALLI 400015↔JFCL
02300		CALL(MKWED1,IMAGE)
02400		LAC 1,IMAGE↔POP2J
02500	
02600	L2:	DAC 0,Q0↔DAC 1,Q1
02700		CALL(THRESH,CUT)
02800		CALL(PACXOR)
02900		SETQ(POLYGON,{MKVIC})↔JUMPE 1,L0
03000		SETQ(LEVEL,{GETBLK})
03100		LAC CUT↔NCNT. 0,1↔MARK 1,LBIT
03200		CALL(RINGIN,LEVEL,IMAGE)
03300	
03400		SKIPA 1,POLYGON
03500	L3:	SETQ(POLYGON,{MKVIC})↔JUMPE 1,L4
03600		CALL(RINGIN,POLYGON,LEVEL)↔GO L3
03700	
03800	L4:	CALL(VICONT,LEVEL)
03900		CALL(BABYKILLER,LEVEL)
04000		CALL(KRAKAUER,LEVEL)
04100		CALL(SMOOTH,LEVEL)
04200		CALL(BUNDLE,LEVEL)
04300		GO L0
04400	
04500	BEND;20/12/72-----------------------------------------------------
04600		DECLARE{IMAGE,LEVEL,POLYGON}
     

00100	SUBR(BABYKILLER)LEVEL---------------------------------------------
00200	BEGIN BABYKILLER; -BGB- 28 DEC 1972.
00300		ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00400		SKIPN FLGBK↔POP1J
00500		LAC 1,ARG1↔HEAD PG,1↔DAC PG,PG0#
00600	;KLUDGE - SPARE HEAD POLYGON UNTIL WE CAN THINK OF A POLICY.
00700		GO L3
00800	;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00900	L1:	NCNT 0,PG↔LACM
01000		CAIL =10↔GO L3
01100	
01200	;RELEASE VIC NODES OF THE POLYGON.
01300		HEAD E0,PG
01400		LAC  E1,E0
01500	L2:	CCW  E2,E1
01600		CALL(RELBLK,E1)
01700		CAMN E2,E0↔GO .+3
01800		LAC  E1,E2↔GO L2
01900	
02000	;KILL A BABY POLYGON.
02100		CAR Q,(PG)↔CDR R,(PG)
02200		DIP Q,(R)↔ DAP R,(Q)	;RINGO PG.
02300		CALL(RELBLK,PG)
02400		SKIPA PG,R		;CCW FROM OUT OF THE GRAVE.
02500	
02600	;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02700	L3:	CCW PG,PG↔CAME PG,PG0↔GO L1
02800		POP1J
02900	
03000	BEND;28/12/72-----------------------------------------------------
     

00100	SUBR(SMOOTH)LEVEL-------------------------------------------------
00200	BEGIN SMOOTH; -BGB- 6 DEC 1972.
00300		ACCUMULATORS{U1,U2,PG,E0,E1,E2}
00400		SKIPN FLGARC↔POP1J	;MAKE ARC ENABLED ?
00500	
00600	;INITIALIZATION.
00700		LAC 1,ARG1
00800		HEAD PG,1
00900		DAC PG,PG0#
01000	
01100	;SMOOTH VIC INTO A  LOOP OF ARC SEGMENTS.
01200	L1:	DAC PG,PGSAVE#
01300		HEAD U1,PG↔DAC U1,E0SAVE#↔ARC U2,PG
01400	
01500		SETQ(V2,{GETBLK})↔LAC RC(U2)↔DAC RC(1)
01600		ARC. 1,U2↔ARC. U2,1↔MARK 1,VBIT
01700	
01800		SETQ(V1,{GETBLK})↔LAC RC(U1)↔DAC RC(1)
01900		ARC. 1,U1↔ARC. U1,1↔MARK 1,VBIT
02000	
02100		LAC 2,V2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
02200		PGON. PG,1↔PGON. PG,2↔ARC. 1,PG
02300		CALL(MKARCS,V1,V2)
02400		CALL(MKARCS,V2,V1)
02500	
02600	L2:	LAC PG,PGSAVE
02700		CCW PG,PG↔CAME PG,PG0↔GO L1
02800		POP1J
02900		DECLARE{V1,V2}
03000	BEND;28/12/72-----------------------------------------------------
     

00100	SUBR(PACXOR)------------------------------------------------------
00200	BEGIN PACXOR;do rook's exclusive OR'ing. BGB 4-DEC-72.
00300		I←2
00400		SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
00500		SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
00600		SETZ I,
00700		HRRI PAC↔DAP L+2
00800	L:	TRNN I,7↔SETZ 1,↔LAC PAC(I)
00900		XORM HSEG+8(I)	; HSEG SOUBIT are above PAC bits.
01000		ROTC -1↔ROT 1,1
01100		XORM VSEG(I)	; VSEG are left of PAC bits.
01200		AOS I
01300		CAIE I,=1728
01400		GO L
01500		SETZM ISAVED
01600		POP0J
01700	BEND;4/12/72------------------------------------------------------
01800	
01900	SUBR(THRESH)------------------------------------------------------
02000	BEGIN THRESH;THRESHOLD(LEVEL) pre foonly version. BGB 4 DEC 1972.
02100		SKIPE FLGKRK↔DETSEG
02200	;SOUBIT TO PAC FOR PIXELS ≥ CUT.
02300		I←13 ↔ J←14
02400		CALL(SEGTV)
02500		LAC [XWD L,2]↔BLT 13
02600		LAC ARG1↔LSH -3↔DAC HCUT
02700		LAP 5,ARG1
02800		GO 3
02900	
03000	;ACCUMULATOR LOOP.
03100	L:	POINT 6,TVBUF,-1
03200		MOVEI J,=36	;3
03300		ILDB 2		;4
03400		SUBI ;CUT	;5
03500		ROTC 1		;6
03600		SOJG J,4	;7
03700		SETCAM 1,PAC(I) ;10
03800		AOBJN I,3	;11
03900		POP1J		;12
04000		XWD -=1728,0	;13
04100	BEND;17/12/72-----------------------------------------------------
04200	
04300	HCUT:	0	;HCUT GLOBAL FROM THRESH TO MKVICS.
     

00100	SUBR(HISTOG)---------------------------------------------------
00200	BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00300	
00400		CALL(SEGTV)
00500		SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00600		LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00700		LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00800	
00900	;ACCUMULATOR LOOP.
01000	L:	=62208		;0
01100		0		;1
01200		ILDB 1,6	;2
01300		AOS HISTO(1)	;3
01400		SOJG 0,2	;4
01500		POP0J		;5
01600		POINT 6,TVBUF,-1;6
01700	
01800	BEND;16/12/72-----------------------------------------------------
01900	
02000	SUBR(BIMOD)-------------------------------------------------------
02100	BEGIN BIMOD;BI-MODAL HISTOGRAM CUT HIGH AND CUT LOW - 14 DEC 72.
02200		ACCUMULATORS{Q1,Q2,HI,LO}
02300		CALL(HISTOG)
02400		LACI HI,77↔SETZM LO↔SETZB Q1,Q2
02500		SETZ↔SKIPE CTRL↔GO[INCHRW↔ANDI 17↔GO .+1]
02600		SKIPE META↔GO[INCHRW 1↔ANDI 1,17↔IMULI =10↔ADD 1↔GO .+1]
02700		SKIPN↔LACI 3↔IMULI =62208↔IDIVI =100↔DAC 1
02800	
02900	;COME IN FROM THE EXTREMES 3 PER CENT.
03000		SETZ↔ADD HISTO(LO)↔CAMGE 1↔AOJA LO,.-2
03100		SETZ↔ADD HISTO(HI)↔CAMGE 1↔SOJA HI,.-2
03200	L2:	CAML LO,HI↔POP0J
03300		SKIPN FTVSIX↔GO L3
03400	
03500	;LOOK FOR LOCAL MINIMUM.
03600		LAC HISTO(LO)↔CAML HISTO+1(LO)↔AOJA LO,L2
03700		LAC HISTO(LO)↔CAML HISTO-1(LO)↔AOJA LO,L2
03800		LAC HISTO(HI)↔CAML HISTO+1(HI)↔SOJA HI,L2
03900		LAC HISTO(HI)↔CAML HISTO-1(HI)↔SOJA HI,L2
04000	
04100	;CUT 'EM UP AND DISPLAY 'EM.
04200	L3:	MOVNS LO↔MOVNS HI
04300		SETZ Q2,↔SLACI Q1,1B18↔LSHC Q1,(LO)
04400		SETZB 0,1↔SLACI 1B18↔LSHC(HI)↔IOR Q1,0↔IOR Q2,1
04500		CALL(MKIMAG,Q1,Q2)
04600		CALL(DPYIMG)
04700		POP0J
04800	BEND;14/12/72-----------------------------------------------------
     

00100	SUBR(MKVIC)-------------------------------------------------------
00200	BEGIN MKVIC;MAKE A VIDEO INTENSITY CONTOUR - BGB - AUGUST 1972.
00300	
00400		ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500		LAC H1,HCUT↔LACI H2,7↔SUB H2,H1
00600		LAC I,ISAVED
00700		CDR PTR,ARG1
00800		SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00900	
01000	;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01100	L1:	SKIPE 1,VSEG(I)↔GO L2
01200		AOS I↔CAIE I,=1728↔GO L1
01300		SETZ 1,↔POP0J;EMPTY.
01400	
01500	L2:	DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01600		MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01700		LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2	;COLUMN.
01800		LAC I↔LSH -3↔DIP RC.↔LSH RC.,6			;ROW.
01900	
02000	;DISTINGUISH BLOBS FROM HOLES.
02100		SETZM HOLE#
02200		TDNN MASK,@PACPTR		;HOLE OR BLOB ?
02300		SETOM HOLE#			;HOLE'A'COMING.
02400		SKIPE HOLE↔EXCH H1,H2
02500	
02600	;AND HEAD SOUTH.
02700	
02800		SETQ(PG,{GETBLK})↔MARK PG,PBIT
02900		SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03000		DAC  RC.,RCMIN#
03100		SETZM RCMAX#
03200		SETZ V,↔SETZM ECNT#
03300		PUSHJ P,FOLLOW
03400		LAC V,V0
03500		CCW. V,E↔CW. E,V
03600	
03700	;MAKE & RETURN VIC POLYGON.
03800	
03900		LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04000		NCNT. 1,PG
04100		LAC V0↔HEAD. 0,PG	;UPPER MOST LEFT.
04200		LAC V1↔ARC.  0,PG	;LOWER MOST RIGHT.
04300		LAC 1,PG
04400	L3:	POP0J
     

00100	;THE SUB-OPERATIONS OF MKVIC.
00200	
00300	DEFINE	TRY (SEG,YES) {
00400		LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500	DEFINE	LEFT	{SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600	DEFINE	RIGHT	{ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700	DEFINE	UP 	{SUB RC.,[1B11]↔SUBI I,8}
00800	DEFINE	DOWN  	{ADD RC.,[1B11]↔ADDI I,8}
00900	
01000	;CREATE NEW EDGE AND VERTEX OF A VIC.
01100	TURN:	0
01200		AOS TURNS#
01300		ADD D,RC.
01400		AOS 2,ECNT
01500	
01600	;VERTEX
01700		CALL GETBLK
01800		IORM BITQ,(1)2
01900		PGON. PG,1
02000		SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02100		DAC 1,V
02200		CCW. V,E↔CW. E,V
02300	T2:	DAC D,RC(V)
02400		CAMLE D,RCMAX
02500		GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02600	;EDGE
02700		DAC V,E
02800		GO @TURN
     

00100	;THE ALCHEMIST OF MKVIC - converts SOUBIT of lead into lines of gold.
00200	
00300	NORTH:	ADD D,[1B11]↔SLACI BITQ,(NORBIT+VBIT)↔JSR TURN
00400	NORTH2:	LEFT↔LAC D,DELPM(H1)↔	TRY HSEG,WEST
00500		RIGHT↔UP↔	TRY VSEG,NORTH2
00600		DOWN↔LAC D,DELPP(H2)↔	TRY HSEG,EAST↔FATAL(NORTH)
00700	NORTH3:	SLACI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00800	NORTH4:	UP↔LAC D,DELPM(H1)↔	TRY HSEG,WEST↔GO NORTH4
00900	
01000	
01100	WEST:	ADDI D,100↔SLACI BITQ,(WESBIT+VBIT)↔JSR TURN
01200	WEST2:	CAMN RC.,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01300	FOLLOW:	LAC D,DELPP(H1)↔	TRY VSEG,SOUTH
01400		LEFT↔		TRY HSEG,WEST2
01500		RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01600	
01700	
01800	SOUTH:	SLACI BITQ,(SOUBIT+VBIT)↔JSR TURN
01900	SOUTH2:	DOWN↔LAC D,DELMP(H1)
02000		CAR RC.↔CAIN =216B29↔GO EAST3
02100				TRY HSEG, EAST
02200				TRY VSEG,SOUTH2
02300		LEFT↔LAC D,DELMM(H2)↔	TRY HSEG,WEST↔	FATAL(SOUTH)
02400	
02500	
02600	EAST:	SLACI BITQ,(EASBIT+VBIT)↔JSR TURN
02700	EAST2:	RIGHT↔LAC D,DELMM(H1)
02800		CDR RC.↔CAIN =288B29↔GO NORTH3
02900		UP↔		TRY VSEG,NORTH
03000		DOWN↔		TRY HSEG,EAST2
03100		LAC D,DELPM(H2)↔	TRY VSEG,SOUTH↔FATAL(EAST)
03200	EAST3:	SLACI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300	EAST4:	RIGHT↔LAC D,DELMM(H1)
03400		CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500				TRY VSEG,NORTH↔GO EAST4
03600	
03700	DELPP:	FOR I←24,33{XWD I,I↔}
03800	DELPM:	FOR I←24,33{XWD I,-I↔}
03900	DELMP:	FOR I←24,33{XWD -I,I↔}
04000	DELMM:	FOR I←24,33{XWD -I,-I↔}
04100	
04200	BEND;14/12/72-----------------------------------------------------
     

00100	SUBR(VICONT)LEVEL-------------------------------------------------
00200	BEGIN VICONT; VIC CONTRAST - BGB - 14 DEC 1972.
00300		ACCUMULATORS{R,C,E,R2,C2,E2,PG,Q1,Q2,Q3,Q4,CNT}
00400		CALL(SEGTV)
00500		LAC 1,ARG1↔HEAD PG,1↔DAC PG,PG0#
00600	L1:	HEAD E2,PG↔DAC E2,E0#
00700		LAC RC(E2)↔ADD[XWD 40,40]
00800		CAR R2,↔LSH R2,-6↔CDR C2,↔LSH C2,-6
00900	
01000	L2:	LAC E,E2↔LAC R,R2↔LAC C,C2↔CCW E2,E2	;ADVANCE E.
01100		LAC RC(E2)↔ADD[XWD 40,40]
01200		CAR R2,↔LSH R2,-6↔CDR C2,↔LSH C2,-6	;GET ROW & COL.
01300		SETZB Q1,Q2↔SETZB Q3,Q4
01400		TESTZ E,WESBIT↔GO WEST
01500		TESTZ E,SOUBIT↔GO SOUTH
01600		TESTZ E,EASBIT↔GO EAST
01700		TESTZ E,NORBIT↔GO NORTH
01800	L3:	CAME E2,E0↔GO L2
01900		CCW PG,PG↔CAME PG,PG0↔GO L1
02000		POP1J
     

00100	;EAST-WEST.
00200	EW:	DAC CNT,SAVCNT
00300		TLZ   1↔DAC P3
00400		ADDI=48↔DAC P4
00500		SUBI=96↔DAC P2
00600		SUBI=48↔DAC P1
00700	
00800	EWL:	ILDB P2↔ADDM Q2
00900		ILDB P3↔ADDM Q3
01000		SOJG CNT,EWL
01100	
01200		LAC Q1,Q2↔LAC Q4,Q3
01300		CAIG  R,1↔SETZ Q1,↔	CAIG  R,0↔SETZ Q2,
01400		CAIL  R,=216↔SETZ Q3,↔	CAIL  R,=215↔SETZ Q4,
01500		ADD Q1,Q2↔ADD Q3,Q4↔ASH Q1,-1↔ASH Q3,-1↔POP0J
01600	
01700	;NORTH-SOUTH.
01800	NS:	DAC CNT,SAVCNT↔TLZ 1↔DAC P1↔TDCA 1,1
01900	
02000	NSL:	LACI 1,=48↔ADDB 1,P1
02100		ILDB 1↔ADDM Q2
02200		ILDB 1↔ADDM Q3
02300		SOJG CNT,NSL
02400		LAC Q1,Q2↔LAC Q4,Q3
02500	
02600		CAIG  C,1↔SETZ Q1,↔	CAIG  C,0↔SETZ Q2,
02700		CAIL  C,=288↔SETZ Q3,↔	CAIL  C,=287↔SETZ Q4,
02800		ADD Q1,Q2↔ADD Q3,Q4
02900		ASH Q1,-1↔ASH Q3,-1↔POP0J
03000	
03100	WEST:	LAC ROWPTR(R2)↔ADD COLPTR-1(C2)
03200		LAC CNT,C↔SUB CNT,C2↔CALL(EW)
03300		SUB Q3,Q1↔IDIV Q3,SAVCNT↔CIS. Q3,E↔GO L3
03400	
03500	SOUTH:	LAC ROWPTR(R)↔ADD COLPTR-2(C)
03600		LAC CNT,R2↔SUB CNT,R↔CALL(NS)
03700		SUB Q3,Q1↔IDIV Q3,SAVCNT↔CIS. Q3,E↔GO L3
03800	
03900	EAST: 	LAC ROWPTR(R)↔ADD COLPTR-1(C)
04000		LAC CNT,C2↔SUB CNT,C↔CALL(EW)
04100		SUB Q1,Q3↔IDIV Q1,SAVCNT↔CIS. Q1,E↔GO L3
04200	
04300	NORTH:	LAC ROWPTR(R2)↔ADD COLPTR-2(C2)
04400		LAC CNT,R↔SUB CNT,R2↔CALL(NS)
04500		SUB Q1,Q3↔IDIV Q1,SAVCNT↔CIS. Q1,E↔GO L3
04600	
04700		DECLARE{P1,P2,P3,P4,SAVCNT}
04800	BEND;14/12/72-----------------------------------------------------
     

00100	; ARC CONTRAST.
00200	SUBR(ARCONT)
00300	BEGIN ARCONT
00400		ACCUMULATORS{U1,U2,V1,V2,E,E0,N}
00500	
00600		LAC E,ARG1	;FIRST EDGE OF AN ARC PGON.
00700		CAR E,1(E)
00800		DAC E,E0
00900		CW V2,E
01000	
01100	L1:	LAC V1,V2↔CCW V2,E
01200		ARC U1,V1↔ARC U2,V2
01300	
01400		SETZ↔MOVEI N,1
01500	
01600		CCW U1,U1↔ADD 2(U1)↔CCW U1,U1
01700		CAME U1,U2↔AOJA N,.-4
01800	
01900		CAR 2,0 ↔ IDIV 2,N ↔ DIP 2,2(E)
02000		CDR 0,0 ↔ IDIV 0,N ↔ DAP 0,2(E)
02100		SUB 2,0 ↔ DAP  2,RC(E)
02200	
02300		CCW E,V2↔CAME E,E0↔JRST L1
02400	
02500	;VERTEX CONTRAST.
02600	L2:	NAP 0,RC(E)↔CCW V1,E
02700		CCW E,V1↔NAP 1,RC(E)
02800		SUB 1,0↔DAP 1,2(V1)
02900	
03000		NAP 1,RC(E)↔MOVMS↔MOVMS 1
03100		CAMG 0,1↔EXCH 0,1
03200		SETO 2,↔CAML 0,VCUT↔CAML 1,VCUT↔SETZ 2,
03300		DIP 2,2(V1)			;MARK TRANSITIONAL VERTEX.
03400	
03500		CAME E,E0↔JRST L2↔POP1J
03600	BEND
     

00100	SUBR(SQRT)--------------------------------------------------------
00200	BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT - BGB - TRADITIONAL.
00300		A←0 ↔ B←1 ↔ C←2
00400		LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
00500	
00600	;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
00700		ASHC B,-=27↔SUBI B,201	;GET EXPONENT IN B, FRACTION IN C.
00800		ROT B,-1		;CUT EXP IN HALF, SAVE ODD BIT
00900		DAP B,L↔LSH B,-=35	;USE THAT ODD BIT.
01000		ASH C,-10↔FSC C,177(B)	;0.25 < FRACTION < 1.00
01100	
01200	;LINEAR APPROXIMATION TO SQRT(F).
01300		DAC C,A
01400		FMP C,[0.8125↔0.578125](B)
01500		FAD C,[0.302734↔0.421875](B)
01600	
01700	;TWO ITERATIONS OF NEWTON'S METHOD.
01800		LAC B,A
01900		FDV B,C↔FAD C,B↔FSC C,-1
02000		FDV A,C↔FADR A,C
02100	     L: FSC A,0↔LAC 1,A↔POP P,2
02200		POP1J↔LIT
02300	BEND;28/12/72-----------------------------------------------------
     

00100	SUBR(MKARCS)V1,V2-------------------------------------------------
00200	BEGIN MKARCS;MAKE ARCS  -  FROM U1 CCW TO U2 - BGB - AUG 1972.
00300		ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00400		LAC V1,ARG2↔LAC V2,ARG1↔SETZM AVCNT#
00500	;CHECK FOR TRIVAIL CASE.
00600	L0:	ARC U1,V1↔ARC U2,V2
00700		CCW 0,U1↔CAMN 0,U2↔GO L3
00800	
00900	;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01000		ROW A,V1↔FLO A,		; A ← Y1.
01100		COL B,V2↔FLO B,		; B ← X2.
01200		COL C,V1↔FLO C,		; C ← X1.
01300		ROW D,V2↔FLO D,		; D ← Y2.
01400		LAC 1,B↔FMPR 1,A	; 1 ← X2*Y1.
01500		FSBR A,D↔FSBR B,C	; A ← Y1-Y2.   B ← X2-X1.
01600		FMPR C,D↔FSBR C,1	; C ← X1*Y2 - X2*Y1.
01700		LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01800		CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
01900	
02000	;SET 'EM UP FOR AN ARC PASS.
02100		ARC U1,V1↔ARC U2,V2
02200		SETZM DMAX#↔SETZM DMIN#
02300		SETZM VMAX#↔SETZM VMIN#
02400		SETZM MAXCON#
02500	;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
02600	L1:	CCW U1,U1↔CAMN U1,U2↔GO L2
02700		COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
02800		FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
02900		CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
03000		CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
03100	;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
03200		NIP(V1)4↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
03300	
03400	;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
03500	L2:	LAC U,VMIN↔LACM DMIN
03600		CAMGE DMAX↔LAC U,VMAX
03700		CAMGE DMAX↔LAC DMAX
03800		LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
03900		
04000	;OLDE ESPLIT: →CW→ V2...D...AV...E...V1 ←CCW←
04100		SETQ(V,{GETBLK})↔MARK 1,VBIT↔AOS AVCNT
04200		ARC. U,V↔ARC. V,U
04300		LAC RC(U)↔DAC RC(V)
04400		CCW. V,V1↔CW. V1,V
04500		CCW. V2,V↔CW. V,V2
04600		LAC V2,V↔GO L0
04700	
04800	;ADVANCE CCW AN ARC-EDGE OR EXIT.
04900	L3:	CAMN V2,ARG1↔POP2J
05000		LAC V1,V2↔CCW V2,V2↔GO L0
05100	BEND;28/12/72-----------------------------------------------------
     

00100	;FARCL(PGON) - FIT ARCS LINEAR.
00200	SUBR(FARCL)
00300	BEGIN FARCL
00400		X←1
00500		ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
00600	
00700	;Clear the Locus of all the Arc Vertices.
00800		LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
00900		CCW V1,E ↔ SETZM RC(V1)
01000		CCW E,V1 ↔ CAME E,E0↔JRST .-4
01100	
01200	;Advance along Polygon.
01300		CW V2,E
01400	L1:	LAC V1,V2↔CCW V2,E
01500		ARC U1,V1↔ARC U2,V2
01600		CW U1,U1↔CW U1,U1
01700		CW U1,U1↔CW U1,U1
01800		CW U1,U1↔CW U1,U1
01900		CCW U2,U2↔CCW U2,U2
02000		CCW U2,U2↔CCW U2,U2
02100		CCW U2,U2↔CCW U2,U2
02200	
02300	;Arc Scan Initialization.
02400		LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
02500	;Advance along VIC within the ARC.
02600	L2:	CCW U1,U1↔CCW U1,U1
02700	;Accumulate a Point.
02800		CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
02900		FAD SX,X ↔ FAD SY,Y
03000		LAC X ↔ FMP Y ↔ FAD XY,0
03100		FMP X,X ↔ FAD XX,X
03200		FMP Y,Y ↔ FAD YY,Y
03300		CAME U1,U2↔AOJA N,L2↔AOS N
     

00100	;COMPUTE SYMMETRIC LEAST SQUARES LINE COEFFICIENTS.
00200	; Q ← N*XY - SY*SX.
00300	; A ← Q + SY*SY - N*YY.
00400	; B ← Q + SX*SX - N*XX.
00500	; C ← SX*YY + SY*XX - XY*(SX+SY).
00600	
00700	L3:	LAC 2,SX↔FMP 2,YY
00800		LAC 0,SY↔FMP 0,XX↔FAD 2,0
00900		LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
01000	
01100		FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N	;all the N terms.
01200		LAC SX↔FMP SY↔FSB XY,0				;Q in XY.
01300	
01400		FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
01500		FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
01600	
01700		FMP SY,SY↔FMP SX,SX↔FAD SX,SY
01800		SLACI(1.0)↔FDVR SX↔DAC QQQQ#	;PSEUDO NORMALIZATION.
01900	
02000	;SOLVE FOR THE LOCII WHERE PERPENDICULARS DROPPED FROM
02100	;THE ARC-EDGE HIT THE FITTED LINE.
02200	; Q ← 1/(A*A + B*B).
02300	; D ← (B*X1 - A*Y1).
02400	; X ← (B*D - A*C)*Q.
02500	; Y ←-(A*D + B*C)*Q.
02600	
02700	L4:	ARC U1,V1
02800		CDR X,RC(U1)↔FLO X,↔CAR Y,RC(U1)↔FLO Y,
02900		FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X		;DDDD.
03000		FMP X,BBBB↔FMP Y,AAAA
03100		LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
03200		LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
03300		DIP Y,X↔ADDM X,RC(V1)
03400	
03500		ARC U2,V2
03600		CDR X,RC(U2)↔FLO X,↔CAR Y,RC(U2)↔FLO Y,
03700		FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X		;DDDD.
03800		FMP X,BBBB↔FMP Y,AAAA
03900		LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
04000		LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
04100		DIP Y,X↔ADDM X,RC(V2)
04200	
04300		CCW E,V2↔CAME E,E0↔JRST L1
04400		LAC 12,AC12↔POP1J
04500	BEND