hershey(3f) - [M_pixel:TEXT] draw text string as Hershey software
vector fonts
(LICENSE:PD
definition:
subroutine hershey(x,y,height,itext,theta,ntext)
character(len=*),intent(in) :: itext
real,intent(in) :: x,y
real,intent(in) :: height
real,intent(in) :: theta
integer,intent(in) :: ntext
X,Y are the coordinates in inches from the current origin to the
lower left corner of the 1st character to be plotted. If either
is set to 999.0 then saved next character position is used.
HEIGHT is the character height in inches
ITEXT contains the text to be plotted
THETA is the positive CCW angle W.R.T. the X-axis
NTEXT is the number of characters in itext to plot
o If NTEXT.lt.-1 the pen is down to (X,Y) and a single special
centered symbol is plotted. ITEXT must be from CHAR(0) to
CHAR(21).
o If NTEXT.eq.-1 the pen is up to (X,Y) and a single special
centered symbol is plotted. ITEXT must be from CHAR(0) to
CHAR(21).
o if NTEXT=0 a single Simplex Roman character from ITEXT,
left-justified, is plotted.
o if NTEXT.gt.0 NTEXT characters from ITEXT are decoded and
NCHR characters are plotted where NCHR.le.NTEXT to remove
backslashes, command codes, etc.
FEATURES:
1) Four HERSHEY letter fonts--SIMPLEX,COMPLEX,ITALIC, and DUPLEX--
are provided in upper and lower case ROMAN
2) Two hershey letter fonts--SIMPLEX and COMPLEX--are provided in
upper and lower case GREEK
3) 47 special mathematical symbols, e.g. integral sign, del... are
provided
4) SUPER- and SUB-scripting is possible within a character string
without separate calls to HERSHEY
Change of font is made by enclosing the name of the font in upper
case in backslashes, e.g \SIMPLEX\. Three letters suffice to
specify the font. SIMPLEX is the default font on the initial call
to HERSHEY. A font remains in effect until explicitly changed.
SUPER- or SUB-scripting is accomplished by enclosing the expression
to be SUPER- or SUB-scripted in curly brackets and preceding it by
SUP or SUB. the closing curly bracket terminates the
SUPER- or SUB-scripting and returns to normal character plotting.
Note that SUPER- and SUB-script letters are plotted with a
different character size.
GREEK letters are drawn by enclosing the ENGLISH name of the
letter in backslashes, e.g. \ALPHA\. The case of the first letter
determines the case of the GREEK letter. The closing backslash must
be included.
Any symbol may be called by enclosing the symbol number+1000 in
backslashes. This is the only way to call some symbols, especially
special mathematical symbols.
The symbol numbers are
1-26 upper case ROMAN SIMPLEX
27-52 lower case ROMAN SIMPLEX
53-72 SIMPLEX numbers and symbols
73-96 upper case GREEK SIMPLEX
97-120 lower case GREEK SIMPLEX
121-146 upper case ROMAN COMPLEX
147-172 lower case ROMAN COMPLEX
173-192 COMPLEX numbers and symbols
193-216 upper case GREEK COMPLEX
217-240 lower case GREEK COMPLEX
241-266 upper case ROMAN ITALIC
267-292 lower case ROMAN ITALIC
293-312 ITALIC numbers and symbols
313-338 upper case ROMAN DUPLEX
339-364 lower case ROMAN DUPLEX
365-384 DUPLEX numbers and symbols
385-432 special mathematical symbols
Additional features added Feb 1982:
The pen may be moved back to the start point for the previous character
by \BS\. This is useful, for example, in writing integral signs with
limits above and below them.
Symbol parameters taken from N.M.Wolcott, FORTRAN IV Enhanced Character
Graphics, NBS
A. CHAVE IGPP/UCSD Aug 1981, Modified Feb 1982 by A. Chave,
R.L. Parker, and L. Shure
programmed in FORTRAN-77
Show all Hershey characters
program demo_hershey
use M_pixel
use M_writegif_animated, only : write_animated_gif
implicit none
integer,parameter :: isize=600
integer,parameter :: topsym=432
integer :: movie(1:topsym,0:isize-1,0:isize-1)
integer :: i
!! set up environment
call prefsize(isize,isize)
call vinit()
call ortho2(-150.0,150.0,-150.0,150.0)
!! draw all characters using hershey numeric strings
do i=1,topsym
!! draw reference circle and crosshairs
call color(0)
call clear()
call color(4)
call linewidth(100)
call circle(0.0,0.0,75.0)
call move2(-75.0,0.0)
call draw2(75.0,0.0)
call move2(0.0,-75.0)
call draw2(0.0,75.0)
call centertext(.true.)
call color(7)
call linewidth(500)
call textang(3.0*i)
call textang(0.0)
call move2(0.0,0.0)
call textsize(150.0,150.0)
call drawstr('\',i+1000,'\',sep='')
call centertext(.false.)
call color(1)
call move2(-120.0,120.0)
call textsize(10.0,10.0)
call linewidth(40)
call drawstr(i+1000,' ')
movie(i,:,:)=P_pixel
enddo
call vexit()
!! write to file and display with display(1)
call write_animated_gif('hershey.3m_pixel.gif',&
& movie,P_colormap,delay=40)
!call execute_command_line('display hershey.3m_pixel.gif')
end program demo_hershey
Derived from the Longlib93 library.
Public Domain
Longlib was written by an employee of a US government contractor and
is in the public domain.
Changes to modernize and make more portable by John S. Urban are also
placed in the public domain.
write(,)’GOT HERE A’,’X=’,x,’Y=’,y,’HEIGHT=’,height,’ITEXT=’,itext,’THETA=’,theta,’NTEXT=’,ntext
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| real, | intent(in) | :: | x | |||
| real, | intent(in) | :: | y | |||
| real, | intent(in) | :: | height | |||
| character(len=*), | intent(in) | :: | itext | |||
| real, | intent(in) | :: | theta | |||
| integer, | intent(in) | :: | ntext |
subroutine hershey(x,y,height,itext,theta,ntext)
! ident_5="@(#) M_pixel hershey(3f) draw text string as Hershey software vector fonts"
character(len=*),intent(in) :: itext
real,intent(in) :: x,y
real,intent(in) :: height
real,intent(in) :: theta
integer,intent(in) :: ntext
real :: oldwid
real :: scale
character(len=4096) :: text
real :: raise(20)
real,save :: xo,yo
real,parameter :: supsub(2)=[0.50,-0.50]
real,parameter :: factor=0.75
integer,parameter :: iup=3
integer,parameter :: idown=2
real :: yy, xx
real :: yoff
real :: yi, xi
real :: si
real :: rscale
real :: co
integer :: ipen
integer :: isav
integer :: ia
integer :: ib
integer :: ic
integer :: is
integer :: ix
integer :: iy
integer :: i,k,l,n
! P_ICHR(J) contains the symbol number of the Jth symbol or a
! code to indicate SPACE (1000),BEGIN SUPER-SCRIPTING (1001),
! BEGIN SUB-SCRIPTING (1002), OR END SUPER/SUB-SCRIPTING (1003),
! OR BACK-SPACE (1004).
! ISTART(P_ICHR(J)) contains the address in SYMBOL of the Jth
! character. SYMBCD contains the pen instructions stored in a
! special form. ISSTAR and SSYMBC contain addresses and pen
! instructions for the special centered symbols. WIDTH contains
! the widths of the characters.
!
!-----------------------------------------------------------------------------------------------------------------------------------
integer :: ixtrct
integer :: nstart
integer :: nbits
integer :: iword
! IXTRCT gets NBITS from IWORD starting at the NSTART bit from the right
IXTRCT(NSTART,NBITS,IWORD)=MOD(IWORD/(2**(NSTART-NBITS)), &
& 2**NBITS)+((1-ISIGN(1,IWORD))/2)* &
& (2**NBITS-MIN0(1,MOD(-IWORD, &
& 2**(NSTART-NBITS))))
!-----------------------------------------------------------------------------------------------------------------------------------
!!write(*,*)'GOT HERE A','X=',x,'Y=',y,'HEIGHT=',height,'ITEXT=',itext,'THETA=',theta,'NTEXT=',ntext
yoff=0.0
si=sind(theta)
co=cosd(theta)
scale=height/21.0
if(scale.eq.0.0)return
if(x.ge.999.0)then
xi=xo
else
xi=x
endif
if(y.ge.999.0)then
yi=yo
else
yi=y
endif
if(ntext.lt.0)then ! plot a single special centered symbol
if(ntext.lt.-1)call hstylus(xi,yi,idown)
ia=ichar(itext(1:1))+1
if(ia.gt.size(isstar))then
write(*,*)'*hershey* error: character out of range for centered characters=',ia,itext(1:1)
ia=size(isstar)
endif
is=isstar(ia)
ib=30
INFINITE: do
ipen=ixtrct(ib,3,ssymbc(is))
if(ipen.eq.0)then
call hstylus(xi,yi,iup)
xi=xi+20.0*co
yi=yi+20.0*si
xo=xi
yo=yi
return
endif
ix=ixtrct(ib-3,6,ssymbc(is))
iy=ixtrct(ib-9,6,ssymbc(is))
xx=scale*(ix-32)
yy=scale*(iy-32)
call hstylus(xi+xx*co-yy*si,yi+xx*si+yy*co,ipen)
ib=45-ib
if(ib.eq.30)is=is+1
enddo INFINITE
elseif (ntext.eq.0)then ! plot a single simplex roman character
isav=P_ioff
P_ioff=0
text(1:1)=itext(1:1)
call chrcod(text,1)
P_ioff=isav
is=istart(P_ichr(1))
ib=30
do
ipen=ixtrct(ib,3,symbcd(is))
if(ipen.eq.0)then
xi=xi+co*scale*width(P_ichr(1))
yi=yi+si*scale*width(P_ichr(1))
xo=xi
yo=yi
return
endif
ix=ixtrct(ib-3,6,symbcd(is))
iy=ixtrct(ib-9,6,symbcd(is))
xx=(ix-10)*scale
yy=(iy-11)*scale
call hstylus(xi+co*xx-si*yy,yi+co*yy+si*xx,ipen)
ib=45-ib
if(ib.eq.30)is=is+1
enddo
else
! plot a character string.
! first find pointer array P_ichr containing the starts of characters-
! but only if P_just1 and P_just2 are not 1, when P_ichr is assumed
! correctly transmitted through common /ajust/.
if(P_just1.ne.1.or.P_just2.ne.1)then
n=ntext
k=1
do i=1,n
text(i:i)=itext(i:i)
k=k+1
enddo
call chrcod(text,n)
endif
P_just2=2
oldwid=0.0
l=1
rscale=scale
EACH_CHAR: do i=1,P_nchr ! plot each character
ic=P_ichr(i)
if(ic.eq.1000)then
! plot a space
xi=xi+20.*rscale*co
yi=yi+20.*rscale*si
xo=xi
yo=yi
call hstylus(xi,yi,iup)
elseif ((ic.eq.1001).or.(ic.eq.1002))then
! begin super-scripting or sub-scripting
raise(l)=supsub(ic-1000)*height*rscale/scale
rscale=factor*rscale
yoff=raise(l)+yoff
l=l+1
elseif (ic.eq.1003)then
! end super/sub-scripting
rscale=rscale/factor
l=l-1
yoff=yoff-raise(l)
elseif (ic.eq.1004)then
! backspace -use the width of the previous letter in oldwid.
xi=xi - co*oldwid
yi=yi - si*oldwid
xo=xi
yo=yi
else
! plot a single symbol
is=istart(ic)
ib=30
do
ipen=ixtrct(ib,3,symbcd(is))
if(ipen.eq.0)then
xi=xi+co*rscale*width(ic)
yi=yi+si*rscale*width(ic)
xo=xi
yo=yi
oldwid=width(ic)*rscale
cycle EACH_CHAR
endif
ix=ixtrct(ib-3,6,symbcd(is))
iy=ixtrct(ib-9,6,symbcd(is))
xx=(ix-10)*rscale
yy=(iy-11)*rscale+yoff
call hstylus(xi+co*xx-si*yy,yi+co*yy+si*xx,ipen)
ib=45-ib
if(ib.eq.30)is=is+1
enddo
endif
enddo EACH_CHAR
endif
end subroutine hershey