Win3x.Org

Windows & DOS Community

Rétablir la vitesse de calcul de QuickBASIC 4.5 (Fwait)

Répondre   Page 1 sur 1  [ 1 message ]
Auteur Message
gm86
Sujet du message : Rétablir la vitesse de calcul de QuickBASIC 4.5 (Fwait)
Publié : 11 avr. 2021 17:35
Membre inscrit
Avatar de l’utilisateur
Hors-ligne
 
Messages : 1290
Inscription : 01 sept. 2008 19:07
 
Le week-end dernier, je lançais avec délectation les jolies démos de Toshihiro Horie sur le mode X et le bump-mapping :
https://www.ocf.berkeley.edu/~horie/project.html
On y trouve aussi le travail d'autrui, à part la grenouille qui s'est sauvée :
http://db0fhn-i.ampr.org:8080/bread/FRO ... =PROGSPR+1

Il conseille de compiler les programmes JULIA5 et RAYTRAC5 avec QB4.0 pour plus de vitesse.
D'ailleurs, les exécutables de l'archive GOURAUD2.ZIP sont considérés lents alors que les fichiers BASIC se révèlent bien plus rapides dans l'environnement de QB4.0 ! La palme de la mollesse revenant à QBasic qui ne fait qu'émuler le coprocesseur, il ne fait aucun doute que la lenteur de QB4.5 provient d'une mauvaise gestion des instructions 8087.

Ecrivons le programme IEEE.BAS :
T = TIMER
WHILE T = TIMER: WEND
T = TIMER
A = 1
FOR I = 1 TO 1000000
A = A / A
NEXT
PRINT TIMER - T
Compilons-le avec la version 4.5 tout en demandant le listing assembleur :
bc ieee,,ieee/a;
link ieee;
Le fichier IEEE.LST met en évidence plusieurs interruptions 8086 du type INT 3xh :
 00BB   0012    PRINT TIMER - T
 00BB   0012    
 00BB   0012    
 00BB    **                    call  B$TIMR
 00C0    **                    mov   si,ax
 00C2    **                    int   35h
 00C4    **                    db    04h
 00C5    **                    int   34h
 00C7    **                    db    26h
 00C8    **                    dw    T!
 00CA    **                    sub   sp,04h
 00CD    **                    mov   bx,sp
 00CF    **                    int   35h
 00D1    **                    db    1Fh
 00D2    **                    int   3Dh
 00D4    **                    call  B$PER4
 00D9    **                    call  B$CENP
 00DE   0012    
Ayant un coprocesseur arithmérique, exécutons IEEE.EXE sous DEBUG tout en veillant à l'absence de la variable d'environnement NO87 :
SET NO87=
DEBUG IEEE.EXE
G
UDS:1BB
Q
Nous remarquons alors que l'interruption 3Dh est la seule à ne pas avoir été remplacée par une autre instruction :
-G
 2.03125

Le programme s'est terminé normalement
-UDS:1BB
17C3:01BB 9A2AA3D58E    CALL    8ED5:A32A
17C3:01C0 8BF0          MOV     SI,AX
17C3:01C2 90            NOP
17C3:01C3 D904                  FLD     DWORD PTR [SI]
17C3:01C5 90            NOP
17C3:01C6 D826C60D              FSUB    DWORD PTR [0DC6]
17C3:01CA 83EC04        SUB     SP,+04
17C3:01CD 8BDC          MOV     BX,SP
17C3:01CF 90            NOP
17C3:01D0 D91F                  FSTP    DWORD PTR [BX]
17C3:01D2 CD3D          INT     3D
17C3:01D4 9A54A4D58E    CALL    8ED5:A454
17C3:01D9 9A3A01D58E    CALL    8ED5:013A
-Q
Ce ne serait pas la cas si nous avions compilé avec la version 4.0 :
-G
 5.078125E-02

Le programme s'est terminé normalement
-UDS:1BB
17C3:01BB 9A6422168F    CALL    8F16:2264
17C3:01C0 8BF0          MOV     SI,AX
17C3:01C2 90            NOP
17C3:01C3 D904                  FLD     DWORD PTR [SI]
17C3:01C5 90            NOP
17C3:01C6 D8263618              FSUB    DWORD PTR [1836]
17C3:01CA 83EC04        SUB     SP,+04
17C3:01CD 8BDC          MOV     BX,SP
17C3:01CF 90            NOP
17C3:01D0 D91F                  FSTP    DWORD PTR [BX]
17C3:01D2 90            NOP
17C3:01D3 9B            WAIT
17C3:01D4 9A8EB6168F    CALL    8F16:B68E
17C3:01D9 9AFED9168F    CALL    8F16:D9FE
-Q
La boucle aurait été nettement plus rapide, vu la lenteur d'une interruption... L'instruction Wait, aussi appelée Fwait, oblige le processeur à attendre que le coprocesseur ait fini.
N.B. : si l'instructions NOP (no operation) située avant chaque instruction 8087 est remplacée par WAIT, cela signifie que le programme a détecté un processeur antérieur au 80186 ou 80188. Si MOV AX,AX remplace INT 3Dh, il faut se payer un coprocesseur (p.458) :
http://ethanwiner.com/BTU_BOOK.PDF

Pour savoir comment transformer INT 3Dh en couple NOP/WAIT, on peut bizaremment explorer le contenu traînant dans BC.EXE (chez Microsoft, le compilateur BASIC a toujours été un interpréteur modifié). Pour le visionner sous SID de DRI, j'ai dû décompacter l'exécutable au préalable :
#RBC.EXE
  Start      End
174F:0000 274F:AF0F
#LCS+1153:782,7D5
  28A2:0782 STI
  28A2:0783 WAIT
  28A2:0784 PUSH   AX
  28A2:0785 MOV    AX,A23D
  28A2:0788 JMPS   0790
  28A2:078A STI
  28A2:078B WAIT
  28A2:078C PUSH   AX
  28A2:078D MOV    AX,5C32
  28A2:0790 PUSH   BP
  28A2:0791 PUSH   DS
  28A2:0792 PUSH   SI
  28A2:0793 MOV    BP,SP
  28A2:0795 LDS    SI,08[BP]
  28A2:0798 DEC    SI
  28A2:0799 DEC    SI
  28A2:079A MOV    08[BP],SI
  28A2:079D SUB    [SI],AX
  28A2:079F PUSH   BX
  28A2:07A0 XOR    BX,BX
  28A2:07A2 PUSH   SP
  28A2:07A3 POP    AX
  28A2:07A4 CMP    AX,SP
  28A2:07A6 JNZ    07D0
  28A2:07A8 MOV    AX,01[BX+SI]
  28A2:07AB AND    AX,30FB
  28A2:07AE CMP    AX,30D9
  28A2:07B1 JNZ    07BA
  28A2:07B3 MOV    AL,02[BX+SI]
  28A2:07B6 CMP    AL,F0
  28A2:07B8 JB     07D0
  28A2:07BA MOV    AX,01[BX+SI]
  28A2:07BD AND    AX,FEFF
  28A2:07C0 CMP    AX,E2DB
  28A2:07C3 JZ     07D0
  28A2:07C5 MOV    AX,01[BX+SI]
  28A2:07C8 CMP    AX,E0DF
  28A2:07CB JZ     07D0
  28A2:07CD MOV    BYTE [SI],90
  28A2:07D0 POP    BX
  28A2:07D1 POP    SI
  28A2:07D2 POP    DS
  28A2:07D3 POP    BP
  28A2:07D4 POP    AX
  28A2:07D5 IRET
#Q
Nous voyons deux valeurs : A23Dh et 5C32h (respectivement connues sous les noms FIWRQQ et FIDRQQ). L'interruption 3Dh pointe la première en présence d'un coprocesseur, plusieurs autres la seconde. Sachant que les opcodes CDh et 3Dh représentent l'INT 3Dh, on pose l'opération 16 bits suivante :
   3DCD
 - A23D
 -------
 = 9B90
Qui donnent les opcodes 90h et 9Bh : NOP et WAIT. Une fois cela fait, notre boucle sera plus rapide les fois suivantes.


Pourtant, FIWRQQ n'est utilisé ainsi ni dans BRUN45.EXE ni dans BCOM45.LIB ni dans l'environnement 4.5 de QuickBASIC. Ce problème est resté dans PDS et VB/DOS, auquel André Victor T. Vicentini (v1ctor) a apporté sa solution (FFIX) :
http://www.phatcode.net/downloads.php?id=183
Il s'agit d'une bibliothèque supplémentaire et d'un TSR. Néanmoins, je préfère corriger directement les trois quatre fichiers fautifs.

Le module objet PIEMR de BCOM45.LIB est l'équivalent de QB4EM de BCOM40.LIB (QB4.0). On l'extrait d'abord :
LIB BCOM45 *PIEMR
Puis on le désassemble (ici, avec OBJ2ASM de Robert F. Day) :
	TITLE	piemr
	EXTRN		FIWRQQ:ABS
	EXTRN		FIDRQQ:ABS

EMULATOR_DATA	SEGMENT	PARA PUBLIC 'FAR_DATA'
$S23	dw	1 dup(?)
;(...)
$S104	db	0
;(...)
EMULATOR_DATA	ENDS

EMULATOR_TEXT	SEGMENT	PARA PUBLIC 'CODE'
	assume	cs: EMULATOR_TEXT
;(...)
	cmp	byte ptr $S104,0
	jnz	$L105
	mov	$S104,al
	mov	byte ptr cs:$S106,90h	;NOP
	jmp	short $L105
$L103:	call	dword ptr $S23
$L105:	pop	ds
	pop	ax
	iret
;(...)
$S41:	sti
	wait
$S106:	iret
	push	ax
	push	ds
	mov	ax,EMULATOR_DATA
	mov	ds,ax
	mov	byte ptr cs:$S106,0CFh	;IRET
	xor	ax,ax
	xchg	al,$S104
	call	dword ptr $S23
	pop	ds
	pop	ax
	iret
$S39:	sti
	wait
	push	ax
	mov	ax,offset FIDRQQ
	push	bp
;(...)
EMULATOR_TEXT	ENDS
	END
Du code optionnel a pris la place de notre fix-up FIWRQQ. En temps normal, seul FWAIT est enclenché avant le retour d'interruption. Cependant, IRET peut être remplacé par NOP. Or ce qui s'ensuit semble lié à la termination du programme. Je décide donc de rétablir l'ancien code tout en permettant d'annuler la saut.
	TITLE	piemr
	EXTRN		FIWRQQ:ABS
	EXTRN		FIDRQQ:ABS

EMULATOR_DATA	SEGMENT	PARA PUBLIC 'FAR_DATA'
$S23	dw	1 dup(?)
;(...)
$S104	db	0
;(...)
EMULATOR_DATA	ENDS

EMULATOR_TEXT	SEGMENT	PARA PUBLIC 'CODE'
	assume	cs: EMULATOR_TEXT
;(...)
	cmp	byte ptr $S104,0
	jnz	$L105
	mov	$S104,al
	mov	byte ptr cs:$S106-1,0	;Saut nul
	jmp	short $L105
$L103:	call	dword ptr $S23
$L105:	pop	ds
	pop	ax
	iret
;(...)
$S41:	sti
	wait
	push	ax
	mov	ax,offset FIWRQQ
	jmp	short OldJump
$S106:	push	ds
	mov	ax,EMULATOR_DATA
	mov	ds,ax
	mov	byte ptr cs:$S106-1,low OldJmp-$S106
	xor	ax,ax
	xchg	al,$S104
	jmp	$L103
$S39:	sti
	wait
	push	ax
	mov	ax,offset FIDRQQ
OldJmp:	push	bp
;(...)
EMULATOR_TEXT	ENDS
	END
Corriger directement un module OBJ n'est pas une mince affaire. Il faut se renseigner sur le format OMF :
http://216.92.85.227/qed/Omfg.pdf
Heureusement, nous n'aurons qu'à agir sur une seule portion de code, comprise dans un enregistrement A0h (LEDATA), suivie de ses corrections d'adresses dans un enregistrement 9Ch (FIXUPP) :
- l'adresse absolue de l'octet contenant IRET termine deux sous-enregistrements de FIXUPP ;
- les sous-enregistrements débutent par un octet contenant les deux bits de poids fort d'une adresse relative au début du code de LEDATA, suivi de l'octet de poids faible ;
- chaque enregistrement est suivi du complément à deux de sa somme de contrôle.

Dans notre cas, la taille du code ne change pas car il faut que la même modification se retrouve dans QB.EXE et BRUN45.EXE qui n'exigent d'autre, en contrepartie, que le fix-up de la valeur EMULATOR_DATA dans l'en-tête MZ (format EXE du DOS). De plus, comme la place libérée par la suppression du sous-enregistrement de l'appel FAR équivaut à celle requis pour FIWRQQ, on se passera du bibliothécaire pour mettre BCOM45.LIB à jour. Sa syntaxe étant :
LIB BCOM45 -+piemr;
Il faudra se munir du débogueur SID de DR DOS en plus de l'utilitaire DEBUG.



P A T C H E S
BCOM45.LIB

BCOM.BAT :
REN BCOM45.LIB *.BAK
COPY BCOM45.BAK *.LIB
LIB BCOM45 *piemr;
DEBUG PIEMR.OBJ<PIEMR.DEB
QB /RUN BCOM45
PIERMR.DEB :
eA3D 0
aB86
PUSH	AX
mov	ax,0000
jmp	0BA7
PUSH	DS
MOV	AX,0000
MOV	DS,AX
CS:
MOV	BYTE PTR [0000],1b
DB	33,C0
XCHG	AL,[0000]
jmp	0A40

eD08 C0
eE52 C7
eE59 CE
eE5D C0
eE60 D5
mE51 E65 E56
eE51 C6 C1 26 09 09
a80
jmp 91
lodsb
xchg dx,ax
mov cx,[si]
inc cx
lodsb
add dl,al
loop 87
neg dl
mov [si],dl
ret
cld
push cx
mov si,8c1
call 82
inc si
call 82
pop cx
ret

g=80 9E
w
q
BCOM45.BAS :
OPEN "piemr.obj" FOR INPUT AS #1
OPEN "piemr.obj" FOR RANDOM AS #2 LEN = LOF(1)
CLOSE #1
OPEN "BCOM45.LIB" FOR BINARY AS #1
FIELD #2, LOF(2) AS Taille$

FOR I& = 5 TO LOF(1) STEP 16
        GET #1, I&, DMOT&
        IF MKL$(DMOT&) = "piem" THEN EXIT FOR
NEXT
GET #2
PUT #1, I& - 4, Taille$
SYSTEM

La position du module varie selon la langue.

NOEM.OBJ

NOEM.BAT :
REN NOEM.OBJ *.BAK
COPY NOEM.BAK *.OBJ
DEBUG NOEM.OBJ<NOEM.DEB
NOEM.DEB :
e995 0
aA51
PUSH	AX
mov	ax,0000
jmp	0A72
PUSH	DS
MOV	AX,0000
MOV	DS,AX
CS:
MOV	BYTE PTR [0000],1b
DB	33,C0
XCHG	AL,[0000]
jmp	0998

eB05 B3
eBAE BA
eBB5 C1
eBB9 B3
eBBC C8
mBAD BC1 BB2
eBAD C5 B4 26 09 09
a80
jmp 91
lodsb
xchg dx,ax
mov cx,[si]
inc cx
lodsb
add dl,al
loop 87
neg dl
mov [si],dl
ret
cld
push cx
mov si,899
call 82
inc si
call 82
pop cx
ret

g=80 9E
w
q
À compiler pour la suite, CHECKSUM.BAS qui calcule le complément à un des exécutables DOS :
'Vérifie la somme de contrôle d'un exécutable DOS, l'ajoute si absente.
'A compiler sans l'option /D.

M$ = "Somme de contrôle correcte."
C$ = "Nouvelle somme de contrôle..."
E$ = "Mauvaise somme de contrôle !"
FICHIER$ = COMMAND$
OPEN FICHIER$ FOR BINARY AS #1
IF LOF(1) = 0 THEN CLOSE : KILL FICHIER$: PRINT FICHIER$; " absent !": SYSTEM

WHILE NOT EOF(1)
        GET #1, , MOT%
        SOMME% = SOMME% + MOT%
WEND

GET #1, &H13, MOT%      'Offset 12h : complément à un de la somme ou mot nul
SOMME% = NOT SOMME%
IF SOMME% THEN IF MOT% THEN M$ = E$ ELSE PUT #1, &H13, SOMME%: M$ = C$
PRINT M$
PRINT "NOT Checksum : "; HEX$(SOMME%); " ("; FICHIER$; ")"
END

BRUN45.EXE

BRUN.BAT :
IF EXIST CHECKSUM.EXE GOTO SUITE
BC CHECKSUM;
LINK CHECKSUM/EX;
DEL CHECKSUM.OBJ
:SUITE
REN BRUN45.EXE *.BAK
SID<BRUN45.SID
CHECKSUM BRUN45.EXE
BRUN45.SID :
rBRUN45.BAK
sw12
0
.
sw32E
06C3
.
aCS+1019:56D
CS:    MOV    BYTE [06c0],00
.
mCS+1019:6BD,6C0,6C1
aCS+1019:6BB
PUSH   AX
mov    ax,a23d
jmps   06dc
.
aCS+1019:6C5
MOV    DS,AX
CS:    MOV    BYTE [06c0],1b
XOR    AX,AX
XCHG   AL,[0014]
jmp    0575
.
wBRUN45.EXE
q
Le fix-up du segment EMULATOR_DATA varie selon la langue.

QB.EXE

QB45.BAT :
IF EXIST CHECKSUM.EXE GOTO SUITE
BC CHECKSUM;
LINK CHECKSUM/EX;
DEL CHECKSUM.OBJ
:SUITE
REN QB.EXE *.BAK
SID QB.BAK<QB.SID
CHECKSUM QB.EXE
QB.SID :
e
rQB.BAK
sw12
0
.
s1823
B8
.
l1823,1825
xSS
SS+200
.
gDS:1823,1826
sw1822
0704
.
aDS+AX+200:5AE
CS:    MOV    BYTE [0701],00
.
mDS+AX+200:6FE,701,702
aDS+AX+200:6FC
PUSH   AX
mov    ax,a23d
jmps   071d
.
aDS+AX+200:706
MOV    DS,AX
CS:    MOV    BYTE [0701],1b
XOR    AX,AX
XCHG   AL,[0014]
jmp    05b6
.
wQB.EXE
q
La position du segment EMULATOR_TEXT varie selon la langue.
Les tests ont été effectués avec les versions française, américaine et allemande de QuickBASIC. J'encourage la consultation des articles de Microsoft :
http://www.qbasicnews.com/dav/qbasic.php#QBTOOLS

Quelqu'un est-t-il tenté pour appliquer ce travail à PDS et VB/DOS ?


P.S. : il existe une contrepartie. Une division par zéro ou un débordement du coprocesseur n'est signalé que lors de la prochaine interruption 3Dh. En attendant d'en recontrer une, QuickBASIC gère une valeur infinie ou indéterminée (±1.#INF ou -1.#IND et 1#.NAN) puis passe toute nouvelle erreur du coprocesseur.
Testons le programme suivant avec notre FPU :
FOR I = -1 TO 0 'Une boucle bonne puis
PRINT 1 / I     'err. 11 la 2nde fois
PRINT -1 / I    'attendant l'INT 3Dh
NEXT
PRINT SQR(-I)   'QB.EXE ignore l' err.5
PRINT -SQR(-I)
WHILE I: WEND   '/0 lors de la condition
La première itération s'étant passée sans erreur, INT 3Dh est remplacée par NOP/WAIT dans la boucle. QB.EXE nous sort cela avant de finir sur une erreur /0 :
-1
 1
 1.#INF
-1.#INF
-1.#IND
 1.#NAN
Erreur /0 à la place des deux dernière lignes si l'exemple est compilé. Plus grave, ces valeurs exceptionnelles deviennent &H8000 lorsqu'elles sont stockées dans un entier ou &H80000000 s'il est long.

Bien sûr, on peut revenir à QuickBASIC 4.0 et oublier ce souci. Mais il faudra alors faire l'impasse sur la précision mathématique :
https://www.pcorner.com/list/BASIC/QB45 ... KGRND.TXT/
Pour vérifier :
?sqr(atn(1#)*4)^4	'Avec le signe dièse bien placé pour QB4.0
De plus, une valeur indéterminée n'est qu'une représentation, telle que -1.#NAN suite à ?CVS(MKL$(-1)) :
http://www.qb64.net/forum/index_topic_5092-0/

Mais comment faire lorsque le code source est perdu ? Rechercher dans l'exécutable les deux CALL FAR[0] (FF 1E 0 0) et le pointeur du fix-up de segment dans la table de relogement, comme pour QB.EXE ET BRUN45.EXE, puis modifier en conséquence. L'emplacement du segment pointé est connu en analysant le code indiqué par le vecteur de l'interruption 3Dh :
gds:130
d0:f4 f7
Il s'agit des deuxième et troisième octets de MOV AX,...

Parfois, c'est plus dur. Comme cette démo que je n'arrive à lancer que sous Windows, avec son propre code de relogement (table absente de l'en-tête EXE pourtant au format MZ) et à l'option NEW GAME défectueuse :
https://qb45.org/rate.php?file=149
Je l'accélère ainsi :
SID
rAST2.EXE
swCS+1661:5E0
D5F3
.
aCS+D13:56D
CS:    MOV    BYTE [06c0],00
.
aCS+D13:6BB
PUSH   AX
mov    ax,a23d
jmps   06dc
PUSH   DS
MOV    AX,14fc
MOV    DS,AX
CS:    MOV    BYTE [06c0],1b
XOR    AX,AX
XCHG   AL,[0014]
jmp    0575
.
wAST.EXE
q
Le fichier AST.EXE obtenu est plus fluide que le programme original.

Revenant aux patches, j'avais oublié durant quinze jours de modifier le fichier NOEM.OBJ qu'on lie aux exécutables autonomes pour les alléger de l'émulation du coprocesseur. Et aux réfracteurs se disant que leur PC est assez puissant pour éviter le changement, c'est justement dans ce cas-là qu'on est tenté de faire du calcul intensif dans des simulations graphiques :
https://www.oocities.org/antonigual/qbasic.html#3d
L'auteur, qui a liée son application à la bibliothèque ffix citée plus haut, constate qu'elle reste tout de même quatre fois plus lente que la version originale écrite sous DJGPP (12,5 fps contre 50 sur Pentium IV 1,4 GHz). Or mon processeur Pentium III 1 GHz semble deux fois plus rapide que le sien ! J'obtiens une cadence raisonnable de 24 fps bien moins frustante qu'une valeur inférieure à deux sans patch... D'ailleurs, il aurait pu garder LINK de Microsoft pour rendre son exécutable encore un peu moins lente grâce aux options jointes /Farcalltranslation et /PACKCode.

Cela n'empêche pas que PDS est parfois bien plus rapide. Par exemple, sa conversion d'un entier en nombre à virgule flottante ne nécessite pas l'appel à une routine. Il aurait accéléré l'opération de division lors du calcul des sphères de la démo suivante (QBCM, miroir) :
https://www.phatcode.net/downloads.php?id=151
L'usage d'une division entière eût été préférable sous QB4.5 et ce, sans risque de débordement :
sx% = sx% * X1% \ H%
sy% = sy% * Y1% \ H%
au lieu de
sx% = sx% * (X1% / H%)
sy% = sy% * (Y1% / H%)
dans les procédures LensPlasmaRT et LensTexture. Notons l'incompatibilité de QB4.0 avec les astres fumant.

Pour finir, son compilateur BC 7.x n'omet jamais le préfixe de segment ES lorsqu'il pointe un tableau dynamique d'entiers longs. Cela évite l'usage de l'option lente /AH afin de contrer d'éventuels bugs hors de l'éditeur QuickBASIC (cf. Ethan Winer) :
https://jeffpar.github.io/kbarchive/kb/030/Q30397/
https://www.betaarchive.com/wiki/index. ... hive/30397
On peut toutefois supprimer la directive $DYNAMIC de la démo suivante (Ocular d'Ibmland) si on souhaite recompiler avec BC 4.5 :
http://www.phatcode.net/downloads.php?id=152
Cela évite l'écran noir juste après le titre.


BONUS : le bump-mapping en plein d'écran avec deux éclairages.
DECLARE SUB makeytable ()
DECLARE SUB Bump (lightay%, lightbx%, lightby%, zoom%)
DECLARE SUB testlight ()
DECLARE SUB ComputeLight ()
DECLARE SUB GetPal (pal() AS INTEGER)
DECLARE SUB ComputeLUT (pal%(), lut%())
DECLARE FUNCTION ClosestColor% (pal%(), r%, g%, b%)
DECLARE SUB ReadGif (filename$)
'************************************************************
'BUMPY.BAS 07-03-00 19:24
'QB Version Copyright 2000 Toshi Horie
'       ----- VERSION EN PLEIN ECRAN DU 28/05/21 -----
'               VOIR COMMENTAIRES EN CAPITALES
'VERSION ORIGINALE :
'https://www.ocf.berkeley.edu/~horie/bumpy.zip
' > Please run this program compiled, unless you understand
'    my comments and know how to make it run in the IDE.
' > The program caches the color optimizations on disk, so it will
'   run faster the second time you run it on a particular
'   colormap file.
' > 83 FPS SUR P3-1000 (199 LIGNES DE 319 PIXELS)
'uses DEGIF6.BAS by Rich Geldreich 1993 (Public domain)
'port of BUMP.C by Alex J. Champandard 1999 (Public domain)
'************************************************************
DEFINT A-Z
CONST lutfile$ = "COLORLUT.DAT"
CONST compiled = 1
CONST RADY = 75
CONST RADX = RADY * 6 \ 5                               'RAPPORT 240/200
CONST lightsize = 255 / RADY                            'LE HALO NE DEBORDE PAS

CONST XMAX = 1 OR 319                                   'NOMBRE IMPAIR
CONST XMAX1 = XMAX + 1&
CONST XMAX2 = (XMAX + 1) \ 2                            'MOTS PAR LIGNE
CONST YMIN = 0
CONST YMIN1 = YMIN + 1
CONST YMAX = 199

'$DYNAMIC
DIM SHARED BumpMap(0 TO XMAX2 * (YMAX - YMIN + 1))      'DONNEES SUR 8 BITS
DIM SHARED colormap(0 TO XMAX2 * (YMAX - YMIN + 1))
DIM SHARED lut(127, 255)
'$STATIC
DIM SHARED light(-RADX TO RADX, -RADY TO RADY)
DIM SHARED pal(768)
DIM SHARED iz(XMAX)                                     'ZOOM SUR L'AXE X
IF compiled THEN
    DIM SHARED ytab(199)
    CALL makeytable
END IF
CALL ReadGif("bump.gif")
COLOR 7: LOCATE 25, 1: PRINT "Computing lightmap...";
CALL ComputeLight
'CALL testlight
CALL ReadGif("map.gif")
CALL GetPal(pal())
COLOR 7: LOCATE 25, 1: PRINT "Computing optimal colors...";
CALL ComputeLUT(pal(), lut())
LOCATE 25, 1: PRINT "computing color LUT... Finished!";
CLS
frames& = 0
DEF SEG = &HA000
t1! = TIMER
DO
    t! = TIMER
    lightbx = INT(COS(t! * .6) * COS(t!) * 160 + 161 - RADX)
    lightby = INT(SIN(t! + .4) * (RADY + 2) + 100 + (99 - RADY) \ 3)
    zoom = 64 + 32 * COS(t!)                            'PREMIER ECLAIRAGE
    lightax = 160 - lightbx + zoom
    lightay = 100 - lightby + zoom
    FOR i = 1 TO XMAX: iz(i) = i * zoom \ 96 - lightax: NEXT
    CALL Bump(lightay, lightbx, lightby, zoom)
    frames& = (frames& + 1)
LOOP UNTIL lightbx = -9999
PALETTE
CLS
COLOR 15
PRINT "BUMPY - by Toshi Horie, Rich Geldreich, and Alex Champandard (version originale)"
COLOR 7
elapsed! = (t! - t1!)
IF elapsed! > .1 THEN
PRINT USING "###.## fps"; frames& / elapsed!
END IF
k$ = INPUT$(1)
END

SUB Bump (lightay, lightbx, lightby, zoom)
'must have DEF SEG=&HA000 before calling this!
IF compiled THEN
    pp = (ytab(lightby) + lightbx)
    POKE pp - 1, 7: POKE pp, 7: POKE pp + 1, 7
    POKE pp - 320, 7: POKE pp + 320, 7
ELSE
    PSET (lightbx, lightby - 1), 7
    PSET (lightbx, lightby), 7
    PSET (lightbx, lightby + 1), 7
    PSET (lightbx - 1, lightby), 7
    PSET (lightbx + 1, lightby), 7
END IF
offset = XMAX2 - 1                              'SAUTE LA LIGNE 0
FOR j = YMIN1 TO YMAX
    IF INKEY$ > "" THEN lightbx = -9999: EXIT SUB
    h0 = -RADX * 2                              'COLONNE 0 DANS LE NOIR
    jz = j * zoom \ 96 - lightay
    y = j - lightby
    FOR i = 0 TO XMAX - 1 STEP 2                '1 ENTIER POUR 2 PIXELS
        offset = offset + 1
        t = colormap(offset)
        h1 = BumpMap(offset - XMAX2)
        h2 = BumpMap(offset)
       
        'calculate coordinates of the pixel we need in light map
        'given the slope at this point, and the zoom coefficient
        h = h2 AND 255                          'PREMIER PIXEL
        px = h0 - h                             'PIXEL(I-1,J)-PIXEL(I,J)
        py = (h1 AND 255) - h                   'PIXEL(I,J-1)-PIXEL(I,J)
        c = 0
        IF ABS(iz(i) + px) <= RADX THEN
            IF ABS(jz + py) <= RADY THEN c = light(iz(i) + px, jz + py)
        END IF
       
        'add movement of SECOND light
        x = i - lightbx
       
        'check if the coordinates are inside the light buffer
        'COLOR 7: LOCATE 25, 1: PRINT "x="; x + px; "y="; y + py;
        IF ABS(x + px) <= RADX THEN
            IF ABS(y + py) <= RADY THEN
                'if so, get the pixel
                c = c + light(x + px, y + py)
                IF c > 254 THEN c = 254
            END IF
        END IF
        IF compiled THEN
            POKE (ytab(j) + i), lut(c \ 2, t AND 255)
        ELSE
            PSET (i, j), lut(c \ 2, t AND 255)
        END IF
      
        h0 = (h2 AND -256) \ 256 AND 255        'SECOND PIXEL
        px = h - h0                             'PIXEL(I,J)-PIXEL(I+1,J)
        py = ((h1 AND -256) \ 256 AND 255) - h0 'PIXEL(I+1,J-1)-PIXEL(I+1,J)
        c = 0
        IF ABS(iz(i + 1) + px) <= RADX THEN
            IF ABS(jz + py) <= RADY THEN c = light(iz(i + 1) + px, jz + py)
        END IF
        IF ABS(x + px + 1) <= RADX THEN
            IF ABS(y + py) <= RADY THEN
                c = c + light(x + px + 1, y + py)
                IF c > 254 THEN c = 254
            END IF
        END IF
        IF compiled THEN
            POKE (ytab(j) + i + 1), lut(c \ 2, (t AND -256) \ 256 AND 255)
        ELSE
            PSET (i + 1, j), lut(c \ 2, (t AND -256) \ 256 AND 255)
        END IF
    NEXT
NEXT
IF lightby >= YMAX OR lightby <= YMIN1 OR lightbx < 2 OR lightbx >= XMAX THEN
    IF compiled THEN
        POKE pp - 1, 0: POKE pp, 0: POKE pp + 1, 0
        POKE pp - 320, 0: POKE pp + 320, 0
    ELSE
        PSET (lightbx, lightby - 1), 0
        PSET (lightbx, lightby), 0
        PSET (lightbx, lightby + 1), 0
        PSET (lightbx - 1, lightby), 0
        PSET (lightbx + 1, lightby), 0
    END IF
END IF
END SUB

FUNCTION ClosestColor (pal(), r, g, b)
dist = 32767
FOR i = 0 TO 255
    i3 = i * 3
    newDist = (r - pal(i3)) * (r - pal(i3)) + (g - pal(i3 + 1)) * (g - pal(i3 + 1)) + (b - pal(i3 + 2)) * (b - pal(i3 + 2))
    IF newDist = 0 THEN ClosestColor = i: EXIT FUNCTION
    IF (newDist < dist) THEN
        index = i
        dist = newDist
    END IF
NEXT
ClosestColor = index
END FUNCTION

' generate a spot light pattern
SUB ComputeLight
    FOR j = -RADY TO RADY
        FOR i = -RADX TO RADX
            dist! = i * i / 1.44 + j * j                '(240/200)^2=1.44
            IF ABS(dist!) > 1 THEN dist! = SQR(dist!)
            'fade according to distance and random coefficient
            c = INT(lightsize * dist! + RND * 7.1) - 3
            ' clip to range [0 to 255]
            IF c < 0 THEN
                c = 0
            ELSEIF c > 255 THEN
                c = 255
            END IF
            light(i, j) = 255 - c
        NEXT
    NEXT
END SUB

SUB ComputeLUT (pal(), lut()) STATIC
OPEN lutfile$ FOR BINARY AS #1
IF LOF(1) > 0 THEN
    'if lookup table is saved on disk, load it
    'because it's faster than the O(n^3) algo below
    CLOSE #1
    DEF SEG = VARSEG(lut(0, 0))
    BLOAD lutfile$, 0
    DEF SEG
ELSE
    CLOSE #1
    KILL lutfile$
    'for each color
    FOR j = 0 TO 255
       PSET (j, 170), j
       r = pal(j * 3)
       g = pal(j * 3 + 1)
       b = pal(j * 3 + 2)
       'for 128 intensity levels
       FOR i = 0 TO 254 STEP 2
          lut(i \ 2, j) = ClosestColor(pal(), (r * i) \ 254, (g * i) \ 254, (b * i) \ 254)
       NEXT
    NEXT
    DEF SEG = VARSEG(lut(0, 0))
    BSAVE lutfile$, 0, 65535
    DEF SEG
END IF

END SUB

' gets the current 256 color VGA palette
SUB GetPal (pal() AS INTEGER)
    OUT &H3C7, 0
    i = 0
    DO
        pal(i) = INP(&H3C9): i = i + 1
        pal(i) = INP(&H3C9): i = i + 1
        pal(i) = INP(&H3C9): i = i + 1
    LOOP UNTIL i = 768
END SUB

SUB makeytable
FOR i = 0 TO 199
ytab(i) = i * 320
NEXT i
END SUB

SUB ReadGif (a$)
IF a$ = "bump.gif" THEN maptype = 1
IF a$ = "map.gif" THEN maptype = 2
'Prefix() and Suffix() hold the LZW phrase dictionary.
'OutStack() is used as a decoding stack.
'ShiftOut() as a power of two table used to quickly retrieve the LZW
'multibit codes.
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)

'stupid QB compiler doesn't do flow analysis,
'so we either have to have two SUBs (one for compiled, one for not)
'or we just comment things out
'IF compiled THEN
    DIM YBase AS INTEGER, Powersof2(11) AS INTEGER, WorkCode AS INTEGER
'ELSE
'    DIM YBase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG
'END IF
'Precalculate power of two tables for fast shifts.
FOR a = 0 TO 8: ShiftOut(8 - a) = 2 ^ a: NEXT
FOR a = 0 TO 11: Powersof2(a) = 2 ^ a: NEXT

'Open file for input so QB stops with an error if it doesn't exist.
OPEN a$ FOR INPUT AS #1: CLOSE #1
OPEN a$ FOR BINARY AS #1

'Check to see if GIF file. Ignore GIF version number.
a$ = "      ": GET #1, , a$
IF LEFT$(a$, 3) <> "GIF" THEN PRINT "Not a GIF file.": END

'Get logical screen's X and Y resolution.
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
'Calculate number of colors and find out if a global palette exists.
NumColors = 2 ^ ((a AND 7) + 1): NoPalette = (a AND 128) = 0
'Retrieve background color.
GOSUB GetByte: Background = a

'Get aspect ratio and ignore it.
GOSUB GetByte

'Retrieve global palette if it exists.
IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$

DO 'Image decode loop

'Skip by any GIF extensions.
'(With a few modifications this code could also fetch comments.)
DO
    'Skip by any zeros at end of image (why must I do this? the
    'GIF spec never mentioned it)
    DO
        IF EOF(1) THEN GOTO AllDone 'if at end of file, exit
        GOSUB GetByte
    LOOP WHILE a = 0           'loop while byte fetched is zero

    SELECT CASE a
    CASE 44  'We've found an image descriptor!
        EXIT DO
    CASE 59  'GIF trailer, stop decoding.
        GOTO AllDone
    CASE IS <> 33
        PRINT "Unknown GIF extension type.": END
    CASE ELSE
        ' do nothing
    END SELECT
    'Skip by blocked extension data.
    GOSUB GetByte
    DO: GOSUB GetByte: a$ = SPACE$(a): GET #1, , a$: LOOP UNTIL a = 0
LOOP
'Get image's start coordinates and size.
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength

'Check for local colormap, and fetch it if it exists.
GOSUB GetByte
IF (a AND 128) THEN
    NoPalette = 0
    NumColors = 2 ^ ((a AND 7) + 1)
    P$ = SPACE$(NumColors * 3): GET #1, , P$
END IF

'Check for interlaced image.
Interlaced = (a AND 64) > 0: PassNumber = 0: PassStep = 8

'Get LZW starting code size.
GOSUB GetByte

'Calculate clear code, end of stream code, and first free LZW code.
ClearCode = 2 ^ a
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = a + 1: CodeSize = StartCodeSize

'Find maximum code for the current code size.
StartMaxCode = 2 ^ (a + 1) - 1: MaxCode = StartMaxCode

BitsIn = 0: BlockSize = 0: BlockPointer = 1

x = XStart: y = YStart: YBase = y * 320

'Set screen 13 in not set yet.
IF FirstTime = 0 THEN
    'Go to VGA mode 13 (320x200x256).
    SCREEN 13: DEF SEG = &HA000
END IF

'Set palette, if there was one.
IF NoPalette = 0 THEN
    'Use OUTs for speed.
    OUT &H3C8, 0
    FOR a = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, a, 1)) \ 4: NEXT
    'Save palette of image to disk.
    OPEN "pal." FOR BINARY AS #2: PUT #2, , P$: CLOSE #2
END IF

IF FirstTime = 0 THEN
  'Clear entire screen to background color. This isn't
  'done until the image's palette is set, to avoid flicker
  'on some GIFs.
    LINE (0, 0)-(319, 199), Background, BF
    FirstTime = -1
END IF

'Decode LZW data stream to screen.
DO
    'Retrieve one LZW code.
    GOSUB GetCode
    'Is it an end of stream code?
    IF Code <> EOSCode THEN
        'Is it a clear code? (The clear code resets the sliding
        'dictionary - it *should* be the first LZW code present in
        'the data stream.)
        IF Code = ClearCode THEN
            NextCode = FirstCode
            CodeSize = StartCodeSize
            MaxCode = StartMaxCode
            DO: GOSUB GetCode: LOOP WHILE Code = ClearCode
            IF Code = EOSCode THEN GOTO ImageDone
            LastCode = Code: LastPixel = Code
            IF x <= XMAX AND y >= YMIN AND y <= YMAX THEN
                POKE x + YBase, LastPixel
                IF maptype = 1 THEN
                    DEF SEG = VARSEG(BumpMap(0))
                    POKE VARPTR(BumpMap(0)) + x + XMAX1 * (y - YMIN), LastPixel
                ELSEIF maptype = 2 THEN
                    DEF SEG = VARSEG(colormap(0))
                    POKE VARPTR(colormap(0)) + x + XMAX1 * (y - YMIN), LastPixel
                END IF
                DEF SEG = &HA000
            END IF
            x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
        ELSE
            CurCode = Code: StackPointer = 0

            'Have we entered this code into the dictionary yet?
            IF Code >= NextCode THEN
                IF Code > NextCode THEN GOTO AllDone 'Bad GIF if this happens.
               'mimick last code if we haven't entered the requested
               'code into the dictionary yet
                CurCode = LastCode
                OutStack(StackPointer) = LastPixel
                StackPointer = StackPointer + 1
            END IF

            'Recursively get each character of the string.
            'Since we get the characters in reverse, "push" them
            'onto a stack so we can "pop" them off later.
            'Hint: There is another, much faster way to accomplish
            'this that doesn't involve a decoding stack at all...
            DO WHILE CurCode >= FirstCode
                OutStack(StackPointer) = Suffix(CurCode)
                StackPointer = StackPointer + 1
                CurCode = Prefix(CurCode)
            LOOP

            LastPixel = CurCode
            IF x <= XMAX AND y >= YMIN AND y <= YMAX THEN
                POKE x + YBase, LastPixel
                IF maptype = 1 THEN
                    DEF SEG = VARSEG(BumpMap(0))
                    POKE VARPTR(BumpMap(0)) + x + XMAX1 * (y - YMIN), LastPixel
                ELSEIF maptype = 2 THEN
                    DEF SEG = VARSEG(colormap(0))
                    POKE VARPTR(colormap(0)) + x + XMAX1 * (y - YMIN), LastPixel
                END IF
                DEF SEG = &HA000
            END IF
            x = x + 1: IF x = XEnd THEN GOSUB NextScanLine

            '"Pop" each character onto the display.
            FOR a = StackPointer - 1 TO 0 STEP -1
                IF x <= XMAX AND y >= YMIN AND y <= YMAX THEN
                    POKE x + YBase, OutStack(a)
                    IF maptype = 1 THEN
                        DEF SEG = VARSEG(BumpMap(0))
                        POKE VARPTR(BumpMap(0)) + x + XMAX1 * (y - YMIN), CLNG(OutStack(a))
                    ELSEIF maptype = 2 THEN
                        DEF SEG = VARSEG(colormap(0))
                        POKE VARPTR(colormap(0)) + x + XMAX1 * (y - YMIN), CLNG(OutStack(a))
                    END IF
                    DEF SEG = &HA000            'BC 4.X SE TROMPE DE SEGMENT^
                END IF
                x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
            NEXT

            'Can we put this new string into our dictionary? (Some GIF
            'encoders will wait a bit when the dictionary is full
            'before sending a clear code- this increases compression
            'because the dictionary's contents are thrown away less
            'often.)
            IF NextCode < 4096 THEN
                'Store new string in the dictionary for later use.
                Prefix(NextCode) = LastCode
                Suffix(NextCode) = LastPixel
                NextCode = NextCode + 1
                'Time to increase the LZW code size?
                IF (NextCode > MaxCode) AND (CodeSize < 12) THEN
                    CodeSize = CodeSize + 1
                    MaxCode = MaxCode * 2 + 1
                END IF
            END IF
            LastCode = Code
        END IF
    END IF
LOOP UNTIL Code = EOSCode
ImageDone:

LOOP

AllDone:

'Save image and palette to BSAVE file.
'DEF SEG = &HA000
'OUT &H3C7, 0
'FOR a = 0 TO 767
'    POKE a + 64000, INP(&H3C9)
'NEXT
'BSAVE "pic.bas", 0, 64768

'Load images saved with the above code with this:
'DEF SEG= &HA000
'BLOAD "Pic.Bas"
'OUT &H3C8, 0
'FOR a = 0 To 767
'     OUT &H3C9, Peek(a+ 64000)
'NEXT
CLOSE #1
ERASE Prefix
ERASE Suffix
ERASE OutStack
ERASE ShiftOut
ERASE Powersof2
EXIT SUB



'Slowly reads one byte from the GIF file...
GetByte: a$ = " ": GET #1, , a$: a = ASC(a$): RETURN

'Moves down one scanline. If the GIF is interlaced, then the number
'of scanlines skipped is based on the current pass.
NextScanLine:
    IF Interlaced THEN
        y = y + PassStep
        IF y >= YEnd THEN
            PassNumber = PassNumber + 1
            SELECT CASE PassNumber
            CASE 1: y = 4: PassStep = 8
            CASE 2: y = 2: PassStep = 4
            CASE 3: y = 1: PassStep = 2
            END SELECT
        END IF
    ELSE
        y = y + 1
    END IF

    x = XStart: YBase = y * 320&
RETURN

'Reads a multibit code from the data stream.
GetCode:
    WorkCode = LastChar \ ShiftOut(BitsIn)
  'Loop while more bits are needed.
    DO WHILE CodeSize > BitsIn
'Reads a byte from the LZW data stream. Since the data stream is
'blocked, a check is performed for the end of the current block
'before each byte is fetched.
        IF BlockPointer > BlockSize THEN
          'Retrieve block's length
            GOSUB GetByte: BlockSize = a
            a$ = SPACE$(BlockSize): GET #1, , a$
            BlockPointer = 1
        END IF
      'Yuck, ASC() and MID$() aren't that fast.
        LastChar = ASC(MID$(a$, BlockPointer, 1))
        BlockPointer = BlockPointer + 1
      'Append 8 more bits to the input buffer
        WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
        BitsIn = BitsIn + 8
    LOOP
  'Take away x number of bits.
    BitsIn = BitsIn - CodeSize
  'Return code to caller.
    Code = WorkCode AND MaxCode
RETURN
END SUB

SUB testlight
FOR i = -RADX TO RADX
FOR j = -RADY TO RADY
PSET (i + RADX + 1, j + RADY + 1), light(i, j)
NEXT j, i
COLOR 7: LOCATE 25, 1: PRINT "press any key to continue";
k$ = INPUT$(1)
END SUB

Texture Bumpmap
Transfert des images d'Alex J. Champandard nécessaires au programme.

Avis aux possesseurs de machine sans coprocesseur arithmétique FPU.
Le compilateur BC 4.5 possède une option non documentée (/FPa) :
https://www.betaarchive.com/wiki/index. ... hive/36899
Elle permet au CPU de calculer en virgule flottante grâce à une autre bibliothèque. Cette alternative est plus rapide que l'émulation du coprocesseur au prix d'une précision moindre. On la trouve dans PDS 7.x sous le nom de BLIBFA.LIB (mode réel). Par contre, en plus du fait que l'exécutable final doit être autonome (BC /O), plusieurs instructions posent problème lors du liage car aucune bibliothèque compatible est fournie avec QB4.5 :
- DRAW ;
- PLAY ;
- LPRINT/PRINT[#]/WRITE[#] avec valeur décimale (point du masque de ?USING inutile) ;
- RANDOMIZE et RND ;
- READ et RESTORE ;
- SOUND ;
- TIMER (à part dans ON TIMER(n) GOSUB).
Compilation :
BC bas/O/FPA;
LINK obj,,,BLIBFA
L'ancien format MBF reste le plus rapide en l'absence de FPU, mais le format IEEE est le standard :
https://jeffpar.github.io/kbarchive/kb/028/Q28023/

_________________

C:\ONGRTLNS.W95


Haut
Profil
Afficher : Trier par : Ordre :
Répondre   Page 1 sur 1  [ 1 message ]
Revenir à « Projets aboutis »
Aller :