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