perm filename CEMAKE[CAR,BGB]1 blob
sn#016005 filedate 1972-12-22 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 SETQ(W,{GETBLK})↔MARK W,BITS↔PGON. M,W
00700 SETQ(S,{GETBLK})↔MARK S,BITE↔PGON. M,S↔ROW. R,S
00800 SETQ(E,{GETBLK})↔MARK E,BITN↔PGON. M,E↔ROW. R,E↔COL. C,E
00900 SETQ(N,{GETBLK})↔MARK N,BITW↔PGON. M,N↔COL. C,N
01000 MARK M,PBIT
01100 MARK W,EBIT↔MARK S,EBIT
01200 MARK E,EBIT↔MARK N,EBIT
01300 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
01400 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
01500 HEAD. W,M
01600 LAC 1,M↔SKIPN FLGKRK↔POP0J
01700
01800 ;MAKE THAT BIG ARRAY UP THERE IN THE SKY.
01900 L1: DETSEG
02000 LACI =217*=289
02100 CALLI 400015
02200 GO[FATAL(AIN'T NO MORE CORE UP YONDER.)]
02300 LAC[SIXBIT/SKYSEG/]↔CALLI 400036↔JFCL
02400 SETZ↔SEGNUM↔DAC SKYSEG
02500
02600 ;CLEAR SKY.
02700 LAC[XWD $,$+1]
02800 SETZM $
02900 BLT $+=217*=289-1
03000
03100 ;PUT THE FRAME UP IN THE SKY.
03200 L2: SETZ C,↔LACI R,=216
03300 DAC W,@SKY(R)↔SOJGE R,.-1 ;WEST SIDE.
03400 LACI R,=216↔LACI C,=288
03500 DAC S,@SKY(R)↔SOJGE C,.-1 ;SOUTH SIDE.
03600 LACI C,=288
03700 DAC E,@SKY(R)↔SOJGE R,.-1 ;EAST SIDE.
03800 SETZ R,↔LACI C,=288
03900 DAC N,@SKY(R)↔SOJGE C,.-1 ;NORTH SIDE.
04000 L3: LAC 1,M↔POP0J
04100 BEND;16/12/72-----------------------------------------------------
04200
04300 ;POINTERS TO SKY ROWS - COLUMN ACCUMULATOR-3.
04400 SKY: FOR I←0,=216{
04500 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 SKIPN 1,@SKY(R)↔SOJA C,.-1
01200 TRNN 1,-1↔SOJA C,.-3
01300 PGON P2,1
01400 TEST 1,BITS
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
03400 BEND;11/12/72-----------------------------------------------------
03500
03600 SUBR(KRAKAUER)LEVEL-----------------------------------------------
03700 BEGIN KRAKAUER;
03800 SKIPN FLGKRK↔POP1J
03900 DETSEG↔LAC SKYSEG
04000 ATTSEG↔GO[FATAL(SKYSEG ATTACH FAILURE IN MKIMAG.)]
04100 LAC 1,ARG1↔HEAD 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
04200 L1: CALL(INTREE,POLYGON)
04300 CALL(INSKY,POLYGON)
04400 LAC 1,POLYGON↔CCW 1,1↔DAC 1,POLYGON
04500 CAME 1,PG0↔GO L1↔POP1J
04600 BEND;20/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,BITE↔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,BITE↔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,BITN↔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,BITN↔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 SETQ(LEVEL,{GETBLK})↔WIP(1)1↔MARK 1,LBIT
01200 CALL(RINGIN,LEVEL,IMAGE)
01300 SETQ(POLYGON,{MKPGON})↔MARK 1,PBIT
01400 CALL(RINGIN,POLYGON,LEVEL)
01500 CALL(SEGTV)
01600
01700 ;FIND AN INTENSITY CONTOUR ENABLE BIT OR EXIT.
01800 L0: LAC 0,Q0↔LAC 1,Q1
01900 L1: AOS 2,CUT↔LSHC 0,1↔JUMPL L2
02000 SKIPE 0↔GO L1↔SKIPE 1↔GO L1
02100 SETZ↔SKIPE FLGKRK↔CALLI 400015↔JFCL
02200 LAC 1,IMAGE↔POP2J
02300
02400 L2: DAC 0,Q0↔DAC 1,Q1
02500 CALL(THRESH,CUT)
02600 CALL(PACXOR)
02700 SETQ(POLYGON,{MKVIC})↔JUMPE 1,L0
02800 SETQ(LEVEL,{GETBLK})
02900 LAC CUT↔NCNT. 0,1↔MARK 1,LBIT
03000 CALL(RINGIN,LEVEL,IMAGE)
03100
03200 SKIPA 1,POLYGON
03300 L3: SETQ(POLYGON,{MKVIC})↔JUMPE 1,L4
03400 CALL(RINGIN,POLYGON,LEVEL)↔GO L3
03500
03600 L4: CALL(VICONT,LEVEL)
03700 CALL(KRAKAUER,LEVEL)
03800 CALL(SMOOTH,LEVEL)
03900 GO L0
04000
04100 BEND;20/12/72-----------------------------------------------------
04200 DECLARE{IMAGE,LEVEL,POLYGON}
00100 SUBR(SMOOTH)LEVEL-------------------------------------------------
00200 BEGIN SMOOTH; -BGB- 6 DEC 1972.
00300 ACCUMULATORS{U1,U2,PG,E0,E1,E2}
00400 LAC 1,ARG1↔HEAD PG,1↔DAC PG,PG0#
00500
00600 ;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00700 L0: DAC PG,PGSAVE#
00800 SKIPN FLGBK↔GO L1
00900 NCNT 0,PG↔LACM
01000 CAIL =10↔GO L1
01300
01400 ;KILL POLYGON.
01500 HEAD E0,PG↔SETZ↔HEAD. 0,PG
01600 ; CAR 1,(PG)↔CDR 2,(PG)↔DIP 1,(2)↔DAP 2,(1);RINGO PG.
01700 ; LAC 1,LEVEL↔HEAD 1,1↔CAMN 1,PG↔ZAP(1)1
01800 LAC E1,E0
01900 L: CCW E2,E1
02000 CALL(RELBLK,E1)
02100 CAMN E2,E0↔GO L2
02200 LAC E1,E2↔GO L
02300
02400
02500 ;SMOOTH VIC INTO A LOOP OF ARC SEGMENTS.
02600 L1: SKIPN FLGARC↔POP1J ;MAKE ARC ENABLED ?
02700 HEAD U1,PG↔DAC U1,E0SAVE#↔ARC U2,PG
02800 SETQ(V2,{GETBLK})↔LAC RC(U2)↔DAC RC(1)
02900 ARC. 1,U2↔ARC. U2,1↔MARK 1,EBIT
03000 SETQ(V1,{GETBLK})↔LAC RC(U1)↔DAC RC(1)
03100 ARC. 1,U1↔ARC. U1,1↔MARK 1,EBIT
03200 LAC 2,V2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
03300 PGON. PG,1↔PGON. PG,2↔HEAD. 1,PG
03400 CALL(MKARCS,V1,V2)
03500 CALL(MKARCS,V2,V1)
03600
03700 ;DELETE UNDER VIC WHEN KRAKAUER IS DISABLED.
03800 SKIPE FLGKRK↔GO L2
03900 LAC E0,E0SAVE↔GO L-1
04000
04100 L2: LAC PG,PGSAVE
04200 CCW PG,PG↔CAME PG,PG0↔GO L0
04300 POP1J↔DECLARE{V1,V2}
04400 BEND;6/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 bits 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------------------------------------------------------
00100 SUBR(THRESH)------------------------------------------------------
00200 BEGIN THRESH;THRESHOLD(LEVEL) pre foonly version. BGB 4 DEC 1972.
00300 SKIPE FLGKRK↔DETSEG
00400 ;BITS TO PAC FOR PIXELS ≥ CUT.
00500 I←13 ↔ J←14
00600 CALL(SEGTV)
00700 LAC [XWD L,2]↔BLT 13
00800 LAC ARG1↔LSH -3↔DAC HCUT
00900 LAP 5,ARG1
01000 GO 3
01100
01200 ;ACCUMULATOR LOOP.
01300 L: POINT 6,TVBUF,-1
01400 MOVEI J,=36 ;3
01500 ILDB 2 ;4
01600 SUBI ;CUT ;5
01700 ROTC 1 ;6
01800 SOJG J,4 ;7
01900 SETCAM 1,PAC(I) ;10
02000 AOBJN I,3 ;11
02100 POP1J ;12
02200 XWD -=1728,0 ;13
02300 BEND;17/12/72-----------------------------------------------------
02400
02500 HCUT: 0 ;HCUT GLOBAL FROM THRESH TO MKVICS.
00100 SUBR(HISTOG)---------------------------------------------------
00200 BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00300
00310 CALL(SEGTV)
00400 SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00500 LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00600 LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00700
00800 ;ACCUMULATOR LOOP.
00900 L: =62208 ;0
01000 0 ;1
01100 ILDB 1,6 ;2
01200 AOS HISTO(1) ;3
01300 SOJG 0,2 ;4
01400 POP0J ;5
01500 POINT 6,TVBUF,-1;6
01600
01700 BEND;16/12/72-----------------------------------------------------
00100 SUBR(BIMOD)-------------------------------------------------------
00200 BEGIN BIMOD;BI-MODAL HISTOGRAM CUT HIGH AND CUT LOW - 14 DEC 72.
00300 ACCUMULATORS{Q1,Q2,HI,LO}
00400 CALL(HISTOG)
00500 LACI HI,77↔SETZM LO↔SETZB Q1,Q2
00600 SETZ↔SKIPE CTRL↔GO[INCHRW↔ANDI 17↔GO .+1]
00700 SKIPE META↔GO[INCHRW 1↔ANDI 1,17↔IMULI =10↔ADD 1↔GO .+1]
00800 SKIPN↔LACI 3↔IMULI =62208↔IDIVI =100↔DAC 1
00900
01000 ;COME IN FROM THE EXTREMES 3 PER CENT.
01100 SETZ↔ADD HISTO(LO)↔CAMGE 1↔AOJA LO,.-2
01200 SETZ↔ADD HISTO(HI)↔CAMGE 1↔SOJA HI,.-2
01300 L2: CAML LO,HI↔POP0J
01400 SKIPN FTVSIX↔GO L3
01500
01600 ;LOOK FOR LOCAL MINIMUM.
01700 LAC HISTO(LO)↔CAML HISTO+1(LO)↔AOJA LO,L2
01800 LAC HISTO(LO)↔CAML HISTO-1(LO)↔AOJA LO,L2
01900 LAC HISTO(HI)↔CAML HISTO+1(HI)↔SOJA HI,L2
02000 LAC HISTO(HI)↔CAML HISTO-1(HI)↔SOJA HI,L2
02100
02200 ;CUT 'EM UP AND DISPLAY 'EM.
02300 L3: MOVNS LO↔MOVNS HI
02400 SETZ Q2,↔SLACI Q1,1B18↔LSHC Q1,(LO)
02500 SETZB 0,1↔SLACI 1B18↔LSHC(HI)↔IOR Q1,0↔IOR Q2,1
02600 CALL(MKIMAG,Q1,Q2)
02700 CALL(DPYIMG)
02800 POP0J
02900 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 DAC RC.,RCMIN#
03000 SETZM RCMAX#
03100 SETZ V,↔SETZM ECNT#
03200 PUSHJ P,FOLLOW
03300 LAC V,V0
03400 CCW. V,E↔CW. E,V
03500
03600 ;MAKE & RETURN VIC POLYGON.
03700
03800 LAC 1,ECNT
03900 SKIPE HOLE#↔MOVNS 1 ;-CNT INDICATES A HOLE.
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 bits of lead into lines of gold.
00200
00300 NORTH: ADD D,[1B11]↔SLACI BITQ,(BITN+EBIT)↔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,(BITN+EBIT)↔JSR TURN↔LEFT
00800 NORTH4: UP↔LAC D,DELPM(H1)↔ TRY HSEG,WEST↔GO NORTH4
00900
01000
01100 WEST: ADDI D,100↔SLACI BITQ,(BITW+EBIT)↔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,(BITS+EBIT)↔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,(BITE+EBIT)↔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,(BITE+EBIT)↔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,BITW↔GO WEST
01500 TESTZ E,BITS↔GO SOUTH
01600 TESTZ E,BITE↔GO EAST
01700 TESTZ E,BITN↔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←1 ↔ B←2 ↔ C←3
00400 LACM B,ARG1↔JUMPE B,POP1J.
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↔L: FSC A,0
02100 SUB 17,[XWD 2,2]
02200 GO @2(17)
02300 LIT
02400 BEND;8/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
00600 ;CHECK FOR TRIVAIL CASE.
00700 L0: ARC U1,V1↔ARC U2,V2
00800 CCW 0,U1↔CAMN 0,U2↔GO L3
00900
01000 ;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01100 ROW A,V1↔FLO A, ; A ← Y1.
01200 COL B,V2↔FLO B, ; B ← X2.
01300 COL C,V1↔FLO C, ; C ← X1.
01400 ROW D,V2↔FLO D, ; D ← Y2.
01500 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
01600 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
01700 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
01800 LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01900 CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02000
00100 ;SET 'EM UP FOR AN ARC PASS.
00200 ARC U1,V1↔ARC U2,V2
00300 SETZM DMAX#↔SETZM DMIN#
00400 SETZM VMAX#↔SETZM VMIN#
00500 SETZM MAXCON#
00600 ;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
00700 L1: CCW U1,U1↔CAMN U1,U2↔GO L2
00800 COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
00900 FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
01000 CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
01100 CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
01200 ;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
01300 NIP(V1)4↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
01400
01500 ;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
01600 L2: LAC U,VMIN↔LACM DMIN
01700 CAMGE DMAX↔LAC U,VMAX
01800 CAMGE DMAX↔LAC DMAX
01900 LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
02000
02100 ;OLDE ESPLIT: →CW→ V2...D...AV...E...V1 ←CCW←
02200 CALL GETBLK↔DAC 1,V↔MARK 1,EBIT↔AOS AVCNT
02300 ARC. U,V↔ARC. V,U
02400 LAC RC(U)↔DAC RC(V)
02500 CCW. V,V1↔CW. V1,V
02600 CCW. V2,V↔CW. V,V2
02700 LAC V2,V↔GO L0
02800
02900 ;ADVANCE CCW AN ARC-EDGE OR EXIT.
03000 L3: CAMN V2,ARG1↔POP2J
03100 LAC V1,V2↔CCW V2,V2
03200 GO L0
03300 BEND;13/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