flatshading.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 FlatShading			! program "FlatShading.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	Cube, Scene			! structure IDs
      parameter	(Cube=1, Scene=2)
      real*4	White(3)			! for colour table values
      data	White /1.0, 1.0, 1.0/
      real	xform(4,4)			! transformation matrix
      !--- lighting variables ------------------------------------------------
      integer*4	LightsOn(4), LightsOff(1)
      data	LightsOn /1, 2, 3, 4/
      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 psdus(WorkstnID, PWAITD, PNIVE)	! set display update state
      call DefineCube(Cube)
      call DefineLightSources(WorkstnID)
      call ppost(WorkstnID, Scene, 1.0)		! post structure
      !=== define the scene ==================================================
      call popst(Scene)				! open structure
      call psfcm(PBKFC)				! set facet-culling mode
      call psedfg(PON)				! set edge flag
      call psedc(PRGB, 0, 3, White)		! set edge colour
      call psis(PSOLID)				! set interior style
      call psic(PRGB, 0, 3, White)		! set interior colour
      call psrfm(PADRM)				! set interior refl. equation
      call pslss(4, LightsOn, 0, LightsOff)	! set light source state
      !--- create modelling transformation -----------------------------------
      call psc3(0.3, 0.3, 0.3, Error, xform)	! scale
      if (Error .ne. 0) print *,"Error", Error, " in psc3."
      call pslmt3(xform, PCREPL)		! set local transformation 3
      call proy(rad(15.), Error, xform)		! rotate about Y axis
      if (Error .ne. 0) print *,"Error", Error, " in proy."
      call pslmt3(xform, PCPOST)		! set local transformation
      call prox(rad(15.), Error, xform)		! rotate about X axis
      if (Error .ne. 0) print *,"Error", Error, " in prox."
      call pslmt3(xform, PCPOST)		! set local transformation
      call ptr3(.5, .5, .5, Error, xform)	! translate into position
      if (Error .ne. 0) print *,"Error", Error, " in ptr3."
      call pslmt3(xform, PCPOST)		! set local transformation
      call pexst(Cube)				! execute structure
      call pclst				! close structure
      !=== close up shop =====================================================
      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 DefineCube(Cube)
      integer*4 Cube
      include 'phigs.f2.h'

      real TopX(5), TopY(5), TopZ(5)
      data TopX    /-1.0, -1.0,  0.0,  1.0,  1.0/
      data TopY    / 1.0,  1.0,  1.0,  1.0,  1.0/
      data TopZ    /-1.0,  1.0,  1.0,  0.0, -1.0/
      real BottomX(4), BottomY(4), BottomZ(4)
      data BottomX /-1.0, -1.0,  1.0,  1.0/
      data BottomY /-1.0, -1.0, -1.0, -1.0/
      data BottomZ / 1.0, -1.0, -1.0,  1.0/
      real RightX(5), RightY(5), RightZ(5)
      data RightX  / 1.0,  1.0,  1.0,  1.0,  1.0/
      data RightY  /-1.0,  1.0,  1.0,  0.0, -1.0/
      data RightZ  /-1.0, -1.0,  0.0,  1.0,  1.0/
      real LeftX(4), LeftY(4), LeftZ(4)
      data LeftX   /-1.0, -1.0, -1.0, -1.0/
      data LeftY   /-1.0,  1.0,  1.0, -1.0/
      data LeftZ   / 1.0,  1.0, -1.0, -1.0/
      real FrontX(5), FrontY(5), FrontZ(5)
      data FrontX  / 1.0,  1.0,  0.0, -1.0, -1.0/
      data FrontY  /-1.0,  0.0,  1.0,  1.0, -1.0/
      data FrontZ  / 1.0,  1.0,  1.0,  1.0,  1.0/
      real BackX(4), BackY(4), BackZ(4)
      data BackX   /-1.0, -1.0,  1.0,  1.0/
      data BackY   /-1.0,  1.0,  1.0, -1.0/
      data BackZ   /-1.0, -1.0, -1.0, -1.0/
      real CornerX(3), CornerY(3), CornerZ(3)
      data CornerX / 1.0,  1.0,  0.0/
      data CornerY / 0.0,  1.0,  1.0/
      data CornerZ / 1.0,  0.0,  1.0/
      integer*4	LastVertices(1)			! for fill-area sets

      call popst(Cube)				! open structure
      LastVertices(1) = 5
      call pfas3(1, LastVertices, TopX, TopY, TopZ)	     ! fill area set 3
      call pfas3(1, LastVertices, RightX, RightY, RightZ)    ! fill area set 3
      call pfas3(1, LastVertices, FrontX, FrontY, FrontZ)    ! fill area set 3
      LastVertices(1) = 4
      call pfas3(1, LastVertices, BottomX, BottomY, BottomZ) ! fill area set 3
      call pfas3(1, LastVertices, LeftX, LeftY, LeftZ)	     ! fill area set 3
      call pfas3(1, LastVertices, BackX, BackY, BackZ)	     ! fill area set 3
      LastVertices(1) = 3
      call pfas3(1, LastVertices, CornerX, CornerY, CornerZ) ! fill area set 3
      call pclst				! close structure
      return
      end
!*****************************************************************************
      subroutine DefineLightSources(WorkstnID)
      integer*4 WorkstnID
      include 'phigs.f2.h'

      call DefineLightSource(WorkstnID, 1,PAMB,	! light source 1: ambient
     +  0.2, 0.2, 0.2,				! colour (dark 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,PPOSI,! light source 2: positional
     +  0.6, 0.0, 0.0,				! colour (dark red)
     +  0.0, 5.0, 0.0,				! position
     +  0.0, 0.0, 0.0,				! direction (unused)
     +  0.0, 0.0, 1.0, 0.0)			! conc/spread (unused), atten
      call DefineLightSource(WorkstnID, 3,PDIRE,! light source 3: directional
     +  0.0, 0.0, 0.7,				! colour (dark blue)
     +  0.0, 0.0, 0.0,				! position (unused)
     +  0.0, 0.0, -5.0,				! direction
     +  0.0, 0.0, 0.0, 0.0)			! conc/spread/atten (unused)
      call DefineLightSource(WorkstnID, 4,PPOSI,! light source 4: positional
     +  0.0, 0.5, 0.0,				! colour (green)
     +  -1.5, 0.0, 0.0,				! position
     +  0.0, 0.0, 0.0,				! direction (unused)
     +  0.0, 0.0, 1.0, 0.0)			! conc/spread (unused), atten
	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