Google
 

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