home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-11-11 | 47.1 KB | 1,440 lines |
- PROGRAM WimpPoly
- C Draws polyhedra from datafiles in directories dat1,2,3
- C format from netlib, index in POLYLIST
- C
- C needs libraries Drawf, graphics, utils, Wimp
- C
- C common for solids
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyWimp'
- C allow for long lines up to 256 characters
- CHARACTER *256 KARD,KARD2
- COMMON/WORK/KARD,KARD2
- C set up null terminated Version number
- VERS='2.01 ( 08 Nov 93 )'//?H00
- C INITIALISE WIMP
- CALL WMPI('WimpPoly',ITHAND)
- C initialise all windows, icons etc.
- CALL INIT
- C WIMP POLL bits mean 'no background work', 'not notified of
- C moving pointer into window'
- 10 CALL WMPP(?I1831,IBLOCK,IREASN)
- C check for file dragging etc.
- CALL SAVEBX(IBLOCK,IREASN)
- IF(IREASN.LT.0) GO TO 10
- IF(IREASN.EQ.1) CALL REDRAW
- IF(IREASN.EQ.2) CALL WMPOW(IBLOCK)
- IF(IREASN.EQ.3) THEN
- C end job when click on close icon of list window
- IF(IBLOCK(1).EQ.IWLIST)THEN
- CALL QUIT
- ELSE
- C Close Window using handle
- CALL WMPCLW(IBLOCK(1))
- ENDIF
- ENDIF
- C mouse button clicked
- IF(IREASN.EQ.6) CALL BUTTON(IBLOCK(3),IBLOCK(4),IBLOCK(5))
- C key board pressed
- IF(IREASN.EQ.8)CALL KEYS
- C mouse click over menu
- IF(IREASN.EQ.9)CALL MENU
- C message received
- IF(IREASN.EQ.17.OR.IREASN.EQ.18) THEN
- C requesting close down
- C some other wimp task says it's time to close
- IF(IBLOCK(5).EQ.0) CALL QUIT
- ENDIF
- GO TO 10
- END
- SUBROUTINE BUTTON(IBUT,IWIN,ICON)
- C decides which mouse button has been pressed
- C given the numbers of the button (IBUT), window, (IWIN) and the icon.
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- C only look at one button pressed at a time
- IF(IBUT.GT.4)RETURN
- IF(IWIN.EQ.IWINTR)THEN
- C close the Intro window
- CALL WMPCLW(IWINTR)
- C OPEN WINDOW with list of Polyhedra
- IBLOCK(1)=IWLIST
- CALL WMPGWS(IBLOCK)
- CALL WMPOW(IBLOCK)
- RETURN
- ENDIF
- IF(IBUT.EQ.4.AND.IWIN.EQ.IWLIST.AND.ICON.GE.0)THEN
- C close other 2 windows
- CALL WMPCLW(IWNET)
- CALL WMPCLW(IW3D)
- C select button pressed over an icon in the LIST window
- CALL RDDAT(ICON,IERR)
- IF(IERR.NE.0)RETURN
- C scale net vertices to window
- CALL CENNET
- C scale 3D vertices to window
- CALL CEN3D
- C open net window
- IBLOCK(1)=IWNET
- CALL WMPGWS(IBLOCK)
- CALL WMPOW(IBLOCK)
- C open 3D window
- IBLOCK(1)=IW3D
- CALL WMPGWS(IBLOCK)
- C get window state and then open window
- CALL WMPOW(IBLOCK)
- C make this window the one in which the caret goes
- CALL WMPSCP(IW3D,-1,100,-100,?I02000000,0)
- ENDIF
- IF(IBUT.EQ.2)THEN
- IF(IWIN.EQ.IW3D)CALL WMPCM(MBLK3D,IBLOCK(1),IBLOCK(2))
- C save window handle
- MENWIN=IWIN
- C open menu at mouse position
- IF(IWIN.EQ.IWNET)CALL WMPCM(MBLKNT,IBLOCK(1),IBLOCK(2))
- IF(IWIN.EQ.IWLIST)CALL WMPCM(MBLK1,IBLOCK(1),IBLOCK(2))
- ELSE
- C set caret into window with input focus
- IF(IWIN.EQ.IW3D)CALL WMPSCP(IW3D,-1,100,-100,?I02000000,0)
- ENDIF
- RETURN
- END
- SUBROUTINE CENNET
- C IS=2 similarly but for CENTRE OF NET
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- XMIN= 99999.
- XMAX=-99999.
- YMIN= 99999.
- YMAX=-99999.
- ZMIN= 99999.
- ZMAX=-99999.
- C net use planar vertices
- IN=1
- ND=NNET
- IF(NNET.LE.0)THEN
- C WRITE(*,*)' Sorry, no net vertices'
- C READ(*,*)KMC
- RETURN
- ENDIF
- C SCLWIN=MIN(IWIDNT,IHINT)
- C D=1./NNET
- DO 10 I=IN,ND
- XMIN=MIN(XMIN,X(I))
- XMAX=MAX(XMAX,X(I))
- YMIN=MIN(YMIN,Y(I))
- YMAX=MAX(YMAX,Y(I))
- ZMIN=MIN(ZMIN,Z(I))
- ZMAX=MAX(ZMAX,Z(I))
- 10 CONTINUE
- XORG=(XMIN+XMAX)*0.5
- YORG=(YMIN+YMAX)*0.5
- ZORG=(ZMIN+ZMAX)*0.5
- C net here, turn round to fit window
- XSIZE=XMAX-XMIN
- YSIZE=YMAX-YMIN
- IF(XSIZE.GT.YSIZE)THEN
- SCLNET=MIN(FLOAT(IHINT),XSIZE*IWIDNT/YSIZE)
- SCLWIN=1./XSIZE
- DO 30 I=IN,ND
- YY=SCLWIN*(X(I)-XORG)
- X(I)=SCLWIN*(YORG-Y(I))
- Y(I)=YY
- 30 CONTINUE
- ELSE
- SCLNET=MIN(YSIZE*IWIDNT/XSIZE,FLOAT(IHINT))
- SCLWIN=1./YSIZE
- DO 40 I=IN,ND
- X(I)=SCLWIN*(X(I)-XORG)
- Y(I)=SCLWIN*(Y(I)-YORG)
- 40 CONTINUE
- ENDIF
- C set scale to default
- SCLNET=0.8*SCLNET
- RETURN
- END
- SUBROUTINE CEN3D
- C IS=1 finds centre of SOLID and translates to it and scales
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- RSQMAX=0.
- C square of the radius of circumscribing sphere
- IF(NVTOT.LE.NNET) RETURN
- C solid use 3D vertices
- IN=1+NNET
- ND=NVTOT
- C denominator when finding origin of plot
- D=1./(NVTOT-NNET)
- XORG=0.
- YORG=0.
- ZORG=0.
- DO 10 I=IN,ND
- XORG=XORG+X(I)
- YORG=YORG+Y(I)
- ZORG=ZORG+Z(I)
- 10 CONTINUE
- C SIZE=MAX(XMAX-XMIN,YMAX-YMIN,ZMAX-ZMIN)
- C SCLWIN=1./SIZE
- XORG=XORG*D
- YORG=YORG*D
- ZORG=ZORG*D
- DO 16 I=IN,ND
- RSQ=(X(I)-XORG)**2 +(Y(I)-YORG)**2+(Z(I)-ZORG)**2
- RSQMAX=MAX(RSQMAX,RSQ)
- 16 CONTINUE
- SCLWIN=0.5/SQRT(RSQMAX)
- C TRANSLATE 3D TO origin and scale to window size
- C -0.5 < all co-ords < 0.5
- DO 20 I=IN,ND
- X(I)=SCLWIN*(X(I)-XORG)
- Y(I)=SCLWIN*(Y(I)-YORG)
- Z(I)=SCLWIN*(Z(I)-ZORG)
- 20 CONTINUE
- C set scale to default
- SCL3D=0.8*MIN(IWID3D,IHI3D)
- RETURN
- END
- SUBROUTINE CRLIST
- C makes window for names of stored polyhedra
- C common for solids MAXW= max length of a name
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- C
- CHARACTER TITLE*10,ITITL*6,DUMMY*1
- DATA TITLE /'Polyhedra.'/,ITITL/'Icon1.'/
- C x,y,width,depth,extx,exty,title,flags
- C extx & exty are total size
- IW=16*MAXW
- IWLIST=IWMPCW(200,700,IW,500,IW,64*NS+64,TITLE,?IFF00001F)
- C Create Icons only one selectable (group name 1)
- DO 10 I=1,NS
- C find last non-blank character in the name
- NX=LNBLNK(SOLIDS(I))
- IF(SOLIDS(I)(1:1).EQ.' ')THEN
- C title not a name of solid, cannot be selected
- ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I1B000431,
- + SOLIDS(I)(6:NX+1),DUMMY)
- C use different colour text red
- ELSE
- IF(SOLIDS(I)(1:1).EQ.'-')THEN
- C title is an alternate name use different colour text
- ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I1A000431,
- 1 SOLIDS(I)(6:NX+1),DUMMY)
- ELSE
- C title is an alternate name use different colour text
- ICONH=IWMPCI(IWLIST,16,-64*I,NX*16,48,?I0801B431,
- 1 SOLIDS(I)(6:NX+1),DUMMY)
- ENDIF
- ENDIF
- 10 CONTINUE
- RETURN
- END
- SUBROUTINE DR3D(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
- C User routine called by DRPOL, sets up co-ordinate pairs for lines into
- C ARRAY.assume units mm MAXPR max no of Pairs, NPTS returned
- C plots the polyhedra as 3D solid (ISTK3D=0)
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- DIMENSION SL(3)
- C SL = light source
- DIMENSION ARRAY(2,MAXPR)
- C 0.3*Sqrt(2) so range of dotproducts -0.6 to 1 in shading
- DATA SL/2*0.6,0.52915/
- C light at top right slightly in front
- IER=0
- IF(NPTS.EQ.0)THEN
- C 1st call NPTS =0
- A=SL(1)*SQRT(2.)
- C coefficients for colour of filled solid
- B=255./(1.+A)
- I=0
- ENDIF
- C check there are vertices for 3D window
- IF(NVTOT.LE.NNET) THEN
- IER=99
- C no 3D vertices
- RETURN
- ENDIF
- C centres and normals to all faces calculated by PLT3D already
- C ready to start plotting
- I=I+1
- IF(I.GT.NFPLOT)THEN
- C all faces plotted, end object
- NPTS=-1
- RETURN
- ENDIF
- 8 NF=INDX(I)
- C NF= face to plot
- NV=NVTX(NF)
- IF(NV.GE.MAXPR)THEN
- IER=99
- RETURN
- ENDIF
- C CALL VDU(4)
- C CALL VDU(26)
- DO 10 N=1,NV
- ARRAY(1,N)=(X(IVTX(N,NF))+0.5)*130.
- C scale the vertex to the screen A5 size mm translate to centre
- C should be 138. but want to try it a bit smaller
- ARRAY(2,N)=(Y(IVTX(N,NF))+0.5)*130. + 60.
- C CALL TAB((N-1)*16,NF)
- C PRINT 101,ARRAY(1,N),ARRAY(2,N)
- C 101 FORMAT($,2F8.1)
- 10 CONTINUE
- C CALL VDU(5)
- ARRAY(1,NV+1)=ARRAY(1,1)
- C close the polygon
- ARRAY(2,NV+1)=ARRAY(2,1)
- NPTS=NV+1
- C decide on colour
- IF(ISTK3D.EQ.0) THEN
- C filled face
- COSANG=SL(1)*DCFACE(1,NF)+SL(2)*DCFACE(2,NF)+
- 1 SL(3)*DCFACE(3,NF)
- C KOL=(0.9718+COSANG)*8.114*0.5
- KOL=(COSANG+A)*B
- C colour of filled face a shade of grey
- L1=ISHFT(KOL,8)+ISHFT(KOL,16)+ISHFT(KOL,24)
- ELSE
- IF(ISTK3D.EQ.1)THEN
- C now draw outline 2nd word is colour
- IF(DCFACE(3,NF).GT.0.0) THEN
- C front of solid blue
- L2=?IFF000000
- ELSE
- C back of solid medium grey
- L2=?IC0C0C000
- ENDIF
- ELSE
- C must be colour option =2 set colour dependent on # vertices
- KOL=5+NV
- IF(KOL.GT.15)KOL=15
- L1=KLRS(KOL)
- LOL=0
- IF(KOL.EQ.9.or.kol.eq.12.or.KOL.EQ.14)LOL=7
- L2=KLRS(LOL)
- ENDIF
- ENDIF
- RETURN
- END
- FUNCTION KLRS(K)
- C given a colour number K, assumed to be a wimp 16 colour
- C returns the word L2 for DRAW colours set up as ?IBBGGRR00
- DIMENSION KOLSDR(0:15)
- DATA KOLSDR/?IFFFFFF00,?IDDDDDD00,?IBBBBBB00,?I09090900,
- 1 ?I07070700,?I05050500,?I03030300,?I00000000,
- 2 ?IFF000000,?I00FFFF00,?I00FF0000,?I0000FF00,
- 3 ?I99FFFF00,?I05FF0500,?I0008FF00,?IFFFF0000/
- C white greys to black at 7
- C blue yellow green red
- C cream army green orange cyan
- IF(K.GT.15)K=15
- IF(K.LT.0)K=0
- KLRS=KOLSDR(K)
- RETURN
- END
- SUBROUTINE DRCHAR(CHARAY,MAXCHR,NCHARS,L1,L2,L3,L4,XL,YL,IER)
- C adds user text to the picture
- C L1,L2 are colours of text, L3 font number, L4 point size (same for x and y)
- C XL,YL lower left corner of text in the picture, IER =error return
- CHARACTER *(*) CHARAY
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- IER=0
- IF(NCHARS.EQ.0)INIT=-1
- C 1st call NCHARS =0
- INIT=INIT+1
- IF(INIT-1)2,10,20
- 2 NCHARS=INDEX(TITL3D,CHAR(0))-1
- CHARAY(1:NCHARS)=TITL3D(1:NCHARS)
- XL=1.
- YL= 200.
- L4=12
- C need smaller characters if longer names
- IF(NCHARS.GT.32)L4=10
- IF(NCHARS.GT.40)L4=8
- RETURN
- 10 NCHARS=LNBLNK(DUAL)
- CHARAY(1:NCHARS+6)='Dual: '//DUAL(1:NCHARS)
- NCHARS=NCHARS+6
- XL=1.
- YL=55.
- L4=8
- RETURN
- 20 NCHARS=-1
- RETURN
- END
- SUBROUTINE DRNT(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
- C User routine called from DRPOL, sets up co-ordinate pairs for lines into
- C ARRAY. assume units mm MAXPR max no of Pairs, NPTS returned
- C plots the net as filled face solid (ISTKNT=0) or wire (ISTKNT=1 )
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- DIMENSION ARRAY(2,MAXPR)
- C 1st call NPTS =0
- IF(NPTS.EQ.0)THEN
- C INET = flag 0 while drawing faces, 1 when drawing hinges
- INET=0
- I=0
- C TEST IF ANy NET
- IF(NNET.EQ.0)THEN
- CALL MOVE(LX0+64,LY0-64)
- WRITE(*,*)' Sorry, no net vertices'
- NPTS=-1
- RETURN
- ENDIF
- ENDIF
- 40 I=I+1
- IF(INET.EQ.1)GOTO60
- IF(I.LE.NFACES)THEN
- C NF= face to plot
- NV=NETVX(I)
- DO 50 N=1,NV
- ARRAY(1,N)=(X(NETNV(N,I))+0.5)*138.
- C scale the vertex to the screen A5 size mm translate to centre
- ARRAY(2,N)=(Y(NETNV(N,I))+0.5)*138. +60.
- 50 CONTINUE
- ARRAY(1,NV+1)=ARRAY(1,1)
- C close the polygon
- ARRAY(2,NV+1)=ARRAY(2,1)
- NPTS=NV+1
- C decide on colour
- IF(ISTKNT.EQ.0)THEN
- C filled net
- L1=?I00FF0000
- L2=-1
- C set foreground colour to green to draw polygons
- ELSE
- C outline faces in black
- L1=-1
- L2=0
- ENDIF
- RETURN
- ELSE
- C set flag faces all plotted
- INET=1
- I=1
- ENDIF
- C now plot the hinges
- 60 IF(I.LE.NHINGS)THEN
- J=IHING(I,1)
- C J = face K=side of the face in the net
- K=IHING(I,2)
- L=NETVX(J)
- C L=no of vertices that face need ones for kth side
- M1=NETNV(K,J)
- KK=K+1
- IF(KK.GT.L)KK=1
- M2=NETNV(KK,J)
- ARRAY(1,1)=(X(M1)+0.5)*138.
- ARRAY(1,2)=(X(M2)+0.5)*138.
- ARRAY(2,1)=(Y(M1)+0.5)*138.+60.
- ARRAY(2,2)=(Y(M2)+0.5)*138.+60.
- L1=-1
- IF(HINANG(I).GT.0.AND.HINANG(I).LT.3.142)THEN
- C plot black dotted lines when hinge angle < PI
- L4=3
- C if stick plot have white lines
- IF(ISTKNT.EQ.0)THEN
- L2=0
- ELSE
- L2=?IFFFFFF00
- ENDIF
- ELSE
- L2=?IA0A0A000
- C mid grey solid lines unless plot is filled
- IF(ISTKNT.EQ.0)L2=0
- L4=0
- ENDIF
- C in both case plot one line, 2 points
- NPTS=2
- ELSE
- C end of plotting
- NPTS=-1
- ENDIF
- RETURN
- END
- SUBROUTINE DRPOL(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
- C User routine sets up co-ordinate pairs for lines into ARRAY
- C assume units mm MAXPR max no of Pairs, NPTS returned
- C plots the polyhedra as 3D solid (ISTK3D=0) or wire (ISTK3D=1 )
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- DIMENSION ARRAY(2,MAXPR)
- IER=0
- IF(MENWIN.EQ.IW3D)THEN
- C make a Drawfile for the 3D solid
- CALL DR3D(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
- ELSE
- C make a Drawfile for the net
- CALL DRNT(ARRAY,MAXPR,NPTS,L1,L2,L3,L4,IER)
- ENDIF
- RETURN
- END
- SUBROUTINE FACENT
- C finds the Z of centres of the surfaces and normals to them
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- REAL V1(3),V2(3),V3(3),XYZ(MAXVTX,3)
- EQUIVALENCE(X(1),XYZ(1,1))
- C V1,V2 are 2 adjacent edges of the face
- DO 60 I=1,NFACES
- ZC=0.
- DO 10 J=1,NVTX(I)
- ZC=ZC+Z(IVTX(J,I))
- 10 CONTINUE
- C store centre of face
- ZFACE(I)=ZC/NVTX(I)
- DO 20 J=1,3
- V1(J)=XYZ(IVTX(2,I),J)-XYZ(IVTX(1,I),J)
- 20 V2(J)=XYZ(IVTX(3,I),J)-XYZ(IVTX(2,I),J)
- C cross product
- DO 30 J=1,3
- K=MOD(J,3)+1
- L=6-J-K
- 30 V3(J)=V1(K)*V2(L)-V1(L)*V2(K)
- W=SQRT(V3(1)*V3(1)+V3(2)*V3(2)+V3(3)*V3(3))
- DO 40 J=1,3
- C store normalised direction cosines for normal face
- 40 DCFACE(J,I)=V3(J)/W
- 60 CONTINUE
- RETURN
- END
- SUBROUTINE FINDHD(INDAT,ITYPE,IERR)
- C reads file INDAT until it finds a line beginning with :
- C checks the rest of line and sets up ITYPE
- PARAMETER (NHEADS=14)
- CHARACTER *80 KARD
- COMMON/WORK/KARD
- CHARACTER *9 TYPES(NHEADS),THIS
- DATA TYPES/'name','number','symbol','dual','sfaces','svertices',
- 1 'net','solid','hinges','dih','vertices','EOF',
- 2 'netformul','comment '/
- IERR=0
- 10 READ(INDAT,101,END=90,ERR=98)KARD
- 101 FORMAT(A)
- IF(KARD(1:1).NE.':') GOTO10
- C find what kind of header
- THIS=KARD(2:10)
- ITYPE=0
- DO 20 I=1,NHEADS
- IF(THIS.EQ.TYPES(I))ITYPE=I
- 20 CONTINUE
- IF(ITYPE.GT.0)RETURN
- CALL WMPRE(3,'Unknown header '//THIS,3,'WimpPoly',IERR)
- C user has selected 'Cancel' when Ierr=2, OK when =1
- IF(IERR.EQ.2)CALL QUIT
- C WRITE(*,*)' error found a header line ',THIS
- C WRITE(*,*)' but only known types are ',(TYPES(I),I=1,NHEADS)
- C READ(*,*)KMC
- IERR=1
- RETURN
- C found the end of file
- C 90 IERR=-1
- C WRITE(*,*)' Found the End of File'
- 90 CALL WMPRE(3,'END of Datafile, OK to try another',3,
- 1'WimpPoly',IERR)
- C user has selected 'Cancel' when Ierr=2, OK when =1
- IF(IERR.EQ.2)CALL QUIT
- 98 IERR=-1
- RETURN
- END
- SUBROUTINE INIT
- C initialises all windows
- C common for solids, WIMP and Pictures
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- PARAMETER(MAXL=100)
- DIMENSION INFICN(MAXL),JWIN(MAXVTX)
- EQUIVALENCE (X(1),JWIN(1))
- CHARACTER*12 TTEM
- C
- C read the names of the NS files containing data
- CALL RDLIST(NS)
- C CREATE WINDOW for names of polyhedra
- CALL CRLIST
- C read the text of the HELP window
- CALL RDHELP
- C Create menu for first window
- TITLM1='Poly'
- LIST1(1)='Info'
- LIST1(2)='Help'
- LIST1(3)='Quit'
- CALL WMPMNU(MBLK1,TITLM1,LIST1,NMENU1)
- C open template file of windows
- CALL WMPOT('<WimpPoly$Dir>.Templates')
- C load templates
- C Read Intro window
- L=MAXL
- IP=0
- TTEM='Intro'//CHAR(0)
- CALL WMPLT(JWIN,INFICN(1),L,-1,TTEM,IP)
- C Create Intro window
- CALL WMPCRW(JWIN,IWINTR)
- C Read info window
- L1=MAXL-L
- IP=0
- TTEM='Info'//CHAR(0)
- CALL WMPLT(JWIN,INFICN(L1+1),L,-1,TTEM,IP)
- C add in Version number
- JWIN(60)=LOCC(VERS)
- C create info window and link to menu
- CALL WMPCRW(JWIN,MBLK1(9))
- C Read Help window
- L1=MAXL-L
- IP=0
- TTEM='help'//CHAR(0)
- CALL WMPLT(JWIN,INFICN(L1+1),L,-1,TTEM,IP)
- C Create Help window
- CALL WMPCRW(JWIN,IWHELP)
- C close template file
- CALL WMPCT
- C Create window for drawing the net
- C
- TITLNT='Net.'
- IWIDNT=360
- IHINT=550
- C x,y,width,depth,extx,exty,title,flags, extx & exty are total size
- IWNET=IWMPCW(0,1020,IWIDNT,IHINT,IWIDNT,IHINT,TITLNT,?IFF00000F)
- C Create window for drawing the solid
- C TITL3D='Solid.' this one set in RDDAT
- IWID3D=800
- IHI3D=864
- IW3D=IWMPCW(480,1020,IWID3D,IHI3D,IWID3D,IHI3D,TITL3D,?IFF00000F)
- C create a menu for the 3D window
- TITLM3='3D menu'
- LIST3D(1)='wire'
- LIST3D(2)='solid'
- LIST3D(3)='colour'
- LIST3D(4)='Save'
- CALL WMPMNU(MBLK3D,TITLM3,LIST3D,NMENU3)
- C create a menu for the net window
- TITLMN='net menu'
- LISTNT(1)='wire'
- LISTNT(2)='solid'
- LISTNT(3)='Save'
- CALL WMPMNU(MBLKNT,TITLMN,LISTNT,NMENUN)
- C set up drag box window with Drawfile type
- CALL SAVEMN(?I0AFF,IWSAVE)
- C connect to 3D menu as 4th item
- MBLK3D(9+6*3)=IWSAVE
- C connect to net window as 3rd item
- MBLKNT(9+6*2)=IWSAVE
- C read datafile on UNIT 10
- INDAT=10
- C initial rotations
- ROTX=0.
- ROTY=0.
- ROTZ=0.
- C screen origin for plot
- IX0=600
- IY0=600
- C OPEN Intro window
- IBLOCK(1)=IWINTR
- CALL WMPGWS(IBLOCK)
- CALL WMPOW(IBLOCK)
- RETURN
- END
- SUBROUTINE INTRO(LX0,LY0)
- C displays Introduction window
- INCLUDE'<WimpPoly$Dir>.f77.WPOLYCH'
- INCLUDE'<WimpPoly$Dir>.f77.WPOLYPIC'
- INCLUDE'<WimpPoly$Dir>.f77.WPOLYWimp'
- C set colour of text
- CALL WMPSC(0,7,0)
- C title bigger letters
- CALL WOGBIG(LX0+340,LY0-200,'WimpPoly',3)
- CALL WMPTXT(LX0+440,LY0-232,'K.M.Crennell')
- CALL WMPTXT(LX0+496,LY0-280,'1991')
- CALL WMPTXT(LX0+200,LY0-400,
- 1 'Draws polyhedra as a 3D solid or planar net')
- CALL WMPTXT(LX0+200,LY0-460,
- 1 'from data files mostly obtained from "netlib"')
- CALL WMPTXT(LX0+200,LY0-520,
- 1 'on the Joint Academic Network (JANET).')
- CALL WMPTXT(LX0+200,LY0-620,
- 1 'It uses the "Fortran Friends" PD_F77 library.')
- CALL WMPSC(0,11,0)
- C change last message to red
- CALL WMPTXT(LX0+180,LY0-700,
- 1 'Click any mouse button over this window to start')
- C draw the net, hope no errors
- CALL RDDAT(2,IER)
- C scale net vertices to window
- CALL CENNET
- C scale 3D vertices to window
- CALL CEN3D
- SCLNET=SCLNET*0.8
- CALL PLTNET(LX0-IWIDNT/2+160,LY0+IHINT/2-200)
- SCL3D=SCL3D*0.4
- CALL PLT3D(LX0-IWID3D/2+900,LY0+IHI3D/2-200)
- RETURN
- END
- SUBROUTINE KEYS
- C handles keyboard input
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- EQUIVALENCE(IBLOCK(7),KODE),(IBLOCK(1),IWIND)
- C KODE is ASCII of key pressed
- IF(KODE.EQ.60.OR.KODE.EQ.44.OR.KODE.EQ.62.OR.KODE.EQ.46)THEN
- C Scale the solid for <, or >.
- CALL SCAL3D(KODE)
- ELSE
- IF(KODE.GE.396.AND.KODE.LE.399)THEN
- C rotate with cursor keys
- CALL ROTPOL(KODE)
- ELSE
- C hand back key to Wimp
- CALL WMPPK(KODE)
- ENDIF
- ENDIF
- RETURN
- END
- SUBROUTINE MENU
- C called when a mouse button has been clicked over a menu in a window
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- DIMENSION MYB(5)
- CHARACTER *20 FILNAM
- DATA FILNAM/'<WimpPoly$Dir>.Polly'/
- IF(MENWIN.EQ.IW3D)THEN
- C menu options for 3D window 1= 'wire' 2 = 'solid' 3 = 'colour'
- IF(IBLOCK(1).EQ.0)THEN
- ISTK3D=1
- ELSE
- IF(IBLOCK(1).EQ.1)THEN
- ISTK3D=0
- ELSE
- ISTK3D=2
- ENDIF
- ENDIF
- CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
- C restore menu if 'Adjust' button pressed
- CALL WMPGPI(MYB)
- IF(MYB(3).EQ.1) CALL WMPCM(MBLK3D,MYB(1),MYB(2))
- ENDIF
- IF(MENWIN.EQ.IWLIST)THEN
- C click over 1st window
- IF(IBLOCK(1).EQ.2)CALL QUIT
- C display INFO done by Wimp with arrow =0
- C open HELP window
- IF(IBLOCK(1).EQ.1)THEN
- IBLOCK(1)=IWHELP
- CALL WMPGWS(IBLOCK)
- C open Help window
- CALL WMPOW(IBLOCK)
- ENDIF
- ENDIF
- IF(MENWIN.EQ.IWNET)THEN
- C click over Net window
- C 1st menu option for net window is 'wire' 2nd is 'solid'
- IF(IBLOCK(1).EQ.0)THEN
- ISTKNT=1
- ELSE
- IF(IBLOCK(1).EQ.1)THEN
- ISTKNT=0
- C ELSE thes done in SAVEFL now ****************
- C CALL DRFILE('A5P',FILNAM,IER)
- ENDIF
- ENDIF
- CALL WMPFR(IWNET,0,-IHINT,IWIDNT,0)
- C restore menu if 'Adjust' button pressed
- CALL WMPGPI(MYB)
- IF(MYB(3).EQ.1) CALL WMPCM(MBLKNT,MYB(1),MYB(2))
- ENDIF
- RETURN
- END
- SUBROUTINE PLTNET(LX0,LY0)
- C LX0,LY0 top left corner of window
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- DIMENSION IX(MXVTF+1),IY(MXVTF+1)
- C TEST IF ANy NET
- CALL WMPSC(0,13,0)
- C set foreground colour to green to draw polygons
- IF(NNET.EQ.0)THEN
- CALL MOVE(LX0+64,LY0-64)
- WRITE(*,*)' Sorry, no net vertices'
- RETURN
- ENDIF
- C move origin to middle of window
- CALL ORIGIN(LX0+IWIDNT/2,LY0-IHINT/2)
- C CALL GCOL(0,15)
- DO 40 I=1,NFACES
- C NF= face to plot
- NV=NETVX(I)
- DO 10 N=1,NV
- IX(N)=X(NETNV(N,I))*SCLNET
- C scale the vertex to the screen
- IY(N)=Y(NETNV(N,I))*SCLNET
- 10 CONTINUE
- IX(NV+1)=IX(1)
- IY(NV+1)=IY(1)
- C close the polygon and draw filled depending on ISTKNT
- IF(ISTKNT.EQ.0)THEN
- CALL POLY(NV+1,IX,IY,.TRUE.)
- ELSE
- CALL POLY(NV+1,IX,IY,.FALSE.)
- ENDIF
- 40 CONTINUE
- C now plot the hinges dotted overwrite in black
- CALL WMPSC(0,0,0)
- DO 60 I=1,NHINGS
- J=IHING(I,1)
- C J = face K=side of the face in the net
- K=IHING(I,2)
- L=NETVX(J)
- C L=no of vertices that face need ones for kth side
- M1=NETNV(K,J)
- KK=K+1
- IF(KK.GT.L)KK=1
- M2=NETNV(KK,J)
- IX(1)=X(M1)*SCLNET
- IX(2)=X(M2)*SCLNET
- IY(1)=Y(M1)*SCLNET
- IY(2)=Y(M2)*SCLNET
- CALL MOVE(IX(1),IY(1))
- IF(HINANG(I).GT.0.AND.HINANG(I).LT.3.142)THEN
- C plot dotted lines when hinge angle < PI
- CALL PLOT(21,IX(2),IY(2))
- ELSE
- CALL PLOT(5,IX(2),IY(2))
- ENDIF
- 60 CONTINUE
- CALL ORIGIN(0,0)
- RETURN
- END
- SUBROUTINE PLT3D(LX0,LY0)
- C plots the polyhedra as 3D solid
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- INCLUDE '<WimpPoly$Dir>.f77.WPOLYCH'
- DIMENSION SL(3)
- C SL = light source
- DIMENSION IX(MXVTF+1),IY(MXVTF+1)
- C 0.3*Sqrt(2) so range of dotproducts -0.6 to 1 in shading
- DATA SL/2*0.6,0.52915/
- C light at top right slightly in front
- C check there are vertices
- IF(NVTOT.LE.NNET) THEN
- CALL MOVE(LX0+16,LY0-64)
- WRITE(*,*)'Sorry, no 3D vertices'
- CALL WMPSC(0,11,0)
- CALL MOVE (LX0+16,LY0-100)
- WRITE(*,*)'Dual: ',DUAL
- RETURN
- ENDIF
- C set origin to centre
- CALL ORIGIN(LX0+IWID3D/2,LY0-IHI3D/2)
- C find centres and normals to all faces
- CALL FACENT
- C sort into Z order
- CALL ZSORT
- C ready to start plotting
- C CALL GWIND(0,64,1280,1136)
- C CALL CLG
- C clear graphics screen
- C CALL ORIGIN(IX0,IY0)
- DO 20 I=1,NFPLOT
- NF=INDX(I)
- C NF= face to plot
- NV=NVTX(NF)
- DO 10 N=1,NV
- IX(N)=X(IVTX(N,NF))*SCL3D
- C scale the vertex to the screen
- IY(N)=Y(IVTX(N,NF))*SCL3D
- 10 CONTINUE
- IX(NV+1)=IX(1)
- C close the polygon
- IY(NV+1)=IY(1)
- IF(ISTK3D.EQ.0) THEN
- C grey shaded solid
- COSANG=SL(1)*DCFACE(1,NF)+SL(2)*DCFACE(2,NF)+SL(3)*DCFACE(3,NF)
- KOL=(0.9718+COSANG)*8.114*0.5
- CALL WMPSC(0,7-KOL,0)
- CALL POLY(NV,IX,IY,.TRUE.)
- ELSE
- IF(ISTK3D.EQ.2)THEN
- C colour faces according to number of sides
- KOL=5+NV
- IF(KOL.GT.15)KOL=15
- CALL WMPSC(0,KOL,0)
- CALL POLY(NV,IX,IY,.TRUE.)
- ENDIF
- ENDIF
- C now draw outline
- IF(ISTK3D.EQ.0.OR.ISTK3D.EQ.2.OR.DCFACE(3,NF).GT.0.0) THEN
- IF(ISTK3D.NE.2)THEN
- CALL WMPSC(0,8,0)
- ELSE
- C for coloured ones
- LOL=0
- IF(KOL.EQ.9.or.kol.eq.12.or.KOL.EQ.14)LOL=7
- CALL WMPSC(0,LOL,0)
- ENDIF
- ELSE
- CALL WMPSC(0,2,0)
- ENDIF
- CALL POLY(NV+1,IX,IY,.FALSE.)
- 20 CONTINUE
- IF(IBLOCK(1).EQ.IW3D.AND.DUAL.NE.' ')THEN
- C only plot name when in the 3D window and Dual not blank
- CALL WMPSC(0,11,0)
- CALL MOVE (16-IWID3D/2,40-IHI3D/2)
- WRITE(*,*)'Dual: ',DUAL
- ENDIF
- 90 CALL ORIGIN(0,0)
- C restore origin of co-ordinates
- RETURN
- END
- SUBROUTINE QUIT
- CALL WMPCD
- STOP
- END
- SUBROUTINE RDDAT(ICON,IERR)
- C read the data for the polyhedra file number ICON
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- C
- C get polyhedron number from beginning of list
- READ(SOLIDS(ICON+1),111)NPOLY
- 111 FORMAT(I3)
- IF(NPOLY.LT.74)THEN
- FNAME='<WimpPoly$Dir>.DAT1.P'//SOLIDS(ICON+1)(1:3)
- ELSE
- IF(NPOLY.LT.142)THEN
- FNAME='<WimpPoly$Dir>.DAT2.P'//SOLIDS(ICON+1)(1:3)
- ELSE
- FNAME='<WimpPoly$Dir>.DAT3.P'//SOLIDS(ICON+1)(1:3)
- ENDIF
- ENDIF
- IERR=0
- OPEN(UNIT=INDAT, FILE=FNAME,FORM='FORMATTED')
- NAME=' '
- DUAL=' '
- NDIH=0
- NFACES=0
- NHING=0
- NNET=0
- NVTOT=0
- C find the next header record
- 20 CALL FINDHD(INDAT,ITYPE,IERR)
- IF(IERR.NE.0)GOTO80
- C error while reading
- GOTO(21,22,20,24,20,20,27,28,29,30,31,100,20,20)ITYPE
- C name of poly
- 21 READ(INDAT,101)NAME
- 101 FORMAT(A)
- C make window title
- NX=LNBLNK(NAME)
- TITL3D=NAME(1:NX)//CHAR(0)
- TITLNT=SOLIDS(ICON+1)(1:4)//'Net'//CHAR(0)
- GOTO20
- C read number
- 22 READ(INDAT,101)NUMBER
- GOTO20
- C dual of poly
- 24 READ(INDAT,101)DUAL
- GOTO20
- C read the net
- 27 CALL RDFACE(INDAT,NETVX,NETNV)
- GOTO20
- C read solid line store vertex numbers each face
- 28 CALL RDFACE(INDAT,NVTX,IVTX)
- GOTO 20
- C read the hinges
- 29 CALL RDHING(INDAT)
- GOTO20
- C read the dihedral angles
- 30 READ(INDAT,*)NDIH
- GOTO20
- C read vertices line and store X,Y,Z
- 31 CALL RDVTX(INDAT,IERR)
- C this should be last header in the file but read for EOF anyway
- IF(IERR)90,100,90
- C 80 WRITE(*,*)' enter 1 to try another file, -1 to stop'
- 80 CALL WMPRE(3,'Error in Datafile, OK to try another',3,
- 1'WimpPoly',IERR)
- C user has selected 'Cancel' when Ierr=2, OK when =1
- IF(IERR.EQ.2)CALL QUIT
- RETURN
- 90 IERR=-1
- 100 CLOSE (INDAT)
- RETURN
- END
- SUBROUTINE RDFACE(INDAT,KVTX,IVBUF)
- C reads the lines following the headers :net and :solid
- C on unit INDAT KVTX= storage for no of vertices per face
- C IVBUF
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- DIMENSION IVBUF(MXVTF,MXFACE),KVTX(*)
- CHARACTER *80 KARD
- COMMON/WORK/KARD
- READ(INDAT,*)NFACES, MAXVF
- IF(NFACES.GT.MXFACE)THEN
- CALL WMPRE(1,'Too many Faces',2,'WimpPoly',IERR)
- C WRITE(*,*)' Nfaces=',NFACES,' Maxvf=',Maxvf
- C WRITE(*,*)' but only ',MXFACE,' faces allowed'
- C READ(*,*)KMC
- C STOP 'too many faces'
- CALL QUIT
- ENDIF
- DO 20 I=1,NFACES
- C read the vertex numbers associated with this face
- READ(INDAT,*)N,(IVBUF(J,I),J=1,N)
- 110 FORMAT(A)
- KVTX(I)=N
- C vertex numbers in data start at zero
- DO 10 J=1,N
- 10 IVBUF(J,I)=IVBUF(J,I)+1
- 20 CONTINUE
- RETURN
- END
- SUBROUTINE RDHELP
- C reads the help text to an array ready to display on the screen
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- CHARACTER *30 FLHLP
- DATA FLHLP/'<WimpPoly$Dir>.PolyHelp'/
- OPEN(22,FILE=FLHLP,STATUS='OLD',FORM='FORMATTED')
- C ignore 1st line, repeats the title
- I=1
- READ(22,101,END=80)HELPTX(1)
- DO 20 I=1,MAXHLP
- READ(22,101,END=80)HELPTX(I)
- 101 FORMAT(A)
- 20 CONTINUE
- CLOSE(22)
- RETURN
- 80 CLOSE(22)
- C end of file before MAXHLP lines
- DO 30 J=I,MAXHLP
- 30 HELPTX(J)=' '
- RETURN
- END
- SUBROUTINE RDHING(INDAT)
- C read in the hinge data
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- READ(INDAT,*)NHINGS
- IF(NHINGS.GT.MAXHIN)THEN
- CALL WMPRE(1,'Too many Hinges',2,'WimpPoly',IERR)
- CALL QUIT
- C WRITE(*,*)' too many hinges ',NHINGS,' no. allowed ',MAXHIN
- C STOP 'many hinges'
- ENDIF
- DO 20 I=1,NHINGS
- C read the data for each hinge
- READ(INDAT,*)(IHING(I,J),J=1,4),HINANG(I)
- C increment vertex nos by 1 to match the vertices
- DO 10 J=1,4
- 10 IHING(I,J)=IHING(I,J)+1
- 20 CONTINUE
- RETURN
- END
- SUBROUTINE RDLIST(N)
- C reads the file of names of polyhedra into array SOLIDS
- C returns N the number of lines read
- CHARACTER * 80 BUFR
- INCLUDE '<WimpPoly$Dir>.f77.WPolyCH'
- CHARACTER *25 FSOLID
- DATA FSOLID/'<WimpPoly$Dir>.POLYLIST'/
- INT=2
- OPEN(INT,FILE=FSOLID,FORM='FORMATTED')
- N=1
- 10 READ(INT,101,ERR=90,END=60)SOLIDS(N)
- 101 FORMAT(A)
- IF(N.GE.MAXSOL)GOTO50
- N=N+1
- GOTO10
- C more entries than dimensions
- C put in code for red triangle here
- 50 CALL WMPRE(2,'Too many entries in list',3,'WimpPoly',IERR)
- C user has selected 'Cancel' when Ierr=2
- IF(IERR.EQ.2)CALL QUIT
- C found the END of file
- 60 N=N-1
- CLOSE(INT)
- RETURN
- 90 WRITE(BUFR,102)N,SOLIDS(N)(1:20)
- 102 FORMAT(' error while reading after ',I3,'records',
- 1' last one was',A20)
- CALL WMPRE(1,BUFR,2,'WimpPoly',IERR)
- C can only reply with IERR=2 for cancel
- CALL QUIT
- END
- SUBROUTINE RDVTX(INDAT,IERR)
- C reads the vertices following the header line :vertices
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- CHARACTER *80 BUFR
- C Returns IERR=0 for good read, 1 or -1 otherwise
- IERR=0
- READ(INDAT,*)NVTOT,NNET
- IF(NVTOT.GE.MAXVTX)THEN
- WRITE(BUFR,102)MAXVTX,NVTOT
- 102 FORMAT('too many vertices ',I3,'allowed,',I3,'read')
- CALL WMPRE(1,BUFR,2,'WimpPoly',IERR)
- C can only reply with IERR=2 for cancel
- CALL QUIT
- ENDIF
- IF(NVTOT.EQ.NNET)THEN
- WRITE(*,*)' no co-ordinates for solid vertices'
- ENDIF
- C now read the X,Y,Z for the solid
- DO 30 I=1,NVTOT
- READ(INDAT,*,END=90,ERR=80)X(I),Y(I),Z(I)
- 30 CONTINUE
- RETURN
- 80 WRITE(*,*)' Error reading vertex ',I
- IERR=-1
- RETURN
- 90 WRITE(*,*)' Unexpected EOF '
- IERR=1
- RETURN
- END
- SUBROUTINE REDRAW
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- CALL WMPRW(IBLOCK,MORE)
- IF(MORE.EQ.0) RETURN
- C set up top left corner of window to draw
- 10 LX0=IBLOCK(2)-IBLOCK(6)
- LY0=IBLOCK(5)-IBLOCK(7)
- IF(IBLOCK(1).EQ.IWNET)CALL PLTNET(LX0,LY0)
- IF(IBLOCK(1).EQ.IW3D)CALL PLT3D(LX0,LY0)
- IF(IBLOCK(1).EQ.IWHELP)CALL SHOHLP(LX0,LY0)
- IF(IBLOCK(1).EQ.IWINTR)CALL INTRO(LX0,LY0)
- CALL WMPGR(IBLOCK,MORE)
- IF(MORE.NE.0) GO TO 10
- RETURN
- END
- SUBROUTINE ROTPOL(IANS)
- C applies the rotation angles in X, Y, not Z
- C IANS = which cursor key pressed
- C 396=left arrow 397=right arrow 398=down 399 =up
- PARAMETER(DEGTOR=0.017453293)
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- C
- IF(IANS.LT.398)THEN
- C rotations about Y
- ROTY=10.
- IF(IANS.EQ.397)ROTY=-10.
- CY=COS(DEGTOR*ROTY)
- SY=SIN(DEGTOR*ROTY)
- C if no 3D vertices, NNET = NVTOT
- DO 20 I=1+NNET, NVTOT
- Z2=Z(I)*CY+X(I)*SY
- X(I)=X(I)*CY-Z(I)*SY
- Z(I)=Z2
- 20 CONTINUE
- ELSE
- C rotations about X
- ROTX=10.
- IF(IANS.EQ.399)ROTX=-10.
- C=COS(DEGTOR*ROTX)
- S=SIN(DEGTOR*ROTX)
- DO 40 I=1+NNET,NVTOT
- Y2=Y(I)*C-Z(I)*S
- Z(I)=Z(I)*C+Y(I)*S
- Y(I)=Y2
- 40 CONTINUE
- ENDIF
- CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
- RETURN
- END
- SUBROUTINE SAVEBX(JBLOC,IREASN)
- C two routines for saving files from menu windows using DragBoxes
- C
- C firstly:
- C
- C SAVEMN(ITYPE,IWINDO) creates the window containing a sprite, filename
- C OK box, to be attached to a menu which includes a 'Save' option.
- C It returns IWINDO, the handle of the created window.
- C It must be given ITYPE, the file type to be saved.
- C at the moment ITYPE can be either ?I0FFF (text) or ?I0AFF (draw)
- C others can be included by incrementing NTYPES and the associated
- C DATA statements below
- C
- C then the work is done by:
- C
- C SAVEBX(JBLOC,IREASN) called in the Wimp_Poll loop
- C JBLOC and IREASN are the WimpPoll block and reason code
- C IREASN is returned negative if SAVEBX has used this poll
- C
- C the user must also supply the following routine:
- C
- C SAVEFL(IERR) user routine to save the file to '<F77$File>' which is a
- C system alias for the name in the icon of the 'save' window. This is to
- C get round the bug in Fortran77 where file names are truncated to 30
- C characters in the OPEN statement.
- C returns IERR=0 if OK;
- C if the save failed, it returns IERR<>0 when the file must not be written
- C or it must be deleted if one has been written.
- C
- DIMENSION JBLOC(*)
- DIMENSION IBLOC(22),IREGS(0:7)
- EQUIVALENCE(IREGS(2),ITYPS)
- PARAMETER (NTYPES=2)
- CHARACTER DUMMY*1,FTYPE*9,VALID*4,FNAME*100,FOK*3
- CHARACTER*11 OLDFNM
- CHARACTER*4 TYPE(NTYPES),LTYP(NTYPES)*3
- DIMENSION JTYP(NTYPES)
- DATA VALID/'A~ .'/,FOK/'OK.'/,DUMMY/'.'/
- DATA TYPE/'Text','Draw'/
- DATA JTYP/?I0FFF,?I0AFF/
- DATA LTYP/ 'fff', 'aff'/
- DATA IBLOC/0,-164,264,0,0,0,-1,?I84000012,?I01070207,?I020103,
- +0,-164,264,0,?I3D,?I3000,0,0,?I65766153,?I3A736120,0,0/
- DATA IREGS/18,7*0/
- C
- IF((IREASN.EQ.17.OR.IREASN.EQ.18).AND.JBLOC(5).EQ.2) THEN
- C
- C 'User message of type 2' (Wimp_Poll reason 17 or 18, JBLOC(5) is type)
- C this is the filer replying to request to save file
- C JBLOC contains the reply from the filer
- C get file name into FNAME
- CALL WMPH2C(JBLOC(12),FNAME,L)
- C close menu
- CALL WMPCM(-1,0,0)
- C set up alias for name
- CALL OSCLI('Set F77$File '//FNAME(1:L))
- C write the file
- CALL SAVEFL(IERR)
- C set file type with OS_File 18
- IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
- C reset filename if not confirmed
- IF(JBLOC(10).LE.-1) FNAME=OLDFNM
- C send data-load message to filer
- JBLOC(4)=JBLOC(3)
- JBLOC(5)=3
- JBLOC(1)=64
- CALL WMPSMG(18,JBLOC,JBLOC(6),JBLOC(7))
- C set 'used' flag
- IREASN=-1
- RETURN
- ENDIF
- C
- C is this mouse click over 'save' window
- IF(IREASN.EQ.6.AND.JBLOC(4).EQ.IWSAVE) THEN
- C set 'used' flag
- IREASN=-1
- C click over 'OK' icon, go save file...
- IF(JBLOC(5).EQ.ICOK) GO TO 300
- C
- IF(JBLOC(5).EQ.ICSPRT .AND. IAND(JBLOC(3),?I50).GT.0) THEN
- C drag initiated with mouse
- C set up drag box attached to mouse
- IBLOC(1)=IWSAVE
- C Find coordinates of save window
- CALL WMPGWS(IBLOC)
- IX0=IBLOC(2)-IBLOC(6)
- IY0=IBLOC(5)-IBLOC(7)
- IBLOC(2)=ICSPRT
- C Find coordinates of sprite icon
- CALL WMPGIS(IBLOC)
- C Set up for drag
- IBLOC(1)=IWSAVE
- C Drag type 5
- IBLOC(2)=5
- C coordinates of sprite boundary
- IBLOC(3)=IX0+IBLOC(3)
- IBLOC(4)=IY0+IBLOC(4)
- IBLOC(5)=IX0+IBLOC(5)
- IBLOC(6)=IY0+IBLOC(6)
- C bounds for dragging to
- IBLOC(7)=0
- IBLOC(8)=0
- IBLOC(9)=99999
- IBLOC(10)=99999
- C initiate drag
- CALL WMPDB(IBLOC)
- ENDIF
- RETURN
- ENDIF
- C
- C is key pressed over save window?
- IF(IREASN.EQ.8.AND.JBLOC(1).EQ.IWSAVE) THEN
- C (Wimp_Poll reason 8, window handle in JBLOC(1), Key value in JBLOC(7))
- C set 'used' flag
- IREASN=-1
- C accept <CR> only
- IF(JBLOC(7).EQ.13) GO TO 300
- C otherwise give back to Wimp
- CALL WMPPK(JBLOC(7))
- RETURN
- ENDIF
- C
- IF(IREASN.EQ.7) THEN
- C drag finished (reason 7 from Wimp_Poll)
- C initiate save dialogue
- C
- C set 'used' flag
- IREASN=-1
- C find where we are
- CALL WMPGPI(IBLOC)
- C check we are over a window
- IF(IBLOC(4).LT.0) RETURN
- C set up datasave message
- C
- C Window & icon handles
- IBLOC(6)=IBLOC(4)
- IBLOC(7)=IBLOC(5)
- C coordinates
- IBLOC(8)=IBLOC(1)
- IBLOC(9)=IBLOC(2)
- C size of file (a guess only!!!)
- IBLOC(10)=9999
- C file type
- IBLOC(11)=ITYPS
- C null terminated file name
- L=INDEX(FNAME,CHAR(0))
- DO 210 I=L-1,1,-1
- IF(FNAME(I:I).EQ.'.') GO TO 220
- 210 CONTINUE
- I=0
- 220 IF(L-I.LT.2 .OR. L-I.GT.11) THEN
- CALL WMPRE(20,'Problem in file name length calculation',
- + 1,'Drag File',IR)
- RETURN
- ENDIF
- OLDFNM=FNAME(I+1:L)
- CALL WMPC2H(FNAME(I+1:L-1),IBLOC(12))
- C block length in bytes & dummy reference #
- IBLOC(1)=64
- IBLOC(4)=0
- C action (1 = save)
- IBLOC(5)=1
- C now send message
- CALL WMPSMG(17,IBLOC,IBLOC(6),IBLOC(7))
- ENDIF
- RETURN
- C
- C file name FNAME entered by hand, save the file
- 300 IF(INDEX(FNAME,'$.').EQ.0) THEN
- CALL WMPRE(20,'Please set up the complete file and path name'
- + ,1,'Drag File',IR)
- ELSE
- C close menu
- CALL WMPCM(-1,0,0)
- C set up alias for name
- L=INDEX(FNAME,CHAR(0))-1
- CALL OSCLI('Set F77$File '//FNAME(1:L))
- C write the file
- CALL SAVEFL(IERR)
- C set file type with OS_File 18
- IF(IERR.EQ.0) CALL SWIF77(8,IREGS,IFLAG)
- ENDIF
- RETURN
- C
- C SAVEMN(ITYPE,IWINDO) sets up a save window with handle IWINDO
- C for files of type ITYPE
- C
- ENTRY SAVEMN(ITYPE,IWINDO)
- C set up file name location for OS_File
- IREGS(1)=LOCC(FNAME)
- C find file type in list
- ITYPS=ITYPE
- DO 10 IT=1,NTYPES
- IF(ITYPE.EQ.JTYP(IT)) GO TO 20
- 10 CONTINUE
- IWINDO=-1
- RETURN
- C construct Wimp sprite name
- 20 FTYPE='file_'//LTYP(IT)
- C make window
- CALL WMPCRW(IBLOC,IWSAVE)
- IWINDO=IWSAVE
- C make file sprite
- ICSPRT=IWMPCI(IWSAVE,100,-92,68,68,?I6102,FTYPE,DUMMY)
- C make file name
- FNAME=TYPE(IT)//'File'//CHAR(0)
- ICNAME=IWMPCI(IWSAVE,8,-156,192,48,?I0700F12D,FNAME,VALID)
- C make 'OK' box
- ICOK=IWMPCI(IWSAVE,208,-156,48,48,?IC701903D,FOK,DUMMY)
- RETURN
- END
- SUBROUTINE SAVEFL(IER)
- C routine to create Drawfile to be saved to file FILNAM using drag box
- C IER is error return, =0 when OK
- C
- CHARACTER *24 TRUBL
- CALL DRFILE('A5P','<F77$File>',IER)
- C save the window here as a DrawFile display error number
- IF(IER.NE.0)THEN
- WRITE(TRUBL,101)IER
- 101 FORMAT('Error ',I3,' from DRFILE',$)
- CALL WMPRE(IER,TRUBL,1,'WimpPoly',IERR)
- C if file still exists remove it
- CALL OSCLI('REMOVE <F77$File>')
- ENDIF
- RETURN
- END
- SUBROUTINE SCAL3D(KODE)
- C scales the solid by fixed amount
- C 60 44 <, smaller 62 46 >. bigger
- INCLUDE '<WimpPoly$Dir>.f77.WPolyPic'
- INCLUDE '<WimpPoly$Dir>.f77.WpolyWimp'
- DATA DSCALE/0.9/,SMIN/64/
- C SMIN is in screen units
- IF(KODE.EQ.60.OR.KODE.EQ.44)THEN
- C make smaller by delta scale
- SCL3D=SCL3D*DSCALE
- IF(SCL3D.LE.SMIN)SCL3D=SMIN
- ELSE
- SCL3D=SCL3D/DSCALE
- IF(SCL3D.GT.IWID3D)SCL3D=IWID3D-32
- ENDIF
- CALL WMPFR(IW3D,0,-IHI3D+64,IWID3D,0)
- RETURN
- END
- SUBROUTINE SHOHLP(LX0,LY0)
- C displays Help text within the help window
- INCLUDE'<WimpPoly$Dir>.f77.WPOLYCH'
- CALL WMPSC(0,7,0)
- C set colour of text
- DO 20 I=1,MAXHLP
- CALL WMPTXT(LX0,LY0+32-32*I,HELPTX(I))
- 20 CONTINUE
- C CALL VDU(4)
- C CALL TAB(0,0)
- C WRITE(*,101)LX0,LY0,(MVDUVAR(I),I=128,131)
- C CALL VDU(5)
- C 101 FORMAT(' LX0,LY0=',2I6,' X1,Y1,X2,Y2=',4I6)
- RETURN
- END
- SUBROUTINE ZSORT
- C COMMON BLOCK
- INCLUDE'<WimpPoly$Dir>.f77.WPOLYPic'
- C SET UP INDEX to which faces to plot
- IF(ISTK3D.NE.1) THEN
- C 3d solid gray shades or colour
- NFPLOT=0
- DO 10 I=1,NFACES
- IF(DCFACE(3,I).GT.-0.0001)THEN
- NFPLOT=NFPLOT+1
- INDX(NFPLOT)=I
- ENDIF
- 10 CONTINUE
- ELSE
- C wire model
- NFPLOT=NFACES
- DO 15 I=1,NFACES
- 15 INDX(I)=I
- ENDIF
- CALL QSORTR(ZFACE,INDX,NFPLOT)
- C I=1
- C 20 IF(ZFACE(INDX(I)).LE.ZFACE(INDX(I+1))) THEN
- C I=I+1
- C ELSE
- C J=INDX(I)
- C INDX(I)=INDX(I+1)
- C INDX(I+1)=J
- C I=I-1
- C IF(I.EQ.0) I=2
- C ENDIF
- C IF(I.LT.NFPLOT) GO TO 20
- RETURN
- END
-