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