grayramp.f

Intro/: Directory containing introductory examples. HelloWorld.c A simple program that draws a bo

$alias fdopen='fdopen'(%val, %ref)
      include 'phigs.f1.h'			! get the HP-PHIGS aliases
      program GrayRamp				! program "GrayRamp.f"
      include 'phigs.f2.h'			! get the HP-PHIGS constants

      integer*4	WorkstnID			! workstation identifier
      parameter	(WorkstnID=1)			! value chosen by the user
      integer*4	ConnID				! connection identifier
      integer*4	WorkstnType			! workstation type
      parameter	(WorkstnType=POIDDX)		! out/in, direct, dbl bfr, X
      integer*4	SphereStruc, Scene		! structure IDs
      parameter	(SphereStruc=1, Scene=2)	!   (chosen by user)
      integer*4	LightsOn(3), LightsOff(1)	! light-state variables
      data	LightsOn /1, 2, 3/		! all lights on
      real	Matrix(4, 4)			! transformation matrix
      real	FirstColour(3), LastColour(3)	! for gray-shade ramp
      data	FirstColour /0.0, 0.0, 0.0/	! dimmest colour is black
      data	LastColour  /1.0, 1.0, 1.0/	! brightest colour is white
      real	WeightVector(3)			! for colour->grays
      data	WeightVector /0.30, 0.59, 0.11/	! conversion factors
      integer*4	Error				! error-return variable
      integer*4 fdopen				! to get file descriptor
      real      rad, deg			! type the statement function
      rad(deg)= ((deg)*3.14159265358979/180.)   ! convert degrees to radians

      call popph(fdopen(fnum(7), 'w'//char(0)), 0)	! open phigs
      call pue004('/dev/screen/phigs_window', ConnID)	! get connection ID
      call popwk(WorkstnID, ConnID, WorkstnType)! open workstation
      call pue250(WorkstnID, 0)			! set colour env: direct
      call popst(SphereStruc)			! open structure
      call CreateSphere(32, 16)			! define the sphere structure
      call pclst				! close structure
      call DefineLightSources(WorkstnID)	! define all lights
      call DefineColourRamp(WorkstnID, FirstColour, LastColour, 101, 1,
     +  WeightVector)
      call popst(Scene)				! open structure
      call pscmi(1)				! set colour mapping index 
      call psfcm(PBKFC)				! set facet-culling mode: back
      call psis(PSOLID)				! set interior style: solid
      call psrfm(PADSRM)			! set reflectance model
      call psism(PNOIS)				! set interior shading method
      call SetReflectanceProperties(WorkstnID,	! insulate user from pprec...
     +  1.0, 1.0, 1.0,				!   amb/diff/spec reflections
     +  1.0, 1.0, 1.0,				!   specular colour
     +  20.0)					!   specular exponent
      call pslss(3, LightsOn, 0, LightsOff)	! set light source state
      call pbltm3(0.0, 0.0, 0.0,		! build local xform. matrix
     +  0.3, 0.7, 0.7,				!   translate
     +  rad(-60.0), rad(30.0), rad(-5.0),	!   rotate
     +  0.3, 0.3, 0.3,				!   scale
     +  Error, Matrix)				!   returned: error, matrix
      call pslmt3(Matrix, PCREPL)		! set local transformation
      call pexst(SphereStruc)			! execute structure
      call psism(PCIS)				! set interior shading method
      call pbltm3(0.0, 0.0, 0.0,		! build local xform. matrix
     +  0.7, 0.3, 0.3,				!   translate
     +  rad(-60.0), rad(30.0), rad(-5.0),	!   rotate
     +  0.3, 0.3, 0.3,				!   scale
     +  Error, Matrix)				!   returned: error, matrix
      call pslmt3(Matrix, PCREPL)		! set local transformation
      call pexst(SphereStruc)			! execute structure
      call pclst				! close structure
      call ppost(WorkstnID, Scene, 1.0)		! post structure
      call pclwk(WorkstnID)			! close workstation
      call pclph				! close phigs
      stop					! stop processing
      end					! end of program
!*****************************************************************************
      subroutine CreateSphere(Longitudes, Latitudes)
      integer*4 Longitudes
      integer*4 Latitudes

      include 'phigs.f2.h'

      !--- arbitrary limit of 50 for number of latitudes and longitudes ------
      real	Sphere(3, 50+1, 50+1)
      integer*4 Longitude, Latitude, I		! loop control variables
      real	Theta, Phi, CosPhi		! working variables
      real	PatchX(4), PatchY(4), PatchZ(4)	! fill area coordinates
      real	Red(3), LightBlue(3), Colour(3)	! direct RGB polygon colors
      data	Red	  /1.0, 0.0, 0.0/	! RGB for red
      data	LightBlue /0.0, 0.5, 0.7/	! RGB for a light blue
      integer*4	LastVertex			! for fill area set 3 with data
      data	LastVertex /4/			! each quad has four verts (!)
      integer*4	Dummy				! placeholder for unused vars
      real rad, deg
      rad(deg)=(deg*3.1415926535897932385/180.0)! convert degrees to radians

      !--- define sphere's data base -----------------------------------------
      do Longitude=1, Longitudes+1
          Theta = 360.0*(Longitude-1)/Longitudes
          do Latitude=1, Latitudes+1
	      Phi = -89.99+179.98*(Latitude-1)/Latitudes
	      CosPhi = cos(rad(Phi))
	      Sphere(1, Longitude, Latitude)=CosPhi*cos(rad(Theta))
	      Sphere(2, Longitude, Latitude)=CosPhi*sin(rad(Theta))
	      Sphere(3, Longitude, Latitude)=sin(rad(Phi))
	  end do
      end do
      !--- create the sphere out of unicolour patches ------------------------
      do Latitude = 1, Latitudes
	  do Longitude = 1, Longitudes
	      PatchX(1) = Sphere(1, Longitude, Latitude)
	      PatchY(1) = Sphere(2, Longitude, Latitude)
	      PatchZ(1) = Sphere(3, Longitude, Latitude)
	      PatchX(2) = Sphere(1, Longitude+1, Latitude)
	      PatchY(2) = Sphere(2, Longitude+1, Latitude)
	      PatchZ(2) = Sphere(3, Longitude+1, Latitude)
	      PatchX(3) = Sphere(1, Longitude+1, Latitude+1)
	      PatchY(3) = Sphere(2, Longitude+1, Latitude+1)
	      PatchZ(3) = Sphere(3, Longitude+1, Latitude+1)
	      PatchX(4) = Sphere(1, Longitude, Latitude+1)
	      PatchY(4) = Sphere(2, Longitude, Latitude+1)
	      PatchZ(4) = Sphere(3, Longitude, Latitude+1)
	      if (mod(ishft((Longitude-1), -1), 2) .eq. 1) then
		  do I=1, 3
		      Colour(I)=LightBlue(I)
		  end do
	      else
		  do I=1, 3
		      Colour(I)=Red(I)
		  end do
	      end if
	      call pfas3d(			! fill area set 3 with data
     +		PFC,				!   facet flag: colour
     +		PENO,				!   edge flag: none
     +		PCDN,				!   vertex flag: coords/norms
     +		PRGB, 3,			!   colour type: RGB
     +		Dummy,				!   indexed colour
     +		Colour,				!   facet colour
     +		Dummy, Dummy, Dummy,		!   facet normal
     +		Dummy, Dummy,			!   facet application data
     +		1,				!   number of fill areas/set
     +		LastVertex,			!   how many vertices/polygon?
     +		Dummy,				!   edge flags
     +		PatchX, PatchY, PatchZ,		!   polygon's geometry
     +		Dummy, Dummy,			!   vertex colour
     +		PatchX, PatchY, PatchZ,		!   vertex normals
     +		Dummy, Dummy)			!   vertex application data
	  end do
      end do
      return
      end
!*****************************************************************************
      subroutine SetReflectanceProperties(WorkstnID, AmbientRefl,
     +  DiffuseRefl, SpecRefl, SpecR, SpecG, SpecB, SpecExp)
      integer*4	WorkstnID		! workstation ID
      real	AmbientRefl		! ambient refl. coefficient (0.0->1.0)
      real	DiffuseRefl		! diffuse refl. coefficient (0.0->1.0)
      real	SpecRefl		! specular refl coefficient (0.0->1.0)
      real	SpecR, SpecG, SpecB	! specular reflection colour
      real	SpecExp			! specular exponent ("shininess")

      include 'phigs.f2.h'

      !--- variables for packing data record ---------------------------------
      integer*4		IntCount	! DataRec's integer count
      integer*4		Ints(2)		! DataRec's integer array
      integer*4		RealCount	! DataRec's real count
      real		Reals(8)	! max needed for DataRec's real array
      integer*4		StrCount	! DataRec's string count
      integer*4		StrLength	! DataRec's string length
      character*1	Strings(1)	! DataRec's string array
      integer*4		RecCount	! DataRec's element count
      data		StrCount /0/, StrLength /0/, RecCount /8/
      integer*4		Length		! DataRec's element return length
      character*80	DataRec(8)	! DataRec array itself

      integer*4		Error		! error-return variable

      IntCount=2			! two significant integers in array
      Ints(1)=PRGB			! specify colour as RGB
      Ints(2)=3				! RGBs have 3 components
      RealCount=7			! seven significant reals in array
      Reals(1)=AmbientRefl		! \
      Reals(2)=DiffuseRefl		!  \
      Reals(3)=SpecRefl			!   \
      Reals(4)=SpecExp			!    > put single values into array
      Reals(5)=SpecR			!   /
      Reals(6)=SpecG			!  /
      Reals(7)=SpecB			! /
      call pprec(IntCount, Ints, RealCount, Reals, StrCount, StrLength,
     +  Strings, RecCount, Error, Length, DataRec)
      if (Error .ne. 0) print *, "Error", Error, " in pprec."
      call psrfp(PSRPT, Length, DataRec)! set reflectance properties
      return
      end
!*****************************************************************************
      subroutine DefineLightSources(WorkstnID)
      integer*4 WorkstnID

      include 'phigs.f2.h'

      call DefineLightSource(WorkstnID, 1,PAMB,	! light source 1: ambient
     +  0.4, 0.4, 0.4,				! colour (gray)
     +  0.0, 0.0, 0.0,				! position (unused)
     +  0.0, 0.0, 0.0,				! direction (unused)
     +  0.0, 0.0, 0.0, 0.0)			! conc/spread/atten (unused)
      call DefineLightSource(WorkstnID, 2,PDIRE,! light source 2: directional
     +  0.8, 0.8, 0.8,				! colour (white, a little dim)
     +  0.0, 0.0, 0.0,				! position (unused)
     +  10.0, 10.0, -10.0,			! direction
     +  0.0, 0.0, 0.0, 0.0)			! conc/spread/atten (unused)
      call DefineLightSource(WorkstnID, 3,PDIRE,! light source 3: directional
     +  0.7, 0.7, 0.7,				! colour (white, a little dim)
     +  0.0, 0.0, 0.0,				! position (unused)
     +  -10.0, -10.0, -2.0,			! direction
     +  0.0, 0.0, 0.0, 0.0)			! conc/spread/atten (unused)
      return
      end
!*****************************************************************************
      subroutine DefineLightSource(WorkstnID, LightNo, LightType,
     +  R, G, B, X, Y, Z, dX, dY, dZ, Exponent, Spread, Att1, Att2)
      integer*4	WorkstnID		! workstation ID
      integer*4	LightNo, LightType	! index and type
      real	R, G, B			! colour
      real	X, Y, Z			! position (positional)
      real	dX, dY, dZ		! direction (all but ambient)
      real	Exponent		! concentration exponent (spot)
      real	Spread			! spread angle (spot)
      real	Att1, Att2		! attenuation factors (pos., spot)
      include 'phigs.f2.h'

      !--- Variables for packing data record ---------------------------------
      integer*4		IntCount	! DataRec's integer count
      integer*4		Ints(2)		! DataRec's integer array
      integer*4		RealCount	! DataRec's real count
      real		Reals(13)	! max needed for DataRec's real array
      integer*4		StrCount	! DataRec's string count
      integer*4		StrLength	! DataRec's string length
      character*1	Strings(1)	! DataRec's string array
      integer*4		RecCount	! DataRec's element count
      data		StrCount /0/, StrLength /0/, RecCount /8/
      integer*4		Length		! DataRec's element return length
      character*80	DataRec(8)	! DataRec array itself

      integer*4		Error		! error-return variable

      IntCount=2			! two significant integers in array
      Ints(1)=PRGB			! specify colour as RGB
      Ints(2)=3				! RGBs have 3 components
      if (LightType .eq. PAMB) then	! if ambient light...
	  RealCount=3			! three significant reals in array
	  Reals(1)=R			! \
	  Reals(2)=G			!  > set ambient light's colour
	  Reals(3)=B			! /
      endif
      if (LightType .eq. PDIRE) then	! if directional light...
	  RealCount=6			! six significant reals in array
	  Reals(1)=dX			! \
	  Reals(2)=dY			!  > set light's direction
	  Reals(3)=dZ			! /
	  Reals(4)=R			! \
	  Reals(5)=G			!  > set directional light's colour
	  Reals(6)=B			! /
      endif
      if (LightType .eq. PPOSI) then	! if positional light...
	  RealCount=8			! eight significant reals in array
	  Reals(1)=X			! \
	  Reals(2)=Y			!  > set light's position
	  Reals(3)=Z			! /
	  Reals(4)=Att1			! attenuation factor 1
	  Reals(5)=Att2			! attenuation factor 2
	  Reals(6)=R			! \
	  Reals(7)=G			!  > set positional light's colour
	  Reals(8)=B			! /
      endif
      if (LightType .eq. PSPOT) then	! if spotlight...
	  RealCount=13			! thirteen significant reals in array
	  Reals(1)=X			! \
	  Reals(2)=Y			!  > set light's position
	  Reals(3)=Z			! /
	  Reals(4)=dX			! \
	  Reals(5)=dY			!  > set light's direction
	  Reals(6)=dZ			! /
	  Reals(7)=Exponent		! concentration exponent
	  Reals(8)=Att1			! attenuation factor 1
	  Reals(9)=Att2			! attenuation factor 2
	  Reals(10)=Spread		! spread angle
	  Reals(11)=R			! \
	  Reals(12)=G			!  > set positional light's colour
	  Reals(13)=B			! /
      endif
      call pprec(IntCount, Ints, RealCount, Reals, StrCount, StrLength,
     +  Strings, RecCount, Error, Length, DataRec)
      if (Error .ne. 0) print *, "Error", Error, " in pprec."
      call pslsr(WorkstnID, LightNo,	! set light source representation
     +  LightType, Length, DataRec)
      return
      end
!*****************************************************************************
      subroutine DefineColourRamp(WorkstnID, FirstColour, LastColour,
     +  RampSize, CMappingIndex, WeightVector)
      integer*4	WorkstnID			! workstation identifier
      real	FirstColour(3), LastColour(3)	! extremes of ramp
      integer*4	RampSize			! size of ramp
      integer*4	CMappingIndex			! colour mapping table index
      real	WeightVector(3)			! for colour->gray conversion
      include 'phigs.f2.h'

      !--- Variables for packing data record ---------------------------------
      integer*4		IntCount	! DataRec's integer count
      integer*4		Ints(3)		! DataRec's integer array
      integer*4		RealCount	! DataRec's real count
      real		Reals(768)	! max needed for DataRec's real array
      integer*4		StrCount	! DataRec's string count
      integer*4		StrLength	! DataRec's string length
      character*1	Strings(1)	! DataRec's string array
      integer*4		RecCount	! DataRec's element count
      data		StrCount /0/, StrLength /0/, RecCount /100/
      integer*4		Length		! DataRec's element return length
      character*80	DataRec(100)	! DataRec array itself
      !--- miscellaneous variables -------------------------------------------
      real		DeltaColour(3)	! diff. between colr(i) and colr(i+1)
      integer*4		Error		! error-return variable
      integer*4	I			! loop control variable

      IntCount=3			! three significant integers in array
      Ints(1)=PRGB			! specify colour as RGB
      Ints(2)=3				! RGBs have 3 components
      Ints(3)=RampSize			! how big is gray ramp?
      RealCount=3+3*RampSize		! weight vector plus 3*RampSize
      Reals(1)=WeightVector(1)		! \
      Reals(2)=WeightVector(2)		!  > assign weight vector
      Reals(3)=WeightVector(3)		! /
      do I=1, 3
	  DeltaColour(I)=(LastColour(I)-FirstColour(I))/(RampSize-1)
      end do
      do I=0, RampSize-1
          Reals(4+I*3)=FirstColour(1)+DeltaColour(1)*I
          Reals(5+I*3)=FirstColour(2)+DeltaColour(2)*I
          Reals(6+I*3)=FirstColour(3)+DeltaColour(3)*I
      end do
      call pprec(IntCount, Ints, RealCount, Reals, StrCount, StrLength,
     +  Strings, RecCount, Error, Length, DataRec)
      if (Error .ne. 0) print *, "Error", Error, " in pprec."
      call pscmr(WorkstnID, CMappingIndex, PSUD,! set colour mapping rep.
     +  Length, DataRec)
      return
      end