dither.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 Dither				! program "Dither.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	Structure			! structure identifier
      parameter (Structure=1)			! value chosen by the user
      real	Black(3), White(3), Gray(3)	! for colour rep. table
      data	Black /0., 0., 0./		! RGB for black
      data	White /1., 1., 1./		! RGB for white
      integer*4 I, Row, Tile			! loop control variables
      real	X, dX, Y			! for positioning tiles
      integer*4	Tiles, Level			! temporary variables
      character*5 String			! the text to be labelled
      integer*4 fdopen				! to get file descriptor
      integer*4 ColourMapSize			! number of entries in table

      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 ppost(WorkstnID, Structure, 1.)	! mark structure for display
      call pscr(WorkstnID, 0, 3, Black)		! set colour rep: 0=black
      do I=1, ColourMapSize(WorkstnID, ConnID)-1! for every colour...
          call pscr(WorkstnID, I, 3, White)	! set colour rep: I=white
      end do
      call pue250(WorkstnID, 0)			! set colour env: direct
      call pue240(WorkstnID, 16)		! set dither cell size
      !--- define the structure ----------------------------------------------
      call popst(Structure)			! open structure
      call psis(PSOLID)				! set interior style
      call pschh(.03)				! set character height
      call pstxal(PACENT, PATOP)		! set text alignment
      Level=0					! start with 0% gray (black)
      do Row=1, 3				! for each of the three rows
          Tiles=6				! usually six tiles per row
          dX=0.0				! usually not shifted right
          if (Row .eq. 2) then			! however, in row two...
              Tiles=5				! ...there are only 5 tiles,
              dX=.085				! ...shifted right a tad.
          end if
          do Tile=1, Tiles			! for each of 5 or 6 tiles
              X=.17*(Tile-1)+dX			! define left edge
              Y=1.2-Row*.3			! define top edge
              do I=1, 3				! for each colour component
                  Gray(I)=Level/16.		! put component in array
              end do
              call psic(1, 0, 3, Gray)		! set interior colour
              call DoRectangle(X, Y, X+.15, Y-.15)	! define the tile
              write(unit=String, fmt='(i2,"/16")') Level
              call ptx(X+.075, Y-.16, String)	! print the label
              Level=Level+1			! a little lighter next time
          end do
      end do
      call pclst				! close structure
      call puwk(WorkstnID, PPERFO)		! update the workstation
      call pclwk(WorkstnID)			! close workstation
      call pclph				! close phigs
      stop					! stop processing
      end					! end of program
!*****************************************************************************
      subroutine DoRectangle(X1, Y1, X2, Y2)	! define rectangle
      real	X1, Y1				! first corner of rectangle
      real	X2, Y2				! last corner of rectangle
      
      real	X(5), Y(5)			! arrays for "pfa"
      
      X(1)=X1					!  > lower left corner 
      Y(1)=Y1					! /                    
      X(2)=X2					!  > lower right corner 
      Y(2)=Y1					! /                    
      X(3)=X2					!  > upper right corner 
      Y(3)=Y2					! /                    
      X(4)=X1					!  > upper left corner 
      Y(4)=Y2					! /                    
      X(5)=X1					!  > for ppl's sake, since
      Y(5)=Y1					! /  pfa doesn't make edges
      call pfa(4, X, Y)				! fill area
      call ppl(5, X, Y)				! polyline
      return
      end
!*****************************************************************************
      integer*4 function ColourMapSize(WorkstnID, ConnID)
      integer*4 WorkstnID, ConnID		! workstation to inquire
      include 'phigs.f2.h'			! get the HP-PHIGS constants

      integer*4	Error				! error-return variable
      integer*4	SpecificType			! specific workstation type
      integer*4	PolyBundl, MkrBundl, TextBundl	! various state table lengths
      integer*4	InterBundl, EdgeBundl, PattrnTbl! more of the same
      integer*4	ColourTbl, ViewTbl		! and yet more

      call pqwkc(WorkstnID, Error, ConnID,	! inq. wkstn. conn. and type
     + 	SpecificType)
      call pqwksl(SpecificType, Error,		! inq. wkstn. state tbl. len.
     + 	PolyBundl, MkrBundl, TextBundl, InterBundl, EdgeBundl,
     +  PattrnTbl, ColourTbl, ViewTbl)
      if (Error .ne. 0) then
	  print *,"Error ", Error, "in pqwksl."
	  stop
      end if
      ColourMapSize=ColourTbl
      return
      end