http://www.ocf.berkeley.edu/~horie/project.html
On y trouve aussi le travail d'autrui, à part la grenouille qui s'est sauvée :
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 :
Code: Select all T = TIMER WHILE T = TIMER: WEND T = TIMER A = 1 FOR I = 1 TO 1000000 A = A / A NEXT PRINT TIMER - T |
Code: Select all bc ieee,,ieee/a; link ieee; |
Code: Select all 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 |
Code: Select all SET NO87= DEBUG IEEE.EXE G UDS:1BB Q |
Code: Select all -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 |
Code: Select all -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 |
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 :
SPOILER Disabled
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 :
Code: Select all #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 |
Code: Select all 3DCD - A23D ------- = 9B90 |
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
Le module objet PIEMR de BCOM45.LIB est l'équivalent de QB4EM de BCOM40.LIB (QB4.0). On l'extrait d'abord :
Code: Select all LIB BCOM45 *PIEMR |
Code: Select all 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 |
Code: Select all 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 |
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 :
Code: Select all LIB BCOM45 -+piemr; |
P A T C H E S
SPOILER Disabled
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 :BCOM45.LIB
BCOM.BAT :
PIERMR.DEB :
BCOM45.BAS :
La position du module varie selon la langue.
NOEM.OBJ
NOEM.BAT :
NOEM.DEB :
À compiler pour la suite, CHECKSUM.BAS qui calcule le complément à un des exécutables DOS :
BRUN45.EXE
BRUN.BAT :
BRUN45.SID :
Le fix-up du segment EMULATOR_DATA varie selon la langue.
QB.EXE
QB45.BAT :
QB.SID :
La position du segment EMULATOR_TEXT varie selon la langue.
BCOM.BAT :
Code: Select all REN BCOM45.LIB *.BAK COPY BCOM45.BAK *.LIB LIB BCOM45 *piemr; DEBUG PIEMR.OBJ<PIEMR.DEB QB /RUN BCOM45 |
Code: Select all 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 |
Code: Select all 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 |
NOEM.OBJ
NOEM.BAT :
Code: Select all REN NOEM.OBJ *.BAK COPY NOEM.BAK *.OBJ DEBUG NOEM.OBJ<NOEM.DEB |
Code: Select all 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 |
Code: Select all '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 |
BRUN.BAT :
Code: Select all 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 |
Code: Select all 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 |
QB.EXE
QB45.BAT :
Code: Select all 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 |
Code: Select all 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 |
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 :
Code: Select all 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 |
Code: Select all -1 1 1.#INF -1.#INF -1.#IND 1.#NAN |
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 :
http://www.pcorner.com/list/BASIC/QB45. ... KGRND.TXT/
Pour vérifier :
Code: Select all ?sqr(atn(1#)*4)^4 'Avec le signe dièse bien placé pour QB4.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 :
Code: Select all gds:130 d0:f4 f7 |
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 :
SPOILER Disabled
Le fichier AST.EXE obtenu est plus fluide que le programme original.Code: Select all 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 |
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 :
Code: Select all sx% = sx% * X1% \ H% sy% = sy% * Y1% \ H% |
Code: Select all sx% = sx% * (X1% / H%) sy% = sy% * (Y1% / H%) |
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) :
http://jeffpar.github.io/kbarchive/kb/030/Q30397/
http://www.betaarchive.com/wiki/index.p ... 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.
SPOILER Disabled
Code: Select all 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 |
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) :
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 :
Code: Select all BC bas/O/FPA; LINK obj,,,BLIBFA |
http://jeffpar.github.io/kbarchive/kb/028/Q28023/
P.S. : FIWRQQ a aussi disparu de QB 4.0B et du compilateur BC 6.0B l'accompagnant. On les trouve ensemble ici :
http://winworldpc.com/product/microsoft ... ompiler-60