Trailing-Edge
-
PDP-10 Archives
-
BB-K829A-BM_1981
-
sources/ge.for
There is 1 other file named ge.for in the archive. Click here to see a list.
C ge> Editing-command functions
C RTA 12/12/80 Don't clobber mosaic when editing single character
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 anlz - analyze wcn
C wcn: window cell number (input)
C output...
C mrow,mcol: mosaic row,col of character that contains wcn
C crow,ccol: row,col of cell within character
subroutine anlz ( wcn , mrow , crow , mcol , ccol )
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.
w = wcn
C make private copy
ccol = mod ( w , 8 ) + 1
w = w / 8
mcol = mod ( w , wcol ) + docol
w = w / wcol
crow = mod ( w , 10 ) + 1
mrow = w / 10 + dorow
end
C anlzm - like anlz, except gives only mrow and mcol
subroutine anlzm ( wcn , mrow , mcol )
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.
mcol = mod ( wcn / 8 , wcol ) + docol
mrow = wcn / ( wcol8 * 10 ) + dorow
end
C edit - process edit command
subroutine edit
implicit integer ( a - z )
logical moved
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 gpcom>
common / gpcom / diagf , lcx , lcy
C prevents multiple diagnostic messages
C locator-mode coordinates returned by VK100
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 states
siz = 3
C assume editing mosaic
if(.not.( chkeol ( 0 ) .eq. 0 ))goto 23000
C editing a character?
ch = pc1 ( 1 )
C yes, parse it
if(.not.( ch .lt. 0 ))goto 23002
return
23002 continue
C badness
siz = 1
C doing 1 X 1
23000 continue
if(.not.( peol ( 0 ) .ne. 0 ))goto 23004
return
23004 continue
C check for eol
if(.not.( siz .eq. 1 ))goto 23006
C editing a character?
C Temporarily substitute the edited-character for one of the
C characters in the mosaic (because all the editing routines
C reference the mosaic). If the mosaic is showing in Area 3,
C blank it so user doesn't think I changed the mosaic. Upon
C exit, restore the character and redisplay the mosaic.
savch = mosmat ( dorow , docol )
C yes, remember what's there now
sava3 = 0
C assume no mosaic in area 3
if(.not.( a3 .eq. 2 .or. a3 .eq. 3 ))goto 23008
C showing mosaic in area 3?
sava3 = a3
C yes, remember what's there now
call seta3 ( 0 )
C request no display in area 3
call clr ( 3 , 6 )
C clear area 3
23008 continue
mosmat ( dorow , docol ) = ch
C install edited-character in mosaic
edchar = ch
C save for area 3 display
call cdisp ( - 2 )
C update area 3 display
23006 continue
call windim ( siz , siz , rmul , cmul )
C set up window
call dcs ( 3 )
C clear area 4 line 1
call pr0 ( 64 )
C @64 Mode: NO-CHANGE
msg = 0
C no message in area 1
call undo ( 1 , 0 )
C clear undo memory
call lmode ( 1 )
C VK100 into SC1 mode
C modes: 0 no-change, 1 flip, 2 erase, 3 draw
C nmode = normal mode, fmode = figure mode
nmode = 0
fmode = 3
C initial modes
state = 1
C initial state
continue
23010 if(.not.( . true . ))goto 23011
C loop once per keystroke
if(.not.( msg .ne. 0 ))goto 23012
C message to display?
call dcs ( - 2 )
C yes
call pr1 ( 61 , msg )
C @61 \033[23;41H\033[K%s
msg = 0
C clear message
23012 continue
call dupd
C update displays
call posgcw ( cwcn , 1 )
C position graphics cursor
call read1 ( 0 )
C read 1 keystroke
if(.not.( diagf .ne. 0 ))goto 23014
call dcs ( 4 )
diagf = 0
C erase diag
23014 continue
cmd = keypad ( 0 )
C get function code
goto ( 1001 , 1002 , 1003 ) , state
C MOVE
1001 goto ( 99 , 99 , 1 , 1 , 1 , 1 , 5 , 1 , 1 , 1 , 1 , 10 , 99 , 99
*, 13 , 14 , 14 , 14 , 14 , 18 , 19 , 20 , 21 , 22 ) , cmd + 2
1 nw = cwcn
moved = . true .
C moving cursor
if(.not.( cmd .ge. 7 ))goto 23016
C up
nw = nw - wcol8
if(.not.( nw .lt. 0 ))goto 23018
moved = . false .
23018 continue
23016 continue
if(.not.( cmd .le. 3 ))goto 23020
C down
nw = nw + wcol8
if(.not.( nw .ge. wcol8 * wrow10 ))goto 23022
moved = . false .
23022 continue
23020 continue
if(.not.( mod ( cmd , 3 ) .eq. 1 ))goto 23024
C left
if(.not.( mod ( nw , wcol8 ) .eq. 0 ))goto 23026
moved = . false .
23026 continue
nw = nw - 1
23024 continue
if(.not.( mod ( cmd , 3 ) .eq. 0 ))goto 23028
C right
nw = nw + 1
if(.not.( mod ( nw , wcol8 ) .eq. 0 ))goto 23030
moved = . false .
23030 continue
23028 continue
if(.not.( moved ))goto 23032
C move legal?
call stcwcn ( nw )
C yes, set new cwcn
if(.not.( state .eq. 1 ))goto 23034
call wcnz ( nw , nmode )
23034 continue
C make change
23032 continue
goto 23010
5 call wcnz ( cwcn , 1 )
C reverse current cell
goto 23010
10 state = 2
C figure
msg = 60
C @60 Specify type of figure
xmode = fmode
C want to show figure mode
goto 141
C go update mode display
13 if(.not.( undo ( 3 , 0 ) .eq. 0 ))goto 23036
call pdiag ( 88 )
23036 continue
C @88 Nothing to undo
goto 23010
14 xmode = cmd - 14
C no-change flip erase draw
if(.not.( state .eq. 1 ))goto 23038
nmode = xmode
call wcnz ( cwcn , nmode )
goto 23039
23038 continue
if(.not.( xmode .ne. 0 ))goto 23040
fmode = xmode
goto 23041
23040 continue
goto 23010
23041 continue
23039 continue
141 call dcs ( - 2 )
call pr1 ( 62 , 50 + xmode )
C @62 \033[23;7H%s
C @50 NO-CHANGE
C @51 FLIP \b
C @52 ERASE \b
C @53 DRAW \b
goto 23010
18 cmd = 8
goto 1
C up arrow
19 cmd = 2
goto 1
C down arrow
20 cmd = 6
goto 1
C right arrow
21 cmd = 4
goto 1
C left arrow
C FIG1
1002 goto ( 99 , 99 , 201 , 202 , 203 , 204 , 99 , 206 , 99 , 99 , 99 ,
* 99 , 99 , 99 , 250 , 14 , 14 , 14 , 14 , 99 , 99 , 99 , 99 , 22 )
* , cmd + 2
201 call undo ( 1 , 0 )
C row
ir = cwcn / wcol8 * wcol8
C get 1st wcn in row
continue
ic = 0
23042 if(.not.(ic.lt.wcol8))goto 23044
C loop over all cols in row
call wcnz ( ir + ic , fmode )
23043 ic=ic+1
goto 23042
23044 continue
goto 252
202 call undo ( 1 , 0 )
C column
ic = mod ( cwcn , wcol8 )
C get column #
continue
ir = 0
23045 if(.not.(ir.lt.wrow10))goto 23047
C loop over all rows
call wcnz ( ir * wcol8 + ic , fmode )
23046 ir=ir+1
goto 23045
23047 continue
goto 252
203 fig = 1
msg = 58
goto 251
C @58 Other endpoint of line
204 fig = 2
msg = 59
goto 251
C @59 Other corner of box
206 fig = 3
msg = 59
C goto 251
251 state = 3
C enter FIG2 state
point1 = cwcn
C remember first point
goto 23010
252 call undo ( 2 , 0 )
C clear at next modification
250 state = 1
C figure processing complete
msg = 1
C clear message
xmode = nmode
C want to show move mode
goto 141
C go update mode display
C FIG2
1003 goto ( 99 , 99 , 1 , 1 , 1 , 1 , 5 , 1 , 1 , 1 , 1 , 310 , 99 , 99
* , 250 , 14 , 14 , 14 , 14 , 18 , 19 , 20 , 21 , 22 ) , cmd + 2
310 call undo ( 1 , 0 )
C have 2nd point ot line/box/sbox
goto ( 3001 , 3002 , 3003 ) , fig
C dispatch according to fig type
3001 call zline ( point1 , cwcn , fmode )
goto 252
3002 call zbox ( point1 , cwcn , fmode )
goto 252
3003 call zsbox ( point1 , cwcn , fmode )
goto 252
99 if(.not.( sv ( sx ( 2 ) ) .eq. 63 ))goto 23048
call emenu
23048 continue
C give menu if "?" typed
C end of editing session: clean up and return to command level
goto 23010
23011 continue
22 call lmode ( 1 )
C back to SC0
if(.not.( siz .eq. 1 ))goto 23050
C single-character edit?
mosmat ( dorow , docol ) = savch
C yes, restore borrowed character
if(.not.( sava3 .ne. 0 ))goto 23052
call seta3 ( sava3 )
23052 continue
C restore mosaic display in area 3
call windim ( 3 , 3 , rmul , cmul )
C put window back in 3 X 3 mode
23050 continue
end
C emenu - draw edit-mode keypad menu in area 3
subroutine emenu
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 NKPV is the number of vectors in keypad grid
integer k ( 19 )
C elements of "k": (direction * 10) + (magnitude / (60 vert or 99 horiz))
C directions: 1 right, 2 up, 3 left, 4 down
data k ( 1 ) , k ( 2 ) , k ( 3 ) , k ( 4 ) , k ( 5 ) , k ( 6 ) , k
* ( 7 ) , k ( 8 ) / 35 , 04 , 15 , 21 , 35 , 21 , 15 , 21 /
data k ( 9 ) , k ( 10 ) , k ( 11 ) , k ( 12 ) , k ( 13 ) , k ( 14
*) , k ( 15 ) / 34 , 02 , 23 , 11 , 04 , 11 , 24 /
data k ( 16 ) , k ( 17 ) , k ( 18 ) , k ( 19 ) / 11 , 04 , 11 , 24
* /
a3x = 2
C arrange to have area 3 regenerated on next command
call clr ( 3 , 6 )
C clear area 3
call posgc ( 305 , 8 + 37 * 9 , 8 + 180 )
call pr0 ( 30 )
C @30 w(s0)t[+0,+17](a0,s1)'FIGURE'
call posgc ( 305 , 4 , 8 )
call pr0 ( 31 )
C @31 t[+9,+0]'NO-CHANGE FLIP ERASE DRAW'
call posgc ( 305 , 4 + 12 * 9 , 8 + 120 )
call wrtstr ( 32 )
C @32 FLIP 1
call posgc ( 305 , 4 + 3 * 9 , 32 + 120 )
call wrtstr ( 33 )
C @33 BOX CELL SOLID-BOX
call posgc ( 305 , 4 + 3 * 9 , 32 + 180 )
call wrtstr ( 34 )
C @34 ROW COLUMN LINE
call posgc ( 305 , 4 + 24 * 9 , 8 + 240 )
call wrtstr ( 35 )
C @35 UNDO/
call posgc ( 305 , 4 + 24 * 9 , 32 + 240 )
call wrtstr ( 36 )
C @36 CANCEL
C draw the grid (a series of vectors)
call posgc ( 305 , 0 , 0 )
call putc ( 118 )
C v is for vector
continue
i = 1
23054 if(.not.(i.le.19))goto 23056
call putc ( 91 )
dir = k ( i ) / 10
C direction
mag = k ( i )
mag = mod ( mag , 10 )
C magnitude
if(.not.( dir .eq. 1 .or. dir .eq. 3 ))goto 23057
C which axis?
call putc ( 44 )
C Y
mag = mag * 60
C vertical multiplier
goto 23058
23057 continue
mag = mag * 99
23058 continue
C X
if(.not.( dir .eq. 1 .or. dir .eq. 2 ))goto 23059
call putc ( 45 )
goto 23060
23059 continue
call putc ( 43 )
23060 continue
call putdec ( mag , 0 , 0 )
C write vector length
call putc ( 93 )
C draw arrows on keys 7,8,9,4,6,1,2,3 (in that order)
23055 i=i+1
goto 23054
23056 continue
call posgc ( 305 , 5 * 9 , 8 + 60 + 10 )
call pr0 ( 38 )
C @38 v[,-10][+10][-10][+14,+14]
call posgc ( 305 , 16 * 9 - 3 , 8 + 60 + 7 )
call pr0 ( 39 )
C @39 v[+7,-7][,+14][,-14][+7,+7]
call posgc ( 305 , 27 * 9 , 8 + 60 )
call pr0 ( 40 )
C @40 v[+10][,+10][,-10][-14,+14]
call posgc ( 305 , 5 * 9 + 7 , 8 + 120 )
call pr0 ( 41 )
C @41 v[-7,+7][+14][-14][+7,+7]
call posgc ( 305 , 27 * 9 , 8 + 120 )
call pr0 ( 42 )
C @42 v[+7,+7][-14][+14][-7,+7]
call posgc ( 305 , 5 * 9 , 8 + 180 + 4 )
call pr0 ( 43 )
C @43 v[,+10][+10][-10][+14,-14]
call posgc ( 305 , 16 * 9 - 3 , 8 + 180 + 4 )
call pr0 ( 44 )
C @44 v[+7,+7][,-14][,+14][+7,-7]
call posgc ( 305 , 27 * 9 , 8 + 180 )
call pr0 ( 45 )
C @45 v[+14,+14][-10][+10][,-10]
call fonta
C switch back to alternate font
end
C stcwcn - set current wcn (for positioning graphics cursor)
C new: new wcn
subroutine stcwcn ( new )
implicit integer ( a - z )
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 .true. if characters changed since last write
if(.not.( new .ge. 0 ))goto 23061
C must be valid
cwcn = new
C set current wcn
call anlz ( cwcn , cmrow , ccrow , cmcol , cccol )
C split it up
23061 continue
end
C undo - support undo command
C func: UNCLR - clear memory
C UNCLRD - same as UNCLR, but deferred until next UNSVFM call
C UNUNDO - restore saved values and clear memory
C UNSVFM - save definition of character from fmat
C arg: if func = UNSVFM, arg is character to save
C for func = UNUNDO, returns 1 if something undone, else 0
integer function undo ( func , arg )
implicit integer ( a - z )
C size of saved character stacks
C should be WROW * WCOL + 1
integer ufch ( 10 )
C characters that were changed
integer udef ( 10 , 10 )
C definitions of characters, parallel to ufch
integer tmp
logical defer
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.
undo = 0
C assume nothing to undo
goto ( 201 , 202 , 203 , 204 ) , func
C dispatch according to function
C UNCLRD
202 defer = . true .
C request deferred undoing
goto 300
C UNUNDO
203 continue
i = 1
23063 if(.not.(ufch(i).ne.0))goto 23065
C loop once per saved char
ch = ufch ( i ) - 30
C get subscript for fmat, fmatc
C swap fmat entry with udef entry, so if the user says
C "undo" again, the last "undo" will be undone
continue
i1 = 1
23066 if(.not.(i1.le.10))goto 23068
tmp = fmat ( ch , i1 )
fmat ( ch , i1 ) = udef ( i , i1 )
udef ( i , i1 ) = tmp
23067 i1=i1+1
goto 23066
23068 continue
fmatc ( ch ) = 1
C mark character as changed
undo = 1
C something restored
23064 i=i+1
goto 23063
23065 continue
goto 300
C UNCLR
201 ufch ( 1 ) = 0
C no saved definitions
defer = . false .
goto 300
C UNSVFM
204 if(.not.( defer ))goto 23069
ufch ( 1 ) = 0
defer = . false .
C clear if deferred
23069 continue
continue
i = 1
23071 if(.not.(ufch(i).ne.0))goto 23073
C char already stacked?
if(.not.( ufch ( i ) .eq. arg ))goto 23074
goto 300
23074 continue
23072 i=i+1
goto 23071
23073 continue
C yes, return
ufch ( i ) = arg
C no, add to stack
ufch ( i + 1 ) = 0
C tie off stack again
continue
i1 = 1
23076 if(.not.(i1.le.10))goto 23078
C make a copy of the definition
udef ( i , i1 ) = fmat ( arg - 30 , i1 )
23077 i1=i1+1
goto 23076
23078 continue
300 continue
end
C wcnz - examine or change window cell
C wcn: window cell #
C func: 0 examine (function returns current setting, 0 or 1),
C 1 complement, 2 clear, 3 set
integer function wcnz ( wcn , func )
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 .true. if characters changed since last write
call anlz ( wcn , tmrow , tcrow , tmcol , tccol )
C get rows and columns
ch = mosmat ( tmrow , tmcol ) - 30
C get character from mosaic
fme = fmat ( ch , tcrow )
C get char row containing wcn
bit = 2 * * ( 8 - tccol )
C get bit in row
if(.not.( func .eq. 0 ))goto 23079
C func 0... return setting
wcnz = 0
C assume off
if(.not.( iand ( fme , bit ) .ne. 0 ))goto 23081
wcnz = 1
23081 continue
C wrong, it's on
goto 23080
23079 continue
call undo ( 4 , ch + 30 )
C save old definition for undo
fme1 = fme
C remember original value
goto ( 201 , 202 , 203 ) , func
C dispatch
201 fme = ieor ( fme , bit )
C complement
goto 210
202 fme = iand ( fme , ieor ( bit , 255 ) )
C clear
goto 210
203 fme = ior ( fme , bit )
C set
C goto 210
210 if(.not.( fme1 .ne. fme ))goto 23083
C has it changed?
fmat ( ch , tcrow ) = fme
C yes, update fmat
fmatc ( ch ) = 1
C this char changed
quitf = . true .
C some char has changed
23083 continue
23080 continue
end
C zbox - draw box given opposite corners
C w1,w2: wcn's of corners
C mode: 1 change, 2 erase, 3 draw
subroutine zbox ( w1 , w2 , mode )
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.
ir = w2 / wcol8 - w1 / wcol8
C get row difference
ic = mod ( w2 , wcol8 ) - mod ( w1 , wcol8 )
C get column difference
if(.not.( ir .ne. 0 .and. ic .ne. 0 ))goto 23085
C a real box?
ir1 = 1
if(.not.( ir .gt. 0 ))goto 23087
ir1 = - 1
23087 continue
C yes
ir1 = ( ir + ir1 ) * wcol8
ir = ir * wcol8
ic1 = ic + 1
if(.not.( ic .gt. 0 ))goto 23089
ic1 = ic - 1
23089 continue
call zline ( w1 , w1 + ic1 , mode )
call zline ( w1 + ic , w1 + ic + ir1 , mode )
call zline ( w2 , w2 - ic1 , mode )
call zline ( w2 - ic , w2 - ic - ir1 , mode )
goto 23086
23085 continue
call zline ( w1 , w2 , mode )
23086 continue
C degenerate case
end
C zline - draw line between 2 wcns
subroutine zline ( w1 , w2 , mode )
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.
ir = w2 / wcol8 - w1 / wcol8
C row distance
ic = mod ( w2 , wcol8 ) - mod ( w1 , wcol8 )
C column distance
ns = max0 ( iabs ( ir ) , iabs ( ic ) )
C compute # of points in line
continue
i = 0
23091 if(.not.(i.le.ns))goto 23093
C loop once per point
wx = w1 + ir * i / ns * wcol8 + ic * i / ns
call wcnz ( wx , mode )
23092 i=i+1
goto 23091
23093 continue
end
C zsbox - draw solid box given opposite corners
subroutine zsbox ( wcn1 , wcn2 , mode )
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.
w1 = wcn1
w2 = wcn2
C private copies
continue
23094 continue
C get w1 and w2 in proper order
ir = w1
w1 = w2
w2 = ir
C swap
ir = w2 / wcol8 - w1 / wcol8
C row distance
ic = mod ( w2 , wcol8 ) - mod ( w1 , wcol8 )
C column distance
23095 if(.not.( ir .ge. 0 ))goto 23094
23096 continue
continue
23097 if(.not.( ir .ge. 0 ))goto 23098
C draw box 1 line at a time
ir = ir - 1
C count 'em down
call zline ( w1 , w1 + ic , mode )
w1 = w1 + wcol8
C step to next row
goto 23097
23098 continue
end