Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/alter1.for
There are no other files named alter1.for in the archive.
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
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 define char byte
C 27+128
C w(riting) opt(ion)s come groups of 8:
C (1) replace(0)/erase(1)/complement(2)/overlay(3)
C (2) negative image 0/1
C (3) pattern < 256 bit mask (e.g. 192 = P11000000)
C >= 256 canned pattern * 256 (e.g. 512 = P2)
C if value >= 256, low 8 bits are ignored
C (4) pattern multiplier, different from 6(?)
C (5) shading flag, sim pattern+ >= 10 use char
C (6) if shading != 0 this is y reference val
C (7) pixel multiplier, 1 <= value <= 10
C (8) alternating 0/1
C (9) foreground intensity, 0 <= value <= 7
C (10) background intensity, 0 <= value <= 7
C
C offsets from gwopsp...
C Inktypes...
C Inkolors...
C Text options
C RSTSONLY define Maxgels 1000 # due to limited RAM on RSTS
C drawing primitive gels...
C attribute/marker/other gels...
C writing attribute gels : Woptbase + wopindex
C similarly topts...
C maximum # of characters in a filespec
C maximum # of characters in a command line
C max length of prompt buffer
C max number of characters in file record
C size of record buffers (Fbufsz + 1)
C include logdef
C ========================================================================
C ========================================================================
integer function alter1 ( p0 , pn )
integer p0 , pn
common / glopts / wrtopt , wrtcrv , wrtlin , wrtbox , wrtcir , wrt
*txt , txtopt , gwopsp , gwop , ttytop
integer wrtopt ( 10 ) , wrtcrv ( 10 ) , wrtlin ( 10 ) , wrtbox ( 1
*0 )
integer wrtcir ( 10 ) , wrttxt ( 10 ) , txtopt ( 6 ) , ttytop ( 6
*)
integer gwop ( 36 ) , gwopsp
C ^ should be Woplen*Maxwops
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
C RSTSONLY define Maxnotz 64 # due to limited RAM on RSTS
integer notx ( 300 ) , noty ( 300 ) , nnotz
integer cpx , cpy
integer cls
common / cnotz / cpx , cpy , nnotz , notx , noty , cls
integer x1 , y1 , wid , hgt , pf
common / cboxes / x1 , y1 , wid , hgt , pf
integer centx , centy , circx , circy , arc
common / ccircl / centx , centy , circx , circy , arc
integer strx , stry
integer ti
C tch allocation pointer
integer tch ( 128 )
common / ctext / strx , stry , ti , tch
integer ednotz , circle , boxes , text
integer strlen , lengel , insgel
integer lwop ( 10 ) , ltop ( 6 )
integer savwop ( 10 )
integer savtop ( 6 )
integer typ , i , j
integer pz , l0 , l1
integer adwopt , adtopt
integer cmd
C string mprmt Modify
integer mprmt ( 7 )
data mprmt ( 1 ) , mprmt ( 2 ) , mprmt ( 3 ) , mprmt ( 4 ) , mprmt
* ( 5 ) / 77 , 111 , 100 , 105 , 102 /
data mprmt ( 6 ) , mprmt ( 7 ) / 121 , 0 /
alter1 = 0
typ = gel ( p0 )
if(.not.( typ .le. 0 .or. typ .gt. 7 ))goto 23000
return
23000 continue
l0 = lengel ( p0 )
if(.not.( typ .ge. 1 .and. typ .le. 4 ))goto 23002
notx ( 1 ) = gel ( p0 + 1 )
noty ( 1 ) = gel ( p0 + 2 )
nnotz = gel ( p0 + 3 ) + 1
j = p0 + 4
continue
i = 2
23004 if(.not.(i.le.nnotz))goto 23006
notx ( i ) = gel ( j )
noty ( i ) = gel ( j + 1 )
j = j + 2
23005 i=i+1
goto 23004
23006 continue
if(.not.( typ .eq. 1 .or. typ .eq. 3 ))goto 23007
cls = 115
goto 23008
23007 continue
cls = 98
23008 continue
if(.not.( typ .le. 2 ))goto 23009
cmd = 118
call copywo ( wrtlin , lwop , 10 )
goto 23010
23009 continue
cmd = 99
call copywo ( wrtcrv , lwop , 10 )
23010 continue
call sumopt ( p0 , lwop , ltop )
call copywo ( lwop , savwop , 10 )
if(.not.( ednotz ( cmd , lwop , mprmt ) .eq. 0 ))goto 23011
return
C call putc(Semicolon); call putc(Quote1); call putdec(nnotz); call putc(Quote1)
23011 continue
call rmgel ( p0 , p0 )
pz = p0
l1 = 0
C (zero length if no notz)
if(.not.( nnotz .gt. 0 ))goto 23013
C if all notz are gone, object is just deleted -- RJF
p0 = adwopt ( p0 , lwop )
l1 = 4 + 2 * ( nnotz - 1 )
if(.not.( insgel ( p0 , l1 ) .lt. 0 ))goto 23015
return
23015 continue
if(.not.( cmd .eq. 118 ))goto 23017
if(.not.( cls .eq. 115 ))goto 23019
typ = 1
goto 23020
23019 continue
typ = 2
23020 continue
goto 23018
23017 continue
if(.not.( cls .eq. 115 ))goto 23021
typ = 3
goto 23022
23021 continue
typ = 4
23022 continue
23018 continue
gel ( p0 ) = typ
gel ( p0 + 1 ) = notx ( 1 )
gel ( p0 + 2 ) = noty ( 1 )
gel ( p0 + 3 ) = nnotz - 1
j = p0 + 4
continue
i = 2
23023 if(.not.(i.le.nnotz))goto 23025
gel ( j ) = notx ( i )
gel ( j + 1 ) = noty ( i )
j = j + 2
23024 i=i+1
goto 23023
23025 continue
l1 = adwopt ( p0 + l1 , savwop ) - p0
23013 continue
goto 23003
23002 continue
if(.not.( typ .eq. 5 ))goto 23026
x1 = gel ( p0 + 1 )
y1 = gel ( p0 + 2 )
hgt = gel ( p0 + 4 )
wid = gel ( p0 + 3 )
call copywo ( wrtbox , lwop , 10 )
call sumopt ( p0 , lwop , ltop )
call copywo ( lwop , savwop , 10 )
if(.not.( boxes ( lwop , mprmt ) .eq. 0 ))goto 23028
return
23028 continue
pz = p0
call rmgel ( p0 , p0 )
p0 = adwopt ( p0 , lwop )
if(.not.( insgel ( p0 , 5 ) .lt. 0 ))goto 23030
return
23030 continue
gel ( p0 ) = 5
gel ( p0 + 1 ) = x1
gel ( p0 + 2 ) = y1
gel ( p0 + 4 ) = hgt
gel ( p0 + 3 ) = wid
l1 = adwopt ( p0 + 5 , savwop ) - p0
goto 23027
23026 continue
if(.not.( typ .eq. 6 ))goto 23032
centx = gel ( p0 + 1 )
centy = gel ( p0 + 2 )
circx = gel ( p0 + 3 )
circy = gel ( p0 + 4 )
arc = gel ( p0 + 5 )
call copywo ( wrtcir , lwop , 10 )
call sumopt ( p0 , lwop , ltop )
call copywo ( lwop , savwop , 10 )
if(.not.( circle ( lwop , mprmt ) .eq. 0 ))goto 23034
return
23034 continue
pz = p0
call rmgel ( p0 , p0 )
p0 = adwopt ( p0 , lwop )
if(.not.( insgel ( p0 , 6 ) .lt. 0 ))goto 23036
return
23036 continue
gel ( p0 ) = 6
gel ( p0 + 1 ) = centx
gel ( p0 + 2 ) = centy
gel ( p0 + 3 ) = circx
gel ( p0 + 4 ) = circy
gel ( p0 + 5 ) = arc
l1 = adwopt ( p0 + 6 , savwop ) - p0
goto 23033
23032 continue
C must be Textgel...
strx = gel ( p0 + 1 )
stry = gel ( p0 + 2 )
call cpystr ( gel ( p0 + 3 ) , tch )
ti = 1
call copywo ( wrttxt , lwop , 10 )
call sumopt ( p0 , lwop , txtopt )
call copywo ( lwop , savwop , 10 )
call copywo ( txtopt , savtop , 6 )
if(.not.( text ( lwop , mprmt ) .eq. 0 ))goto 23038
return
23038 continue
pz = p0
call rmgel ( p0 , p0 )
p0 = adtopt ( adwopt ( p0 , lwop ) , txtopt )
if(.not.( insgel ( p0 , 3 + strlen ( tch ) ) .lt. 0 ))goto 23040
return
23040 continue
gel ( p0 ) = 7
gel ( p0 + 1 ) = strx
gel ( p0 + 2 ) = stry
call cpystr ( tch , gel ( p0 + 3 ) )
l1 = adtopt ( adwopt ( p0 + 3 + strlen ( tch ) , savwop ) , txtopt
* ) - p0
23033 continue
23027 continue
23003 continue
pn = pn + p0 - pz + l1 - l0
alter1 = 1
return
end