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 : http://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/FROG2.BAS?read=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.
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 :
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 :
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 :
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
'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
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 :
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.
?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 :
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 : http://qb45.org/rate.php?file=149
Je l'accélère ainsi :
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 : http://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) : http://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 :
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 :
'[url]http://www.ocf.berkeley.edu/~horie/bumpy.zip[/url]
' > 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
Avis aux possesseurs de machine sans coprocesseur arithmétique FPU.
Le compilateur BC 4.5 possède une option non documentée (/FPa) : http://www.betaarchive.com/wiki/index.p ... 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 :
Quick links
FAQ
Register
Login
