home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / tgraphics < prev    next >
Encoding:
Text File  |  1992-09-18  |  9.2 KB  |  331 lines
  1.       PROGRAM TGRAPHICS
  2. C        tests all Graphics library
  3. C        needs 'graphics' and 'utils' libraries
  4.       COMMON/MTYPE/MONIT
  5.       DIMENSION KPX(6),KPY(6)
  6.       DIMENSION KFX(10),KFY(10)
  7.       DIMENSION IBUF(32)
  8.       CHARACTER*1 QUEST,COLR(32)
  9. C                    
  10.       LOGICAL ANS, OSCLI
  11. C                    
  12.       DATA KPX/300,400,500,600,500,400/
  13.       DATA KPY/700,800,800,700,600,600/
  14.       DATA KFX/  0,  0,100,200,200,164,164,200,200,  0/
  15.       DATA KFY/  0,200,100,200,100,100, 64, 64,  0,  0/
  16.       DO 5 I=1,16
  17.       IBUF(I   )=I-1
  18.       IBUF(I+16)=I+15
  19.       COLR(I   )=CHAR(I-1)
  20.     5 COLR(I+16)=CHAR(I-1)
  21.    10 PRINT *,' Ordinary or Multisync monitor (O/M)'
  22.       READ (*,101,ERR=10)QUEST
  23.   101 FORMAT(A)
  24.       IF(QUEST.NE.'O'.AND.QUEST.NE.'M') GO TO 10
  25.       IF(QUEST.EQ.'O') THEN
  26.         M=12
  27.         MONIT=0
  28.         IX1=30
  29.         IY1=31
  30.         IX2=79
  31.         IY2=28 
  32.       ELSE
  33.         ANS=OSCLI('CO.MONITORTYPE 1')
  34.         M=20
  35.         IX1=20
  36.         IY1=63
  37.         IX2=79
  38.         IY2=58 
  39.         MONIT=1
  40.       ENDIF
  41.       NCOLS=16
  42.       CALL MODE(M)
  43.       DO 12 I=8,NCOLS-1                      
  44. C                     set up colours
  45.       IGRAY=16*I
  46.       CALL VDU19(I,16,IGRAY,IGRAY,IGRAY)
  47.   12  CONTINUE
  48.       CALL TAB(20,0)
  49.       WRITE(*,*)'MODE ',M,' ',NCOLS,'Colours'
  50.       CALL TWIND(IX1,IY1,IX2,IY2)
  51.       WRITE(*,*)'Text window at ',IX1,IY1,IX2,IY2
  52.       CALL COLOUR(2)
  53.       WRITE(*,*)'cursor ON, press a key to turn it off'
  54.       IF(IGET().EQ.27) STOP 'ESC'
  55.       ANS=.FALSE.
  56.       CALL CURSOR(ANS)
  57.       WRITE(*,*)'Press a key to turn cursor on again'
  58.       IF(IGET().EQ.27) STOP 'ESC'
  59.       CALL COLOUR(7)
  60.       ANS=.TRUE.
  61.       CALL CURSOR(ANS)
  62.       WRITE(*,*)'Press a key to test CLS'
  63.       IF(IGET().EQ.27) STOP 'ESC'
  64.       CALL CLS               
  65.    14 WRITE(*,*)'Enter a number to test ModeVar(0-12)'
  66.       READ(*,*,ERR=14)MVR
  67.       IF(MVR.GT.12) GO TO 14
  68.       IF(MVR.GT.-1) THEN
  69.         CALL CLS
  70.         PRINT *,' ModeVar(',MVR,')=',MODEVAR(-1,MVR)
  71.         GO TO 14
  72.       ENDIF
  73.    15 WRITE(*,*)'Enter a number to test MVDUVar(128-257)'
  74.       READ(*,*,ERR=15)MVR
  75.       IF(MVR.GT.257) GO TO 15
  76.       IF(MVR.GT.127) THEN
  77.         CALL CLS
  78.         PRINT *,' MVDUVar(',MVR,')=',MVDUVAR(MVR)
  79.         GO TO 15
  80.       ENDIF
  81.       WRITE(*,*)'Press a key to test FCOL16'
  82.       IF(IGET().EQ.27) STOP 'ESC'
  83. C                        now test fcol16
  84.       DO 16 IY=11,27
  85.       CALL FCOL16(IY,IY   ,16,1,IBUF(IY-10),1,COLR   ,0)
  86.       CALL FCOL16(IY,IY+32,16,1,IBUF(IY-10),1,CHAR(0),0)
  87.    16 CONTINUE
  88. C                        now test rectangles
  89.       LX=200
  90.       LY=100
  91.       KOL=1
  92.       CALL GCOL(0,KOL)
  93.       CALL RECTAN(0,0,LX,LY,.FALSE.)
  94.       CALL WOG(4,LY-32,'Outline rectangle')
  95.       CALL WOC(4,32,KOL)
  96.       KOL=2
  97.       CALL GCOL(0,KOL)
  98.       CALL ORIGIN(LX,LY)
  99.       CALL RECTAN(0,0,LX,LY,.FALSE.)
  100.       CALL WOG(4,LY-32,'Outline rectangle')
  101.       CALL WOC(4,32,KOL)
  102.       CALL MOVE(-LX+4,LY-4)
  103.       WRITE(*,*)' Origin at ',LX,LY
  104.       CALL ORIGIN(0,0)
  105. C                     test of move origin completed
  106.       WRITE(*,*)'Press a key to continue'
  107.       IF(IGET().EQ.27) STOP 'ESC'
  108.       IS=74
  109.       IX=40
  110.       IY=1024-128
  111.       CALL WOG(IX,IY+IS+32,'Filled rectangles')  
  112.       DO 20 I=0,NCOLS-1                      
  113.       IF(I.GT.7)THEN
  114. C                     set up colours
  115.         IGRAY=16*I
  116.         CALL VDU19(I,16,IGRAY,IGRAY,IGRAY)
  117.       ENDIF
  118.       CALL GCOL(0,I)                           
  119.       CALL RECTAN(IX,IY,IX+IS,IY+IS,.TRUE.)
  120.       CALL MOVE(IX,IY-32)                   
  121.       CALL GCOL(0,7)
  122.       CALL VDU(5)
  123.       WRITE(*,*)I
  124.       CALL VDU(4)
  125.    20 IX=IX+IS  
  126.       WRITE(*,*)'Press a key to interchange colours 2 and 6'
  127.       IF(IGET().EQ.27) STOP 'ESC'
  128.       CALL VDU19(2,6,0,0,0)
  129. C                     changing physical and logical colours
  130.       CALL VDU19(6,2,0,0,0)
  131.       WRITE(*,*)'Press a key to continue'
  132.       IF(IGET().EQ.27) STOP 'ESC'
  133. C                     now circles
  134.       IX=200
  135.       IY=300
  136.       IR=96
  137.       KOL=3
  138.       CALL GCOL(0,KOL)
  139.       CALL CIRCLE(IX,IY,IR,.FALSE.)
  140.       CALL WOG(IX-IR+32,IY,'Outline circle')
  141.       CALL WOC(IX-IR+32,IY-64,KOL)
  142.       KOL=4
  143.       CALL GCOL(0,KOL)
  144.       IY=IY+IR+IR+8
  145.       CALL CIRCLE(IX,IY,IR,.TRUE.)
  146.       CALL GCOL(0,7)
  147.       CALL WOG(IX-IR+32,IY,'Filled circle')
  148.       CALL WOC(IX-IR+32,IY-64,KOL)
  149. C                      area fill general
  150.       CALL ORIGIN(20,600)
  151.       KOL=KOL+1
  152.       CALL GCOL(0,7)
  153.       CALL POLY(10,KFX,KFY,.FALSE.)
  154.       CALL GCOL(0,KOL)
  155.       CALL FILL(KFX(1)+20,KFY(1)+20)
  156.       CALL GCOL(0,7)
  157.       CALL WOG(0,+64,'Area fill')
  158.       CALL WOC(0,32,KOL)
  159.       CALL ORIGIN(0,0)
  160. C                        area fill with triangles
  161.       KOL=KOL+1
  162.       CALL GCOL(0,KOL)
  163.       CALL POLY(6,KPX,KPY,.TRUE.)
  164.       CALL GCOL(0,7)
  165.       CALL WOG(KPX(1),KPY(1)-32,'Triangle fill')
  166.       CALL WOC(KPX(1),KPY(1)-64,KOL)
  167.       WRITE(*,*)'Press a key for graphics window'
  168.       IF(IGET().EQ.27) STOP 'ESC'
  169. C                          make graphics window
  170.       IX1=500
  171.       IY1=300
  172.       IX2=1200
  173.       IY2=700
  174.       CALL GWIND(IX1,IY1,IX2,IY2)
  175.       CALL WOG(IX1+32,IY2-32,'Graphics window here')
  176.       WRITE(*,*)'Press a key to test CLG'
  177.       IF(IGET().EQ.27) STOP 'ESC'
  178.       KOL=128+9
  179.       CALL GCOL(0,KOL)
  180. C                          test CLG
  181.       CALL CLG
  182.       PRINT *,'Press a key to test LINE'
  183.       IF(IGET().EQ.27) STOP 'ESC'
  184. C                          test LINE
  185.       CALL GCOL(0,1)
  186.       CALL LINE(IX1,IY1,IX2,IY2)
  187.       PRINT *,'Press to test DRAW etc'
  188.       IF(IGET().EQ.27) STOP 'ESC'
  189.       CALL PLOT(4,IX1,IY2)
  190.       CALL DRAW(IX2,IY1)
  191.       CALL GCOL(3,7)
  192.       CALL PLOT85(IX2,IY2)
  193.       KOL=0
  194.       CALL GCOL(0,KOL)
  195. C                          test SPOT
  196.       WRITE(*,*)'Press a key to test SPOTS'
  197.       IF(IGET().EQ.27) STOP 'ESC'
  198.       DO 40 I=IX1+50, IX2-50, 50
  199.       DO 40 J=IY1+50, IY2-50, 50
  200.    40 CALL SPOT(I,J)
  201.       CALL VDU23(254,0,127,36,36,36,36,36,0)
  202.       WRITE(*,102)254
  203.   102 FORMAT(' Printing a Pi here: ',A1)
  204.       WRITE(*,*)'Press a key to test big characters'
  205.       IF(IGET().EQ.27) STOP 'ESC'
  206.       CALL GCOL(0,1)
  207.       CALL WOGBIG(800,400,'BIG',4)      
  208.       WRITE(*,*)'Press a key to do 256 colours'
  209.       IF(IGET().EQ.27) STOP 'ESC'
  210.    50 CALL TG256(MONIT)
  211.       IF (MONIT.EQ.1) THEN
  212.         ANS=OSCLI('CO.MONITORTYPE 4')
  213.         CALL MODE(20)
  214.       ENDIF
  215.       STOP
  216.       END
  217.       SUBROUTINE TG256(MONIT)
  218.       DIMENSION IBUF(512)
  219.       CHARACTER*256 KOLOUR(2)
  220.       DO 2 I=1,512
  221.       IBUF(I)=I-1
  222.     2 CONTINUE
  223.       CALL COLSET(KOLOUR)
  224.       KOLOUR(2)=KOLOUR(1)
  225.       IF(MONIT.EQ.1) THEN
  226.         IYSIZ=2
  227.         M=21
  228.       ELSE     
  229.         IYSIZ=1
  230.         M=15
  231.       ENDIF
  232.       CALL MODE(M)
  233. C**** TEST GCOLT HERE  ****
  234.       DO 5 I=0,60,4
  235.       DO 5 J=0,3
  236.       DO 5 IT=0,192,64
  237.       CALL GCOLT(3,I+J,IT)
  238.       CALL CIRCLE(I*20+40,J*64+IT*4+32,40,.TRUE.)
  239.     5 CONTINUE
  240.       PRINT *,'Press a key to continue'
  241.       IF(IGET().EQ.27) STOP 'ESC'
  242.       CALL CLG
  243.       CALL COLORT(42,128)
  244.       PRINT 101,M
  245.   101 FORMAT(21X,'256 Colour mode',I3)
  246.       DO 50 IB=0,3
  247.       IYS=8*IB*IYSIZ
  248.       CALL TAB(15,IYS+3*IYSIZ-2)
  249.       CALL TXTCOL(0,0,IB,3)
  250.       PRINT 102,IB
  251.   102 FORMAT('Blue =',I2)
  252.       CALL COLORT(63,192)
  253.       PRINT 103
  254.   103 FORMAT('  \Red'/'  G')
  255.       DO 10 IR=0,3
  256.       CALL TXTCOL(IR,0,IB,3)
  257.       CALL WOT(IR*20+12,IYS+3*IYSIZ-1,CHAR(IR+48))
  258.   104 FORMAT($,I1)
  259.    10 CONTINUE
  260.       DO 40 IG=0,3
  261.       CALL TXTCOL(0,IG,IB,3)
  262.       CALL WOT(2,IYS+IYSIZ*IG+4*IYSIZ,CHAR(IG+48))
  263.       IX=64
  264.       IY=864-IB*256-IG*32
  265.       DO 30 IR=0,3
  266.       DO 20 IT=0,3
  267.       CALL GRFCOL(0,IR,IG,IB,IT)
  268.       CALL RECTAN(IX,IY,IX+64,IY+32,.TRUE.)
  269.    20 IX=IX+64
  270.    30 IX=IX+64
  271.    40 CONTINUE
  272.    50 CONTINUE
  273.       CALL TAB(40,0)
  274.       PRINT *,'Press a key to continue'
  275.       IF(IGET().EQ.27) STOP 'ESC'
  276.       NY=MODEVAR(-1,12)+1
  277.       CALL CLG
  278.       CALL FCOL256(0,0,512,NY,IBUF,0,KOLOUR,1)
  279.       PRINT *,'Press a key to end'
  280.       IF(IGET().EQ.27) STOP 'ESC'
  281.       RETURN
  282.       END
  283.       SUBROUTINE WOC(IX,IY,KOL)
  284.       CHARACTER*9 COLOUR
  285.       DATA COLOUR(1:6)/'Colour'/
  286. C                   writes out colour number used KOL at position IX,IY
  287.       WRITE(COLOUR(7:9),101)KOL
  288.   101 FORMAT(I3)
  289.       CALL WOG(IX,IY,COLOUR)
  290.       RETURN
  291.       END
  292.       SUBROUTINE COLSET(COLOUR)
  293. C          sets default colours for FCL256
  294.       CHARACTER*256 COLOUR
  295.       DIMENSION IC(16),IND(64)
  296. C              BLAC     R    G    B
  297. C                 BR   RR   RG   GG   GB   BB
  298. C           BBG  BGG  GGG  GGR  GBR  GRR  RRR  RRB  RBB  BBB
  299. C     BBBG BBGG BGGG GGRB GGGR GGRR GRRR RRBG RRRB RRBB RBBB BBRG
  300.       DATA IND/    0,   4,  32,   8,
  301.      +            12,  16,  36,  64,  40, 128,                    
  302.      +      160,  72,  96,  68,  44,  48,  20,  24, 132, 136,
  303.      + 168, 192, 104,  76, 100,  80,  52,  56,  28, 144, 140, 164,32*0/
  304. C                           
  305.       DATA IC/0,0,0,1,2,5,11,21,33,45,55,61,64,65,65,65/
  306. C
  307.       DO 10 I=1,32
  308.    10 IND(I+32)=252-IND(33-I)
  309.       K=0
  310.       DO 40 I=1,13
  311.       DO 30 J=0,3
  312.       J1=I+J
  313.       IC1=IC(J1)
  314.       IF(IC1.LE.0.OR.IC1.GT.64)GOTO30
  315.       IC2=IC(J1+1)-1
  316.       DO 20 I1=IC1,IC2
  317.       K=K+1
  318.    20 COLOUR(K:K)=CHAR(IND(I1)+3-J)
  319.    30 CONTINUE
  320.    40 CONTINUE
  321.       IF(K.NE.256)STOP  'K > 256'
  322.       DO 60 I=1,255
  323.       DO 50 J=I+1,256
  324.       IF(COLOUR(I:I).EQ.COLOUR(J:J))
  325.      1       PRINT*,' GOof I,J,COLOUR',I,J,COLOUR(I:I)
  326.    50 CONTINUE
  327.    60 CONTINUE
  328.       RETURN
  329.       END
  330.  
  331.