Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/icmdc.for
There are no other files named icmdc.for in the archive.
C icmdc> ReGIS input -- parse "C" command (curves, circles)
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 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 ClosedCurves primitive. The rest of the cases become OpenCurves.
C to a ClosedCurves primitive. Forms like
C C(B)[50,50]W(S1)[30,30](E)
C are split into 2 OpenCurves primitives, because there is no gelly
C facility to change writing options in the middle of a curve.
C Appearance of any option (B,E,S,W) terminates the current primitive.
C cmdc - process "C" command
subroutine cmdc
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 / ccomn / npts , startg , ctype , darc , optc
C for talking to ccls
integer npts
C number of points
integer startg
C gel subscript where primitive begins
integer ctype
C type of primitive (OpenCurves or ClosedCurves)
integer darc
C degrees of arc for circle (-360 <= darc <= 360)
logical optc
C circle has current position on circumference
integer ch , dum , gel1 , gel2 , kgnum , kterm , rdpos
integer x1 , y1
logical twopfl
C .true. if W option scanned
ctype = 6
C no (S) or (B) yet
npts = - 1
C nothing drawn yet
twopfl = . false .
C W not seen yet
darc = 360
C reset to full circle
optc = . false .
C C(C) not in effect
C scan next element of C command, either position spec or (options)
continue
23000 continue
x1 = xpos
y1 = ypos
C get current position
if(.not.( rdpos ( x1 , y1 ) .ne. 0 ))goto 23003
C position spec?
if(.not.( ctype .eq. 6 ))goto 23005
C yes, doing circle?
if(.not.( optc ))goto 23007
C yes, where is center?
C center is x1,y1
dum = gel2 ( 6 , x1 )
dum = gel2 ( y1 , xpos )
dum = gel2 ( ypos , darc )
call cmfxy ( x1 , y1 , darc )
C get new xpos,ypos
C Warning: if abs(darc) != 360, xpos and
C ypos may be slightly wrong
goto 23008
23007 continue
C center is the current cursor position
dum = gel2 ( 6 , xpos )
dum = gel2 ( ypos , x1 )
dum = gel2 ( y1 , darc )
23008 continue
goto 23001
C position spec seen while doing Open or Closed Curves
23005 continue
if(.not.( ctype .eq. 3 ))goto 23009
C open curves?
if(.not.( npts .lt. 0 ))goto 23011
C started primitive?
C not yet, reserve space for geltype
startg = gel1 ( 0 )
dum = gel2 ( x1 , y1 )
C 1st XY pair
dum = gel1 ( 0 )
C space for # of points
C primitive started, add point if there's room
goto 23012
23011 continue
if(.not.( npts .lt. 300 - 1 ))goto 23013
dum = gel2 ( x1 , y1 )
23013 continue
23012 continue
23009 continue
if(.not.( ctype .eq. 4 ))goto 23015
C closed curves?
if(.not.( npts .lt. 0 ))goto 23017
C started primitive?
C not yet, reserve space for geltype
startg = gel1 ( 0 )
dum = gel2 ( xpos , ypos )
dum = gel1 ( 0 )
C space for # of points
npts = 0
C flag primitive started
C add new point to gelly if there's room for it
23017 continue
if(.not.( npts .lt. 300 - 1 ))goto 23019
dum = gel2 ( x1 , y1 )
23019 continue
23015 continue
if(.not.( npts .eq. 300 - 1 ))goto 23021
call imerr ( 25 )
23021 continue
C too many pts
npts = npts + 1
xpos = x1
ypos = y1
C update cursor position
goto 23001
23003 continue
call gnbc ( ch )
if(.not.( kterm ( ch ) .ne. 0 ))goto 23023
C end of C command?
C yes, check for another C command and parse it
C only if the previous C set no temp writing options
if(.not.( ch .eq. 99 .and. ( . not . twopfl ) ))goto 23025
C OK to do C
darc = 360
C reset to full circle
optc = . false .
C C(C) not in effect
goto 23001
goto 23026
23025 continue
C can't continue
call putbak ( ch )
C put it back
goto 23002
C wrap up C command
23026 continue
23023 continue
if(.not.( ch .eq. 40 ))goto 23027
C option list?
continue
23029 continue
C yes
call gnbc ( ch )
C get next option
if(.not.( ch .eq. 41 .or. ch .eq. 59 ))goto 23032
goto 23031
C end of options
23032 continue
if(.not.( ch .eq. 97 ))goto 23034
C Arc ?
if(.not.( kgnum ( darc ) .gt. 0 ))goto 23036
C yes, parse number
if(.not.( darc .lt. - 360 ))goto 23038
darc = - 360
23038 continue
if(.not.( darc .gt. 360 ))goto 23040
darc = 360
23040 continue
23036 continue
goto 23035
23034 continue
if(.not.( ch .eq. 98 ))goto 23042
C Begin
call ccls ( 1 )
C close current primitive
ctype = 4
C bounded curves
goto 23043
23042 continue
if(.not.( ch .eq. 99 ))goto 23044
C Circumference
optc = . true .
goto 23045
23044 continue
if(.not.( ch .eq. 101 ))goto 23046
C End
call ccls ( 0 )
C wrap up primitive
darc = 360
C reset to full circle
optc = . false .
C C(C) not in effect
goto 23047
23046 continue
if(.not.( ch .eq. 115 ))goto 23048
C Start (open curves)
call ccls ( 1 )
C close current primitive
ctype = 3
C unbounded curves
goto 23049
23048 continue
if(.not.( ch .eq. 119 ))goto 23050
C Writing options
call ccls ( 1 )
C close current primitive
call scantw
C do temp writing options
twopfl = . true .
C remember W seen
goto 23051
23050 continue
if(.not.( ch .ne. 44 ))goto 23052
C comma?
call imerr ( 15 )
C no, signal bad C option
call cfind ( 41 )
C skip to ) or Sync
goto 23031
23052 continue
23051 continue
23049 continue
23047 continue
23045 continue
23043 continue
23035 continue
23030 goto 23029
23031 continue
goto 23028
23027 continue
call imerr ( 15 )
23028 continue
C not pos spec or (
23001 goto 23000
23002 continue
call ccls ( 1 )
C close primitive if any
end
C ccls - if ccmd has begun creating the gelly for a Curves primitive,
C wrap it up; inputs are from ccomn
subroutine ccls ( errf )
integer errf
C 1 if terminating curves prematurely (i.e., not C(E))
C following defines are offsets from the start of the Curves gel
C offset to number of points
C offset to X coordinate of second point
C offset to Y coordinate of second point
integer dollar , dotgel , gel ( 3000 ) , goflo
common / cgelly / dotgel , dollar , gel , goflo
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 / ccomn / npts , startg , ctype , darc , optc
integer npts , startg , ctype , darc
logical optc
if(.not.( npts .lt. 0 ))goto 23054
return
23054 continue
C return if no primitive started
if(.not.( errf .ne. 0 ))goto 23056
call imerr ( 19 )
23056 continue
C signal premature termination
npts = min0 ( npts , 300 - 1 )
C get actual # of points
if(.not.( ctype .eq. 3 ))goto 23058
C open curves?
if(.not.( npts .gt. 0 ))goto 23060
C yes
call geld1
call geld1
C delete the last point
npts = npts - 1
23060 continue
if(.not.( npts .eq. 0 ))goto 23062
call imerr ( 18 )
23062 continue
C error if < 3 points specified
23058 continue
if(.not.( ctype .eq. 4 ))goto 23064
C closed curves?
if(.not.( npts .ge. 2 ))goto 23066
C yes, enough points?
if(.not.( goflo .eq. 0 ))goto 23068
xpos = gel ( startg + 6 )
C yes, set new position
ypos = gel ( startg + 7 )
23068 continue
goto 23067
23066 continue
call imerr ( 17 )
23067 continue
C < 2 points, signal error
23064 continue
if(.not.( goflo .eq. 0 ))goto 23070
gel ( startg ) = ctype
C store primitive type
gel ( startg + 3 ) = npts
C store # of points
23070 continue
npts = - 1
C set no primitive in progress
ctype = 6
C default for next C primitive
end
C cmfxy - compute new xpos and ypos after drawing circle with C(C)
C Note: this algorithm is subject to inaccuracy (see
C GIGI documentation regarding cursor pos. after C(C))
subroutine cmfxy ( centx , centy , darc )
integer centx , centy
C coords of center of circle
integer darc
C degrees of arc C(A...)
real dx , dy , radius , theta
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
dx = xpos - centx
C get X,Y dist from center to circum
dy = ypos - centy
radius = sqrt ( dx * dx + dy * dy )
if(.not.( dy .eq. 0 ))goto 23072
theta = 0
if(.not.( dx .lt. 0 ))goto 23074
theta = 3 . 14159
23074 continue
goto 23073
23072 continue
if(.not.( dx .eq. 0 ))goto 23076
theta = 3 . 14159 / 2
if(.not.( dy .gt. 0 ))goto 23078
theta = 3 . 14159 * 3 / 2
23078 continue
goto 23077
23076 continue
theta = atan ( - dy / dx )
if(.not.( dx .lt. 0 ))goto 23080
theta = theta + 3 . 14159
C quadrant II or III
C if (dy > 0) theta = theta + PI #quadrant III or IV #?rjf?
23080 continue
23077 continue
23073 continue
theta = theta + float ( darc ) / 180 . * 3 . 14159
xpos = centx + ifix ( radius * cos ( theta ) )
ypos = centy - ifix ( radius * sin ( theta ) )
end