Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/icmdv.for
There are no other files named icmdv.for in the archive.
C icmdv> ReGIS input -- parse "V" command
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 ========================================================================
C Error code definitions for imerr subroutine
C These represent errors detected while reading a ReGIS file
C gel vector overflow
C Illegal syntax in W command
C Illegal syntax in P option of W command
C Illegal [x,y] coordinate specification
C Macrograph defined or deleted within a macrograph
C Illegal character after @
C Attempt to define non-alpha macrograph
C Macrograph storage exhausted
C Macrograph calls nested too deeply
C Illegal syntax in L command
C Illegal syntax in R command
C Illegal syntax in S command
C Illegal syntax in V command
C Illegal syntax in P command
C Illegal syntax in C command
C Illegal syntax in T command
C fewer than 2 points in closed curve
C fewer than 3 points in open curve
C C(B) or C(S) terminated prematurely
C Illegal label or object name
C ;"}" found and no object was open
C Eof hit and open object(s) exist
C Putbak error - not your fault
C Too many points in line
C Too many points in curve
C How I translate the V command:
C
C If a paired B and E are separated by only position specifications
C (i.e., pixel vectors and bracketed coordinates), they will translate
C to a ClosedLines primitive. The rest of the cases become OpenLines.
C Appearance of any option (B,E,S,W) termiantes the current primitive.
C A primitive is generated when the first position spec is seen; thus
C a lone V gathers no gelly.
C
C A few examples:
C
C V(B)[+100,+100](B)[-442,+239][+127,+38](E)[60,20][25,22](E)
C \ /\ /\ /
C --- Open --- --------- Closed -------- ---- Open -----
C
C V[507,+79][511,+79](W(I3))[531,+45][-27,106]
C \ / \ /
C ----- Open ------ ----- Open -----
C cmdv - process "V" command
subroutine cmdv
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
C cram> GIGI "RAM" common
C size of coordinate stack (P,V,C commands)
integer prmtop ( 10 )
C permanent text options
integer wrkwop ( 10 )
C filled in by rdwopt
integer prmwop ( 10 )
C permanent writing options
integer tmpwop ( 10 )
C temporary writing options
integer xpos , ypos
C coordinates of current cursor position
integer xystak ( 10 , 2 )
C coordinate stack (P,V commands)
integer xysp
C coordinate stack pointer
integer cdum
C garbage argument for rdpos
common / cram / prmtop , wrkwop , prmwop , tmpwop , xpos , ypos ,
*xystak , xysp , cdum
common / vcomn / npts , startg , vtype
C for talking to vcls
integer ch , dum , gel1 , gel2 , i , kterm , rdpos , tstxy
integer npts
C number of points
integer startg
C gel subscript where primitive begins
integer vtype
C type of primitive (OpenLines or ClosedLines)
integer xi , yi
C coordinates of first point
logical twopfl
C .true. if W option scanned
vtype = 1
C assume open lines
npts = - 1
C nothing drawn yet
twopfl = . false .
C W not seen yet
C scan next element of V command, either position spec or (options)
continue
23000 continue
xi = xpos
yi = ypos
C save current position
if(.not.( rdpos ( xpos , ypos ) .ne. 0 ))goto 23003
C position spec?
if(.not.( npts .lt. 0 ))goto 23005
C yes, started primitive?
C not yet, reserve space for geltype
startg = gel1 ( 0 )
dum = gel2 ( xi , yi )
C 1st XY pair
dum = gel1 ( 0 )
C space for # of points
npts = 0
C if V[] case, suppress duplicate point
23005 continue
if(.not.( npts .gt. 1 .or. xi .ne. xpos .or. yi .ne. ypos ))goto 2
*3007
if(.not.( npts .lt. 300 - 1 ))goto 23009
dum = gel2 ( xpos , ypos )
23009 continue
if(.not.( npts .eq. 300 - 1 ))goto 23011
call imerr ( 24 )
23011 continue
npts = npts + 1
23007 continue
goto 23001
23003 continue
call gnbc ( ch )
if(.not.( kterm ( ch ) .ne. 0 ))goto 23013
C end of V command?
C yes, check for another V command and parse it
C only if the previous V set no temp writing options
if(.not.( ch .eq. 118 .and. ( . not . twopfl ) ))goto 23015
goto 23001
C OK to do V
goto 23016
23015 continue
C can't continue
call putbak ( ch )
C put it back
goto 23002
C wrap up V command
23016 continue
23013 continue
if(.not.( ch .eq. 40 ))goto 23017
C option list?
continue
23019 continue
C yes
call gnbc ( ch )
C get next option
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23022
goto 23021
C end of options
23022 continue
if(.not.( ch .eq. 98 ))goto 23024
C B ?
call vcls ( 1 )
C yes, close current prim
call pushxy
C put current XY on stack
vtype = 2
C bounded vectors
goto 23025
23024 continue
if(.not.( ch .eq. 101 ))goto 23026
C E ?
i = tstxy ( 0 )
C yes, look at stack
call popxy
C get stacked XY back
C did the user originally say V(B) (ClosedLines)
C and then make me change my mind to OpenLines?
if(.not.( i .gt. 0 .and. vtype .ne. 2 ))goto 23028
C yes, then I have to close it by hand
dum = gel2 ( xpos , ypos )
npts = npts + 1
23028 continue
call vcls ( vtype )
C wrap up primitive
goto 23027
23026 continue
if(.not.( ch .eq. 115 ))goto 23030
C S ?
call vcls ( 1 )
C yes, close current prim
call nullxy
C null entry on stack
vtype = 1
C unbounded vectors
goto 23031
23030 continue
if(.not.( ch .eq. 119 ))goto 23032
C W ?
call vcls ( 1 )
C yes, close current prim
call scantw
C do temp writing options
twopfl = . true .
C remember W seen
goto 23033
23032 continue
if(.not.( ch .ne. 44 ))goto 23034
C comma?
call imerr ( 13 )
C no, signal bad V option
call cfind ( 41 )
C skip to ) or Sync
goto 23021
23034 continue
23033 continue
23031 continue
23027 continue
23025 continue
23020 goto 23019
23021 continue
goto 23018
23017 continue
call imerr ( 13 )
23018 continue
C not pos spec or (
23001 goto 23000
23002 continue
call vcls ( 1 )
C close primitive if any
end
C vcls - if vcmd has begun creating the gelly for a Lines primitive,
C wrap it up; inputs are from vcomn
subroutine vcls ( typ )
integer typ
C type of primitive (OpenLines or ClosedLines)
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
common / vcomn / npts , startg , vtype
integer npts , startg , vtype
if(.not.( npts .ge. 0 ))goto 23036
C any output?
if(.not.( goflo .eq. 0 ))goto 23038
gel ( startg ) = typ
C yes, store primitive type
npts = min0 ( npts , 300 - 1 )
C get actual number of points
gel ( startg + 3 ) = npts
C store # of points
23038 continue
npts = - 1
C set no primitive in progress
vtype = 1
C default for next Lines primitive
call v2box ( startg )
C convert to Boxgel if possible
23036 continue
end
C v2box - given an OpenLines or ClosedLines primitive, determine
C if it falls into the special case of "box". If so,
C replace the Lines gel with a Boxgel
subroutine v2box ( start )
integer start
C subscript of gel where the Lines gel begins
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
integer h , w
C height, width
integer npts
C number of points in Lines gel
integer x1 , y1 , x2 , y2 , x3 , y3 , x4 , y4
C coordinates of corners of box
integer i , temp
if(.not.( goflo .ne. 0 ))goto 23040
return
23040 continue
C don't mess if there was an overflow
npts = 3
C assume ClosedLines
if(.not.( gel ( start ) .eq. 1 ))goto 23042
npts = 4
23042 continue
C OpenLines
if(.not.( gel ( start + 3 ) .ne. npts ))goto 23044
return
23044 continue
C check number of points
x1 = gel ( start + 1 )
y1 = gel ( start + 2 )
x2 = gel ( start + 4 )
y2 = gel ( start + 5 )
x3 = gel ( start + 6 )
y3 = gel ( start + 7 )
x4 = gel ( start + 8 )
y4 = gel ( start + 9 )
C try various permutations of points 1-4, looking for
C
C 1---------------2
C | |
C | |
C 4---------------3
i = 8
C 8 possible combinations
continue
23046 continue
i = i - 1
if(.not.( i .eq. 3 ))goto 23049
C time for mirror-image
temp = x2
x2 = x4
x4 = temp
temp = y2
y2 = y4
y4 = temp
goto 23050
23049 continue
C just rotate
temp = x1
x1 = x2
x2 = x3
x3 = x4
x4 = temp
temp = y1
y1 = y2
y2 = y3
y3 = y4
y4 = temp
23050 continue
if(.not.( y1 .ne. y2 .or. x2 .ne. x3 .or. y3 .ne. y4 ))goto 23051
goto 23047
23051 continue
w = x2 - x1
C compute width
h = y3 - y2
C compute height
if(.not.( w .le. 0 .or. h .le. 0 .or. x3 - x4 .ne. w ))goto 23053
goto 23047
C must both be positive
C we've got us a box here
23053 continue
continue
i = npts * 2 + 4
23055 if(.not.(i.gt.0))goto 23057
call geld1
23056 i=i-1
goto 23055
23057 continue
C delete Lines gel
call gel1 ( 5 )
C create gel for box
call gel2 ( x1 , y1 )
C coords of upper-left corner
call gel2 ( w , h )
C width, height
return
23047 if(.not.( i .eq. 0 ))goto 23046
23048 continue
C the points are not in a rectangle, no action taken
end