diff options
| -rw-r--r-- | BIC.FOR | 12 | ||||
| -rw-r--r-- | BRI.FOR | 9 | ||||
| -rw-r--r-- | ICH.FOR | 15 | ||||
| -rw-r--r-- | KRI.FOR | 8 | ||||
| -rw-r--r-- | PALICE.FOR | 80 | ||||
| -rw-r--r-- | PKURZ.FOR | 41 | ||||
| -rw-r--r-- | POH.FOR | 10 | ||||
| -rw-r--r-- | SPACE.FOR | 8 | ||||
| -rw-r--r-- | ZMA.FOR | 47 | ||||
| -rw-r--r-- | ZVEZDE.FOR | 186 |
10 files changed, 416 insertions, 0 deletions
@@ -0,0 +1,12 @@ + SUBROUTINE BIC(CH,IV,IP) + CHARACTER CH(10)*40 + IPP=IP + DO 10 I=1,40 + IF(CH(IV)(I:I).EQ.'*') THEN + CH(IV)(I:I)=' ' + IPP=IPP-1 + IF(IPP.EQ.0) RETURN + ENDIF +10 CONTINUE + RETURN + END @@ -0,0 +1,9 @@ + SUBROUTINE BRI + DO 10 I=1,23 + CALL PKURZ(I,1,IND) + WRITE(*,5) +5 FORMAT(' ') +10 CONTINUE + RETURN + END + @@ -0,0 +1,15 @@ + SUBROUTINE ICH(CH,IZV,N) + CHARACTER CH(10)*40 + DIMENSION IZV(1) + CALL PKURZ(3,32,IND) + WRITE(*,1) +1 FORMAT('Vr Zv') + DO 10 I=1,N + II=2*I+3 + CALL PKURZ(II,22,IND) + WRITE(*,5)I,IZV(I),CH(I) +5 FORMAT(10X,I2,'. ',I2,1X,A40) +10 CONTINUE + RETURN + END + @@ -0,0 +1,8 @@ + SUBROUTINE KRI + WRITE(*,10) +10 FORMAT(1X,'To ni nobena zmaga! S tako majhnim stevilom'/, + * 1x,'zvezdic se ne igra.') + PAUSE '<ENTER>' + RETURN + END + diff --git a/PALICE.FOR b/PALICE.FOR new file mode 100644 index 0000000..61e19ee --- /dev/null +++ b/PALICE.FOR @@ -0,0 +1,80 @@ + SUBROUTINE PALICE(IZV,N,IVRSTA,IPALIC,IZMA,KON) + DIMENSION IZV(1),IPA(100) + IZMA=0 + IMAK=0 + KON=0 + ISOTIC=0 + DO 10 I=1,N + IF(IZV(I).GE.IMAK) THEN + IVMAK=I + IMAK=IZV(I) + ENDIF + ISOTIC=ISOTIC+IZV(I) +10 IPA(I)=IZV(I) + IF(IMAK.EQ.0) THEN + IZMA=1 + KON=1 + RETURN + ENDIF + IF(ISOTIC.EQ.0) KON=1 + J=0 + KODA=0 + DO 20 I=1,N +20 IF(IZV(I).GE.2) J=J+1 + IF(J.EQ.1) KODA=1 + IF(J.EQ.0) KODA=2 + LL=0 + DO 21 L=1,N + IF(IPA(L).GT.0) LL=LL+1 +21 CONTINUE + ICC=MOD(LL,2) + IF((KODA.EQ.1).AND.(IMAK.GT.1)) THEN + IF(ICC.EQ.0) THEN + IVRSTA=IVMAK + IPALIC=IMAK + IZMA=1 + RETURN + ELSE + IVRSTA=IVMAK + IPALIC=IMAK-1 + IZMA=1 + RETURN + ENDIF + ENDIF + DO 30 I=1,N + IF(IPA(I).EQ.0) GO TO 30 + DO 25 J=1,IMAK + IPA(I)=IPA(I)-J + IF(IPA(I).EQ.-1) THEN + IPA(I)=IPA(I)+J + GO TO 30 + ENDIF + CALL SRC(IPA,N,IND) + IF((KODA.EQ.0).AND.(IND.EQ.0)) THEN + IVRSTA=I + IPALIC=J + IZMA=1 + RETURN + ENDIF +25 IPA(I)=IPA(I)+J +30 CONTINUE + IF((KODA.EQ.2).AND.(ICC.EQ.0)) IZMA=1 +C IVRSTA=IVMAK +C IPALIC=1 + CALL GETTIM(LU,LM,LS,L) + IZN=1 + J=MOD(L,N)+1 +40 IF(IPA(J).EQ.0) J=J+IZN + IF(J.GT.N) THEN + IZN=-1 + J=J-1 + GO TO 40 + ENDIF + IF(IPA(J).NE.0) GO TO 50 + GO TO 40 +50 IVRSTA=J + IPALIC=1 + RETURN + END + + diff --git a/PKURZ.FOR b/PKURZ.FOR new file mode 100644 index 0000000..5bec267 --- /dev/null +++ b/PKURZ.FOR @@ -0,0 +1,41 @@ + SUBROUTINE PKURZ(IVR,IST,IND) +C +C Lenasi,maj 1990 +C +C********************************************************************** +C* Postavi kurzor na IVR vrstico in IST stolpec. IND je normalno 0, * +C* 1 je, ce prekoracimo stevilo 25 vrstic in 2, ce je stevilo stolpcev* +C* vecje kot 80. Na tem mestu v glavnem programu napisemo ali ustrezno* +C* delujemo. Po tem se kurzor prestavi na zacetek nove vrstice. * +C* IVR, IST, IND so INTEGER tipa. * +C********************************************************************** +C +C + J=4 + IND=0 + IF((IVR.LT.10).AND.(IST.LT.10)) J=1 + IF((IVR.LT.10).AND.(IST.GE.10)) J=2 + IF((IVR.GE.10).AND.(IST.LT.10)) J=3 + IF(IVR.GT.25) THEN + IND=1 + RETURN + ENDIF + IF(IST.GT.80) THEN + IND=2 + RETURN + ENDIF + GO TO (10,20,30,40),J +10 WRITE(*,15)IVR,IST +15 FORMAT(' [',I1,';',I1,'H',$) + RETURN +20 WRITE(*,25)IVR,IST +25 FORMAT(' [',I1,';',I2,'H',$) + RETURN +30 WRITE(*,35)IVR,IST +35 FORMAT(' [',I2,';',I1,'H',$) + RETURN +40 WRITE(*,45)IVR,IST +45 FORMAT(' [',I2,';',I2,'H',$) + RETURN + END + @@ -0,0 +1,10 @@ + SUBROUTINE POH + WRITE(*,10) +10 FORMAT(1X,'Odlicno! Postajas mojster. Ko bos dobil na'/, + * 1x,'eno mojo zmago eno svojo, obvladas igro in za tebe'/, + * 1x,'ni vec zanimiva. Seveda pri primernem stevilu'/,1x, + * 'vrstic in zvezdic ter nivoju 4.') + PAUSE '<ENTER>' + RETURN + END + diff --git a/SPACE.FOR b/SPACE.FOR new file mode 100644 index 0000000..d1713c7 --- /dev/null +++ b/SPACE.FOR @@ -0,0 +1,8 @@ + SUBROUTINE SPACE + write(*,*)'ENTER' + READ(*,*) + DO I=1,27 + WRITE(*,*) + ENDDO + RETURN + END @@ -0,0 +1,47 @@ +C * subroutine dodal jaz da bi popravil gettime * + subroutine GetTim(ihr,imin,isec,i100th) + integer(4), intent(out):: ihr, imin, isec, i100th + character(8):: sdate + character(10):: stime + call date_and_time(sdate,stime) + read(sTime,"(I2,I2,I2,1x,I3)") ihr, imin, isec, i100th + end subroutine GetTim + SUBROUTINE ZMA + CALL GETTIM(LU,LM,LS,L) + I=INT(L/10)+1 + GO TO (10,20,30,40,50,60,70,80,90,100),I +10 WRITE(*,11) +11 FORMAT(1X,'Smola - ne obupaj!') + GO TO 200 +20 WRITE(*,21) +21 FORMAT(1X,'Vec treniraj!') + GO TO 200 +30 WRITE(*,31) +31 FORMAT(1X,'Se vec treniraj!') + GO TO 200 +40 WRITE(*,41) +41 FORMAT(1X,'Vprasanje je, ce vaja res dela mojstra.') + GO TO 200 +50 WRITE(*,51) +51 FORMAT(1X,'Nisi samo ti slab. Tudi Janez je izgubljal.') + GO TO 200 +60 WRITE(*,61) +61 FORMAT(1X,'Drugic bo bolje!') + GO TO 200 +70 WRITE(*,71) +71 FORMAT(1X,'Ne gre ti dobro. Vec misli!') + GO TO 200 +80 WRITE(*,81) +81 FORMAT(1X,'Predvsem pa brez panike! Casa za uk je dovolj.') + GO TO 200 +90 WRITE(*,91) +91 FORMAT(1X,'Verjetno si politik. Po stilu sem te spoznal.') + GO TO 200 +100 WRITE(*,101) +101 FORMAT(1X,'Izgubljas, toda tu in tam bos tudi dobil, ce'/ + * 1x,'bos vadil.') +200 CONTINUE + PAUSE '<ENTER>' + RETURN + END + diff --git a/ZVEZDE.FOR b/ZVEZDE.FOR new file mode 100644 index 0000000..ce9e579 --- /dev/null +++ b/ZVEZDE.FOR @@ -0,0 +1,186 @@ + PROGRAM ZVEZDE + DIMENSION IZV(100) + CHARACTER CH(10)*40,CR*2 + IO=0 + WRITE(*,10) +10 FORMAT(' [2J') + WRITE(*,20) +20 FORMAT(' P O Z D R A V L J E N Z V E Z D N I I G R A L E C', + * 2X,'!'///) + WRITE(*,30) +30 FORMAT(1X,'Pravila - Midva bova igrala. Izberi do 10 vrstic', + * 1x,'in v vsaki vrstici do 20'/1x,'zvezd. Ko bos na potezi,', + * 1x,'poberi iz poljubne vrstice vsaj eno zvezdo ali vec.'/, + * 1x,'Zaradi mene lahko poberes tudi celo vrstico zvezd. Sve', + * 'tujem vsaj 4'/,1x,'zacetne vrstice, sicer si neresen igral', + * 'ec.'/,1x,'Kdor pobere zadnjo zvezdo, je izgubil!'//) + WRITE(*,40) +40 FORMAT(1X,'Posebno navodilo - Ce kupujes transformatorje,', + * 1x,'kupuj le v Tovarni transforma-'/1x,'torjev Ljubljana,', + * 1x,'ce pa so zelo majhni, pri ELMI v Ljubljani. Naj te pri', + * 1x,'nakupu'/1x,'ne moti morebiten neuspeh pri zvezdicah!'//) + WRITE(*,45) +45 FORMAT(1X,'Ce si jezen, koncaj z Ctrl C'//) + WRITE(*,50) +50 FORMAT(1X,'Za nadaljevanje pritisni <ENTER>'//) + WRITE(*,51) +51 FORMAT(1X,'(c) Lenasi 1990') + PAUSE ' ' +54 WRITE(*,10) + WRITE(*,31) +31 FORMAT(1X,'N I V O J I Z N A N J A '///) +33 WRITE(*,32) +32 FORMAT(1X,'Nivo 1 .... Zacetnik'//1x,' 2 .... Kar gre'//1x, + * ' 3 .... Zdi se, da znam'//1x,' 4 .... Mojster'///1x, + * 'Izberem nivo stevilka=[s',$) + read(*,*,ERR=35,IOSTAT=IO)NIVO +35 IF((NIVO.LT.1.OR.NIVO.GT.4).OR.(IO.NE.0)) THEN + IO=0 + WRITE(*,*)'Popravi![u',' ',' [10A' + GO TO 33 + ENDIF + PAUSE '<ENTER>' + WRITE(*,10) +55 WRITE(*,60) +60 FORMAT(1X,'Stevilo'/1x,'vrstic =',$) + READ(*,*,ERR=65,IOSTAT=IO)N +65 IF((N.GT.10.OR.N.LT.1).OR.(IO.NE.0)) THEN + IO=0 + WRITE(*,70) +70 FORMAT(1X,'Popravi![3;9H',' ',' [1;1H') + GO TO 55 + ENDIF + DO 90 I=1,N +79 WRITE(*,80)I +80 FORMAT(' Stevilo zvezd'/1x,'v ',I2,'. vrstici =',$) + READ(*,*,ERR=85,IOSTAT=IO)IZV(I) +85 IF((IZV(I).GT.20.OR.IZV(I).LT.1).OR.(IO.NE.0)) THEN + IO=0 + II=2*I+3 + WRITE(*,81) +81 FORMAT(1X,'Popravi!') + CALL PKURZ(II,16,IND) + WRITE(*,82) +82 FORMAT(' ') + II=II-2 + CALL PKURZ(II,1,IND) + WRITE(*,83) +83 FORMAT('v') + GO TO 79 + ENDIF +90 CONTINUE + IVVS=0 + DO 100 I=1,N + IVVS=IVVS+IZV(I) + KA=0 + IPRA=INT((40-IZV(I)*2)/2)+1 + DO 100 J=1,40 + IF((J.LE.IPRA).OR.(J.GT.(IPRA+IZV(I)*2))) THEN + CH(I)(J:J)=' ' + ELSE + IF(KA.EQ.0) THEN + CH(I)(J:J)='*' + KA=1 + ELSE + CH(I)(J:J)=' ' + KA=0 + ENDIF + ENDIF +100 CONTINUE + CALL ICH(CH,IZV,N) + CALL PKURZ(1,1,IND) +C PAUSE '<ENTER> ' +C CALL BRI +C CALL PKURZ(1,1,IND) +C PAUSE '<ENTER> ' + CALL PALICE(IZV,N,IVRSTA,IPALIC,IZMA,KON) + CALL GETTIM(L,M,I,K) + IF(NIVO.EQ.1) KI=20 + IF(NIVO.EQ.2) KI=30 + IF(NIVO.EQ.3) KI=40 + IF(NIVO.EQ.4) KI=50 + IZA=0 + IF((IZMA.EQ.1).AND.(K.LE.KI)) IZA=1 + IF((IZMA.EQ.0).AND.(K.LT.(100-KI))) IZA=1 + IF(IZA-1)135,110,110 +110 IF(KON.EQ.1) GO TO 1000 + CALL BRI + CALL PALICE(IZV,N,IVRSTA,IPALIC,IZMA,KON) + IF(KON.EQ.1) GO TO 1000 + CALL PKURZ(4,1,IND) + WRITE(*,120)IVRSTA,IPALIC +120 FORMAT(1X,'Moja poteza'/1x,'Iz vrste =',I3/ + * 1x,'vzamem zvezd =',I3//1x,'Na sliki je'/1x,'staro stanje') + PAUSE '<ENTER>' + CALL BRI + CALL BIC(CH,IVRSTA,IPALIC) + IZV(IVRSTA)=IZV(IVRSTA)-IPALIC + CALL ICH(CH,IZV,N) +C CALL PKURZ(4,1,IND) +C WRITE(*,130) +C130 FORMAT(1X,'Novo stanje,'/1x,'tvoja poteza') +C PAUSE '<ENTER>' +135 IF(KON.EQ.1) GO TO 1000 + CALL PALICE(IZV,N,IVRSTA,IPALIC,IZMA,KON) + IF(IZMA.EQ.0) IZMA=1 + IF(IZMA.EQ.1) IZMA=0 + IF(KON.EQ.1) GO TO 1000 + CALL BRI + CALL PKURZ(4,1,IND) +139 WRITE(*,140) +140 FORMAT(1X,'Tvoja poteza'/1x,'Iz vrste =',$) + READ(*,*,ERR=145,IOSTAT=IO)IVRSTA + M=IVRSTA +145 IF((IZV(M).EQ.0.OR.(M.LT.1.OR.M.GT.N)).OR.(IO.NE.0)) THEN + IO=0 + WRITE(*,150) +150 FORMAT(1X,'Popravi![5;11H',' ',' [4;1H',$) + GO TO 139 + ENDIF +159 WRITE(*,160) +160 FORMAT(1X,'vzamem zvezd =',$) + READ(*,*,ERR=165,IOSTAT=IO)IPALIC +165 IF((IPALIC.LT.1.OR.IPALIC.GT.IZV(IVRSTA)).OR.(IO.NE.0)) THEN + IO=0 + WRITE(*,170) +170 FORMAT(1X,'Popravi![6;15H',' ',' [5;1H') + GO TO 159 + ENDIF + WRITE(*,180) +180 FORMAT(//1X,'Na sliki je'/1x,'staro stanje') + PAUSE '<ENTER> ' + CALL BRI + CALL BIC(CH,IVRSTA,IPALIC) + IZV(IVRSTA)=IZV(IVRSTA)-IPALIC + CALL ICH(CH,IZV,N) +C CALL PKURZ(4,1,IND) +C WRITE(*,190) +C190 FORMAT(1X,'Novo stanje,'/1x,'moja poteza') +C PAUSE '<ENTER> ' + GO TO 110 +1000 WRITE(*,10) + INDEK=0 + IF(N.LE.3.OR.IVVS.LE.8) INDEK=1 + IF(IZMA.EQ.1) THEN + CALL ZMA + GO TO 1010 + ELSE + IF(INDEK.EQ.1) THEN + CALL KRI + GO TO 1010 + ELSE + CALL POH + GO TO 1010 + ENDIF + ENDIF +1010 WRITE(*,1020) +1020 FORMAT(1X,'Zelis nadaljevati? (DA/NE) =[s',$) + READ(*,1)CR +1 FORMAT(A2) + IF(CR(1:1).EQ.'D'.OR.CR(1:1).EQ.'d') GO TO 54 + IF(CR(1:1).EQ.'N'.OR.CR(1:1).EQ.'n') GO TO 1030 + WRITE(*,*)' [u',' ',' [1A' + GO TO 1010 +1030 CONTINUE + END + |