Postez vos petits programmes en QBasic

Auteur

Message

gm86

Sujet du message : Re: Postez vos petits programmes en QBasic

Publié : 04 déc. 2019 15:43

Membre inscrit

Hors-ligne

Messages : 630

Inscription : 01 sept. 2008 19:07

Comme tous les 2/3 ans, un nouveau message.

La touche COS¯¹ des calculatrices n'a pas d'équivalent en BASIC. Heureusement, le guide du GW-BASIC donne la solution :
http://www.antonis.de/qbebooks/gwbasman ... x%20B.html

Prenons par exemple une formule trigonométrique utile en astronomie,
cos A/2 = - tg D . tg L
tirée du lien suivant :
http://oncle.dom.pagesperso-orange.fr/p ... tm#Maisons
Elle donne la valeur angulaire de l'arc que parcourt une étoile dans le ciel sous la forme
A = 2 arc cos (- tg D . tg L)
avec D la déclinaison de l'astre et L la latitude du lieu.

Vu que le BASIC Microsoft travaille en radians, les données en degrés seront converties pour obtenir le résultat intermédiaire T=-TAN(D)*TAN(L).
Avec A=2*FNARCCOS(T),
DEF FNARCCOS(X)=ATN (X/SQR(-X*X+1)) + PI/2
soit ATN (X/SQR(-X*X+1)) + ATN(1)*2
puisque PI=ATN(1)*4 en simple précision (355/113).

Lors de la recopie du code suivant, faites sauter les sauts à l'intérieur des lignes numérotées ! Les éditeurs de texte ne connaissent pas Ctrl+J.

Code : Tout sélectionner

10 REM Déterminer le parcours angulaire d'un astre depuis son lever au coucher.
20 PRINT"Renseignez la position de l'étoile et le lieu d'observation."
30 INPUT "Déclinaison ";D
40 IF D>90 OR D<-90 THEN PRINT"Angle requis entre -90 et 90° !" :GOTO 30
50 INPUT "Latitude ";L
60 IF L>90 OR L<-90 THEN PRINT"Angle requis entre -90 et 90° !" :GOTO 50
70 REM Coordonnées converties en radians sauf cas particuliers des pôles.
80 IF ABS(D)-90 AND ABS(L)-90 THEN T=-TAN(D*ATN(1)/45)*TAN(L*ATN(1)/45)
				ELSE T=(ABS(D-L)<90)*2+1	'T=+/-1 si pôle
90 IF FIX(T) THEN
	IF T<0 THEN PRINT"L'étoile est circumpolaire."		:END
		ELSE PRINT"L'étoile reste sous l'horizon."	:END
100 A=90*-ATN(T/SQR(1-T*T))/ATN(1)+180				'(2.arc cos T)°
110 PRINT"L'étoile décrit un arc de";STR$(A);"° dans le ciel."

La formule traite avec |T|<1 pour renvoyer 0°<A<360°. De même, nous tenons compte des cas spécifiques aux pôles célestes et terrestres.

En attendant 2021 ou 2022...

_________________

C:\ONGRTLNS.W95

Haut

Profil

Citer

glaby91

Sujet du message : Re: Postez vos petits programmes en QBasic

Publié : 17 juil. 2020 21:21

Membre inscrit

Hors-ligne

Messages : 20

Inscription : 17 juil. 2020 20:54

Voila le dernier programme non pas en Qbasic mais en basic compatible CPC 6128.

C'est un editeur de niveau de jeu de labyrinthe et on peut aussi tester les niveaux creer:

Code : Tout sélectionner

10 MODE 1:BORDER 0:INK 0,0:PAPER 0:INK 1,5: PEN 1:INK 3,18,25:SPEED INK 25,25
20 INK 2,17
30 index=1:carac=143
35 PEN 1
40 REM FOR a=110 TO 255:PRINT a;:PRINT CHR$(a)
50 REM IF INKEY$="" THEN GOTO 50
60 REM NEXT
70 FOR a=1 TO 40
80 LOCATE a,1:PRINT CHR$(carac)
85 LOCATE a,25:PRINT CHR$(carac);:
90 NEXT
100 FOR a=1 TO 25 : LOCATE 1,a:PRINT CHR$(carac);:LOCATE 40,a:PRINT CHR$(carac);:NEXT
105 PEN 2:LOCATE 1,1:PRINT CHR$(22)+CHR$(1)+"EDiteur Laby V0.3":PRINT CHR$(22)+CHR$(0)
110 DIM table(40,25)
120 cursx=20:cursy=12
130 PEN 1:LOCATE cursx,cursy:PRINT CHR$(carac)
140 clav$=INKEY$:clav$=LOWER$(clav$)
150 IF clav$="4" THEN GOSUB 210
160 IF clav$="6" THEN GOSUB 260
170  IF clav$="8" THEN GOSUB 310
180  IF clav$="2" THEN GOSUB 350
181 IF clav$="t" THEN GOSUB 1300
190  IF clav$=" " THEN GOSUB 400
191 IF clav$="j" THEN GOSUB 2000
192 IF clav$="s" THEN GOSUB 1000
193 IF clav$="c" THEN CLS:FOR y=1 TO 25:FOR x=1 TO 40:table(x,y)=0:NEXT x:NEXT y:index=1:carac=143:PEN 1:LOCATE cursx,cursy:PRINT CHR$(carac);:FOR a=1 TO 40:LOCATE a,1:PRINT CHR$(carac):LOCATE a,25:PRINT CHR$(carac);:NEXT
194 IF clav$="l" THEN GOSUB 1100
200 GOTO 140
210 'rem gauche
220 GOSUB 600
230 cursx=cursx-1
231 PEN 1
240 IF cursx=0 THEN cursx=1
241 IF index=1 THEN PEN 1 ELSE IF index=2 THEN PEN 3 ELSE IF index=3 OR INDEX=8 THEN PEN 2
242 LOCATE cursx,cursy:PRINT CHR$(carac);:
250 RETURN
260 ' droite
270 GOSUB 600
280 cursx=cursx+1
281 PEN 1
290 IF cursx=41 THEN cursx=40
291 IF index=1 THEN PEN 1 ELSE IF index=2 THEN PEN 3 ELSE IF index=3 OR INDEX=8 THEN PEN 2
300 LOCATE cursx,cursy:PRINT CHR$(carac);:RETURN
310 'rem haut
320 GOSUB 600
321 PEN 1
330 cursy=cursy-1:IF cursy=0 THEN cursy=1
331 IF index=1 THEN PEN 1 ELSE IF index=2 THEN PEN 3 ELSE IF index=3 OR INDEX=8 THEN PEN 2
340 LOCATE cursx,cursy:PRINT CHR$(carac);:RETURN
350 'rem BAS
360 GOSUB 600    
365 PEN 1
370 cursy=cursy+1:IF cursy=26 THEN cursy=25
371 IF index=1 THEN PEN 1 ELSE IF index=2 THEN PEN 3 ELSE IF index=3 OR INDEX=8 THEN PEN 2
380 LOCATE cursx,cursy:PRINT CHR$(carac);:RETURN  
390 'press space
400 IF table(cursx,cursy)=index THEN table(cursx,cursy)=0 ELSE table(cursx,cursy)=index
410 RETURN
600 PEN 0:LOCATE cursx,cursy:PRINT CHR$(143);
601 IF table(cursx,cursy)=1 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(143)
602 IF table(cursx,cursy)=2 THEN PEN 3:LOCATE cursx,cursy:PRINT CHR$(231)
603 IF table(cursx,cursy)=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(207)
604 IF table(cursx,cursy)=4 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(244)
605 IF table(cursx,cursy)=5 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(245) 
606 IF table(cursx,cursy)=6 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(246) 
607 IF table(cursx,cursy)=7 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(247)
608 IF table(cursx,cursy)=8 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(228)
610 RETURN
1000 'sauvegarde tableau
1010 OPENOUT"table.lab"
1020 REM PRINT #9,40
1030 FOR x=1 TO 40
1040 FOR y=1 TO 25
1050 PRINT #9,table(x,y)
1060 NEXT y
1070 NEXT x
1080 CLOSEOUT
1090 RETURN
1100 ' charge table
1110 OPENIN"table.lab"
1130 FOR x=1 TO 40
1140 FOR y=1 TO 25
1150 INPUT #9,table(x,y)
1160 NEXT y
1170 NEXT x
1175 CLOSEIN
1180 'affichage
1190 FOR y=1 TO 25
1200 FOR x=1 TO 40
1210 index=table(x,y):IF index=1 THEN PEN 1:carac=143:LOCATE x,y:PRINT CHR$(carac)
1211 IF index=2 THEN PEN 3:carac=231:LOCATE x,y:PRINT CHR$(carac)
1212 IF index=3 THEN PEN 2:carac=207:LOCATE x,y:PRINT CHR$(carac) 
1213 IF index=4 THEN PEN 1:carac=244:LOCATE x,y:PRINT CHR$(carac)
1214 IF index=5 THEN PEN 1:carac=245:LOCATE x,y:PRINT CHR$(carac)
1215 IF index=6 THEN PEN 1:carac=246:LOCATE x,y:PRINT CHR$(carac)     
1216 IF index=7 THEN PEN 1:carac=247:LOCATE x,y:PRINT CHR$(carac)
1217 IF index=8 THEN PEN 2:carac=228:LOCATE x,y:PRINT CHR$(carac)   
1220 NEXT x
1230 NEXT y
1240 LOCATE cursx,cursy:PRINT CHR$(carac);:
1250 RETURN
1300 index=index+1
1310 IF index=9 THEN index=1
1320 IF index=1 THEN carac=143:PEN 1
1321 IF index=8 THEN carac=228:PEN 2
1330 IF index=2 THEN carac=231:PEN 3
1335 IF index=3 THEN carac=207:PEN 2
1336 IF index=4 THEN carac=244:PEN 1
1337 IF index=5 THEN carac=245:PEN 1
1338 IF index=6 THEN carac=246:PEN 1
1339 IF index=7 THEN carac=247:PEN 1
1340 LOCATE cursx,cursy:PRINT CHR$(carac);:
1350 RETURN
2000 REM jeux simulation
2001 tableau=1
2010 vie=3:index=table(cursx,cursy):miam=0
2011 FOR y=1 TO 25
2012 FOR x=1 TO 40
2013 IF table(x,y)=2 THEN miam=miam+1
2014 NEXT x
2015 NEXT y
2020 IF index=0 THEN PEN 0:LOCATE cursx,cursy:PRINT CHR$(143)
2030 IF index=1 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(143)
2040 IF index=2 THEN PEN 3:LOCATE cursx,cursy:PRINT CHR$(231)
2050 IF index=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(203)
2051 IF index=4 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(244)
2052 IF index=5 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(245)
2053 IF index=6 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(246)
2054 IF index=7 THEN PEN 1:LOCATE cursx,cursy:PRINT CHR$(247)
2055 IF index=8 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(228)
2060 REM affichage perso
2070 cursx=2:cursy=24
2080 PEN 2:LOCATE cursx,cursy:PRINT CHR$(224);:
2082 GOSUB 4000
2090 REM test clavier
2100 a$=INKEY$
2110 IF a$="r" THEN RETURN
2120 IF a$="6" THEN GOSUB 2300
2130 IF a$="4" THEN GOSUB 2500
2140 IF a$="8" THEN GOSUB 2700
2150 IF a$="2" THEN GOSUB 2900
2151 IF a$="p" THEN miam=0:vie=3:GOSUB 5000
2200 GOTO 2100
2300  GOSUB 3500
2350 cursx=cursx+1:IF cursx=40 THEN cursx=cursx-1:vie=vie-1:SOUND 2,1200,7:GOSUB 4000
2360 index=table(cursx,cursy)
2370 IF index=0 OR index=2 OR index=3 OR index=8 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(224) ELSE cursx=cursx-1:PEN 2:LOCATE cursx,cursy:PRINT CHR$(224):SOUND 2,1200,7:vie=vie-1:GOSUB 4000 
2380 IF index=2 THEN miam=miam-1:table(cursx,cursy)=0:SOUND 2,150,15:SOUND 2,200,15:SOUND 2,250,15:GOSUB 4000
2381 IF index=8 THEN table(cursx,cursy)=0:vie=vie+1:GOSUB 4000
2390 IF miam=0 AND index=3 THEN GOSUB 5000
2400 RETURN
2500 GOSUB 3500:cursx=cursx-1:IF cursx=1 THEN cursx=cursx+1:vie=vie-1:SOUND 2,1200,7:GOSUB 4000 
2510 index=table(cursx,cursy) 
2520 IF index=8 OR index=0 OR index=2 OR index=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(224) ELSE cursx=cursx+1:PEN 2:LOCATE cursx,cursy:PRINT CHR$(224):SOUND 2,1200,7:vie=vie-1:GOSUB 4000     
2530 IF index=2 THEN miam=miam-1:table(cursx,cursy)=0:SOUND 2,150,15:SOUND 2,200,15:SOUND 2,250,15:GOSUB 4000   
2531 IF index=8 THEN table(cursx,cursy)=0:vie=vie+1:GOSUB 4000
2540 IF miam=0 AND index=3 THEN GOSUB 5000    
2600 RETURN
2700 GOSUB 3500:cursy=cursy-1:IF cursy=1 THEN cursy=cursy+1:vie=vie-1:SOUND 2,1200,7:GOSUB 4000 
2710 index=table(cursx,cursy)   
2720 IF index=8 OR index=0 OR index=2 OR index=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(224) ELSE cursY=cursY+1:PEN 2:LOCATE cursx,cursy:PRINT CHR$(224):SOUND 2,1200,7:vie=vie-1:GOSUB 4000
2730 IF index=2 THEN miam=miam-1:table(cursx,cursy)=0:SOUND 2,150,15:SOUND 2,200,15:SOUND 2,250,15:GOSUB 4000 
2731 IF index=8 THEN table(cursx,cursy)=0:vie=vie+1:GOSUB 4000   
2740 IF miam=0 AND index=3 THEN GOSUB 5000
2800 RETURN
2900 GOSUB 3500:cursY=cursY+1:IF cursy=25 THEN cursy=cursy-1:vie=vie-1:SOUND 2,1200,7:GOSUB 4000
2910 index=table(cursx,cursy)
2920 IF index=8 OR index=0 OR index=2 OR index=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(224) ELSE cursY=cursY-1:PEN 2:LOCATE cursx,cursy:PRINT CHR$(224):SOUND 2,1200,7:vie=vie-1:GOSUB 4000      
2930 IF index=2 THEN miam=miam-1:table(cursx,cursy)=0:SOUND 2,150,15:SOUND 2,200,15:SOUND 2,250,15:GOSUB 4000   
2931 IF index=8 THEN table(cursx,cursy)=0:vie=vie+1:GOSUB 4000
2940 IF miam=0 AND index=3 THEN GOSUB 5000
3100 RETURN
3500 index=table(cursx,cursy) 
3510 IF index=0 THEN PEN 0:LOCATE cursx,cursy:PRINT CHR$(143)  
3520 IF index=2 THEN PEN 3:LOCATE cursx,cursy:PRINT CHR$(231)    
3530 IF index=3 THEN PEN 2:LOCATE cursx,cursy:PRINT CHR$(207)   
3540 RETURN
4000 PEN 1:LOCATE 17,25:PRINT CHR$(143);:PRINT CHR$(143):PEN 2:LOCATE 10,25:PRINT CHR$(22)+CHR$(1)+"Vies :"+STR$(vie);:PEN 1:LOCATE 31,25:PRINT CHR$(143);:PRINT CHR$(143);:PRINT CHR$(143):PEN 2:LOCATE 25,25:PRINT"Miam:";:PRINT miam;:PRINT CHR$(22)+CHR$(0)
4010 IF vie=0 THEN END
4020 RETURN
5000 'charge tableau prochaine
5001 IF tableau=1 THEN OPENIN"table1.lab"
5011 IF tableau=2 THEN OPENIN"table2.lab"
5021 IF tableau=3 THEN OPENIN"table3.lab" 
5031 IF tableau=4 THEN OPENIN"table4.lab"   
5041 IF tableau=5 THEN OPENIN"table5.lab"    
5051 IF tableau=6 THEN OPENIN"table6.lab"
5061 IF tableau=7 THEN OPENIN"table7.lab" 
5071 IF tableau=8 THEN OPENIN"table8.lab" 
5081 IF tableau=9 THEN OPENIN"table9.lab"
5091 IF tableau=10 THEN CLS:PRINT" Bravo vous avez fini le jeu":CLOSEIN:END
5092 tableau=tableau+1
5093 CLS
5096 FOR x=1 TO 40
5099 FOR y=1 TO 25
5102 INPUT #9,table(x,y)
5112 NEXT y:NEXT x: CLOSEIN
5122 FOR x=1 TO 40:FOR y=1 TO 25:index=table(x,y)
5123 IF index=2 THEN PEN 3:LOCATE x,y:PRINT CHR$(231);:miam=miam+1
5124 IF index=1 THEN PEN 1:LOCATE x,y:PRINT CHR$(143);:
5133 IF index=3 THEN PEN 2:LOCATE x,y:PRINT CHR$(207);: 
5134 IF index=4 THEN PEN 1:LOCATE x,y:PRINT CHR$(244);:
5135 IF index=5 THEN PEN 1:LOCATE x,y:PRINT CHR$(245);:
5136 IF index=6 THEN PEN 1:LOCATE x,y:PRINT CHR$(246);:
5137 IF index=7 THEN PEN 1:LOCATE x,y:PRINT CHR$(247);:
5138 IF index=8 THEN PEN 2:LOCATE x,y:PRINT CHR$(228);:
5139 NEXT y
5140 NEXT x 
5141 FOR x=1 TO 40:PEN 1:LOCATE x,1:PRINT CHR$(143);:LOCATE x,25:PRINT CHR$(143);:NEXT x:FOR y=1 TO 25:LOCATE 1,y:PRINT CHR$(143);:LOCATE 40,y:PRINT CHR$(143);:NEXT y
5142 cursx=2:cursy=24:PEN 2:LOCATE cursx,cursy:PRINT CHR$(224);:
5143 GOSUB 4000
5144 RETURN

Un petit générateur de courbe de bézier, modifié les valeurs des couples de points x0,y0 x1,y1 x2,y2 et x3,y3 pour changer l'allure de la courbe.

Code : Tout sélectionner

10 REM courbe de bezier
20 MODE 2
30 x0=100:y0=350
40 x1=200:y1=350
50 x2=400:y2=10
51 x3=500:y3=250
60 FOR t=0 TO 1.01 STEP 0.001
70 x=(x0*(1-t)*(1-t)*(1-t))+(3*x1*t*(1-t)*(1-t)*(1-t))+(3*x2*t*t*(1-t))+(x3*t*t*t)
71 y=(y0*(1-t)*(1-t)*(1-t))+(3*y1*t*(1-t)*(1-t)*(1-t))+(3*y2*t*t*(1-t))+(y3*t*t*t)  
75 REM PRINT "T";:PRINT t;:PRINT"X";:PRINT x;:PRINT "Y";:PRINT Y
76 PLOT x,y,1
80 NEXT
90 PLOT x0,y0
100 PLOT x1,y1
110 PLOT x2,y2
120 PLOT x3,y3

Fonctionne sur CPC Basic V1.1 !

Haut

Profil

Citer

remax17

Sujet du message : Re: Postez vos petits programmes en QBasic

Publié : 18 juil. 2020 10:03

Membre inscrit

Hors-ligne

Messages : 1133

Inscription : 22 sept. 2010 15:03

PC Rétro : PIII 500mhz -384Mb RAM - Voodoo 2 en SLI

C'est du Locomotive Basic

_________________

Mon OneDrive

Haut

Profil

Citer

glaby91

Sujet du message : Re: Postez vos petits programmes en QBasic

Publié : 18 juil. 2020 22:28

Membre inscrit

Hors-ligne

Messages : 20

Inscription : 17 juil. 2020 20:54

Oui et je programme aussi en Z80. C'est juste qu'en basic on peut faire des petites choses assez vite.
Pour le côté vitesse c'est toutefois mieux avec l'ASM, j'ais noté 42s pour charger/afficher un niveau du petit jeu en basic et à peine 8 pour faire la même action en ASM. Toutefois il es certainement possible d'optimisé le code mais pour le moment je m'attelle à le faire fonctionner !

En faite j'ais commençé assez jeune avec le CPC et son manuel a programmé en basic ou plutot recopié les programmes du manuel puis j'ais fait du qbasic sur un IBM PS1 je croit bien, et ceci jusqu'au dernier Qbasic compilable meme windows 10 je crois bien. Aujourdhui je me remet au CPC et surtout son asm , de formation bts electronique , j'ais fait pas mal de programmation pour du Atmel / Pic / 6809 et du C / VHDL mais je ne me souviens plus de grand chose. Maintenant c'est Z80 et ses banques memoire de 64 Ko qui m'appele, le pilotage du gate array , crtrc, puce sonore yamaha. C'est ce que j'aime dans la programmation, maitrisé le bazarre de A à Z et etre independant de tout autre systeme. Si ça ne marche pas ça n'est que de ma faute !
Bonne soirée à tous !

Dernière modification par glaby91 le 18 juil. 2020 22:34, modifié 1 fois.

Haut

Profil

Citer

gm86

Sujet du message : Re: Postez vos petits programmes en QBasic

Publié : 03 janv. 2021 19:19

Membre inscrit

Hors-ligne

Messages : 630

Inscription : 01 sept. 2008 19:07

Super ! Le dernier est facile à modifier pour l'écran du PC (PSET au lieu de PLOT).

Ces derniers temps, je me suis intéressé à l'arithmérique non signée en BASIC. Cela signifie en dehors de tout interpréteur (y compris QBasic) et sans l'option Debug, car /D ajouterait des appels INTO (interruption si overflow). Voici le résultat qui use de la faculté d'annuler une valeur en débordant (retenue hors des seize bits) :

Code : Tout sélectionner

REM $LINESIZE:132
'Compilation du crible d'Eratosthène (tableau de nombres impairs).
'
'Version Microsoft 5.36 (FCB) :
'	BASCOM SIEVE/N/O/T;
'	LINK SIEVE;
'
'QuickBASIC 4.5 (IBM DOS 2.1) :
'	BC SIEVE/O;
'	LINK SIEVE+SMALLERR/EX/NOE/STACK:1024;
'
'Micro MS-DOS/PC>64/96K|I'm afraid, Dave. Dave, my mind is going. I can fill it.

OPTION BASE 1: DEFINT D-Z
DIM P(31250)							'[1;1000000/32]
T$ = TIME$
100 IF T$ = TIME$ THEN 100 ELSE PRINT TIME$, "Début du calcul." 'Synchronisation

N2 = 5								'Pointe un carré
M2 = 1								'Masque d'un mot
FOR I = 2 TO 499						'2;SQR(1E6)/2-1
	N = N2
	N2 = N2 + 2 * I + 2 * I					'(a+b)²/2 ; b=2
	IF (P(I) AND 1) = 0 THEN PAS = 2 * I - 1: M = M2	'Saut si non 1er
	IF N2 - 31250 > 0 THEN N2 = N2 - 31250: M2 = 2 * M2	'Ignore le signe
	WHILE M
1000		P(N) = P(N) OR M				'Bit positionné
		N = N + PAS
		IF N <= 31250 THEN 1000				'Bits entrelacés
		N = N - 31250
		M = 2 * M					'Nul si retenue
	WEND
NEXT

PRINT TIME$, "Fin du calcul."
PRINT "Appuyez sur une touche pour sortir les nombres premiers..."
WHILE LEN(INKEY$) = 0: WEND
P(1) = P(1) + 1							'1 n'est pas 1er
C = 1
PRINT 2;							'2 est premier
A = -1
M = 1								'Bit 0 à tester
10000	FOR I = 1 TO 31250
	IF (P(I) AND M) = 0 THEN PRINT CHR$(9); STR$(A + I + I); : C = C + 1
	NEXT
	A = A + 62500
	M = 2 * M						'Bit suivant...
IF M THEN 10000
PRINT : PRINT C; "nombres inférieurs au million sont premiers."

Le listing en assembleur a permis le choix des opérateurs :

Code : Tout sélectionner

BASCOM SIEVE,nul,sieve/a/N/O/T;

P.S. : le label 1000 seul limiterait l'optimisation du compilateur. Lié au saut interne à la boucle WHILE, il apporte un gain de temps. Autre précision, il vaut mieux reprendre la variable d'une des instructions adjacentes que d'écrire LET PAS%=PAS%+2. Ici, BASCOM remarque l'emploi de I% pour PAS% et récupère donc le calcul automatique d'index P%(I%), lui-même repris de 2*I% mis en évidence.

Code : Tout sélectionner

                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  PAGE   1
                                                                                                                           03-14-21
                                                                                                                           18:59:50
Offset  Data    Source Line                                                                          Microsoft BASIC Compiler V5.36

 001A   0002    REM $LINESIZE:132
 001A   0002    'Compilation du crible d'Eratosthène (tableau de nombres impairs).
 001A   0002    '
 001A   0002    'Version Microsoft 5.36 (FCB) :
 001A   0002    '       BASCOM SIEVE/N/O/T;
 001A   0002    '       LINK SIEVE;
 001A   0002    '
 001A   0002    'QuickBASIC 4.5 (IBM DOS 2.1) :
 001A   0002    '       BC SIEVE/O;
 001A   0002    '       LINK SIEVE+SMALLERR/EX/NOE/STACK:1024;
 001A   0002    '
 001A   0002    'Micro MS-DOS/PC>64/96K|I'm afraid, Dave. Dave, my mind is going. I can fill it.
 001A   0002    
 001A   0002    OPTION BASE 1: DEFINT D-Z
 001A   0002    DIM P(31250)                                                    '[1;1000000/32]
 001A   0002    T$ = TIME$
 0026    **            I00001: CALL  $535
 002B   F426    100 IF T$ = TIME$ THEN 100 ELSE PRINT TIME$, "Début du calcul." 'Synchronisation
 002B    **                    CALL  $TIF
 0030    **                    MOV   DX,OFFSET T$
 0033    **                    CALL  $SASA
 0038    **            L00100: CALL  $TIF
 003D    **                    XCHG  AX,BX
 003E    **                    MOV   BX,OFFSET T$
 0041    **                    CALL  $SCMA
 0046    **                    JE    $-10H
 0048    **                    CALL  $PR0A
 004D    **                    CALL  $TIF
 0052    **                    CALL  $PV0D
 0057    **                    MOV   BX,OFFSET <const>
 005A    **                    CALL  $PV2D
 005F   F42A    
 005F   F42A    N2 = 5                                                          'Pointe un carré
 005F   F42A    M2 = 1                                                          'Masque d'un mot
 005F   F42A    FOR I = 2 TO 499                                                '2;SQR(1E6)/2-1
 005F    **            I00003: MOV   N2%,0005H
 0065    **                    MOV   M2%,0001H
 006B    **                    MOV   AX,0002H
 006E    **                    JMP   I00004
 0071   F42E            N = N2
 0071   F42E            N2 = N2 + 2 * I + 2 * I                                 '(a+b)²/2 ; b=2
 0071   F42E            IF (P(I) AND 1) = 0 THEN PAS = 2 * I - 1: M = M2        'Saut si non 1er
 0071    **            I00005: MOV   AX,N2%
 0074    **                    MOV   N%,AX
 0077    **                    MOV   BX,I%
 007B    **                    SAL   BX,1
 007D    **                    MOV   DX,BX
 007F    **                    ADD   BX,AX
 0081    **                    ADD   BX,DX
 0083    **                    XCHG  AX,BX
 0084    **                    MOV   N2%,AX
 0087    **                    XCHG  DI,DX
 0089    **                    MOV   BX,P%-0002H[DI]
 008D    **                    AND   BX,01H
                                                                                                                           PAGE   2
                                                                                                                           03-14-21
                                                                                                                           18:59:50
Offset  Data    Source Line                                                                          Microsoft BASIC Compiler V5.36

 0090    **                    OR    BX,BX
 0092    **                    JE    $+03H
 0094    **                    JMP   I00006
 0097    **                    XCHG  AX,DI
 0098    **                    DEC   AX
 0099    **                    MOV   PAS%,AX
 009C    **                    MOV   AX,M2%
 009F    **                    MOV   M%,AX
 00A2   F436            IF N2 - 31250 > 0 THEN N2 = N2 - 31250: M2 = 2 * M2     'Ignore le signe
 00A2    **            I00006: MOV   BX,N2%
 00A6    **                    ADD   BX,85EEH
 00AA    **                    OR    BX,BX
 00AC    **                    JG    $+03H
 00AE    **                    JMP   I00007
 00B1    **                    XCHG  AX,BX
 00B2    **                    MOV   N2%,AX
 00B5    **                    MOV   AX,M2%
 00B8    **                    SAL   AX,1
 00BA    **                    MOV   M2%,AX
 00BD   F436            WHILE M
 00BD    **            I00007:
 00BD   F436    1000            P(N) = P(N) OR M                                'Bit positionné
 00BD    **            I00008: MOV   BX,M%
 00C1    **                    AND   BX,BX
 00C3    **                    JNE   $+03H
 00C5    **                    JMP   I00009
 00C8   F436                    N = N + PAS
 00C8   F436                    IF N <= 31250 THEN 1000                         'Bits entrelacés
 00C8    **            L01000: MOV   DI,N%
 00CC    **                    MOV   BX,DI
 00CE    **                    SAL   DI,1
 00D0    **                    MOV   DX,P%-0002H[DI]
 00D4    **                    OR    DX,M%
 00D8    **                    MOV   P%-0002H[DI],DX
 00DC    **                    ADD   BX,PAS%
 00E0    **                    XCHG  AX,BX
 00E1    **                    MOV   N%,AX
 00E4    **                    CMP   N%,7A12H
 00EA    **                    JNG   $-24H
 00EC   F436                    N = N - 31250
 00EC   F436                    M = 2 * M                                       'Nul si retenue
 00EC   F436            WEND
 00EC    **                    MOV   AX,N%
 00EF    **                    ADD   AX,85EEH
 00F2    **                    MOV   N%,AX
 00F5    **                    MOV   AX,M%
 00F8    **                    SAL   AX,1
 00FA    **                    MOV   M%,AX
 00FD    **                    JMP   I00008
 0100   F436    NEXT
 0100    **            I00009: MOV   AX,I%
 0103    **                    INC   AX
 0104    **            I00004: MOV   I%,AX
 0107    **                    CMP   I%,01F3H
                                                                                                                           PAGE   3
                                                                                                                           03-14-21
                                                                                                                           18:59:50
Offset  Data    Source Line                                                                          Microsoft BASIC Compiler V5.36

 010D    **                    JG    $+03H
 010F    **                    JMP   I00005
 0112   F436    
 0112   F436    PRINT TIME$, "Fin du calcul."
 0112   F436    PRINT "Appuyez sur une touche pour sortir les nombres premiers..."
 0112   F436    WHILE LEN(INKEY$) = 0: WEND
 0112    **                    CALL  $PR0A
 0117    **                    CALL  $TIF
 011C    **                    CALL  $PV0D
 0121    **                    MOV   BX,OFFSET <const>
 0124    **                    CALL  $PV2D
 0129    **                    CALL  $PR0A
 012E    **                    MOV   BX,OFFSET <const>
 0131    **                    CALL  $PV2D
 0136    **            I00011: CALL  $INK
 013B    **                    CALL  $LENA
 0140    **                    OR    BX,BX
 0142    **                    JE    $-0EH
 0144   F436    P(1) = P(1) + 1                                                 '1 n'est pas 1er
 0144   F436    C = 1
 0144   F436    PRINT 2;                                                        '2 est premier
 0144   F436    A = -1
 0144   F436    M = 1                                                           'Bit 0 à tester
 0144   F436    10000   FOR I = 1 TO 31250
 0144    **                    MOV   AX,P%
 0147    **                    INC   AX
 0148    **                    MOV   P%,AX
 014B    **                    MOV   DI,OFFSET C!
 014E    **                    MOV   SI,OFFSET <const>
 0151    **                    CALL  $FASA
 0156    **                    CALL  $PR0A
 015B    **                    MOV   BX,0002H
 015E    **                    CALL  $PV1C
 0163    **                    MOV   DI,OFFSET A!
 0166    **                    MOV   SI,OFFSET <const>
 0169    **                    CALL  $FASA
 016E    **                    MOV   M%,0001H
 0174    **            L10000: MOV   AX,0001H
 0177    **                    JMP   I00013
 017A   F43E            IF (P(I) AND M) = 0 THEN PRINT CHR$(9); STR$(A + I + I); : C = C + 1
 017A    **            I00014: MOV   DI,I%
 017E    **                    MOV   BX,DI
 0180    **                    SAL   DI,1
 0182    **                    MOV   DX,P%-0002H[DI]
 0186    **                    AND   DX,M%
 018A    **                    OR    DX,DX
 018C    **                    JE    $+03H
 018E    **                    JMP   I00015
 0191    **                    CALL  $PR0A
 0196    **                    MOV   DX,BX
 0198    **                    MOV   BX,0009H
 019B    **                    CALL  $CHR
 01A0    **                    CALL  $PV1D
 01A5    **                    XCHG  BX,DX
                                                                                                                           PAGE   4
                                                                                                                           03-14-21
                                                                                                                           18:59:50
Offset  Data    Source Line                                                                          Microsoft BASIC Compiler V5.36

 01A7    **                    CALL  $CISA
 01AC    **                    CALL  $STFA
 01B1    **                    DB    81H
 01B2    **                    CALL  $FADG
 01B7    **                    DB    81H
 01B8    **                    MOV   DI,OFFSET A!
 01BB    **                    CALL  $FADC
 01C0    **                    MOV   BX,OFFSET $AC!
 01C3    **                    CALL  $STR
 01C8    **                    CALL  $PV1D
 01CD    **                    MOV   DI,OFFSET <const>
 01D0    **                    MOV   SI,OFFSET C!
 01D3    **                    CALL  $FADA
 01D8    **                    XCHG  DI,SI
 01DA    **                    CALL  $FASC
 01DF   F43E            NEXT
 01DF    **            I00015: MOV   AX,I%
 01E2    **                    INC   AX
 01E3    **            I00013: MOV   I%,AX
 01E6    **                    CMP   I%,7A12H
 01EC    **                    JNG   $-74H
 01EE   F43E            A = A + 62500
 01EE   F43E            M = 2 * M                                               'Bit suivant...
 01EE   F43E    IF M THEN 10000
 01EE    **                    MOV   DI,OFFSET <const>
 01F1    **                    MOV   SI,OFFSET A!
 01F4    **                    CALL  $FADA
 01F9    **                    XCHG  DI,SI
 01FB    **                    CALL  $FASC
 0200    **                    MOV   AX,M%
 0203    **                    SAL   AX,1
 0205    **                    MOV   M%,AX
 0208    **                    MOV   BX,M%
 020C    **                    AND   BX,BX
 020E    **                    JE    $+03H
 0210    **                    JMP   L10000
 0213   F43E    PRINT : PRINT C; "nombres inférieurs au million sont premiers."
 0213   F43E    
 0213    **                    CALL  $PR0A
 0218    **                    MOV   BX,OFFSET <const>
 021B    **                    CALL  $PV2D
 0220    **                    CALL  $PR0A
 0225    **                    MOV   BX,OFFSET C!
 0228    **                    CALL  $PV1A
 022D    **                    MOV   BX,OFFSET <const>
 0230    **                    CALL  $PV2D
 0235    **                    CALL  $ENP
 023A   F43E    

23791 Bytes Available
22733 Bytes Free

    0 Warning Error(s)
    0 Severe  Error(s)

Ce n'est pas un compilateur totalement optimisant (sauts NEAR en avant, A%=A%+B%+B% plus long que A%=B%+B%+A%, etc.) mais il s'en sort bien. Une courte routine en langage 8086 aurait permis de calculer le carré 32 bits d'un nombre 16 bits, mais s'ensuivrait une lente division par la taille du tableau. Enfin, le fait que la boucle la plus utilisée soit alignée sur un quadruple-mot est une coïncidence : sur un Pentium aux caches désactivés, on constate un léger ralentissement en débutant avec LET P%(1)=1 par exemple.

Bonus.

J'aime les veilles versions pour leur syntaxe plus souple, comme situer NEXT ou WEND dans une condition IF. Contrairement au compilateur, l'interpréteur s'avère plus rapide à gérer le pas dans FOR/NEXT qu'une variable dans une boucle WHILE/WEND. Or utiliser NEXT après THEN ou ELSE nous oblige à indiquer la variable en jeu dans la prochaine instruction NEXT, alors que NEXT variable y est plus lent que NEXT tout court. C'est un petit sacrifice à consentir.

Code : Tout sélectionner

10 GOTO 100
20 REM Tri Shell pour interpréteur MS BASIC (incompatible QuickBASIC 3+).
30 M=-16248
40 WHILE M
50 FOR J=1 TO N+M:FOR I=J TO 1 STEP M:IF X(I)>X(I-M) THEN SWAP X(I),X(I-M):NEXT
60 NEXT J
70 M=M\4+M\8
80 WEND
90 RETURN
100 REM ---- T E S T ----
110 DEFINT A-Z:OPTION BASE 1
120 N=FRE(0)/2-24:DIM X(N)
130 FOR I=1 TO N:X(I)=-32768!+INT(65536!*RND):NEXT
140 T#=CVD(TIME$)
150 WHILE T#=CVD(TIME$):WEND
160 PRINT TIME$
170 GOSUB 20
180 PRINT N; "nombres entiers triés."
190 PRINT TIME$

Pour du code à compiler, mieux vaut réécrire l'algorithme :

Code : Tout sélectionner

' Tri Shell pour compilateur BASIC Microsoft antérieur à QuickBASIC 3.
M = 24606					'Plus petit pas maxi menant à 5
WHILE M
	FOR J = 1 TO N - M
		I = J
		L = J + M
		WHILE X(I) > X(L)
			SWAP X(I), X(L)
			L = I
			I = I - M
		IF I > 0 THEN WEND		'Syntaxe incompatible avec QB3+
	NEXT
	M = M \ 3 + M \ 10			'Suite géométrique 13/30
WEND
RETURN

Le but est de minimiser les comparaisons autant que les échanges. Le tri se termine obligatoirement par le pas de un.

_________________

C:\ONGRTLNS.W95

Haut

Profil

Win3x.Org

Règles du forum