Quick links
FAQ
Register
Login
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
