home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / tspriteop < prev    next >
Encoding:
Text File  |  1993-11-20  |  14.0 KB  |  432 lines
  1.       PROGRAM Tspritop
  2. C         tests all the SpriteOp library
  3. C      needs 'utils', 'graphics' and 'spriteop' libraries
  4. C                                       COMMON BLOCK
  5.       PARAMETER(ISPSIZ=2014)
  6.       COMMON IX1,IY1,IZ1,
  7.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  8.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  9.      4 MODES,MX1,MY1,MZ1,NPTS         
  10.       CHARACTER *4 SPR,FRED,MARY
  11.       COMMON/CHRS/SPR(2)
  12. C
  13.       INTEGER MMOUSE(3)
  14.       LOGICAL OSCLI
  15. C
  16.       DATA MMOUSE/2,1,1/
  17. C
  18.       CALL INIT
  19.       CALL MODE (MODES)
  20.       CALL MAKES1
  21.       CALL MAKES2
  22.       CALL TESTSP
  23.       CALL CLS
  24.       CALL ORIGIN (640,512)
  25.       CALL CURSOR(.FALSE.)
  26.       ISS=4
  27. C                     ------------start of main loop----------
  28.    10 CONTINUE
  29.       CALL MOUSE (IX1,IY1,MB1)
  30. C                                     left mouse button
  31.       IF(MB1.EQ.1) IZP=IZP+ISS
  32. C                                     right mouse button
  33.       IF(MB1.EQ.4) IZP=IZP-ISS
  34.       IC=INKEY(0)
  35.       IF(IC.EQ.81.OR.IC.EQ.113)THEN
  36. C                  put cursor keys back to arrow operation
  37.         CALL CURSOR(.TRUE.)
  38.         STOP'OK'
  39.       ENDIF
  40.       CALL CLS
  41.       CALL PLOTP
  42. C                        ------------end of main loop-------
  43.       GOTO10
  44.       END
  45.       SUBROUTINE SPERR
  46.       CHARACTER*80 ERRTXT
  47.       CALL SPOPER(IERR,ERRTXT,LERR)
  48.       CALL COLOUR(1)
  49.         PRINT 112,IERR,LERR
  50.   112   FORMAT(' Error code ',Z6,I3)
  51.         IF(LERR.GT.0) PRINT *,ERRTXT(1:LERR)
  52.       CALL COLOUR(7)
  53.       RETURN
  54.       END
  55.       SUBROUTINE WHAT(JSP)
  56.       CHARACTER*12 SPNAME
  57.       LOGICAL SPOP08,SPOP13
  58.       IF(SPOP08(JSP,ISPSIZ,NSPRIT,ISPR1,IFREE)) CALL SPERR
  59.       PRINT 101,NSPRIT
  60.   101 FORMAT(I4,' sprites are:',$)
  61.       DO 10 I=1,NSPRIT
  62.       IF(SPOP13(JSP,I,SPNAME,L)) CALL SPERR
  63.       PRINT 102,SPNAME(1:L)
  64.   102 FORMAT($,' ',A)
  65.    10 CONTINUE
  66.       PRINT *
  67.       CALL KEYX
  68.       RETURN
  69.       END
  70.       SUBROUTINE INIT
  71. C                                       COMMON BLOCK
  72.       PARAMETER(ISPSIZ=2014)
  73.       COMMON IX1,IY1,IZ1,
  74.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  75.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  76.      4 MODES,MX1,MY1,MZ1,NPTS         
  77.       CHARACTER *4 SPR
  78.       COMMON/CHRS/SPR(2)
  79.       LOGICAL SPOP08   
  80. C
  81. C           sprite size ISP now in WORDS not BYTES (was &FBB)            
  82. C      DIM sp ssize%        
  83.       MX1=0
  84.       MY1=0
  85.       MZ1=0
  86.       IXP=0
  87.       IYP=0
  88.       IZP=100
  89.       Ipros=1000
  90.       Iscale(3)=100
  91.       Iscale(4)=100
  92.       Izcut=10
  93.       Isize=6
  94.       ISH=1                                           
  95. C                      screen MODE
  96.       MODES=27           
  97.       IX1=0
  98.       IY1=0
  99.       IZ1=0
  100.       IF(SPOP08(0,ISPSIZ,NSPRIT,ISPR1,IFREE)) CALL SPERR
  101.       PRINT *,' system sprite area size ',ISPSIZ,' #sprites ',NSPRIT
  102.       PRINT *,' offset to first sprite ',ISPR1,' free space',IFREE
  103.       I=IGET()
  104.       RETURN
  105.       END
  106.       SUBROUTINE MakeS1
  107. C                           makes the initial sprite
  108.       PARAMETER (RTODEG=57.29578)
  109. C                                       COMMON BLOCK
  110.       PARAMETER(ISPSIZ=2014)
  111.       COMMON IX1,IY1,IZ1,
  112.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  113.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  114.      4 MODES,MX1,MY1,MZ1,NPTS         
  115.       CHARACTER *4 SPR
  116.       COMMON/CHRS/SPR(2)
  117. C                LSAVE size increased 02 Nov 1992
  118.       PARAMETER (LSAVE=96)
  119.       INTEGER IW(2),IREGS(4),ISAVE(LSAVE)
  120.       LOGICAL SPOP09,SPOP15,SPOP24,SPOP29,SPOP41,SPOP44,SPOP60,NPOP60
  121.      +,       SPOP61,SPOP62
  122.       SPR(1)='Bal1'
  123. C                          set up sprite block header
  124.       ISP(1)=4027
  125.       Isp(2)=0
  126.       Isp(3)=16
  127.       Isp(4)=16
  128.       IPX=2
  129.       IPY=2
  130.       IRAD=35
  131.       IDIA=IRAD+IRAD
  132.       PRINT *,' opening sprite area ISP'
  133.       IF(SPOP09(ISP)) CALL SPERR
  134. C             9= set up sprite area  15= create sprite in area
  135.       PRINT *,' Making Bal1 sprite'
  136.       IF(SPOP15(ISP,SPR(1),0,IDIA/IPX+1,IDIA/IPY+1,MODES)) CALL SPERR
  137.       PRINT *,' creating mask area'
  138.       IF(SPOP29(ISP,SPR(1))) CALL SPERR
  139. C            29=create mask   60=set up VDUs to draw into sprite not screen
  140.       IF(SPOP62(ISP,SPR(1),NBYTES)) CALL SPERR
  141.       PRINT *,' save area of ',NBYTES,' bytes would be required'
  142.       IF(NBYTES.GT.LSAVE*4) STOP 'LSAVE'
  143.       PRINT *,' redirect VDU to spriteop  (60), using save area'
  144.       ISAVE(1)=2
  145.       IF(SPOP60(ISP,SPR(1),ISAVE,IREGS)) CALL SPERR
  146. C                         -------------------- start drawing sprite
  147.       CALL GCOL(0,7)
  148.       CALL CIRCLE(IRAD,IRAD,IRAD-IPX,.TRUE.)
  149.       IF(NPOP60(IREGS)) CALL SPERR
  150. C          get mask from screen 
  151.       IF(SPOP61(ISP,SPR(1),0,IREGS)) CALL SPERR
  152.       CALL GCOL(0,0)
  153.       DO 50 JX=0, IDIA, IPX
  154.       DO 40 JY=0, IDIA, IPY
  155.       IF(SPOP41(ISP,SPR(1),JX/IPX,JY/IPY,ICOL,ITNT)) CALL SPERR
  156.       IF(ICOL.EQ.0) THEN
  157. C        IF(SPOP44(ISP,SPR(1),JX/IPX,JY/IPY,0)) CALL SPERR
  158.          CALL SPOT(JX,JY)
  159.       ENDIF
  160.    40 CONTINUE
  161.    50 CONTINUE
  162. C                 60=set VDU drivers to draw on screen   24=select sprite
  163.       IF(NPOP60(IREGS)) CALL SPERR
  164.       PRINT *,' select sprite'
  165.       IF(SPOP24(ISP,SPR,IPTR)) CALL SPERR
  166. C                     ------------------end of sprite creation     
  167.       RETURN
  168.       END
  169.       SUBROUTINE MakeS2
  170. C                           makes another sprite
  171.       PARAMETER (RTODEG=57.29578)
  172. C                                       COMMON BLOCK
  173.       PARAMETER(ISPSIZ=2014)
  174.       COMMON IX1,IY1,IZ1,
  175.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  176.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  177.      4 MODES,MX1,MY1,MZ1,NPTS         
  178.       CHARACTER *4 SPR(2)
  179.       COMMON/CHRS/SPR
  180.       LOGICAL SPOP15,SPOP29,SPOP42,SPOP44
  181.       SPR(2)='Bal2'
  182. C         set up sprite Bal2 in ISP
  183. C         radius in PIXELS
  184.       IR=17
  185. C         NPIX = size of sprite
  186.       NPIX=IR+IR+1
  187.       IR2=IR*IR+IR
  188.       PRINT *,' Making Bal2 sprite'
  189.       IF(SPOP15(ISP,SPR(2),0,NPIX,NPIX,MODES)) CALL SPERR
  190. C         set up mask
  191.       IF(SPOP29(ISP,SPR(2))) CALL SPERR
  192.       DO 20 IX=0,NPIX-1
  193.       IIX=IX-IR
  194.       DO 10 IY=0,NPIX-1
  195.       IIY=IY-IR
  196.       IF(IIX*IIX+IIY*IIY.GT.IR2) THEN
  197.         IF(SPOP44(ISP,SPR(2),IX,IY,0)) CALL SPERR
  198.       ELSE
  199.         IF(SPOP42(ISP,SPR(2),IX,IY,6,0)) CALL SPERR
  200.       ENDIF
  201.    10 CONTINUE
  202.    20 CONTINUE
  203.       RETURN
  204.       END
  205.       SUBROUTINE PLOTP
  206. C                                       COMMON BLOCK
  207.       PARAMETER(ISPSIZ=2014)
  208.       COMMON IX1,IY1,IZ1,
  209.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  210.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  211.      4 MODES,MX1,MY1,MZ1,NPTS         
  212.       CHARACTER *4 SPR(2)
  213.       COMMON/CHRS/SPR
  214.       LOGICAL SPOP52,SPOP34
  215. C                   
  216.       PROS=Ipros
  217.       IF (IZP.GT.IZCUT) THEN
  218.         fact=pros/IZP
  219.         IS=fact/ISIZE*100
  220.         Iscale(1)=IS
  221.         Iscale(2)=IS
  222.         IF(SPOP52(JSP,SPR(1),INT(fact*IX1),INT(fact*IY1),8,Iscale,0))
  223.      +     CALL SPERR
  224.       ENDIF
  225.       IF(SPOP34(JSP,SPR(2),0,0,8)) CALL SPERR
  226.       RETURN
  227.       END
  228.       SUBROUTINE TESTSP
  229.       PARAMETER(ISPSIZ=2014)
  230.       COMMON IX1,IY1,IZ1,
  231.      2 ISCALE(5),ISP(ISPSIZ),JSP(ISPSIZ),KSP(ISPSIZ),
  232.      3 IXP,IYP,IZP,IPROS,IZCUT,ISH,ISIZE,IRAD,IDIA,
  233.      4 MODES,MX1,MY1,MZ1,NPTS         
  234.       CHARACTER *4 SPR(2)
  235.       COMMON/CHRS/SPR
  236.       LOGICAL SPOP02,SPOP03,SPOP08,SPOP09,SPOP10,SPOP11,SPOP12,SPOP14
  237.      +,       SPOP16,SPOP24,SPOP25,SPOP26,SPOP27,SPOP28,SPOP30,SPOP31
  238.      1,       SPOP32,SPOP33,SPOP34,SPOP35,SPOP36,SPOP40,SPOP41,SPOP43
  239.      2,       SPOP45,SPOP46,SPOP47,SPOP48,SPOP49,SPOP50,SPOP51,SPOP53
  240.      3,       SPOP54
  241. C
  242. C      spriteops used in other subroutines are
  243. C      13,15,29,42,44,52,60,60',61,62
  244. C
  245. C      spriteop not yet tested
  246. C      36
  247. C                   
  248.       INTEGER ISPP(ISPSIZ)
  249.       CHARACTER FRED*4,MARY*4,PPTR*26
  250.       DATA FRED/'FRED'/,MARY/'MARY'/
  251.       DATA PPTR/'f77.Pointer'/
  252.       IF(SPOP40(ISP,'bal1',IWID,IHITE,MASK,MOD)) CALL SPERR
  253.       PRINT*,' sprite bal1 has width ',IWID,', height ',IHITE,
  254.      +', mask ',MASK,', MODE ',MOD
  255.       PRINT*,'Saving sprites in file',FRED
  256.       IF(SPOP12(ISP,FRED)) CALL SPERR
  257.       CALL KEYX
  258.       PRINT*,'Reading sprites back from',MARY
  259.       KSP(1)=4027
  260.       KSP(2)=0
  261.       KSP(3)=16
  262.       KSP(4)=16
  263.       IF(SPOP09(KSP)) CALL SPERR
  264.       JSP(1)=4027
  265.       IF(SPOP10(JSP,MARY)) CALL SPERR
  266.       CALL KEYX
  267.       PRINT *,' reading pointer sprite'
  268.       ISPP(1)=4027
  269.       IF(SPOP10(ISPP,PPTR)) CALL SPERR
  270.       IF(SPOP34(ISPP,'ptr_default',500,0,0)) CALL SPERR
  271.       CALL KEYX
  272.       IF(SPOP36(ISPP,'ptr_default',1,2,2,0,0)) CALL SPERR
  273.       PRINT*,'turn pointer on, click "adjust" to turn off'
  274.       CALL GCOL(0,3)
  275.     5 CALL MOUSE(IXP,IYP,IZP)
  276.       IF(IZP.EQ.4) CALL SPOT(IXP,IYP)
  277.       IF(IZP.NE.1) GO TO 5
  278.       CALL OSCLI('POINTER 0')
  279.       PRINT*,'Reading sprites back from',FRED
  280.       JSP(1)=4027
  281.       JSP(2)=0
  282.       JSP(3)=16
  283.       JSP(4)=16
  284.       IF(SPOP09(JSP)) CALL SPERR
  285.       IF(SPOP10(JSP,FRED)) CALL SPERR
  286.       CALL OSCLI('REMOVE FRED')
  287.       IF(SPOP08(JSP,ISPSIZ,NSPRIT,ISPR1,IFREE)) CALL SPERR
  288.       PRINT *,' sprite area size ',ISPSIZ,' #sprites ',NSPRIT
  289.       PRINT *,' offset to first sprite ',ISPR1,' free space',IFREE
  290.       CALL WHAT(JSP)
  291.       CALL MOVE(0,896)
  292.       CALL MOVE(60,956)
  293.       IF(SPOP14(KSP,'RECTAN1',0,IADD1)) CALL SPERR
  294.       IF(SPOP14(JSP,'RECTAN1',0,IADD1)) CALL SPERR
  295.       PRINT *,' rectangular area saved as sprite at address ',IADD1
  296.       CALL WHAT(JSP)
  297.       IF(SPOP16(JSP,'RECTAN2',0,64,896,124,956,IADD2)) CALL SPERR
  298.       PRINT *,' rectangular area saved as sprite at address ',IADD2
  299.       CALL WHAT(JSP)
  300.       CALL WHAT(KSP)
  301.       PRINT*,'Saving sprites KSP in file',MARY
  302.       IF(SPOP12(KSP,MARY)) CALL SPERR
  303.       CALL KEYX
  304.       IF(SPOP16(KSP,'RECTAN2',0,64,896,124,956,IADD3)) CALL SPERR
  305.       PRINT *,' rectangular area saved as sprite in KSP at ',IADD3
  306.       CALL WHAT(KSP)
  307.       IF(SPOP34(JSP,'RECTAN1',1000,0,0)) CALL SPERR
  308.       IF(SPOP34(JSP,'RECTAN2',1000,200,0)) CALL SPERR
  309.       PRINT *,' plot rectans 1&2 '
  310.       CALL WHAT(JSP)
  311.       IF(SPOP35(KSP,'RECTAN1','RECTAN2',0)) CALL SPERR
  312.       IF(SPOP34(KSP,'RECTAN1',100,100,0)) CALL SPERR
  313.       PRINT *,' merge 1&2 horizontally and plot'
  314.       CALL WHAT(KSP)
  315.       PRINT *,' try to copy another sprite, should not work'
  316.       IF(SPOP27(JSP,'Rectan1','Rectan3')) CALL SPERR
  317.       CALL WHAT(JSP)
  318.       IF(SPOP24(JSP,'rectan1',IADD1)) CALL SPERR
  319.       IF(SPOP25(JSP,IADD1)) CALL SPERR
  320.       PRINT *,' remove sprite rectan1 ' 
  321.       CALL WHAT(JSP)
  322.       IF(SPOP26(JSP,'RECTAN2','Rectan1')) CALL SPERR
  323.       PRINT *,' sprite RECTAN2 renamed as Rectan1'
  324.       CALL WHAT(JSP)
  325.       IF(SPOP33(JSP,'Rectan1')) CALL SPERR
  326.       IF(SPOP34(JSP,'RECTAN1',1000,400,0)) CALL SPERR
  327.       PRINT *,' rectan1 flipped top to bottom'
  328.       CALL WHAT(JSP)
  329.       CALL MOVE(1000,800)
  330.       IF(SPOP47(JSP,'Rectan1')) CALL SPERR
  331.       IF(SPOP34(JSP,'RECTAN1',1000,600,0)) CALL SPERR
  332.       PRINT *,' and side to side'
  333.       CALL WHAT(JSP)
  334.       CALL MOVE(1000,800)
  335.       IF(SPOP28(JSP,'bal1',0)) CALL SPERR
  336.       PRINT *,' bal1 plotted at 1000,800'
  337.       CALL KEYX
  338.       IF(SPOP24(JSP,'rectan1',IADD1)) CALL SPERR
  339.       IF(SPOP25(JSP,IADD1)) CALL SPERR
  340.       PRINT *,' remove sprite rectan1 ' 
  341.       CALL WHAT(JSP)
  342.       PRINT *,' now add Mary (spop11)'
  343.       IF(SPOP11(JSP,MARY)) CALL SPERR
  344.       CALL OSCLI('REMOVE MARY')
  345.       CALL WHAT(JSP)
  346.       PRINT *,' testing spop02 - screen save to FRED'
  347.       IF(SPOP02('FRED',1)) CALL SPERR
  348.       PRINT *,' now clear screen and restore with spop03'
  349.       CALL KEYX
  350.       CALL CLS
  351.       IF(SPOP03('FRED')) CALL SPERR
  352.       CALL KEYX
  353.       CALL OSCLI('REMOVE FRED')
  354.       CALL CLS
  355.       PRINT *,' testing sprite editing   *****'
  356.       IF(SPOP31(ISP,'bal1',10)) CALL SPERR
  357.       IF(SPOP34(ISP,'bal1',1000,800,8)) CALL SPERR
  358.       PRINT *,' insert line into bal1'
  359.       CALL KEYX
  360.       IF(SPOP32(ISP,'bal1',10)) CALL SPERR
  361.       IF(SPOP34(ISP,'bal1',1000,600,8)) CALL SPERR
  362.       PRINT *,' delete the line from bal1'
  363.       CALL KEYX
  364.       IF(SPOP45(ISP,'bal1',10)) CALL SPERR
  365.       IF(SPOP34(ISP,'bal1',1000,400,8)) CALL SPERR
  366.       PRINT *,' insert column into bal1'
  367.       CALL KEYX
  368.       IF(SPOP46(ISP,'bal1',10)) CALL SPERR
  369.       IF(SPOP34(ISP,'bal1',1000,200,8)) CALL SPERR
  370.       PRINT *,' delete the column from bal1'
  371.       CALL KEYX
  372.       IF(SPOP41(ISP,'bal1',1,1,ICOL1,ITT1)) CALL SPERR
  373.       IF(SPOP43(ISP,'bal1',1,1,MASK)) CALL SPERR
  374.       PRINT *,' colour/tint at 1,1 ',ICOL1,' ',ITT1,', mask ',MASK
  375.       CALL KEYX
  376.       IF(SPOP41(ISP,'bal1',20,20,ICOL1,ITT1)) CALL SPERR
  377.       IF(SPOP43(ISP,'bal1',20,20,MASK)) CALL SPERR
  378.       PRINT *,' colour/tint at 20,20 ',ICOL1,' ',ITT1,', mask ',MASK
  379.       IF(SPOP34(ISP,'bal2',980,580,8)) CALL SPERR
  380.       PRINT *,' plot bal2 with mask'
  381.       CALL KEYX
  382.       PRINT *,' remove mask and plot again'
  383.       IF(SPOP30(ISP,'bal2')) CALL SPERR
  384.       IF(SPOP34(ISP,'bal2',980,180,8)) CALL SPERR
  385.       CALL KEYX
  386.       CALL GCOL(0,130)
  387.       CALL MOVE(200,100)
  388.       PRINT *,'set background colour green and plot bal1 mask'
  389.       IF(SPOP48(ISP,'bal1')) CALL SPERR
  390.       CALL KEYX
  391.       PRINT *,' and again at user coords'
  392.       IF(SPOP49(ISP,'bal1',300,100)) CALL SPERR
  393.       CALL KEYX
  394.       PRINT *,' and again scaled'
  395.       Iscale(1)=200
  396.       Iscale(2)=200
  397.       IF(SPOP50(ISP,'bal1',500,100,ISCALE)) CALL SPERR
  398.       CALL GCOL(0,128)
  399.       CALL KEYX
  400.       PRINT *,' double sized text'
  401.       DO 10 I=1,10
  402.       IF(SPOP51(I+64,I*32,0,ISCALE)) CALL SPERR
  403.    10 CONTINUE
  404.       CALL KEYX
  405.       CALL CLS
  406.       DO 20 I=0,15
  407.       CALL VDU19(I,16,16*I,16*I,16*I)
  408.    20 CONTINUE
  409.       CALL COLOUR(15)
  410.       PRINT *,' plot sprite grey-scaled'
  411.       ISCALE(1)=400
  412.       ISCALE(2)=400
  413.       IF(SPOP53(ISP,'bal1',800,600,ISCALE,0)) CALL SPERR
  414.       CALL KEYX
  415.       IF(SPOP08(KSP,ISPSIZ,NSPRIT,ISPR1,IFREE)) CALL SPERR
  416.       PRINT *,' before SpriteOp54'
  417.       PRINT *,' sprite area size ',ISPSIZ,' #sprites ',NSPRIT
  418.       PRINT *,' offset to first sprite ',ISPR1,' free space',IFREE
  419.       IF(SPOP54(KSP,'RECTAN1')) CALL SPERR
  420.       PRINT *,' after SpriteOp54'
  421.       IF(SPOP08(KSP,ISPSIZ,NSPRIT,ISPR1,IFREE)) CALL SPERR
  422.       PRINT *,' sprite area size ',ISPSIZ,' #sprites ',NSPRIT
  423.       PRINT *,' offset to first sprite ',ISPR1,' free space',IFREE
  424.       CALL KEYX
  425.       CALL VDU(20)
  426.       RETURN
  427.       END
  428.       SUBROUTINE KEYX
  429.       IF(IGET().EQ.27) STOP 'ESCAPE'
  430.       RETURN
  431.       END
  432.