Trailing-Edge
-
PDP-10 Archives
-
BB-K818A-BM_1981
-
sources/geom1.for
There are no other files named geom1.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 ========================================================================
integer function movgel ( lo , hi )
integer lo , hi
real xfm ( 3 , 3 )
common / cxform / xfm
integer pikloc
integer ox , oy , nx , ny
C string org origin
C string new new origin
integer org ( 7 )
integer new ( 11 )
data org ( 1 ) , org ( 2 ) , org ( 3 ) , org ( 4 ) , org ( 5 ) / 1
*11 , 114 , 105 , 103 , 105 /
data org ( 6 ) , org ( 7 ) / 110 , 0 /
data new ( 1 ) , new ( 2 ) , new ( 3 ) , new ( 4 ) , new ( 5 ) / 1
*10 , 101 , 119 , 32 , 111 /
data new ( 6 ) , new ( 7 ) , new ( 8 ) , new ( 9 ) , new ( 10 ) /
*114 , 105 , 103 , 105 , 110 /
data new ( 11 ) / 0 /
movgel = 0
call frstxy ( lo , hi , ox , oy )
if(.not.( pikloc ( org , ox , oy ) .lt. 0 ))goto 23000
return
23000 continue
nx = ox
ny = oy
C could mark origin here...
if(.not.( pikloc ( new , nx , ny ) .ge. 0 ))goto 23002
call drwgel ( lo , hi , 1 )
call idxfm ( xfm )
call xlate ( nx - ox , ny - oy )
call xfmgel ( lo , hi )
movgel = 1
call drwgel ( lo , hi , 1 )
23002 continue
return
end
integer function rotgel ( lo , hi )
integer lo , hi
real xfm ( 3 , 3 )
common / cxform / xfm
integer pikloc , pikarc
integer ox , oy , arc
C string org rotation center
integer org ( 16 )
data org ( 1 ) , org ( 2 ) , org ( 3 ) , org ( 4 ) , org ( 5 ) / 1
*14 , 111 , 116 , 97 , 116 /
data org ( 6 ) , org ( 7 ) , org ( 8 ) , org ( 9 ) , org ( 10 ) /
*105 , 111 , 110 , 32 , 99 /
data org ( 11 ) , org ( 12 ) , org ( 13 ) , org ( 14 ) , org ( 15
*) / 101 , 110 , 116 , 101 , 114 /
data org ( 16 ) / 0 /
rotgel = 0
call frstxy ( lo , hi , ox , oy )
if(.not.( pikloc ( org , ox , oy ) .lt. 0 ))goto 23004
return
23004 continue
if(.not.( pikarc ( ox , oy , arc ) .ge. 0 ))goto 23006
call drwgel ( lo , hi , 1 )
call idxfm ( xfm )
call xlate ( - ox , - oy )
call rotate ( arc )
call xlate ( ox , oy )
call xfmgel ( lo , hi )
rotgel = 1
call drwgel ( lo , hi , 1 )
23006 continue
return
end
integer function sclgel ( lo , hi )
integer lo , hi
real xfm ( 3 , 3 )
common / cxform / xfm
integer pikloc
integer ox , oy , x1 , x2 , y1 , y2
real xs , ys
C string org origin
C string point1 point before scale
C string point2 point after scale
integer org ( 7 )
integer point1 ( 19 )
integer point2 ( 18 )
data org ( 1 ) , org ( 2 ) , org ( 3 ) , org ( 4 ) , org ( 5 ) / 1
*11 , 114 , 105 , 103 , 105 /
data org ( 6 ) , org ( 7 ) / 110 , 0 /
data point1 ( 1 ) , point1 ( 2 ) , point1 ( 3 ) , point1 ( 4 ) , p
*oint1 ( 5 ) / 112 , 111 , 105 , 110 , 116 /
data point1 ( 6 ) , point1 ( 7 ) , point1 ( 8 ) , point1 ( 9 ) , p
*oint1 ( 10 ) / 32 , 98 , 101 , 102 , 111 /
data point1 ( 11 ) , point1 ( 12 ) , point1 ( 13 ) , point1 ( 14 )
* , point1 ( 15 ) / 114 , 101 , 32 , 115 , 99 /
data point1 ( 16 ) , point1 ( 17 ) , point1 ( 18 ) , point1 ( 19 )
* / 97 , 108 , 101 , 0 /
data point2 ( 1 ) , point2 ( 2 ) , point2 ( 3 ) , point2 ( 4 ) , p
*oint2 ( 5 ) / 112 , 111 , 105 , 110 , 116 /
data point2 ( 6 ) , point2 ( 7 ) , point2 ( 8 ) , point2 ( 9 ) , p
*oint2 ( 10 ) / 32 , 97 , 102 , 116 , 101 /
data point2 ( 11 ) , point2 ( 12 ) , point2 ( 13 ) , point2 ( 14 )
* , point2 ( 15 ) / 114 , 32 , 115 , 99 , 97 /
data point2 ( 16 ) , point2 ( 17 ) , point2 ( 18 ) / 108 , 101 , 0
* /
sclgel = 0
call frstxy ( lo , hi , ox , oy )
if(.not.( pikloc ( org , ox , oy ) .lt. 0 ))goto 23008
return
C could mark origin here...
23008 continue
x1 = ox
y1 = oy
if(.not.( pikloc ( point1 , x1 , y1 ) .ge. 0 ))goto 23010
x2 = x1
y2 = y1
if(.not.( pikloc ( point2 , x2 , y2 ) .ge. 0 ))goto 23012
xs = x1 - ox
if(.not.( xs .eq. 0 ))goto 23014
xs = 1
goto 23015
23014 continue
xs = ( x2 - ox ) / xs
23015 continue
ys = y1 - oy
if(.not.( ys .eq. 0 ))goto 23016
ys = 1
goto 23017
23016 continue
ys = ( y2 - oy ) / ys
23017 continue
call drwgel ( lo , hi , 1 )
call idxfm ( xfm )
call xlate ( - ox , - oy )
call scale ( xs , ys )
call xlate ( ox , oy )
call xfmgel ( lo , hi )
sclgel = 1
call drwgel ( lo , hi , 1 )
23012 continue
C and un-mark here.
23010 continue
return
end