Google
 

Trailing-Edge - PDP-10 Archives - BB-K818A-BM_1981 - sources/geom.for
There are no other files named geom.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 ========================================================================
C debug
C int func prmat(m)
C real m(3, 3)
C int i, j, d
C for (i=1; i<=3; i=i+1)
C 	for (j=1; j<=3; j=j+1)
C 		{
C 		d = m(i, j)
C 		call putdec(d)
C 		call putc(Comma)
C 		}
C call putc(Newline)
C prmat = Novalue
C return
C end
C gubed
      integer function pikloc ( pmsg , x , y )
      integer pmsg ( 1 )
      integer x , y
      integer curdx , curdy , smalld , larged
      integer scf , lorng , hirng
      integer cname ( 75 )
      common / keypad / curdx , curdy , smalld , larged , scf , lorng , 
     *hirng , cname
      integer c , key , inch
C string select Select
      integer select ( 7 )
      data select ( 1 ) , select ( 2 ) , select ( 3 ) , select ( 4 ) , s
     *elect ( 5 ) / 83 , 101 , 108 , 101 , 99 /
      data select ( 6 ) , select ( 7 ) / 116 , 0 /
      pikloc = 0
      call pushxo
      call prompt ( select , pmsg )
      continue
23000 if(.not.( pikloc .eq. 0 ))goto 23001
      call positn ( x , y )
      key = inch ( c )
      if(.not.( key .ge. 256 .and. key .le. 267 ))goto 23002
      x = x + curdx
      y = y + curdy
      goto 23003
23002 continue
      if(.not.( key .eq. 268 ))goto 23004
      pikloc = 1
      goto 23005
23004 continue
      pikloc = - 1
23005 continue
23003 continue
      goto 23000
23001 continue
      call usemac ( 80 )
      call popwo
      return
      end
      integer function pikarc ( cx , cy , a )
      integer cx , cy , a
      integer curdx , curdy , smalld , larged
      integer scf , lorng , hirng
      integer cname ( 75 )
      common / keypad / curdx , curdy , smalld , larged , scf , lorng , 
     *hirng , cname
      integer pikloc
      integer rx , ry , sx , sy
      integer key , inch , ch
      real arc , tx , ty , s , c , sin , cos
C string pt1 point before rotation
C string pt2 point
C string pta after rotation
      integer pt1 ( 22 )
      integer pt2 ( 6 )
      integer pta ( 15 )
      data pt1 ( 1 ) , pt1 ( 2 ) , pt1 ( 3 ) , pt1 ( 4 ) , pt1 ( 5 ) / 1
     *12 , 111 , 105 , 110 , 116 /
      data pt1 ( 6 ) , pt1 ( 7 ) , pt1 ( 8 ) , pt1 ( 9 ) , pt1 ( 10 ) / 
     *32 , 98 , 101 , 102 , 111 /
      data pt1 ( 11 ) , pt1 ( 12 ) , pt1 ( 13 ) , pt1 ( 14 ) , pt1 ( 15 
     *) / 114 , 101 , 32 , 114 , 111 /
      data pt1 ( 16 ) , pt1 ( 17 ) , pt1 ( 18 ) , pt1 ( 19 ) , pt1 ( 20 
     *) / 116 , 97 , 116 , 105 , 111 /
      data pt1 ( 21 ) , pt1 ( 22 ) / 110 , 0 /
      data pt2 ( 1 ) , pt2 ( 2 ) , pt2 ( 3 ) , pt2 ( 4 ) , pt2 ( 5 ) / 1
     *12 , 111 , 105 , 110 , 116 /
      data pt2 ( 6 ) / 0 /
      data pta ( 1 ) , pta ( 2 ) , pta ( 3 ) , pta ( 4 ) , pta ( 5 ) / 9
     *7 , 102 , 116 , 101 , 114 /
      data pta ( 6 ) , pta ( 7 ) , pta ( 8 ) , pta ( 9 ) , pta ( 10 ) / 
     *32 , 114 , 111 , 116 , 97 /
      data pta ( 11 ) , pta ( 12 ) , pta ( 13 ) , pta ( 14 ) , pta ( 15 
     *) / 116 , 105 , 111 , 110 , 0 /
      pikarc = - 1
      rx = cx
      ry = cy
      if(.not.( pikloc ( pt1 , rx , ry ) .lt. 0 ))goto 23006
      return
23006 continue
      pikarc = 0
      call pushxo
      call prompt ( pt2 , pta )
      a = 0
      continue
23008 if(.not.( pikarc .eq. 0 ))goto 23009
      call defmac ( 90 )
      call drcirc ( cx , cy , rx , ry , a )
      call fedmac ( 90 )
      arc = - a * 3 . 14159686 / 180
      c = cos ( arc )
      s = sin ( arc )
      tx = rx - cx
      ty = ry - cy
      sx = c * tx - s * ty + cx
      sy = s * tx + c * ty + cy
      call positn ( sx , sy )
      key = inch ( ch )
      if(.not.( key .ge. 256 .and. key .le. 267 ))goto 23010
      a = a + curdx - curdy
      if(.not.( a .gt. 360 ))goto 23012
      a = 360
      goto 23013
23012 continue
      if(.not.( a .lt. - 360 ))goto 23014
      a = - 360
23014 continue
23013 continue
      goto 23011
23010 continue
      if(.not.( key .eq. 268 ))goto 23016
      pikarc = 1
      goto 23017
23016 continue
      pikarc = - 1
23017 continue
23011 continue
      call usemac ( 90 )
      goto 23008
23009 continue
      call usemac ( 80 )
      call popwo
      return
      end
      integer function idxfm ( xfm )
      real xfm ( 3 , 3 )
      integer i , j
      continue
       i = 1
23018 if(.not.(i.le.3))goto 23020
      continue
       j = 1
23021 if(.not.(j.le.3))goto 23023
      if(.not.( i .eq. j ))goto 23024
      xfm ( i , j ) = 1 . 0
      goto 23025
23024 continue
      xfm ( i , j ) = 0 . 0
23025 continue
23022 j=j+1
      goto 23021
23023 continue
23019 i=i+1
      goto 23018
23020 continue
      idxfm = 0
      return
      end
      integer function xlate ( x , y )
      integer x , y
      real m ( 3 , 3 )
      call idxfm ( m )
      m ( 3 , 1 ) = x
      m ( 3 , 2 ) = y
      call catmat ( m )
      xlate = 0
      return
      end
      integer function scale ( x , y )
      real x , y
      real m ( 3 , 3 )
      call idxfm ( m )
      m ( 1 , 1 ) = x
      m ( 2 , 2 ) = y
      call catmat ( m )
      scale = 0
      return
      end
      integer function rotate ( angle )
      integer angle
      real m ( 3 , 3 ) , r , s , c , sin , cos
      call idxfm ( m )
      r = angle * 3 . 14159686 / 180
      s = sin ( r )
      c = cos ( r )
      m ( 1 , 1 ) = c
      m ( 2 , 2 ) = c
      m ( 1 , 2 ) = - s
      m ( 2 , 1 ) = s
      call catmat ( m )
      rotate = 0
      return
      end
      integer function catmat ( mat )
      real mat ( 3 , 3 )
      real xfm ( 3 , 3 )
      common / cxform / xfm
      real t ( 3 , 3 )
      integer i , j , k
      continue
       i = 1
23026 if(.not.(i.le.3))goto 23028
      continue
       j = 1
23029 if(.not.(j.le.3))goto 23031
      t ( i , j ) = 0
      continue
       k = 1
23032 if(.not.(k.le.3))goto 23034
      t ( i , j ) = t ( i , j ) + xfm ( i , k ) * mat ( k , j )
23033 k=k+1
      goto 23032
23034 continue
23030 j=j+1
      goto 23029
23031 continue
23027 i=i+1
      goto 23026
23028 continue
      continue
       i = 1
23035 if(.not.(i.le.3))goto 23037
      continue
       j = 1
23038 if(.not.(j.le.3))goto 23040
      xfm ( i , j ) = t ( i , j )
23039 j=j+1
      goto 23038
23040 continue
23036 i=i+1
      goto 23035
23037 continue
      catmat = 0
      return
      end
      integer function xfmgel ( lo , hi )
      integer lo , hi
      integer dollar , dotgel , gel ( 3000 ) , goflo
      common / cgelly / dotgel , dollar , gel , goflo
      integer lengel
      integer p , i
      integer xydum ( 2 )
      xfmgel = 0
      continue
       p = lo
23041 if(.not.(p.le.hi))goto 23043
      if(.not.( gel ( p ) .gt. 0 .and. gel ( p ) .le. 7 ))goto 23044
      call xfmpt ( gel ( p + 1 ) )
      if(.not.( gel ( p ) .eq. 6 ))goto 23046
      call xfmpt ( gel ( p + 3 ) )
      goto 23047
23046 continue
      if(.not.( gel ( p ) .le. 4 ))goto 23048
      continue
       i = 1
23050 if(.not.(i.le.gel(p+3)))goto 23052
      call xfmpt ( gel ( p + 2 + 2 * i ) )
23051 i=i+1
      goto 23050
23052 continue
23048 continue
23047 continue
      goto 23045
23044 continue
      if(.not.( gel ( p ) .eq. 127 + 6 ))goto 23053
      xydum ( 2 ) = gel ( p + 1 )
C extract Y value into dummy XY pair
      xydum ( 1 ) = 0
C dummy X value
      call xfmpt ( xydum )
C transform it
      gel ( p + 1 ) = xydum ( 2 )
C return to gel vector
23053 continue
23045 continue
23042 p=p+lengel(p)
      goto 23041
23043 continue
      return
      end
      integer function xfmpt ( xy )
      integer xy ( 2 )
      real xfm ( 3 , 3 )
      common / cxform / xfm
      integer tx , ty
      xfmpt = 0
      tx = xfm ( 1 , 1 ) * xy ( 1 ) + xfm ( 2 , 1 ) * xy ( 2 ) + xfm ( 3
     * , 1 )
      ty = xfm ( 1 , 2 ) * xy ( 1 ) + xfm ( 2 , 2 ) * xy ( 2 ) + xfm ( 3
     * , 2 )
      xy ( 1 ) = tx
      xy ( 2 ) = ty
      return
      end
      integer function frstxy ( lo , hi , x , y )
      integer lo , hi , x , y
      integer dollar , dotgel , gel ( 3000 ) , goflo
      common / cgelly / dotgel , dollar , gel , goflo
      integer lengel
      integer p
      frstxy = 0
      continue
       p = lo
23055 if(.not.(p.le.hi))goto 23057
      if(.not.( gel ( p ) .gt. 0 .and. gel ( p ) .le. 7 ))goto 23058
      x = gel ( p + 1 )
      y = gel ( p + 2 )
      return
23058 continue
23056 p=p+lengel(p)
      goto 23055
23057 continue
      x = 384
      y = 243
      return
      end