c tekcvt - convert a tek file to move and draw commands subroutine tekcvt integer x,y,xhi,yhi,xlo,ylo,xeb,yeb logical sensw byte a,b,c,d,e,mode,dflag,gettkb integer flag external len integer width,height,charsp,linesp,rotang,slnang integer tabsep,mrgsep,spacon,font,stdfnt,altfnt real xratio,yratio,xscale,yscale,tr(2,3) common/alfcom/width,height,charsp,linesp,rotang,slnang,tabsep, & mrgsep,spacon,font,stdfnt,altfnt,xratio,yratio,xscale,yscale,tr data flag /0/ data xhi,yhi,xlo,ylo,xeb,yeb/0,0,0,0,0,0/ c reset device parameters call devres(0) dflag=0 c while 23000 if(.not.(gettkb(b).ne.0))goto 23001 c get bytes from input if(.not.(b.eq.27))goto 23002 c decode escape sequence c while 23004 if(.not.(b.eq.27))goto 23005 if(.not.(gettkb(b).eq.'A'))goto 23006 c assume device name is 'A' c plotter esc sequence call esccod(b) goto 23007 c else 23006 continue if(.not.(b.eq."14))goto 23008 xlo=0 xhi=0 ylo=127-'`' yhi=55-' ' y=yhi*128+ylo*4 call tmove(0,y) call gettkb(b) goto 23009 c else 23008 continue if(.not.(b.eq.'`'))goto 23010 c set line mode call gettkb(b) 23010 continue 23009 continue 23007 continue goto 23004 c endwhile 23005 continue 23002 continue if(.not.(b.eq.0))goto 23012 goto 23001 c else 23012 continue if(.not.(b.eq.10))goto 23014 c ignore line feeds goto 23015 c else 23014 continue if(.not.(b.eq.14))goto 23016 c set alternate font font=altfnt goto 23017 c else 23016 continue if(.not.(b.eq.15))goto 23018 c set standard font font=stdfnt goto 23019 c else 23018 continue if(.not.(b.eq.31))goto 23020 c enter alpha mode mode=1 goto 23021 c else 23020 continue if(.not.(b.eq.29))goto 23022 c enter graphics mode mode=2 c move to next (x,y) dflag=0 goto 23023 c else 23022 continue if(.not.(mode.eq.2))goto 23024 c process byte in graphics mode if(.not.(b.ge.' '.and.b.lt.'@'))goto 23026 c xhi and yhi if(.not.(flag .eq. 1))goto 23028 xhi=(b-' ').and."7777 goto 23029 c else 23028 continue yhi=(b-' ').and."7777 23029 continue goto 23027 c else 23026 continue if(.not.(b.ge.'@'.and.b.lt.'`'))goto 23 & 030 c xlo and action byte xlo=(b-'@').and."7777 x=xhi*128+xlo*4+xeb y=yhi*128+ylo*4+yeb if(.not.(dflag.eq.1))goto 23032 c draw command call tdraw(x,y) goto 23033 c else 23032 continue c move command call tmove(x,y) 23033 continue c draw to next (x,y) dflag=1 flag=0 goto 23031 c else 23030 continue if(.not.(b.ge.'`'))goto 23034 c ylo and extended bits xeb,yeb xeb=(ylo.and.3) yeb=(ylo.and."17)/4 ylo=(b-'`'.and."7777) flag=1 23034 continue 23031 continue 23027 continue goto 23025 c else 23024 continue c process byte in alpha mode call alfmod(b,x,y) 23025 continue 23023 continue 23021 continue 23019 continue 23017 continue 23015 continue 23013 continue goto 23000 c endwhile 23001 continue return end c gettkb - get a byte from the tek file on unit 2 byte function gettkb(b) byte b,buf(512) integer ib,ip,ier data ib,ip/-1,512/ ip=ip+1 if(.not.(ip.gt.512))goto 23036 ip=1 ib=ib+1 call rdblk(2,ib,buf,1,ier) if(.not.(ier.le.0))goto 23038 b=0 gettkb=0 return 23038 continue 23036 continue b=buf(ip) gettkb=b return end c opntek - open a tek file subroutine opntek(filnam) external len byte filnam(16) call opnblk(2,filnam,ier) if(.not.(ier.gt.0))goto 23040 return 23040 continue type 200,(filnam(i),i=1,len(filnam)) call exit 200 format(' can''t open file: ',15a1) end c clstek - close a tek file subroutine clstek call clsblk(2,ier) return end c gteknm - get a tek filename subroutine gteknm(filnam) byte filnam(1),prompt(15),defext(5),dot data prompt/'t','e','k',' ','f','i','l','e','n','a','m','e',':', & ' ',128/ data defext/'.','t','e','k',0/ call gtlin(filnam,prompt) dot=0 c for i=1 23042 if(.not.(filnam(i).ne.0))goto 23044 if(.not.(filnam(i).eq.'.'))goto 23045 dot=1 23045 continue i=i+1 goto 23042 c endfor 23044 continue if(.not.(dot.eq.0.and.i.le.11))goto 23047 c add default extension c for j=1 23049 if(.not.(j.le.5))goto 23051 filnam(i)=defext(j) i=i+1 j=j+1 goto 23049 c endfor 23051 continue 23047 continue return end c tarc - tek arc subroutine tarc(x1,y1,x2,y2) real x1,y1,x2,y2,rc,xc,yc integer x,y,xr integer tx,ty,currx,curry,lastx,lasty common/tcom/tx,ty,currx,curry,lastx,lasty real arcsmo,segmin common/arccom/arcsmo,segmin data pi/3.1415927/,eps/1.e-6/ tpi=2.*pi x0=currx y0=curry call circen(x0,y0,x1,y1,x2,y2,rc,xc,yc,a0,ac) if(.not.(rc.gt.segmin))goto 23052 n=abs(ac)/amax1(.25*pi*arcsmo,segmin/rc)+.5 goto 23053 c else 23052 continue n=8.*(abs(ac)/tpi) 23053 continue if(.not.(n.gt.0))goto 23054 da=ac/n a=a0 c for i=1 23056 if(.not.(i.lt.n))goto 23058 a=a+da x=xc+rc*cos(a)+.5 y=yc+rc*sin(a)+.5 call tdraw(x,y) i=i+1 goto 23056 c endfor 23058 continue 23054 continue x=x2 y=y2 call tdraw(x,y) lastx=currx lasty=curry return end c tcirc - tek circle subroutine tcirc(radius) integer radius,x,y integer tx,ty,currx,curry,lastx,lasty common/tcom/tx,ty,currx,curry,lastx,lasty real arcsmo,segmin common/arccom/arcsmo,segmin data pi/3.1415927/ tpi=2.*pi xc=currx yc=curry rc=radius a0=0. ac=tpi if(.not.(rc.ge.segmin))goto 23059 n=abs(ac)/amax1(.25*pi*arcsmo,segmin/rc)+.5 goto 23060 c else 23059 continue n=8.*(abs(ac)/tpi) 23060 continue if(.not.(n.gt.0))goto 23061 x=xc+rc y=yc call tmove(x,y) da=ac/n a=a0 c for i=1 23063 if(.not.(i.lt.n))goto 23065 a=a+da x=xc+rc*cos(a)+.5 y=yc+rc*sin(a)+.5 call tdraw(x,y) i=i+1 goto 23063 c endfor 23065 continue x=xc+rc y=yc call tdraw(x,y) x=xc y=yc call tmove(x,y) 23061 continue lastx=currx lasty=curry return end c tmove - tek move subroutine tmove(x,y) integer x,y integer tx,ty,currx,curry,lastx,lasty common/tcom/tx,ty,currx,curry,lastx,lasty lastx=currx lasty=curry currx=x curry=y return end c tdraw - tek draw subroutine tdraw(x,y) integer x,y,dflag integer tx,ty,currx,curry,lastx,lasty common/tcom/tx,ty,currx,curry,lastx,lasty real arcsmo,segmin common/arccom/arcsmo,segmin if(.not.((tx.ne.currx .or. ty.ne.curry) .and. (inwind(currx,curry) & .ge.0)))goto 23066 cmove call pmove(currx,curry) dflag=1 tx=currx ty=curry goto 23067 c else 23066 continue if(.not.((iabs(currx-x)+iabs(curry-y)).ge.segmin*.5))goto 23068 dflag=1 goto 23069 c else 23068 continue dflag=0 23069 continue 23067 continue if(.not.(inwind(x,y).ge.0 .and. inwind(currx,curry).ge.0 .and. & dflag.eq.1))goto 23070 cdraw call pdraw(x,y) tx=x ty=y 23070 continue lastx=currx lasty=curry currx=x curry=y return end c inwind - see if (x,y) is in the window integer function inwind(x,y) integer x,y integer wx1,wy1,wx2,wy2 integer tx,ty,currx,curry,lastx,lasty common/tcom/tx,ty,currx,curry,lastx,lasty data wx1,wy1,wx2,wy2/0,0,4095,3019/ if(.not.(x.ge.wx1 .and. x.le.wx2 .and. y.ge.wy1 .and. y.le.wy2)) & goto 23072 if(.not.(x.gt.wx1 .and. x.lt.wx2 .and. y.gt.wy1 .and. y.lt.wy2) & )goto 23074 inwind=1 goto 23075 c else 23074 continue inwind=0 23075 continue goto 23073 c else 23072 continue inwind=-1 23073 continue return end c circen - find the center and radius of a circle defined by 3 points subroutine circen(x0,y0,x1,y1,x2,y2,rc,xc,yc,a0,ac) data pi/3.1415927/,eps/1.e-6/ a=sqrt((x1-x0)**2+(y1-y0)**2) b=sqrt((x2-x1)**2+(y2-y1)**2) c=sqrt((x0-x2)**2+(y0-y2)**2) s1=.5*(a+b+c) s2=sqrt(s1*(s1-a)*(s1-b)*(s1-c)) if(.not.(s2.lt.eps))goto 23076 rc=.25*a*b*c/eps goto 23077 c else 23076 continue rc=.25*a*b*c/s2 23077 continue d=sqrt(rc**2-(.5*c)**2) an1=atan2(y2-y0,x2-x0) an2=atan2(d,.5*c) an3=an1+an2-pi an4=an1-an2-pi xc1=x0-rc*cos(an3) yc1=y0-rc*sin(an3) xc2=x0-rc*cos(an4) yc2=y0-rc*sin(an4) d1=abs(rc**2-(x1-xc1)**2-(y1-yc1)**2) d2=abs(rc**2-(x1-xc2)**2-(y1-yc2)**2) if(.not.(d1.lt.d2))goto 23078 xc=xc1 yc=yc1 goto 23079 c else 23078 continue xc=xc2 yc=yc2 23079 continue a0=atan2(y0-yc,x0-xc) a1=atan2(y1-yc,x1-xc) a2=atan2(y2-yc,x2-xc) aa=a2-a0 ab=a1-a0 if(.not.(sign(1.,aa).eq.sign(1.,ab) .and. (abs(aa).gt.abs(ab)))) & goto 23080 ac=aa goto 23081 c else 23080 continue ac=aa-sign(2.*pi,aa) 23081 continue return end