Trailing-Edge
-
PDP-10 Archives
-
BB-K829A-BM_1981
-
sources/gt.for
There are no other files named gt.for in the archive.
C gt> VK100 control
C RTA 10/23/80 Font-name fixes for Charlie Rose
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C operating system dependent switches
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C copyright notice
C
C
C C O P Y R I G H T
C
C
C Copyright (C) 1980 by
C Digital Equipment Corporation, Maynard, Mass.
C
C
C This software is furnished under a license and may be used and
C copied only in accordance with the terms of such license and
C with the inclusion of the above copyright notice. This
C software or any other copies thereof may not be provided or
C otherwise made available to any other person. No title to and
C ownership of the software is hereby transferred.
C
C The information in this software is subject to change without
C notice and should not be construed as a commitment by Digital
C Equipment Corporation.
C
C DIGITAL assumes no responsibility for the use or reliability
C of its software on equipment that is not supplied by DIGITAL.
C
C ** Symbolic definitions **
C data types
C define character byte
C max string storage
C max string index storage
C important string indices (see gs module)
C cdisp - function codes
C coord - axis codes
C cpystr - option codes
C da1 - function codes
C da2 - function codes
C dcs - function codes
C ffopen - modes
C frtyp - record types
C (careful - used in computed goto's)
C ftran - function codes
C undo - function codes
C utty - function codes
C codes returned by keypad function
C character types
C composites
C CTKEY = CTALPHA + CTNUM + CTHYPH
C CTFILE = CTALPHA + CTNUM + CTDOT + CTSLASH + CTCOLON
C colors - temporarily all white
C screen dimensions (pixels)
C displays in area 3
C must match showtab in gm
C maximum mosaic dimensions
C dimensions of mosaic display window
C quan to subtract from char to get fmat/fmatc subscript
C lowest, highest, number of characters in VK100 font
C number of loadable fonts in VK100
C character definitions
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C character definitions
C To simplify area and object positioning on the VK100 screen,
C this module contains definitions of points and a subroutine
C to reference them. Points are numbered according to the scheme:
C
C 0-99 Screen-wide points (points 1 thru 4 are the upper
C left-hand corners of areas 1 thru 4, respectively)
C 100-199 Points in area 1
C 200-299 Points in area 2
C 300-399 Points in area 3
C
C The p0def array contains X and Y coordinates of points 0-99.
C The p1def, p2def, and p3def arrays contain offsets into their
C respective areas. These offsets must be added to the coordinates
C of the upper left-hand corner of the area to get the absolute
C screen coordinates of the desired point (this was done to make it
C easy to change the positions of the areas without having to change
C the interior point definitions in the process).
C The coord function returns the X or Y coordinate of a point.
C Map of Points 0 thru 7
C
C
C 1 ------------------------------------------------
C ! Area 1 !
C ! 3 !
C 2 ------------------------------------------------ 0
C ! ! !
C ! Area 2 ! Area 3 !
C ! ! !
C ! ! !
C 4 ------------------------------------------------ 6
C ! 5 !
C ! Area 4 !
C ------------------------------------------------ 7
block data
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gtcom>
integer p0def ( 8 , 2 ) , p1def ( 5 , 2 ) , p2def ( 1 , 2 ) , p3de
*f ( 6 , 2 )
common / gtcom / p0def , p1def , p2def , p3def , nogrph
C x,y coordinates of points in area 0
C x,y coordinates of points in area 1
C x,y coordinates of points in area 2
C x,y coordinates of points in area 3
C if nonzero, don't send <esc>Pp sequence
data p0def ( 1 , 1 ) , p0def ( 1 , 2 ) , p0def ( 2 , 1 ) , p0def (
* 2 , 2 ) / 767 , 82 , 0 , 0 /
data p0def ( 3 , 1 ) , p0def ( 3 , 2 ) , p0def ( 4 , 1 ) , p0def (
* 4 , 2 ) / 0 , 82 , 347 , 82 /
data p0def ( 5 , 1 ) , p0def ( 5 , 2 ) , p0def ( 6 , 1 ) , p0def (
* 6 , 2 ) / 0 , 436 , 347 , 436 /
data p0def ( 7 , 1 ) , p0def ( 7 , 2 ) , p0def ( 8 , 1 ) , p0def (
* 8 , 2 ) / 767 , 436 , 767 , 479 /
data p1def ( 1 , 1 ) , p1def ( 1 , 2 ) , p1def ( 2 , 1 ) , p1def (
* 2 , 2 ) / 0 , 0 , 135 , 0 /
data p1def ( 3 , 1 ) , p1def ( 3 , 2 ) , p1def ( 4 , 1 ) , p1def (
* 4 , 2 ) / 135 , 20 , 135 , 40 /
data p1def ( 5 , 1 ) , p1def ( 5 , 2 ) / 135 , 60 /
C 200 upper left corner of window; changed by windim routine
data p2def ( 1 , 1 ) , p2def ( 1 , 2 ) / 24 , 24 /
C 300 mosmap characters, 301 mosmap window, 302 help
C 303 cdisp character # 1, 304 alternate-character mosaic
data p3def ( 1 , 1 ) , p3def ( 1 , 2 ) , p3def ( 2 , 1 ) , p3def (
* 2 , 2 ) / 58 , 38 , 52 , 56 /
data p3def ( 3 , 1 ) , p3def ( 3 , 2 ) , p3def ( 4 , 1 ) , p3def (
* 4 , 2 ) / 12 , 12 , 15 , 10 /
data p3def ( 5 , 1 ) , p3def ( 5 , 2 ) , p3def ( 6 , 1 ) , p3def (
* 6 , 2 ) / 40 , 20 , 20 , 27 /
data nogrph / 0 /
end
C clr - clear rectangle given opposite corners
C the perimeter of the rectangle is not cleared
subroutine clr ( point1 , point2 )
implicit integer ( a - z )
x1 = coord ( point1 , 1 )
y1 = coord ( point1 , 2 )
x2 = coord ( point2 , 1 )
y2 = coord ( point2 , 2 )
call sqz ( x1 , x2 , 767 )
call sqz ( y1 , y2 , 479 )
call dcs ( - 3 )
call pr4 ( 105 , x1 , y1 , y2 , x2 )
C @105 p[%d,%d]w(s1)p[,%d]v(w(e))[%d]
end
C coord - return coordinate of point
integer function coord ( point , xy )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gtcom>
integer p0def ( 8 , 2 ) , p1def ( 5 , 2 ) , p2def ( 1 , 2 ) , p3de
*f ( 6 , 2 )
common / gtcom / p0def , p1def , p2def , p3def , nogrph
C x,y coordinates of points in area 0
C x,y coordinates of points in area 1
C x,y coordinates of points in area 2
C x,y coordinates of points in area 3
C if nonzero, don't send <esc>Pp sequence
pf = mod ( point , 100 )
goto ( 10 , 11 , 12 , 13 ) , point / 100 + 1
10 coord = p0def ( pf + 1 , xy )
return
11 coord = p0def ( 2 , xy ) + p1def ( pf + 1 , xy )
return
12 coord = p0def ( 3 , xy ) + p2def ( pf + 1 , xy )
return
13 coord = p0def ( 4 , xy ) + p3def ( pf + 1 , xy )
return
end
C dcs - send device control strings
subroutine dcs ( func )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gtcom>
integer p0def ( 8 , 2 ) , p1def ( 5 , 2 ) , p2def ( 1 , 2 ) , p3de
*f ( 6 , 2 )
common / gtcom / p0def , p1def , p2def , p3def , nogrph
C x,y coordinates of points in area 0
C x,y coordinates of points in area 1
C x,y coordinates of points in area 2
C x,y coordinates of points in area 3
C if nonzero, don't send <esc>Pp sequence
dimension f2n ( 6 )
C function code to string number mapping
C @10 \033[2J
C @11 \033[K
C @12 \033[23;1H\033[K
C @13 \033[24;1H\033[K
C @14 \033<
C @15 \033[?2l
data f2n ( 1 ) , f2n ( 2 ) , f2n ( 3 ) , f2n ( 4 ) , f2n ( 5 ) , f
*2n ( 6 ) / 10 , 11 , 12 , 13 , 14 , 15 /
data modef / - 2 /
if(.not.( func .eq. - 4 ))goto 23000
f2n ( 5 ) = 1
f2n ( 6 ) = 1
return
23000 continue
if(.not.( func .gt. 0 ))goto 23002
if(.not.( modef .ne. - 2 ))goto 23004
call pr0 ( 101 )
modef = - 2
23004 continue
call pr0 ( f2n ( func ) )
return
23002 continue
f1 = func
C don't clobber caller's func code
if(.not.( f1 .eq. - 3 .and. nogrph .ne. 0 ))goto 23006
f1 = - 2
23006 continue
if(.not.( f1 .ne. modef ))goto 23008
if(.not.( modef .ne. - 2 ))goto 23010
call pr0 ( 101 )
23010 continue
C @101 \033\\
if(.not.( f1 .ne. - 2 ))goto 23012
ch = 112
if(.not.( f1 .ne. - 3 ))goto 23014
ch = 114
23014 continue
call pr1 ( 102 , ch )
C @102 \033P%c
23012 continue
modef = f1
23008 continue
end
C defhex - generate hexadecimal char definition string for ReGIS L cmd
C ch: character (used to access fmat)
C svp: subscript of sv where you want me to put the string
C updated to point to position following string
subroutine defhex ( ch , svp )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
integer hex ( 16 )
C should be character data type
data hex ( 1 ) , hex ( 2 ) , hex ( 3 ) , hex ( 4 ) / 48 , 49 , 50
*, 51 /
data hex ( 5 ) , hex ( 6 ) , hex ( 7 ) , hex ( 8 ) / 52 , 53 , 54
*, 55 /
data hex ( 9 ) , hex ( 10 ) , hex ( 11 ) , hex ( 12 ) / 56 , 57 ,
*65 , 66 /
data hex ( 13 ) , hex ( 14 ) , hex ( 15 ) , hex ( 16 ) / 67 , 68 ,
* 69 , 70 /
ls = svp
C position of last non-zero
chs = ch - 30
C get 1st subscript for fmat
continue
i = 1
23016 if(.not.(i.le.10))goto 23018
i1 = fmat ( chs , i )
C get 1 row of bits
if(.not.( i1 .ne. 0 ))goto 23019
ls = svp
23019 continue
C update position of last non-zero
sv ( svp ) = hex ( i1 / 16 + 1 )
C high/order 4 bits
sv ( svp + 1 ) = hex ( mod ( i1 , 16 ) + 1 )
C low order 4 bits
svp = svp + 2
23017 i=i+1
goto 23016
23018 continue
svp = ls + 3
C discard trailing zeros
sv ( svp - 1 ) = 59
C close it out
end
C font0 - switch from alternate font to ASCII font (font 0)
C NOTE: As a rule, the CE code assumes the rotation (D) and slant (I)
C parameters are both zero. The only instance where this is not
C so is during writing the mangled sample characters in area 3;
C after this is done, I and D are immediately set back to zero.
C The CE typically operates with the T command set to the current
C alternate font. To type characters from the ASCII font in graphics
C mode, call font0, issue the T command, and then call fonta to point
C the terminal back at the alternate font once again.
subroutine font0
implicit integer ( a - z )
call dcs ( - 3 )
call pr0 ( 110 )
C @110 w(r)t(a0,s1)
end
C fonta - switch T command to current alternate font
subroutine fonta
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
call dcs ( - 3 )
call pr1 ( 71 , sfont )
C @71 t(a%d)
end
C lmode - toggle things necessary for reading in locator mode
C argument is string to display in area 4 line 1
subroutine lmode ( sno )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
dimension utfn ( 2 )
data curlm , utfn ( 1 ) , utfn ( 2 ) / 0 , 5 , 4 /
if(.not.( sv ( sx ( sno ) ) .ne. 0 ))goto 23021
call dcs ( 3 )
call pr0 ( sno )
23021 continue
curlm = mod ( curlm + 1 , 2 )
C toggle
call utty ( utfn ( curlm + 1 ) )
call dcs ( - 1 )
call pr4 ( 103 , curlm , curlm , 67 , curlm * 2 + 1 )
C @103 SC%dKP%dV%c%dMB0
end
C loadc - transmit ReGIS character definition to VK100
C ch: character, or 0 to clear entire font
subroutine loadc ( ch )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
if(.not.( ch .eq. 0 ))goto 23023
C clear entire font
call dcs ( - 3 )
C VK100 in graphics mode
continue
i = 32
23025 if(.not.(i.le.126))goto 23027
call pr1 ( 139 , qchar ( i ) )
23026 i=i+1
goto 23025
23027 continue
C @139 l%s0;
goto 23024
23023 continue
uptr = iuptr
C single char, set up work area pointer
call defhex ( ch , uptr )
C get hex stuff into work string
sv ( uptr ) = 0
C terminate string
call dcs ( - 3 )
C VK100 in graphics mode
call pr2 ( 140 , qchar ( ch ) , 6 )
C @140 l%s%s
23024 continue
end
C loadf - load current font name into VK100
subroutine loadf
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
call cpystr ( 70 , 512 )
C 70 = l(a"
pfn = sx ( 9 )
C get pointer to font name string
if(.not.( sv ( pfn ) .eq. 0 ))goto 23028
return
23028 continue
C if no name set yet, don't do anything
continue
23030 if(.not.( . true . ))goto 23031
ch = sv ( pfn )
pfn = pfn + 1
C get char from font name
if(.not.( ch .eq. 0 ))goto 23032
goto 23031
C end of name
23032 continue
call putuq ( ch )
C copy char to utility string
goto 23030
23031 continue
call putu ( 34 )
call putu ( 41 )
call putu ( 0 )
C tie it all off
call dcs ( - 3 )
C get into graphics mode
call pr0 ( 6 )
C send font name to VK100
end
C posgc - position graphics cursor with respect to point
C xoff and yoff are pixel offsets
subroutine posgc ( point , xoff , yoff )
implicit integer ( a - z )
call dcs ( - 3 )
call pr2 ( 3 , coord ( point , 1 ) + xoff , coord ( point , 2 ) +
*yoff )
end
C posgcc - like posgc, except offsets are characters */
subroutine posgcc ( point , xoff , yoff )
implicit integer ( a - z )
call posgc ( point , xoff * 9 , yoff * 20 )
end
C posgcw - position to cell in window (area 2)
C wcn: window cell #
C modif: modifier - 0 for top left, 1 for center
subroutine posgcw ( wcn , modif )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
call posgc ( 200 , mod ( wcn , wcol8 ) * rmul + modif * rmul / 2 ,
* wcn / wcol8 * cmul + modif * cmul / 2 )
end
C postcm - position text-mode cursor within mosaic map
subroutine postcm ( row , col )
implicit integer ( a - z )
call dcs ( - 2 )
C put VK100 in text mode
call pr2 ( 93 , row + coord ( 300 , 2 ) / 20 + 2 , col * 3 + coord
* ( 300 , 1 ) / 9 + 1 )
C @93 \033[%d;%dH
end
C qchar - return string # of string containing quoted character
integer function qchar ( ch )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
i = sx ( 4 )
q = 34
if(.not.( ch .eq. 34 ))goto 23034
q = 39
23034 continue
sv ( i ) = q
sv ( i + 1 ) = ch
sv ( i + 2 ) = q
qchar = 4
end
C regis - write ReGIS string
subroutine regis ( sno )
implicit integer ( a - z )
call dcs ( - 3 )
call pr0 ( sno )
call putc ( 59 )
end
C setfnt - tell VK100 which font the character-set editor is using
C fnt: font number (1 thru MAXFONT)
subroutine setfnt ( fnt )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
sfont = fnt
C save font name in COMMON variable
call dcs ( - 3 )
C get into graphics mode
call pr2 ( 138 , sfont , sfont )
C @138 l(a%d);t(a%d);
end
C sqz - used by shade to move coordinates toward each other
C except if on edge of display
C args: c1,c2 are x1,x2 or y1,y2; cmax = xmax or ymax
subroutine sqz ( c1 , c2 , cmax )
implicit integer ( a - z )
add = - 2
if(.not.( c1 .lt. c2 ))goto 23036
add = 2
23036 continue
if(.not.( c1 .ne. 0 .and. c1 .ne. cmax ))goto 23038
c1 = c1 + add
23038 continue
if(.not.( c2 .ne. 0 .and. c2 .ne. cmax ))goto 23040
c2 = c2 - add
23040 continue
end
C tsm - compute T-command parameters and write to terminal
C the output to the terminal is: s[RSIZE,CSIZE]m[RMUL,CMUL])
C RMUL and CMUL are computed from the argument "s"
C RSIZE and CSIZE are computed from RMUL and CMUL and
C dncol and dnrow (set by "dimension" command)
C s: size of character
subroutine tsm ( s )
implicit integer ( a - z )
C gccom>
integer mosmat ( 10 , 10 ) , omosmt ( 10 , 10 )
integer fmat ( 96 , 10 ) , fmatc ( 96 )
logical cdcec , rdmos
common / gccom / a3 , a3x , cdch ( 7 ) , cdcec ( 7 ) , cdrot ( 7
*) , cdsiz ( 7 ) , cdsln ( 7 ) , dinitf , dnrow , dncol , dorow , d
*ocol , edchar , fmat , fmatc , mosmat , omosmt , rdmos , rmul , cm
*ul , rsize , csize , sfont , uprow , upcol , wcol , wcol8 , wrow ,
* wrow10
C handle of display currently in area 3
C >0 no action, =0 regenerate area 3, <0 update area 3
C characters being displayed in area 3
C .true. = always shows currently-edited character
C height of window in characters, cells
C sfont may be changed ONLY by calling setfnt(new-font-#)
C fmat: contains the bit definitions for all characters in the font.
C The row is given by <character>-FMOFF, such that Space is
C defined in fmat(2,*), ! in fmat(3,*), etc. The row fmat(1,*)
C always contains all zeros (used by ffcreate). Each column of
C fmat contains 8 bits that define 1 row of the character.
C fmatc: fmatc(x) is parallel to fmat(x,*). A non-zero fmatc entry
C indicates that the definition of the respective character
C has changed, and that the dupd routine must update the
C screen accordingly. fmatc(1) is unused.
s1 = s * 3 / 2 + mod ( s , 2 )
C apply 1.5 ratio
call pr4 ( 67 , s * dncol , s1 * dnrow , s , s1 )
C @67 s[%d,%d]m[%d,%d])
end
C wrtch - give ReGIS T command to write character
subroutine wrtch ( ch )
implicit integer ( a - z )
call putc ( 116 )
call pr0 ( qchar ( ch ) )
end
C wrtstr - write string with ReGIS T command
subroutine wrtstr ( sno )
implicit integer ( a - z )
C Copyright (C) 1980, by Digital Equipment Corporation, Maynard, Mass.
C gscom>
integer sv ( 4000 )
integer sx ( 150 )
common / gscom / iuptr , pptr , uptr , sv , sx
C contains sx (SNUST)
C index into sv, used when parsing tty input (SNINP)
C index into sv, used when building a string (SNUST)
C string vector - ALL strings live here
C subscript is string #, contains index into sv
integer sp
sp = sx ( sno )
call putc ( 116 )
call putc ( 34 )
continue
23042 if(.not.( . true . ))goto 23043
ch = sv ( sp )
sp = sp + 1
if(.not.( ch .eq. 0 ))goto 23044
goto 23043
23044 continue
call putc ( ch )
if(.not.( ch .eq. 34 ))goto 23046
call putc ( 34 )
23046 continue
goto 23042
23043 continue
call putc ( 34 )
end