Trailing-Edge
-
PDP-10 Archives
-
BB-K829A-BM_1981
-
sources/gm.for
There are no other files named gm.for in the archive.
C gm> Character-set Editor ::: Main program #
C RTA 10/23/80 Font-name fixes for Charlie Rose
C RTA 10/22/80 Add "help" command
C ################################################
C GIGI Character Set Editor #
C Rick Ace #
C New York Institiute of Technology #
C March, 1980 #
C ################################################
C GLOSSARY
C
C Area 1 The ascii-to-font correspondence at the top of the screen.
C
C Area 2 The character composition area at the left of the screen.
C
C Area 3 The selectable display at the right of the screen.
C
C Area 4 The command and diagnostic area at the bottom of the screen.
C
C Cell One of the bits that compose a character. There are 80
C cells (10 rows of 8 cells each) per character.
C
C Mosaic A 10 X 10 character matrix that can be displayed in area 3.
C The window always shows a subset of the mosaic.
C
C wcn Window cell number - identifies one of the cells in the window
C (area 2). A wcn is a number between 0 and n*80-1 inclusive,
C where n = wrow*wcol = the number of characters being displayed
C in the window. Numbering is done a row at a time; for example,
C if the window is 3 X 3, the first row of the window contains
C wcns 0 thru 23, the 2nd row 24 thru 47, etc.
C
C Window The character composition display in area 2.
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
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 gecom>
logical quitf
common / gecom / ccrow , cccol , cmrow , cmcol , cwcn , lmrow , l
*mcol , lwcn , quitf
C character row,col of cwcn
C mosaic row,col of cwcn
C wcn of current position in window
C mosaic row,col of lwcn
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 fillsa
C hack to fill string arrays
iuptr = sx ( 6 )
C initialize iuptr (never changes)
C determine if VT52 or ANSI
call lmode ( 1 )
C put VK100 into SC1 mode, no echoing
call dcs ( - 2 )
call pr0 ( 100 )
C who are you? #@100 \033Z
call read1 ( 0 )
if(.not.( sv ( pptr + 1 ) .eq. 91 ))goto 23000
call dcs ( - 4 )
23000 continue
C if [, it's TM1 (ANSI)
call lmode ( 1 )
C init special strings
sv ( sx ( 5 ) ) = 0
sv ( sx ( 7 ) ) = 0
sv ( sx ( 9 ) ) = 0
continue
ir = 1
23002 if(.not.(ir.le.10))goto 23004
C set 10 X 10 mosaic to all spaces
continue
ic = 1
23005 if(.not.(ic.le.10))goto 23007
mosmat ( ir , ic ) = 32
omosmt ( ir , ic ) = 32
23006 ic=ic+1
goto 23005
23007 continue
23003 ir=ir+1
goto 23002
23004 continue
continue
ir = 1
23008 if(.not.(ir.le.95+1))goto 23010
C clear font definitions, def-changed
continue
ic = 1
23011 if(.not.(ic.le.10))goto 23013
fmat ( ir , ic ) = 0
23012 ic=ic+1
goto 23011
23013 continue
fmatc ( ir ) = 0
23009 ir=ir+1
goto 23008
23010 continue
call undo ( 1 , 0 )
C init undo database
call utty ( 2 )
C no gratuitous crlf's
call dcs ( 5 )
C set VK100 to ANSI mode
call dcs ( - 3 )
call setfnt ( 1 )
C use font # 1 initially
call pr2 ( 104 , 767 , 479 )
C @104 w(i7)s(a[0,0][%d,%d])t(d0,i0)
call windim ( 3 , 3 , 12 , 10 )
C set window dimensions
call loadc ( 0 )
C clear VK100 font
call dfull ( 0 )
C set up screen
quitf = . false .
C no characters modified since last write
dinitf = 0
C no longer in initialization
C loop to read and process next command
continue
23014 if(.not.( . true . ))goto 23015
call prdtty ( 133 )
C @133 Command:\b
cmd = pkey ( 8 )
C @8 00quit^
C 01regis [STRING]^
C 02dimension OPTION^
C 04edit [CHAR]^
C 05write [OPTION-LIST]^
C 06read [OPTION-LIST]^
C 07redraw [AREA]^
C 08mosaic^
C 09show OPTION^
C 10font-name NAME^
C 11clear [CHAR ...]^
C 12use FONT^
C 13copy FROM-CHAR TO-CHAR^
C 14help
goto ( 99 , 100 , 1 , 2 , 99 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 1
*2 , 13 , 14 ) , cmd + 2
99 if(.not.( sv ( pptr ) .ne. 63 ))goto 23016
call pr0 ( 136 )
23016 continue
C parse error
goto 23014
C @136 - type ? for list of commands
100 if(.not.( peol ( 0 ) .ne. 0 ))goto 23018
goto 23014
C quit - check for trash at end
23018 continue
if(.not.( quitf ))goto 23020
C any unwritten stuff around?
call pdiag ( 84 )
C yes
C @84 Characters have changed since last write
if(.not.( yn ( 83 ) .eq. 0 ))goto 23022
goto 23014
C @83 Do you really want to quit?\b
23022 continue
23020 continue
goto 23015
1 call regcmd
C regis [STRING]
goto 23014
2 i = pkey ( 85 )
C dimension OPTION
C @85 00window HEIGHT WIDTH^
C 01characters ROWS COLUMNS
if(.not.( i .eq. 0 ))goto 23024
C window
i1 = pdec ( 2 , 10 )
if(.not.( i1 .lt. 0 ))goto 23026
goto 23014
C HEIGHT
23026 continue
i2 = pdec ( 2 , 12 )
if(.not.( i2 .lt. 0 ))goto 23028
goto 23014
C WIDTH
23028 continue
if(.not.( peol ( 0 ) .eq. 0 ))goto 23030
call windim ( wrow , wcol , i2 , i1 )
23030 continue
23024 continue
if(.not.( i .eq. 1 ))goto 23032
C characters
i1 = pdec ( 1 , 10 )
if(.not.( i1 .lt. 0 ))goto 23034
goto 23014
C ROWS
23034 continue
i2 = pdec ( 1 , 9 )
if(.not.( i2 .lt. 0 ))goto 23036
goto 23014
C COLUMNS
23036 continue
if(.not.( peol ( 0 ) .eq. 0 ))goto 23038
C parse ok?
dnrow = i1
C yes
dncol = i2
call da1 ( 2 )
C update area 1
call cdisp ( - 3 )
C update area 3
23038 continue
23032 continue
goto 23014
C 3 call testfn #test
C next
4 call edit
C edit [CHAR]
goto 23014
5 call wrtcmd
C write [OPTION-LIST]
goto 23014
6 call rdcmd
C read [OPTION-LIST]
goto 23014
C redraw [AREA]
7 if(.not.( chkeol ( 0 ) .ne. 0 ))goto 23040
call dfull
C no area given, do all
goto 23041
23040 continue
C have to parse area #
i = pdec ( 1 , 3 )
if(.not.( i .gt. 0 ))goto 23042
C number parsed ok
if(.not.( peol ( 0 ) .eq. 0 ))goto 23044
C chk for trash
if(.not.( i .eq. 1 ))goto 23046
call da1 ( 31 )
23046 continue
if(.not.( i .eq. 2 ))goto 23048
call da2 ( 1 )
23048 continue
if(.not.( i .eq. 3 ))goto 23050
call da3
23050 continue
23044 continue
23042 continue
23041 continue
goto 23014
8 call mospec
C mosaic
goto 23014
9 i = pkey ( 135 )
C show OPTION
C NOTE: The numbers of the keywords in string 135 must
C correspond to the A3xxx definitions in gdef
C @135 00nothing^
C 01characters [CHAR [OPTION-LIST]]^
C 02mosaic-map^
C 03alternate-character-mosaic
if(.not.( i .eq. 1 .and. chkeol ( 0 ) .eq. 0 ))goto 23052
C characters w/ options?
call discmd
C yes, process options
goto 23014
23052 continue
if(.not.( i .ge. 0 ))goto 23054
if(.not.( peol ( 0 ) .eq. 0 ))goto 23056
call seta3 ( i )
23056 continue
23054 continue
goto 23014
10 if(.not.( chkeol ( 0 ) .ne. 0 ))goto 23058
C font-name NAME
call pdiag ( 89 )
C @89 Font name missing
goto 23014
23058 continue
j = sx ( 9 )
C get pointer to font-name string
continue
i = 1
23060 if(.not.(i.le.10))goto 23062
C loop to scan input
i1 = gsc ( pptr )
C get next char of name
if(.not.( i1 .eq. 0 ))goto 23063
goto 23062
C stop at eol
23063 continue
sv ( j ) = i1
C copy char to SNFNM
j = j + 1
23061 i=i+1
goto 23060
23062 continue
sv ( j ) = 0
C tie it off
call da1 ( 4 )
C update area 1 display
goto 23014
C clear [CHAR CHAR ...]
11 continue
i = 32
23065 if(.not.(i.le.126))goto 23067
sv ( iuptr + i - 32 ) = i
23066 i=i+1
goto 23065
23067 continue
C assume all
sv ( iuptr + 126 - 32 + 1 ) = 0
C tie it off
uptr = iuptr
C get to start of SNUST
continue
23068 if(.not.( chkeol ( 0 ) .eq. 0 ))goto 23069
C end of line?
ch = pc1 ( 1 )
C no, parse character
if(.not.( ch .lt. 0 ))goto 23070
goto 111
23070 continue
C check for parse error
sv ( uptr ) = ch
C install char in list
uptr = uptr + 1
sv ( uptr ) = 0
C tie it off
goto 23068
23069 continue
uptr = iuptr
C back to start of SNUST
continue
23072 if(.not.( . true . ))goto 23073
C clear chars in SNUST
ch = sv ( uptr ) - 30
C get character
if(.not.( ch .lt. 0 ))goto 23074
goto 111
23074 continue
C exit if end of list
uptr = uptr + 1
continue
i = 1
23076 if(.not.(i.le.10))goto 23078
fmat ( ch , i ) = 0
23077 i=i+1
goto 23076
23078 continue
C clear each row
fmatc ( ch ) = 1
C character-has-changed
goto 23072
23073 continue
111 goto 23014
C use FONT
12 i = pdec ( 1 , 3 )
C parse font #
if(.not.( i .gt. 0 ))goto 23079
if(.not.( peol ( 0 ) .eq. 0 ))goto 23081
call setfnt ( i )
C tell VK100 about new font
call loadf
C load font name into new font
C load characters into new font
continue
i = 32
23083 if(.not.(i.le.126))goto 23085
call loadc ( i )
23084 i=i+1
goto 23083
23085 continue
23081 continue
23079 continue
goto 23014
C copy FROM-CHAR TO-CHAR
13 i = pc1 ( 1 ) - 30
if(.not.( i .lt. 0 ))goto 23086
goto 23014
C parse FROM-CHAR
23086 continue
j = pc1 ( 1 ) - 30
if(.not.( j .lt. 0 ))goto 23088
goto 23014
C parse TO-CHAR
23088 continue
if(.not.( peol ( 0 ) .eq. 0 ))goto 23090
C parse end-of-line
continue
i1 = 1
23092 if(.not.(i1.le.10))goto 23094
fmat ( j , i1 ) = fmat ( i , i1 )
23093 i1=i1+1
goto 23092
23094 continue
fmatc ( j ) = 1
C char has changed
quitf = . true .
C global char-changed
23090 continue
goto 23014
C help
14 sv ( pptr ) = 63
C fudge a question-mark
i = pkey ( 8 )
C get the menu on the screen
goto 23014
goto 23014
23015 continue
call dcs ( - 2 )
call dcs ( 6 )
C restore TMn
call utty ( 1 )
C restore tty modes
end