Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/drprim.for
There are no other files named drprim.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 drwgel ( lo , hi , wheref )
integer lo , hi , wheref
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
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 cx , cy , relflg , sx , sy
common / compos / cx , cy
common / comrel / relflg
common / comsav / sx , sy
integer lengel
integer lwop ( 10 ) , ltop ( 6 )
integer p , j , n
integer opn , ord
integer waswop , wastop , wasbck
integer typ
if(.not.( hi .lt. lo ))goto 23000
return
23000 continue
call putwop
C force to current assumed wops (top of stack)
call puttop
C force to current assumed tops (ttytop)
call getwop ( lwop )
C copy current top of stack to lwop
call copywo ( txtopt , ltop , 6 )
C copy txtopt to ltop
call sumopt ( lo , lwop , ltop )
C gather latest of all options up to "lo"
if(.not.( wheref .gt. 0 ))goto 23002
C special wops for highlighting
lwop ( 1 ) = 2
lwop ( 9 ) = 8
23002 continue
call pushwo ( lwop )
C push wops, issues W command for differences
call newtop ( ltop )
C ... issue T command for text differences-RJF
wastop = 0
waswop = 0
wasbck = 0
continue
p = lo
23004 if(.not.(p.le.hi))goto 23006
typ = gel ( p )
if(.not.( waswop .ne. 0 .and. typ .lt. 127 ))goto 23007
call newwop ( lwop )
C issue W command for changes
waswop = 0
if(.not.( wasbck .ne. 0 ))goto 23009
C background color?
call bakolr ( lwop ( 10 ) )
wasbck = 0
23009 continue
23007 continue
if(.not.( wastop .ne. 0 .and. typ .lt. 127 ))goto 23011
call newtop ( ltop )
C issue T command for changes
wastop = 0
23011 continue
if(.not.( typ .gt. 255 .and. typ .le. 255 + 6 ))goto 23013
ltop ( typ - 255 ) = gel ( p + 1 )
C remember T option
wastop = 1
goto 23014
23013 continue
if(.not.( typ .gt. 127 .and. typ .le. 127 + 10 ))goto 23015
lwop ( typ - 127 ) = gel ( p + 1 )
C remember W option
waswop = 1
if(.not.( wheref .gt. 0 ))goto 23017
C force special wops for highlighting
lwop ( 1 ) = 2
lwop ( 9 ) = 8
23017 continue
if(.not.( typ - 127 .eq. 10 ))goto 23019
wasbck = 1
23019 continue
goto 23016
23015 continue
if(.not.( typ .eq. 7 ))goto 23021
C draw text
if(.not.( relflg .ne. 0 ))goto 23023
call savpos
23023 continue
call drwstr ( gel ( p + 3 ) , gel ( p + 1 ) , gel ( p + 2 ) )
if(.not.( relflg .ne. 0 ))goto 23025
call oldpos
23025 continue
goto 23022
23021 continue
if(.not.( typ .eq. 6 ))goto 23027
C draw circle
if(.not.( relflg .ne. 0 ))goto 23029
call savpos
23029 continue
call drcirc ( gel ( p + 1 ) , gel ( p + 2 ) , gel ( p + 3 ) , gel
*( p + 4 ) , gel ( p + 5 ) )
if(.not.( relflg .ne. 0 ))goto 23031
call oldpos
23031 continue
goto 23028
23027 continue
if(.not.( typ .eq. 5 ))goto 23033
C draw box
call drwbox ( gel ( p + 1 ) , gel ( p + 2 ) , gel ( p + 3 ) , gel
*( p + 4 ) )
goto 23034
23033 continue
if(.not.( typ .ge. 1 .and. typ .le. 4 ))goto 23035
C draw figure
if(.not.( relflg .ne. 0 .and. ( typ .eq. 3 .or. typ .eq. 4 ) ))got
*o 23037
call savpos
23037 continue
if(.not.( typ .eq. 1 .or. typ .eq. 2 ))goto 23039
ord = 118
goto 23040
23039 continue
ord = 99
23040 continue
if(.not.( typ .eq. 1 .or. typ .eq. 3 ))goto 23041
opn = 115
goto 23042
23041 continue
opn = 98
23042 continue
notx ( 1 ) = gel ( p + 1 )
noty ( 1 ) = gel ( p + 2 )
j = p + 4
continue
n = 2
23043 if(.not.(n-1.le.gel(p+3)))goto 23045
notx ( n ) = gel ( j )
noty ( n ) = gel ( j + 1 )
j = j + 2
23044 n=n+1
goto 23043
23045 continue
call drnotz ( ord , opn , 0 , gel ( p + 3 ) + 1 , notx , noty )
if(.not.( typ .eq. 2 ))goto 23046
call setpos ( gel ( p + 1 ) , gel ( p + 2 ) )
23046 continue
C closed lines return to beginnings
if(.not.( relflg .ne. 0 .and. ( typ .eq. 3 .or. typ .eq. 4 ) ))got
*o 23048
call oldpos
23048 continue
goto 23036
23035 continue
if(.not.( typ .eq. 11 ))goto 23050
call drmark ( 0 , gel ( p + 1 ) )
goto 23051
23050 continue
if(.not.( typ .eq. 12 ))goto 23052
call drmark ( 123 , gel ( p + 1 ) )
goto 23053
23052 continue
if(.not.( typ .eq. 13 ))goto 23054
call drmark ( 125 , 0 )
goto 23055
23054 continue
if(.not.( typ .eq. 10 ))goto 23056
call erase ( lwop ( 10 ) )
goto 23057
23056 continue
if(.not.( typ .eq. ( - 1 ) ))goto 23058
call putcha ( gel ( p + 1 ) )
23058 continue
23057 continue
23055 continue
23053 continue
23051 continue
23036 continue
23034 continue
23028 continue
23022 continue
23016 continue
23014 continue
23005 p=p+lengel(p)
goto 23004
23006 continue
call popwo
relflg = 0
drwgel = 0
return
end
integer function drnotz ( ord , opn , ancf , n , notx , noty )
integer ord , opn
integer ancf , n , notx ( 1 ) , noty ( 1 )
integer i
C string txc (e)
C string txcte (e)t(e)
C string txo t(b,i0,d0,s[16,20],m[2,2],a0)
C string ebrack []
C string duck p(b)t'^'p(e)
C string ptsep \n\
integer txc ( 4 )
integer txcte ( 8 )
integer txo ( 30 )
integer ebrack ( 3 )
integer duck ( 13 )
integer ptsep ( 3 )
data txc ( 1 ) , txc ( 2 ) , txc ( 3 ) , txc ( 4 ) / 40 , 101 , 41
* , 0 /
data txcte ( 1 ) , txcte ( 2 ) , txcte ( 3 ) , txcte ( 4 ) , txcte
* ( 5 ) / 40 , 101 , 41 , 116 , 40 /
data txcte ( 6 ) , txcte ( 7 ) , txcte ( 8 ) / 101 , 41 , 0 /
data txo ( 1 ) , txo ( 2 ) , txo ( 3 ) , txo ( 4 ) , txo ( 5 ) / 1
*16 , 40 , 98 , 44 , 105 /
data txo ( 6 ) , txo ( 7 ) , txo ( 8 ) , txo ( 9 ) , txo ( 10 ) /
*48 , 44 , 100 , 48 , 44 /
data txo ( 11 ) , txo ( 12 ) , txo ( 13 ) , txo ( 14 ) , txo ( 15
*) / 115 , 91 , 49 , 54 , 44 /
data txo ( 16 ) , txo ( 17 ) , txo ( 18 ) , txo ( 19 ) , txo ( 20
*) / 50 , 48 , 93 , 44 , 109 /
data txo ( 21 ) , txo ( 22 ) , txo ( 23 ) , txo ( 24 ) , txo ( 25
*) / 91 , 50 , 44 , 50 , 93 /
data txo ( 26 ) , txo ( 27 ) , txo ( 28 ) , txo ( 29 ) , txo ( 30
*) / 44 , 97 , 48 , 41 , 0 /
data ebrack ( 1 ) , ebrack ( 2 ) , ebrack ( 3 ) / 91 , 93 , 0 /
data duck ( 1 ) , duck ( 2 ) , duck ( 3 ) , duck ( 4 ) , duck ( 5
*) / 112 , 40 , 98 , 41 , 116 /
data duck ( 6 ) , duck ( 7 ) , duck ( 8 ) , duck ( 9 ) , duck ( 10
* ) / 39 , 94 , 39 , 112 , 40 /
data duck ( 11 ) , duck ( 12 ) , duck ( 13 ) / 101 , 41 , 0 /
data ptsep ( 1 ) , ptsep ( 2 ) , ptsep ( 3 ) / 10 , 32 , 0 /
drnotz = 0
if(.not.( n .lt. 1 ))goto 23060
return
23060 continue
if(.not.( ancf .ne. 0 ))goto 23062
call putcha ( txo )
continue
i = 1
23064 if(.not.(i.le.n))goto 23066
call positn ( notx ( i ) - 10 , noty ( i ) - 2 )
call putcha ( duck )
23065 i=i+1
goto 23064
23066 continue
call putcha ( txcte )
23062 continue
call positn ( notx ( 1 ) , noty ( 1 ) )
call putc ( ord )
call putc ( 40 )
call putc ( opn )
call putc ( 41 )
if(.not.( n .lt. 2 .or. ( ord .eq. 99 .and. opn .ne. 98 ) ))goto 2
*3067
call putcha ( ebrack )
23067 continue
continue
i = 2
23069 if(.not.(i.le.n))goto 23071
call putcha ( ptsep )
call putpos ( notx ( i ) , noty ( i ) )
23070 i=i+1
goto 23069
23071 continue
if(.not.( n .lt. 2 .or. ( ord .eq. 99 .and. opn .ne. 98 ) ))goto 2
*3072
call putcha ( ebrack )
23072 continue
call putcha ( txc )
return
end
integer function drcirc ( cx , cy , rx , ry , a )
integer cx , cy , rx , ry , a
call positn ( cx , cy )
call putc ( 99 )
if(.not.( a .lt. 360 ))goto 23074
call putc ( 40 )
call putc ( 97 )
call putdec ( a )
call putc ( 41 )
23074 continue
call putpos ( rx , ry )
drcirc = 0
return
end
integer function drline ( x1 , y1 , x2 , y2 )
integer x1 , y1 , x2 , y2
drline = 0
call positn ( x1 , y1 )
call putc ( 118 )
call putpos ( x2 , y2 )
return
end
integer function drwbox ( ulx , uly , wid , hgt )
integer ulx , uly , wid , hgt
C string dbs1 \np
C string dbs2 v(b)[+
C string dbs3 ][,+
C string dbs4 ][-
C string dbs5 ](e)
integer dbs1 ( 3 )
integer dbs2 ( 7 )
integer dbs3 ( 5 )
integer dbs4 ( 4 )
integer dbs5 ( 5 )
data dbs1 ( 1 ) , dbs1 ( 2 ) , dbs1 ( 3 ) / 10 , 112 , 0 /
data dbs2 ( 1 ) , dbs2 ( 2 ) , dbs2 ( 3 ) , dbs2 ( 4 ) , dbs2 ( 5
*) / 118 , 40 , 98 , 41 , 91 /
data dbs2 ( 6 ) , dbs2 ( 7 ) / 43 , 0 /
data dbs3 ( 1 ) , dbs3 ( 2 ) , dbs3 ( 3 ) , dbs3 ( 4 ) , dbs3 ( 5
*) / 93 , 91 , 44 , 43 , 0 /
data dbs4 ( 1 ) , dbs4 ( 2 ) , dbs4 ( 3 ) , dbs4 ( 4 ) / 93 , 91 ,
* 45 , 0 /
data dbs5 ( 1 ) , dbs5 ( 2 ) , dbs5 ( 3 ) , dbs5 ( 4 ) , dbs5 ( 5
*) / 93 , 40 , 101 , 41 , 0 /
call putcha ( dbs1 )
call putpos ( ulx , uly )
call putcha ( dbs2 )
call putdec ( wid )
call putcha ( dbs3 )
call putdec ( hgt )
call putcha ( dbs4 )
call putdec ( wid )
call putcha ( dbs5 )
drwbox = 0
return
end
integer function drwstr ( str , x , y )
integer str ( 1 )
integer x , y
integer i
call positn ( x , y )
call putc ( 116 )
call putc ( 39 )
continue
i = 1
23076 if(.not.(str(i).ne.0))goto 23078
call putc ( str ( i ) )
if(.not.( str ( i ) .eq. 39 ))goto 23079
call putc ( 39 )
23079 continue
23077 i=i+1
goto 23076
23078 continue
call putc ( 39 )
drwstr = 0
return
end
integer function drmark ( c , str )
integer c , str ( 1 )
C string opn \n;"
integer opn ( 4 )
data opn ( 1 ) , opn ( 2 ) , opn ( 3 ) , opn ( 4 ) / 10 , 59 , 34
*, 0 /
drmark = 0
call putcha ( opn )
if(.not.( str ( 1 ) .ne. 0 ))goto 23081
call putc ( 58 )
23081 continue
call putcha ( str )
if(.not.( c .ne. 0 ))goto 23083
call putc ( c )
23083 continue
call putc ( 34 )
return
end