00001
00002 c
00003 c Copyright (c) 1986,1987,1988,1989,1990,1991,1992,1993,
00004 c by Steve McMillan, Drexel University, Philadelphia, PA.
00005 c
00006 c All rights reserved.
00007 c
00008 c Redistribution and use in source and binary forms are permitted
00009 c provided that the above copyright notice and this paragraph are
00010 c duplicated in all such forms and that any documentation,
00011 c advertising materials, and other materials related to such
00012 c distribution and use acknowledge that the software was developed
00013 c by the author named above.
00014 c
00015 c THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
00016 c IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
00017 c WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
00018 c
00019
00020 c *************************************************************
00021 c * *
00022 c * Fancy font-set symbol/number drawers. *
00023 c * *
00024 c *************************************************************
00025 c
00026 subroutine simbol(xcall,ycall,hite,chars,theta,numch)
00027 save
00028 c
00029 c extended-font version of symbol
00030 c positioning info is returned in common/fontc1/...
00031 c numch.lt.0 : string centered on (xi,yi)
00032 c numch.ge.0 : string starts with (xi,yi) at lower lh corner,
00033 c or the point defined by subroutine strpos.
00034 c hite.le.0. : only positioning info returned: nothing drawn
00035 c
00036 character*(*) chars
00037 character*10 first10
00038 integer*2 n,m,num,jl,jr,idic,long
00039 integer*4 numch,nch
00040 real*4 lastinc
00041 c
00042 common /fontc1/ offx,offy,lastinc,xp,yp,xmax,xmin,ymax,ymin
00043 common /sim fc2/ n,m,num(288),jl(288),jr(288),idic(288),
00044 & long(20000)
00045 common /sim ang/ sint,cost/sim len/nch,height
00046 common /str posn/ i pos set,frx,fry
00047 common /str limits/ offxmin,offxmax,offymin,offymax
00048 common /debug trace/ itrace
00049 c
00050 data flag/0./
00051 c
00052 xi = xcall
00053 yi = ycall
00054 go to 10
00055 c
00056 entry usimbol(xcall,ycall,hite,chars,theta,numch)
00057 entry usersimbol(xcall,ycall,hite,chars,theta,numch)
00058 call fr inches(xcall,ycall,xi,yi)
00059 c
00060 10 if (itrace.eq.1) write(2,*)'simbol:',
00061 & xi,yi,hite,chars(1:1),numch
00062 first10 = chars(1:min(10,abs(numch)))
00063 call routine id('simbol '
00064 c
00065 if (flag.eq.2.) return
00066 c
00067 if (flag.eq.0.) then
00068 n = 0
00069 call getfonts
00070 flag = 1.
00071 if (n.eq.0) then
00072 flag = 2.
00073 return
00074 end if
00075 end if
00076 c
00077 height = 0.04762*abs(hite)
00078 c (factor is 1./21.)
00079 c
00080 xmax = -1.e10
00081 ymax = xmax
00082 xmin = -xmax
00083 ymin = xmin
00084 sint = sin(theta*.0174533)
00085 cost = cos(theta*.0174533)
00086 nch = iabs(numch)
00087 if(nch.gt.1000)stop 'error: >1000 characters sent to simbol.'
00088 if(nch.eq.0)nch = 1000
00089 c
00090 if(numch.lt.0.or.i pos set.ne.0)then
00091 call sim draw(xi,yi,chars,0,1)
00092 if(numch.lt.0)then
00093 c
00094 c n.b. numch < 0 takes precedence over strpos.
00095 c
00096 dx = .5*(xmax+xmin)-xi
00097 dy = .5*(ymax+ymin)-yi
00098 else
00099 if(frx.ge.0..and.frx.le.1.)then
00100 dxs = (offxmin+(offxmax-offxmin)*frx)*height
00101 else
00102 dxs = 0.
00103 end if
00104 if(fry.ge.0..and.fry.le.1.)then
00105 dys = (offymin+(offymax-offymin)*fry)*height
00106 else
00107 dys = 0.
00108 end if
00109 dx = dxs*cost-dys*sint
00110 dy = dxs*sint+dys*cost
00111 end if
00112 xmax = xmax-dx
00113 xmin = xmin-dx
00114 xp = xp-dx
00115 ymax = ymax-dy
00116 ymin = ymin-dy
00117 yp = yp-dy
00118 if(hite.le.0.)return
00119 call sim draw(xi-dx,yi-dy,chars,1,0)
00120 else
00121 if(hite.le.0.)call sim draw(xi,yi,chars,0,1)
00122 if(hite.gt.0.)call sim draw(xi,yi,chars,1,1)
00123 end if
00124 c
00125 end
00126
00127
00128 subroutine getfonts
00129 save
00130 c
00131 c Read the SIMBOL fonts.
00132 c
00133 integer*2 n,m,num,jl,jr,idic,long
00134 common /sim fc2/ n,m,num(288),jl(288),jr(288),idic(288),
00135 & long(20000)
00136 c
00137 parameter (NDIR = 10)
00138 character*120 directory(NDIR)
00139 dimension ldir(NDIR)
00140 c
00141 parameter (IOPTION = 2)
00142 c
00143 c Specify possible locations for the font file.
00144 c
00145 nd = NDIR
00146 call listdir(directory,ldir,nd,iunit)
00147 c
00148 if (iunit.lt.0) then
00149 write(6,*)'No free unit number!'
00150 return
00151 end if
00152 c
00153 c Read the fonts.
00154 c
00155 20 do 50 idir=1,nd
00156 n = ldir(idir)
00157 if (n.le.0) go to 50
00158 c
00159 c-----------------------------------------------------------------------
00160 c
00161 if (IOPTION.eq.1) then
00162 c
00163 c Old version:
00164 c -----------
00165 c
00166 open(iunit,status='old',form='unformatted',
00167 & file=directory(idir)(1:n)
00168 read(iunit)n,m,num,jl,jr,idic,(long(i),i=1,m)
00169 c
00170 else if (IOPTION.eq.2) then
00171 c
00172 c New version:
00173 c -----------
00174 c
00175 c write(6,*)idir,'. Trying font file ',
00176 c & directory(idir)(1:n)
00177 c
00178 open(iunit,status='old',form='formatted',
00179 & file=directory(idir)(1:n)
00180
00181 read(iunit,*)n,m
00182 c
00183 j = 0
00184 l = 1
00185 100 read(iunit,*,err=101,end=101)
00186 read(iunit,*,err=101,end=101)
00187 read(iunit,*,err=101,end=101)i1,i2,i3
00188 j = j + 1
00189 num(j) = i1
00190 jl(j) = i2
00191 jr(j) = i3
00192 c
00193 if (num(j).gt.0) then
00194 idic(j) = l
00195 read(iunit,*)(long(k),k=l,l+num(j)-1)
00196 l = l + num(j)
00197 else
00198 idic(j) = -1
00199 end if
00200 c
00201 go to 100
00202 c
00203 else
00204 go to 50
00205 end if
00206 c
00207 c-----------------------------------------------------------------------
00208 c
00209 101 close(iunit)
00210 return
00211 c
00212 50 continue
00213 c
00214 write(6,'(a)')'Can''t find the fonts!'
00215 c
00216 end
00217
00218
00219 subroutine listdir(directory,ldir,ndir,iunit)
00220 save
00221 c
00222 c Make a list of places to look for useful files, and return
00223 c a free unit number. (Also used by fullhelp.)
00224 c
00225 c On entry, ndir specifies the maximum allowable number of
00226 c list entries. On exit, it is the actual length of the list.
00227 c
00228 character*120 directory(ndir)
00229 dimension ldir(ndir)
00230 logical opened
00231 c
00232 if (ndir.le.0) return
00233 c
00234 do idir=1,min(6,ndir)
00235 directory(idir) = ' '
00236 end do
00237 c
00238 c UNIX calls!
00239 c ----------
00240 c
00241 nd = 1
00242 call mygetenv('MCD_FONT_DIR',directory(nd))
00243 c
00244 c Now list various likely locations. Note the order of precedence.
00245 c
00246 if (nd.lt.ndir) then
00247 nd = nd + 1
00248 directory(nd) = '.'
00249 end if
00250 c
00251 if (nd.lt.ndir) then
00252 nd = nd + 1
00253 directory(nd) = '..'
00254 end if
00255 c
00256 if (nd.lt.ndir) then
00257 nd = nd + 1
00258 nd = nd + 1
00259 call mygetenv('HOME',directory(nd))
00260 do n=120,1,-1
00261 if (directory(nd)(n:n).gt.' ') then
00262 directory(nd)(n+1:n+4) = '/bin'
00263 go to 20
00264 end if
00265 end do
00266 20 continue
00267 end if
00268 c
00269 if (nd.lt.ndir) then
00270 nd = nd + 1
00271 directory(nd) = '/usr/local/mcdraw'
00272 end if
00273 c
00274 if (nd.lt.ndir) then
00275 nd = nd + 1
00276 directory(nd) = '/usr/local/mcdraw/libs'
00277 end if
00278 c
00279 if (nd.lt.ndir) then
00280 nd = nd + 1
00281 directory(nd) = '/usr/local/mcdraw/draw'
00282 end if
00283 c
00284 if (nd.lt.ndir) then
00285 nd = nd + 1
00286 call mygetenv('STARLAB_PATH',directory(nd))
00287 do n=120,1,-1
00288 if (directory(nd)(n:n).gt.' ') then
00289
00290 directory(nd)(n+1:n+13) = '/src/gfx/libs'
00291 c
00292 c Add this for help documentation...
00293 c
00294 nd = nd + 1
00295 directory(nd) = directory(nd-1)
00296 directory(nd)(n+1:n+13) = '/src/gfx/draw'
00297 go to 30
00298 end if
00299 end do
00300 30 continue
00301 end if
00302 c
00303 if (nd.lt.ndir) then
00304 nd = nd + 1
00305 call mygetenv('SIM_FONT_DIR',directory(nd))
00306 end if
00307 c
00308 ndir = nd
00309 c
00310 c Determine lengths of directory names.
00311 c
00312 do idir=1,nd
00313 do n=120,1,-1
00314 if (directory(idir)(n:n).gt.' ') then
00315 ldir(idir) = n
00316 go to 50
00317 end if
00318 end do
00319 ldir(idir) = 0
00320 50 end do
00321
00322 c do ii=1,nd
00323 c write(6,*)ii,directory(ii)(1:ldir(ii))
00324 c end do
00325
00326 c
00327 c Find a free unit number.
00328 c
00329 do 100 iunit=10,99
00330 inquire(iunit,opened=opened)
00331 if (.not.opened) go to 120
00332 100 continue
00333 iunit = -1
00334 c
00335 120 end
00336
00337
00338 block data sboxsetup
00339 save
00340 common /sboxdata/ iborder,ierase,fraction
00341 data iborder/0/ierase/0/fraction/.5/
00342 end
00343
00344
00345 subroutine sboxset(ib,ie,fr)
00346 save
00347 common /sboxdata/ iborder,ierase,fraction
00348 c
00349 iborder = ib
00350 ierase = ie
00351 if (fr.ge.0.) fraction = fr
00352 c
00353 end
00354
00355
00356 subroutine boxsim(x,y,ht,string,theta,nch)
00357 save
00358 c
00359 c Same as "simbol," but optionally first erase the background
00360 c and/or add a bounding box.
00361 c
00362 character*(*) string
00363 c
00364 common /sboxdata/ iborder,ierase,fraction
00365 common/fontc1/offx,offy,lastinc,xp,yp,xmax,xmin,ymax,ymin
00366 dimension xbox(4),ybox(4)
00367 c
00368 if (iborder.ne.0.or.ierase.ne.0) then
00369 c
00370 c Get string dimensions and location.
00371 c
00372 call simsize(ht,string,nch,dx,dy)
00373 call simbol(x,y,-ht,string,theta,nch)
00374 call simwhe(xp,yp)
00375 c
00376 c String "end" (xp) includes some space. Correct by adjusting dx.
00377 c
00378 dx = dx + .5*ht
00379 c
00380 c Set up box containing the string.
00381 c
00382 cost = cos(3.14159*theta/180.)
00383 sint = sin(3.14159*theta/180.)
00384 c
00385 xbox(1) = xp - dx*cost
00386 xbox(2) = xp
00387 xbox(3) = xp - dy*sint
00388 xbox(4) = xp - dx*cost - dy*sint
00389 ybox(1) = yp - dx*sint
00390 ybox(2) = yp
00391 ybox(3) = yp + dy*cost
00392 ybox(4) = yp - dx*sint + dy*cost
00393 c
00394 c Enlarge the box (anisotropically).
00395 c
00396 c "Fraction" refers to the height direction. Along the string,
00397 c cap the enlargement at ht.
00398 c
00399 ddy = .5*fraction*dy
00400 ddx = max(ddy,min(.5*ht,.5*fraction*dx))
00401 c
00402 xbox(1) = xbox(1) - ddx*cost + ddy*sint
00403 xbox(2) = xbox(2) + ddx*cost + ddy*sint
00404 xbox(3) = xbox(3) + ddx*cost - ddy*sint
00405 xbox(4) = xbox(4) - ddx*cost - ddy*sint
00406 c
00407 ybox(1) = ybox(1) - ddx*sint - ddy*cost
00408 ybox(2) = ybox(2) + ddx*sint - ddy*cost
00409 ybox(3) = ybox(3) + ddx*sint + ddy*cost
00410 ybox(4) = ybox(4) - ddx*sint + ddy*cost
00411 c
00412 c Add the embellishment(s).
00413 c
00414 if (ierase.ne.0) call polyerase(xbox,ybox,4)
00415 if (iborder.ne.0) call polydraw(xbox,ybox,4)
00416 c
00417 end if
00418 c
00419 c Draw the string, as usual.
00420 c
00421 call simbol(x,y,ht,string,theta,nch)
00422 c
00423 end
