Engine pre hru MilkNuts
Delphi & Pascal (česká wiki)
Category: KMP (Club of young programmers)
Author: Martin Koleček
Program: Engine.pas, Speaker.pas, Blok.asm, Clearpag.asm, Flippage.asm, Writeblk.asm
File exe: Milknuts.exe, Editgra.exe, Editmap.exe, Editsnd.exe, Wav2raw.exe
need: Kolecek.zip
Example: Manual1.txt, Manual2.txt, Manual3.txt, Manual4.txt
Author: Martin Koleček
Program: Engine.pas, Speaker.pas, Blok.asm, Clearpag.asm, Flippage.asm, Writeblk.asm
File exe: Milknuts.exe, Editgra.exe, Editmap.exe, Editsnd.exe, Wav2raw.exe
need: Kolecek.zip
Example: Manual1.txt, Manual2.txt, Manual3.txt, Manual4.txt
Unit Engine.pas je určený pro DOS, pro Borland Pascal 7.0 reálny režim, nebo freepascal. Má za cíl vytvárení jednoduchých 2D her s podporou složitých zvukú pres PC-Speaker na pozadí behu programu, držení nekolika kláves na klávesnici najednou, BMP soubory a grafika podobná na 8mi-bitové NINTENDO. Platí zde limit 640KB takže pri použití všech hlavních funkci enginu vytvoříte program velký maximálne 90KB (samozrejme se nepočítají data externích souboru) pak dojde k chybe "heap overflow" (náraz na limit 640KB), takže je to vhodné spíš na malé projekty.
{ ENGINE.PAS Copyright (c) Martin Kolecek } { Unit Engine.pas je urceny pro DOS, pro Borland Pascal 7.0 realny rezim, nebo } { freepascal. Ma za cil vytvareni jednoduchych 2D her s podporou slozitych zvuku} { pres PC-Speaker na pozadi behu programu, drzeni nekolika klaves na klavesnici } { najednou, BMP soubory a grafika podobna na 8mi-bitove NINTENDO. Plati zde } { limit 640KB takze pri pouziti vsech hlavnich funkci enginu vytvorite program } { velky maximalne 90KB (samozrejme se nepocitaji data externich souboru) pak } { dojde k chybe "heap overflow" (naraz na limit 640KB), takze je to vhodne spis } { na male projekty jako je ukazkova hra milknuts. Ovsem je treba uvest ze o } { vsechno je uz postarano v enginu od grafiky pres zvuky az po mapu takze se } { muzete soustredit hlavne na hru samotnou. Verze pro freepascal limitem 640KB } { samozrejme netrpi. } { } { Author: Martin Kolecek } { Datum: 01.05.2011 http://www.trsek.com } {$G+} Unit Engine; {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Interface Var Key: array[0..127] of Boolean; Buffer: array[0..4] of Word; xmsCelkem,xmsMaxBlok: Word; xmsChyba: Byte; Procedure Init320x200; Procedure Init80x25; Procedure WaitRetrace; Procedure InitBuffers; Procedure ShutdownBuffers; Procedure GetPal(Color:Byte; Var R,G,B:Byte); Procedure SetPal(Color:Byte; R,G,B:Byte); Procedure LoadGRPage(JmenoSouboru:string;Pozice:LongInt); Procedure LoadBmpFile(JmenoSouboru: string; pozice: LongInt; StartColor: Byte); Procedure LoadBlok(x1,y1,x2,y2,x3,y3,BufferTo: Word); Procedure LoadSprite(x1,y1,x2,y2,x3,y3,BufferTo: Word); Procedure LoadBlokM(x1,y1,x2,y2,x3,y3,BufferTo: Word); Procedure LoadSpriteM(x1,y1,x2,y2,x3,y3,BufferTo: Word); Procedure LoadBitMap(X,Y: Word; BufferTo: Word); Procedure LoadBitMapM(X,Y: Word; BufferTo: Word); Procedure WritePixel(X:Word;Y,Color:Byte;Buffer:Word); Procedure Blok(x1,y1,x2,y2,Color,Buffer:Word); Procedure Ramecek(X1,Y1,X2,Y2:Word;Color:Byte;Buffer:Word); Procedure WriteBlok(x1,y1,x2,y2,x3,y3,BufferFrom,BufferTo: Word); Procedure WriteSprite(x1,y1,x2,y2,x3,y3,BufferFrom,BufferTo: Word); Procedure FlipPage(BufferFrom,BufferTo: Word); Procedure ClearPage(Buffer:Word); Procedure InitTexter(Barva:Byte); Procedure ShutdownTexter; Procedure ChangeTexterColor(Barva:Byte); Procedure WriteText(X,Y:Word;retezec:string;BufferTo:Word); Procedure WriteNumber(x,y:Word;Cislo:Longint;Small:Boolean;BufferTo:Word); Procedure LoadMapFile(soubor:string; pozice:Longint); Procedure SetMapByte(MapOffset:Word;bajt:Byte); Function GetMapByte(MapOffset:Word): Byte; Procedure InitKeyboard; Procedure ShutdownKeyboard; Function DetekujXms: Word; Procedure GetSizeXms(var celkemXMS,blokXMS: Word); Function AlokujXms(kolik: Word): word; Procedure UvolniXms(handle: Word); Procedure MoveToXMS(Handle: Word; XMSOffset: LongInt; Var Source; BlockLength: LongInt); Procedure MoveFromXMS(Handle: Word; XMSOffset: LongInt; Var Dest; BlockLength: LongInt); Procedure InitTimer; Procedure ShutdownTimer; Procedure Wait(ms: Word); Procedure Sound(Hertz: Word); Procedure Silence; Procedure Stopky_Start; Procedure Stopky_Stop; Function Stopky_GetNumber: LongInt; Procedure LoadSNDFile(Filename:String;Pozice:LongInt); Procedure LoadRAWFile(filename:String;Pozice:LongInt;N:Byte); Procedure PlaySound(Sample:Byte); Procedure PlayRaw(Cislo:Byte); Procedure StopPlay; Function FPS2s: Boolean; {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Implementation {$L C:\SOURCES\STORE1\ENGINE\blok.obj} {$L C:\SOURCES\STORE1\ENGINE\writeblk.obj} {$L C:\SOURCES\STORE1\ENGINE\flippage.obj} {$L C:\SOURCES\STORE1\ENGINE\clearpag.obj} Uses DOS; Type TRGB= Record R: Byte; G: Byte; B: Byte; End; TBMPHeader = Record Id: Word; Velikost: LongInt; Reserved: LongInt; DataOffset: LongInt; HeaderSize: LongInt; RozsahX: LongInt; RozsahY: LongInt; BitPlanes: Word; BPP: Word; Komprese: LongInt; ImageSize: LongInt; HorizontalRes: LongInt; VerticalRes: LongInt; Colors: LongInt; ImportantColors: LongInt; End; TBmpRGB = Record B: Byte; G: Byte; R: Byte; Reserved: Byte; End; TBMP = Record Header: TBMPHeader; Palette: array[0..15] of TBmpRGB; DataByte: Byte; End; TSample = Record Handle: Word; Delka: LongInt; Pocitadlo: Word; End; TMapa = Record MapBuffer: Word; MapBufferP: Pointer; MapBufferRLE: Word; MapBufferRLEP: Pointer; DelkaRLE: Word; End; XMSParamBlock= Record Length: LongInt; SHandle: Word; SOffset: Array[1..2] Of Word; DHandle: Word; DOffset: Array[1..2] Of Word; End; Const znaky: array[0..204] of Byte = ( {A} 126,144,144,144,126, {B} 254,146,146,146,108, {C} 124,130,130,130,68, {D} 254,130,130,130,124, {E} 254,146,146,146,130, {F} 254,144,144,144,128, {G} 124,130,146,146,92, {H} 254,16,16,16,254, {I} 130,254,130,0,0, {J} 4,2,2,2,252, {K} 254,16,40,68,130, {L} 254,2,2,2,2, {M} 254,64,32,64,254, {N} 254,32,16,8,254, {O} 124,130,130,130,124, {P} 254,144,144,144,96, {Q} 124,130,138,134,126, {R} 254,144,152,148,98, {S} 100,146,146,146,76, {T} 128,128,254,128,128, {U} 252,2,2,2,252, {V} 248,4,2,4,248, {W} 252,2,4,2,252, {X} 198,40,16,40,198, {Y} 224,16,14,16,224, {Z} 134,138,146,162,194, {+} 16,16,124,16,16, {-} 16,16,16,16,16, {x} 40,16,40, {/} 2,4,8,16,32,64,128, {:} 0,0,40,0,0, {.} 2,0,0,0,0, {,} 6,0,0,0,0, {=} 40,40,40,40,40, {?} 64,128,138,144,96, {%} 4,72,16,36,64, {!} 250,0,0,0,0, {(} 56,68,130,0,0, {)} 130,68,56,0,0, {>} 130,68,40,16,0, {<} 16,40,68,130,0); SmallZnaky: array[0..131] of Byte = ( {a} 2,21,21,21,14,1, {b} 127,10,17,17,14, {c} 14,17,17,17,10, {d} 14,17,17,10,127, {e} 14,17,21,21,12, {f} 5,63,69,64,32, {g} 57,69,69,62,64, {h} 127,8,16,16,15, {i} 1,47,1, {j} 1,33,190, {k} 127,4,10,17, {l} 64,127,1, {m} 31,8,16,15,16,15, {n} 31,8,16,16,15, {o} 14,17,17,17,14, {p} 65,127,41,68,68,56, {q} 56,68,68,41,127,65, {r} 31,8,16,16,8, {s} 9,21,21,21,18, {t} 16,126,17,2, {u} 16,30,1,17,30,1, {v} 28,2,1,2,28, {w} 28,2,1,2,1,2,28, {x} 17,10,4,10,17, {y} 112,9,9,10,124, {z} 17,19,21,25,17, {ř} 32,80,32 ); Cifry: array[0..49] of Byte = ( {0} 124,138,146,162,124, {1} 34,66,254,2,2, {2} 78,146,146,146,98, {3} 130,146,146,146,108, {4} 16,48,80,144,254, {5} 242,146,146,146,140, {6} 124,146,146,146,76, {7} 130,132,136,144,224, {8} 108,146,146,146,108, {9} 100,146,146,146,124); SmallCifry: array[0..39] of Byte = ( {0} 112,136,136,112, {1} 40,72,248,8, {2} 152,168,168,72, {3} 136,168,168,80, {4} 32,96,160,248, {5} 232,168,168,144, {6} 112,168,168,16, {7} 128,152,160,192, {8} 80,168,168,80, {9} 64,168,168,112); MaxRawu = 20; Var F: File; Bmp: TBMP; Map: TMapa; GrafikaSeg: Word; GrafikaP: Pointer; Barvy4Seg: Word; Barvy4P: Pointer; PaletaSeg: Word; PaletaP: Pointer; RLESeg: Word; RLEP: Pointer; RLEKompressedSeg: Word; RLEKompressedP: Pointer; RLEdelka: Word; Barva: array[0..15] of TRGB; CisloStranky: Byte; BufferP: array[0..3] of Pointer; Buffer2: Pointer; BufferSeg2: Word; BufferC,BufferC1,BufferC2,BufferC3: Pointer; BufferSegC,BufferSegC1,BufferSegC2,BufferSegC3: Word; TexterColor: Byte; xmsAdr:longint; xmsVersion,ovlXmsVersion,hmaDetect: Word; b: array[0..7] of Byte; PressedKey: Byte; BIOSKeyboardHandler: Procedure; BIOSTimerHandler: Procedure; clock_ticks,counter: longint; StopkyTics: LongInt; StopkyActive: Boolean; SoundDataSeg: Word; SoundDataP: Pointer; ZvukTabSeg: Word; ZvukTabP: Pointer; PrehravatZvuk: Boolean; {start hrani zvuku} CisloZvuku: Byte; {poradi v tabulce zvuku} PosuvZ: Word; {posun po zvuku} delaycounter: Word; {pocitadlo milisekund pro Wait} waiting: Boolean; {jestli je volana procedura Wait} player: Byte; {obecne pocitadlo - setiny vterin} stopky: LongInt; {pocitadlo pro stopky} fps_helper: Byte; {pomocna promenna na vypocet FPS} SPBuffer,XMSTransfer: Pointer; {Buffery na load rawu a prehravani} SPBufferSeg,XMSTransferSeg: Word; {segmenty tech bufferu} XMSCelkemPotreba: Word; {potrebna XMS pamet} XMSBlokPotreba: Word; {potrebna velikost bloku XMS} vzorek: Byte; PrehravanyZvuk: Byte; {zvuk ktery hraje} PocetRawu: Byte; {pocet rawu v pameti} RawHraje: Boolean; {True=Raw hraje} Sample: array[0..MaxRawu] of TSample; {data rawu pod 4 vteriny} OffsetSpeakeru: Word; {offset do bufferu speakeru 32KB} {SECTION GRAPHICS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Procedure Init320x200; Assembler; Asm Mov AH, 00h Mov AL, 13h Int 10h End; Procedure Init80x25; Assembler; Asm Mov AH, 00h Mov AL, 03h Int 10h End; Procedure WaitRetrace; Assembler; Asm Mov dx,3DAh @l1: In al,dx And al,08h Jnz @l1 @l2: In al,dx And al,08h Jz @l2 End; Procedure InitBuffers; Var I,x: Word; Begin GetMem(BufferP[0],32000); Buffer[0]:=Seg(BufferP[0]^); For x:=0 to 31999 do mem[Buffer[0]:x]:=0; {vymaz bufferu} For I:=1 to 3 do Begin GetMem(BufferP[I],64000); Buffer[I]:=Seg(BufferP[I]^); For x:=0 to 63999 do mem[Buffer[I]:x]:=0; {vymaz bufferu} End; GetMem(Map.MapBufferP,64000); Map.MapBuffer:=Seg(Map.MapBufferP^); For x:=0 to 63999 do mem[Map.MapBuffer:x]:=0; {vymaz bufferu} GetMem(Map.MapBufferRLEP,64000); Map.MapBufferRLE:=Seg(Map.MapBufferRLEP^); For x:=0 to 63999 do mem[Map.MapBufferRLE:x]:=0; {vymaz bufferu} Buffer[4]:=$A000; GetMem(Buffer2,2000); BufferSeg2:=Seg(Buffer2^); GetMem(GrafikaP,8000); GrafikaSeg:=Seg(GrafikaP^); GetMem(Barvy4P,1008); Barvy4Seg:=Seg(Barvy4P^); GetMem(PaletaP,48); PaletaSeg:=Seg(PaletaP^); GetMem(RLEP,9056); RLESeg:=Seg(RLEP^); GetMem(RLEKompressedP,9056); RLEKompressedSeg:=Seg(RLEKompressedP^); For I:=0 to 1999 do mem[BufferSeg2:I]:=0; {vymaz bufferu} For I:=0 to 7999 do mem[GrafikaSeg:I]:=0; {vymaz bufferu} For I:=0 to 1007 do mem[Barvy4Seg:I]:=0; {vymaz bufferu} For I:=0 to 47 do mem[PaletaSeg:I]:=0; {vymaz bufferu} For I:=0 to 9055 do mem[RLESeg:I]:=0; {vymaz bufferu} For I:=0 to 9055 do mem[RLEKompressedSeg:I]:=0; {vymaz bufferu} End; Procedure ShutdownBuffers; Var I: Byte; Begin FreeMem(BufferP[0],32000); For I:=1 to 3 do FreeMem(BufferP[I],64000); FreeMem(Map.MapBufferP,64000); FreeMem(Map.MapBufferRLEP,64000); FreeMem(Buffer2,2000); FreeMem(GrafikaP,8000); FreeMem(Barvy4P,1008); FreeMem(PaletaP,48); FreeMem(RLEP,9056); FreeMem(RLEKompressedP,9056); End; Function Bin2Dec(b7,b6,b5,b4,b3,b2,b1,b0: Byte): Byte; Var I: Byte; Begin I:=0; If b7=1 then Inc(I,128); If b6=1 then Inc(I,64); If b5=1 then Inc(I,32); If b4=1 then Inc(I,16); If b3=1 then Inc(I,8); If b2=1 then Inc(I,4); If b1=1 then Inc(I,2); If b0=1 then Inc(I,1); Bin2Dec:=I; End; Procedure Dec2Bin(DCnum:Byte); Var I: Byte; Begin For I:=0 to 7 do b[I]:=(DCnum AND (1 SHL I)) SHR I; End; Procedure GetPal(Color:Byte; Var R,G,B:Byte); Begin Port[$3c7]:=Color; R:=Port[$3c9]; G:=Port[$3c9]; B:=Port[$3c9]; End; Procedure SetPal(Color:Byte; R,G,B:Byte); Begin Port[$3c8]:=Color; Port[$3c9]:=R; Port[$3c9]:=G; Port[$3c9]:=B; End; Procedure RLEDekompress; Var WritedBA: Byte; {znak A} WritedBB: Byte; {je-li komprese tak stejny jako znak A} WritedBC: Byte; {pocet kolikrat tam je znak A } I,A,posun: Word; Begin I:=0; posun:=0; While not (posun=RLEDelka) do Begin WritedBA:=mem[RLEKompressedSeg:posun]; {nacteme A} Inc(posun); If posun=RLEDelka then {je-li konec zapsat a BREAK} Begin mem[RLESeg:I]:=WritedBA; Break; End; WritedBB:=mem[RLEKompressedSeg:posun]; {nacteme B} Inc(posun); If posun=RLEDelka then {je-li konec zapsat a BREAK} Begin mem[RLESeg:I]:=WritedBA; mem[RLESeg:I+1]:=WritedBB; Break; End; If WritedBA=WritedBB then {jsou-li dva stejne tzn. nasleduje pocet} Begin WritedBC:=mem[RLEKompressedSeg:posun]; {muzeme nacist pocet} Inc(posun); For A:=1 to WritedBC do Begin mem[RLESeg:I]:=WritedBA; {zapisujeme WritedBC krat} Inc(I); End; End else {jsou dva ruzne} Begin mem[RLESeg:I]:=WritedBA; {zapisme jeden a navrat nahoru} Inc(I); Dec(posun); {posuneme index o jednu nazpet} End; End; {While End} End; Procedure MovArraysTo3; Var I,A: Word; Begin A:=0; For I:=0 to 7999 do Begin mem[GrafikaSeg:I]:=mem[RLESeg:A]; Inc(A); End; For I:=0 to 999 do Begin mem[Barvy4Seg:I]:=mem[RLESeg:A]; Inc(A); End; For I:=0 to 47 do Begin mem[PaletaSeg:I]:=mem[RLESeg:A]; Inc(A); End; CisloStranky:=mem[RLESeg:9048]; End; Procedure Rozkodovat; Var Offset32,Offset2,Xa,Ya,X1,Y1,x,y,A,I: Word; Begin {Rozkodovani grafiky 8000B} A:=0; I:=0; Repeat Dec2Bin(mem[GrafikaSeg:I]); mem[Buffer[0]:A+0]:=Bin2Dec(0,0,0,0,0,0,b[1],b[0]); mem[Buffer[0]:A+1]:=Bin2Dec(0,0,0,0,0,0,b[3],b[2]); mem[Buffer[0]:A+2]:=Bin2Dec(0,0,0,0,0,0,b[5],b[4]); mem[Buffer[0]:A+3]:=Bin2Dec(0,0,0,0,0,0,b[7],b[6]); Inc(A,4); Inc(I); Until I=8000; {Rozkodovani barvy4 2000B} A:=0; I:=0; Repeat Dec2Bin(mem[Barvy4Seg:I]); mem[BufferSeg2:A+0]:=Bin2Dec(0,0,0,0,b[3],b[2],b[1],b[0]); mem[BufferSeg2:A+1]:=Bin2Dec(0,0,0,0,b[7],b[6],b[5],b[4]); Inc(A,2); Inc(I); Until I=1000; {Nahravani palety RGB ze souboru} A:=0; For I:=0 to 15 do Begin Barva[I].R:=mem[PaletaSeg:A+0]; Barva[I].G:=mem[PaletaSeg:A+1]; Barva[I].B:=mem[PaletaSeg:A+2]; Inc(A,3); End; {Nastaveni palety RGB - nutny graficky rezim} For I:=0 to 15 do SetPal(CisloStranky*16+I,Barva[I].R,Barva[I].G,Barva[I].B); {Nastaveni spravnych barev 160x200 po krocich 8x8} For Ya:=0 to 24 do For Xa:=0 to 19 do Begin For y:=0 to 7 do For x:=0 to 7 do Begin X1:=Trunc((Xa*8+x)/8); Y1:=Trunc((Ya*8+y)/8); Offset2:=(Y1*20+X1)*4; Offset32:=((Ya*8+y)*160)+(Xa*8+x); Case mem[Buffer[0]:Offset32] of 0: Begin If mem[BufferSeg2:Offset2+0]>0 then mem[Buffer[0]:Offset32]:=mem[BufferSeg2:Offset2+0]+(CisloStranky*16) else mem[Buffer[0]:Offset32]:=0; End; 1: Begin If mem[BufferSeg2:Offset2+1]>0 then mem[Buffer[0]:Offset32]:=mem[BufferSeg2:Offset2+1]+(CisloStranky*16) else mem[Buffer[0]:Offset32]:=0; End; 2: Begin If mem[BufferSeg2:Offset2+2]>0 then mem[Buffer[0]:Offset32]:=mem[BufferSeg2:Offset2+2]+(CisloStranky*16) else mem[Buffer[0]:Offset32]:=0; End; 3: Begin If mem[BufferSeg2:Offset2+3]>0 then mem[Buffer[0]:Offset32]:=mem[BufferSeg2:Offset2+3]+(CisloStranky*16) else mem[Buffer[0]:Offset32]:=0; End; End; {Case End} End; End; End; Procedure LoadGRPage(JmenoSouboru:string;Pozice:LongInt); Var I: Word; WritedByte: Byte; Begin Assign(F,JmenoSouboru); Reset(F,1); Seek(F,Pozice); BlockRead(F,RLEdelka,2); {nacist delku} For I:=1 to RLEDelka do Begin BlockRead(F,WritedByte,1); mem[RLEKompressedSeg:I-1]:=WritedByte; End; RLEDekompress; {RLEkompressed => RLE} MovArraysTo3; {RLE => arrays} Rozkodovat; Close(F); End; Procedure LoadBmpFile(JmenoSouboru: string; pozice: LongInt; StartColor: Byte); Var I,N: LongInt; Pixel1: Byte; Pixel2: Byte; Begin Assign(F,JmenoSouboru); Reset(F,1); Seek(F,pozice); {Header} BlockRead(F,BMP.Header,54); {Palette} For I:=0 to 15 do Begin BlockRead(F,BMP.Palette[I].B,1); BlockRead(F,BMP.Palette[I].G,1); BlockRead(F,BMP.Palette[I].R,1); BlockRead(F,BMP.Palette[I].Reserved,1); BMP.Palette[I].B:=BMP.Palette[I].B DIV 4; BMP.Palette[I].G:=BMP.Palette[I].G DIV 4; BMP.Palette[I].R:=BMP.Palette[I].R DIV 4; SetPal(StartColor+I,BMP.Palette[I].R,BMP.Palette[I].G,BMP.Palette[I].B); End; {Data} N:=0; For I:=0 to (BMP.Header.ImageSize-1) do Begin BlockRead(F,BMP.DataByte,1); Pixel1:=(BMP.DataByte SHR 4); Pixel2:=(BMP.DataByte AND 15); mem[Buffer[0]:N]:=StartColor+Pixel1; mem[Buffer[0]:N+1]:=StartColor+Pixel2; Inc(N,2); End; Close(F); End; Procedure LoadBlok(x1,y1,x2,y2,x3,y3,BufferTo: Word); Var Xa,Ya,x,y,Offset1,Offset2: Word; Begin Xa:=x1; Ya:=y1; For y:=y2 to y3 do Begin For x:=x2 to x3 do Begin Offset1:=Ya*320+Xa; Offset2:=y*160+x; mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; inc(Xa); End; Xa:=x1; Inc(Ya); End; End; Procedure LoadSprite(x1,y1,x2,y2,x3,y3,BufferTo: Word); Var Xa,Ya,x,y,Offset1,Offset2: Word; Begin Xa:=x1; Ya:=y1; For y:=y2 to y3 do Begin For x:=x2 to x3 do Begin Offset1:=Ya*320+Xa; Offset2:=y*160+x; If mem[Buffer[0]:Offset2]>0 then mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; inc(Xa); End; Xa:=x1; Inc(Ya); End; End; Procedure LoadBlokM(x1,y1,x2,y2,x3,y3,BufferTo: Word); Var Xa,Ya,x,y,Offset1,Offset2: Word; Begin Xa:=x1; Ya:=y1; For y:=y2 to y3 do Begin For x:=x3 downto x2 do Begin Offset1:=Ya*320+Xa; Offset2:=y*160+x; mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; inc(Xa); End; Xa:=x1; Inc(Ya); End; End; Procedure LoadSpriteM(x1,y1,x2,y2,x3,y3,BufferTo: Word); Var Xa,Ya,x,y,Offset1,Offset2: Word; Begin Xa:=x1; Ya:=y1; For y:=y2 to y3 do Begin For x:=x3 downto x2 do Begin Offset1:=Ya*320+Xa; Offset2:=y*160+x; If mem[Buffer[0]:Offset2]>0 then mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; inc(Xa); End; Xa:=x1; Inc(Ya); End; End; Procedure LoadBitMap(X,Y: Word; BufferTo: Word); Var xa,ya: Word; Offset1: Word; Offset2: Word; Begin Offset2:=0; For ya:=(BMP.Header.RozsahY-1) downto 0 do For xa:=0 to (BMP.Header.RozsahX-1) do Begin Offset1:=((Y+ya)*320+(X+xa)); mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; Inc(Offset2); End; End; Procedure LoadBitMapM(X,Y: Word; BufferTo: Word); Var xa,ya: Word; Offset1: Word; Offset2: Word; Begin Offset2:=0; For ya:=(BMP.Header.RozsahY-1) downto 0 do For xa:=(BMP.Header.RozsahX-1) downto 0 do Begin Offset1:=((Y+ya)*320+(X+xa)); mem[BufferTo:Offset1]:=mem[Buffer[0]:Offset2]; Inc(Offset2); End; End; Procedure WritePixel(X:Word;Y,Color:Byte;Buffer:Word); Assembler; Asm MOV AX, Buffer MOV ES, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX XOR BX, BX MOV BL, Y MUL BX MOV CX, X ADD AX, CX MOV DI, AX XOR AX, AX MOV AL, Color STOSB End; Procedure Blok(x1,y1,x2,y2,Color,Buffer:Word); external; Procedure Ramecek(X1,Y1,X2,Y2:Word;Color:Byte;Buffer:Word); Assembler; Asm MOV AX, Buffer MOV ES, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX MOV SI, AX MOV BX, y1 MUL BX MOV CX, x1 ADD AX, CX MOV DI, AX XOR AX, AX MOV AL, Color MOV DX, x2 MOV CX, x1 SUB DX, CX MOV CX, DX INC CX @cyklus1: STOSB LOOP @cyklus1 DEC DI SUB DI, DX ADD DI, SI MOV CX, y2 MOV BX, y1 SUB CX, BX DEC CX @cyklus2: STOSB DEC DI ADD DI, DX STOSB DEC DI SUB DI, DX ADD DI, SI LOOP @cyklus2 MOV CX, DX INC CX @cyklus3: STOSB LOOP @cyklus3 End; Procedure WriteBlok(x1,y1,x2,y2,x3,y3,BufferFrom,BufferTo: Word); external; Procedure WriteSprite(x1,y1,x2,y2,x3,y3,BufferFrom,BufferTo: Word); Assembler; Asm PUSH DS @testing: MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} INC DX TEST DX, 0000000000000001b JNE @odd @even: MOV AX, BufferTo MOV ES, AX MOV AX, BufferFrom MOV DS, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX {AX=320} PUSH AX MOV BX, y1 MUL BX MOV CX, x1 ADD AX, CX MOV DI, AX {ES:DI BufferTo} POP AX MOV BX, y2 MUL BX MOV CX, x2 ADD AX, CX MOV SI, AX {DS:SI BufferFrom} MOV BX, y3 MOV DX, y2 SUB BX, DX {BX=vyska} INC BX @cyklus2: MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} INC DX SHR DX, 1 MOV CX, DX @cyklus1: PUSH BX XOR BX, BX LODSW CMP AX, BX JE @je_nulaW JNE @neni_nulaW @je_nulaW: INC DI INC DI JMP @konec @neni_nulaW: CMP AL, BL JE @prvnibajt CMP AH, BL JE @druhybajt JMP @oba2bajty @prvnibajt: INC DI CMP AH, BL JE @equal1 JMP @equal2 @equal1: INC DI JMP @konec @equal2: DEC SI MOVSB JMP @konec @druhybajt: DEC SI DEC SI MOVSB INC DI INC SI JMP @konec @oba2bajty: DEC SI DEC SI MOVSW @konec: POP BX LOOP @cyklus1 MOV CX, BX SHL DX, 1 SUB DI, DX ADD DI, 320 SUB SI, DX ADD SI, 320 SHR DX, 1 DEC BX LOOP @cyklus2 JMP @final @odd: MOV AX, BufferTo MOV ES, AX MOV AX, BufferFrom MOV DS, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX {AX=320} PUSH AX MOV BX, y1 MUL BX MOV CX, x1 ADD AX, CX MOV DI, AX {ES:DI BufferTo} MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} ADD DI, DX POP AX MOV BX, y2 MUL BX MOV CX, x2 ADD AX, CX MOV SI, AX {DS:SI BufferFrom} MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} ADD SI, DX MOV CX, y3 MOV DX, y2 SUB CX, DX {CX=vyska} INC CX XOR BL, BL @cyklus3: LODSB {DS:SI -> AL} CMP AL, BL JE @je_nulaB JNE @neni_nulaB @je_nulaB: DEC SI ADD SI, 320 ADD DI, 320 JMP @konec_nulaB @neni_nulaB: STOSB DEC SI ADD SI, 320 DEC DI ADD DI, 320 @konec_nulaB: LOOP @cyklus3 JMP @even @final: POP DS End; Procedure FlipPage(BufferFrom,BufferTo: Word); external; Procedure ClearPage(Buffer:Word); external; Procedure InitTexter(Barva:Byte); Var Offset,I,A: Word; Begin GetMem(BufferC,1435); BufferSegC:=Seg(BufferC^); {205=delka*7=vyska=1435B} For I:=0 to 1434 do mem[BufferSegC:I]:=0; {vymaz bufferu} GetMem(BufferC1,350); BufferSegC1:=Seg(BufferC1^); {50=delka*7=vyska=350B} For I:=0 to 349 do mem[BufferSegC1:I]:=0; {vymaz bufferu C1 cifry} GetMem(BufferC2,280); BufferSegC2:=Seg(BufferC2^); {40=delka*7=vyska=280B} For I:=0 to 279 do mem[BufferSegC2:I]:=0; {vymaz bufferu C2 small cifry} GetMem(BufferC3,1056); BufferSegC3:=Seg(BufferC3^); {40=delka*7=vyska=280B} For I:=0 to 1055 do mem[BufferSegC3:I]:=0; {vymaz bufferu C3 small znaky} TexterColor:=Barva; For I:=0 to 204 do Begin Dec2Bin(Znaky[I]); For A:=7 downto 0 do If b[A]=1 then mem[BufferSegC:205*(7-A)+I]:=TexterColor; End; For I:=0 to 49 do Begin Dec2Bin(Cifry[I]); For A:=7 downto 0 do If b[A]=1 then mem[BufferSegC1:50*(7-A)+I]:=TexterColor; End; For I:=0 to 39 do Begin Dec2Bin(SmallCifry[I]); For A:=7 downto 0 do If b[A]=1 then mem[BufferSegC2:40*(7-A)+I]:=TexterColor; End; For I:=0 to 131 do Begin Dec2Bin(SmallZnaky[I]); For A:=7 downto 0 do If b[A]=1 then mem[BufferSegC3:132*(7-A)+I]:=TexterColor; End; End; Procedure ShutdownTexter; Begin FreeMem(BufferC,1435); FreeMem(BufferC1,350); FreeMem(BufferC2,280); FreeMem(BufferC3,1056); End; Procedure ChangeTexterColor(Barva:Byte); Var I: Word; Begin For I:=0 to 1434 do If mem[BufferSegC:I]<>0 then mem[BufferSegC:I]:=Barva; For I:=0 to 349 do If mem[BufferSegC1:I]<>0 then mem[BufferSegC1:I]:=Barva; For I:=0 to 279 do If mem[BufferSegC2:I]<>0 then mem[BufferSegC2:I]:=Barva; For I:=0 to 1055 do If mem[BufferSegC3:I]<>0 then mem[BufferSegC3:I]:=Barva; End; Procedure WriteTexterSprite1(x1,y1,x2,y2,x3,y3,BufferTo:Word); Assembler; Asm PUSH DS MOV AX, BufferTo MOV ES, AX MOV AX, BufferSegC MOV DS, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX {AX=320} MOV BX, y1 MUL BX MOV CX, x1 ADD AX, CX MOV DI, AX {ES:DI BufferTo} MOV AX, 205 MOV BX, y2 MUL BX MOV CX, x2 ADD AX, CX MOV SI, AX {DS:SI BufferFrom} MOV BX, y3 MOV DX, y2 SUB BX, DX {BX=vyska} INC BX @cyklus2: MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} INC DX MOV CX, DX @cyklus1: PUSH BX XOR BL, BL LODSB CMP AL, BL JE @je_nula DEC SI MOVSB JMP @konec @je_nula: INC DI @konec: POP BX LOOP @cyklus1 MOV CX, BX SUB DI, DX ADD DI, 320 SUB SI, DX ADD SI, 205 DEC BX LOOP @cyklus2 POP DS End; Procedure WriteTexterSprite2(x1,y1,x2,y2,x3,y3,BufferTo:Word); Assembler; Asm PUSH DS MOV AX, BufferTo MOV ES, AX MOV AX, BufferSegC3 MOV DS, AX XOR AX, AX INC AX SHL AX, 8 XOR CX, CX INC CX SHL CX, 6 ADD AX, CX {AX=320} MOV BX, y1 MUL BX MOV CX, x1 ADD AX, CX MOV DI, AX {ES:DI BufferTo} MOV AX, 132 MOV BX, y2 MUL BX MOV CX, x2 ADD AX, CX MOV SI, AX {DS:SI BufferFrom} MOV BX, y3 MOV DX, y2 SUB BX, DX {BX=vyska} INC BX @cyklus2: MOV DX, x3 MOV CX, x2 SUB DX, CX {DX=delka} INC DX MOV CX, DX @cyklus1: PUSH BX XOR BL, BL LODSB CMP AL, BL JE @je_nula DEC SI MOVSB JMP @konec @je_nula: INC DI @konec: POP BX LOOP @cyklus1 MOV CX, BX SUB DI, DX ADD DI, 320 SUB SI, DX ADD SI, 132 DEC BX LOOP @cyklus2 POP DS End; Procedure WriteCifra(x,y:Word;Cislo:Byte;BufferTo:Word); Var xa,ya,Offset:Word; Begin For ya:=0 to 6 do Begin For xa:=0 to 4 do Begin Offset:=ya*50+((Cislo*5)+xa); If mem[BufferSegC1:Offset]>0 then mem[BufferTo:(y+ya)*320+(x+xa)]:=TexterColor; End; End; End; Procedure WriteSmallCifra(x,y:Word;Cislo:Byte;BufferTo:Word); Var xa,ya,Offset:Word; Begin For ya:=0 to 4 do Begin For xa:=0 to 3 do Begin Offset:=ya*40+((Cislo*4)+xa); If mem[BufferSegC2:Offset]>0 then mem[BufferTo:(y+ya)*320+(x+xa)]:=TexterColor; End; End; End; Procedure WriteZnak(X,Y:Word;Znak:Char;BufferTo:Word); Var Ordinal: Byte; Begin Ordinal:=Ord(Znak); If Ordinal in [48..57] then {znaky 0..9} WriteCifra(X,Y+1,Ordinal-48,BufferTo); If Ordinal in [65..90] then {znaky A..Z} WriteTexterSprite1(X,Y+1,(Ordinal-65)*5,0,(Ordinal-65)*5+4,6,BufferTo); Case Ordinal of {ostatni znaky} {+} 43: WriteTexterSprite1(X,Y+1,130,0,134,6,BufferTo); {-} 45: WriteTexterSprite1(X,Y+1,135,0,139,6,BufferTo); {*} 42: WriteTexterSprite1(X,Y+1,140,0,142,6,BufferTo); {/} 47: WriteTexterSprite1(X,Y,143,0,149,6,BufferTo); {:} 58: WriteTexterSprite1(X,Y+1,150,0,154,6,BufferTo); {.} 46: WriteTexterSprite1(X,Y+1,155,0,155,6,BufferTo); {,} 44: WriteTexterSprite1(X,Y+2,160,0,160,6,BufferTo); {=} 61: WriteTexterSprite1(X,Y+1,165,0,169,6,BufferTo); {?} 63: WriteTexterSprite1(X,Y+1,170,0,174,6,BufferTo); {%} 37: WriteTexterSprite1(X,Y+1,175,0,179,6,BufferTo); {!} 33: WriteTexterSprite1(X,Y+1,180,0,180,6,BufferTo); {(} 40: WriteTexterSprite1(X,Y+1,185,0,189,6,BufferTo); {)} 41: WriteTexterSprite1(X,Y+1,190,0,194,6,BufferTo); {>} 62: WriteTexterSprite1(X,Y+1,195,0,199,6,BufferTo); {<} 60: WriteTexterSprite1(X,Y+1,200,0,204,6,BufferTo); {a} 97: WriteTexterSprite2(X,Y,0,0,5,7,BufferTo); {b} 98: WriteTexterSprite2(X,Y,6,0,10,7,BufferTo); {c} 99: WriteTexterSprite2(X,Y,11,0,15,7,BufferTo); {d} 100: WriteTexterSprite2(X,Y,16,0,20,7,BufferTo); {e} 101: WriteTexterSprite2(X,Y,21,0,25,7,BufferTo); {f} 102: WriteTexterSprite2(X,Y,26,0,30,7,BufferTo); {g} 103: WriteTexterSprite2(X,Y+2,31,0,35,7,BufferTo); {h} 104: WriteTexterSprite2(X,Y,36,0,40,7,BufferTo); {i} 105: WriteTexterSprite2(X,Y,41,0,43,7,BufferTo); {j} 106: WriteTexterSprite2(X,Y+2,44,0,46,7,BufferTo); {k} 107: WriteTexterSprite2(X,Y,47,0,50,7,BufferTo); {l} 108: WriteTexterSprite2(X,Y,51,0,53,7,BufferTo); {m} 109: WriteTexterSprite2(X,Y,54,0,59,7,BufferTo); {n} 110: WriteTexterSprite2(X,Y,60,0,64,7,BufferTo); {o} 111: WriteTexterSprite2(X,Y,65,0,69,7,BufferTo); {p} 112: WriteTexterSprite2(X,Y+2,70,0,75,7,BufferTo); {q} 113: WriteTexterSprite2(X,Y+2,76,0,81,7,BufferTo); {r} 114: WriteTexterSprite2(X,Y,82,0,86,7,BufferTo); {s} 115: WriteTexterSprite2(X,Y,87,0,91,7,BufferTo); {t} 116: WriteTexterSprite2(X,Y,92,0,95,7,BufferTo); {u} 117: WriteTexterSprite2(X,Y,96,0,101,7,BufferTo); {v} 118: WriteTexterSprite2(X,Y,102,0,106,7,BufferTo); {w} 119: WriteTexterSprite2(X,Y,107,0,113,7,BufferTo); {x} 120: WriteTexterSprite2(X,Y,114,0,118,7,BufferTo); {y} 121: WriteTexterSprite2(X,Y+2,119,0,123,7,BufferTo); {z} 122: WriteTexterSprite2(X,Y,124,0,128,7,BufferTo); { } 160: Begin WriteTexterSprite2(X,Y,0,0,5,7,BufferTo); WriteTexterSprite2(X+3,Y,130,2,131,3,BufferTo); End; {} 159: Begin WriteTexterSprite2(X,Y,11,0,15,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {+} 212: Begin WriteTexterSprite2(X,Y,16,0,20,7,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {} 130: Begin WriteTexterSprite2(X,Y,21,0,25,7,BufferTo); WriteTexterSprite2(X+2,Y,130,2,131,3,BufferTo); End; {+} 216: Begin WriteTexterSprite2(X,Y,21,0,25,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {Ą} 161: Begin WriteTexterSprite2(X,Y,41,0,43,7,BufferTo); WriteTexterSprite2(X+1,Y+1,130,2,131,3,BufferTo); End; {s} 229: Begin WriteTexterSprite2(X,Y,60,0,64,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {˘} 162: Begin WriteTexterSprite2(X,Y,65,0,69,7,BufferTo); WriteTexterSprite2(X+2,Y,130,2,131,3,BufferTo); End; {ý} 253: Begin WriteTexterSprite2(X,Y,82,0,86,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {t} 231: Begin WriteTexterSprite2(X,Y,87,0,91,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {} 156: Begin WriteTexterSprite2(X,Y,92,0,95,7,BufferTo); WriteTexterSprite2(X,Y-2,129,2,131,3,BufferTo); End; {Ł} 163: Begin WriteTexterSprite2(X,Y,96,0,101,7,BufferTo); WriteTexterSprite2(X+3,Y,130,2,131,3,BufferTo); End; { } 133: Begin WriteTexterSprite2(X,Y,96,0,101,7,BufferTo); WriteTexterSprite2(X+1,Y-1,129,1,131,3,BufferTo); End; {8} 236: Begin WriteTexterSprite2(X,Y+2,119,0,123,7,BufferTo); WriteTexterSprite2(X+2,Y,130,2,131,3,BufferTo); End; {§} 167: Begin WriteTexterSprite2(X,Y,124,0,128,7,BufferTo); WriteTexterSprite2(X+1,Y,129,2,131,3,BufferTo); End; {Ý} 181: Begin WriteTexterSprite1(X,Y+1,0,0,4,6,BufferTo); WriteTexterSprite2(X+2,Y-2,130,2,131,3,BufferTo); End; {Ź} 172: Begin WriteTexterSprite1(X,Y+1,10,0,14,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {-} 210: Begin WriteTexterSprite1(X,Y+1,15,0,19,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {} 144: Begin WriteTexterSprite1(X,Y+1,20,0,24,6,BufferTo); WriteTexterSprite2(X+2,Y-2,130,2,131,3,BufferTo); End; {+} 183: Begin WriteTexterSprite1(X,Y+1,20,0,24,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {+} 214: Begin WriteTexterSprite1(X,Y+1,40,0,44,6,BufferTo); WriteTexterSprite2(X+1,Y-2,130,2,131,3,BufferTo); End; {+} 213: Begin WriteTexterSprite1(X,Y+1,65,0,69,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {a} 224: Begin WriteTexterSprite1(X,Y+1,70,0,74,6,BufferTo); WriteTexterSprite2(X+2,Y-2,130,2,131,3,BufferTo); End; {n} 252: Begin WriteTexterSprite1(X,Y+1,85,0,89,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {ć} 230: Begin WriteTexterSprite1(X,Y+1,90,0,94,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {} 155: Begin WriteTexterSprite1(X,Y+1,95,0,99,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; {T} 233: Begin WriteTexterSprite1(X,Y+1,100,0,104,6,BufferTo); WriteTexterSprite2(X+2,Y-2,130,2,131,3,BufferTo); End; {Ý} 222: Begin WriteTexterSprite1(X,Y+1,100,0,104,6,BufferTo); WriteTexterSprite2(X+1,Y-3,129,1,131,3,BufferTo); End; {f} 237: Begin WriteTexterSprite1(X,Y+1,120,0,124,6,BufferTo); WriteTexterSprite2(X+2,Y-2,130,2,131,3,BufferTo); End; {Ś} 166: Begin WriteTexterSprite1(X,Y+1,125,0,129,6,BufferTo); WriteTexterSprite2(X+1,Y-2,129,2,131,3,BufferTo); End; End; {Case End} End; Procedure WriteText(X,Y:Word;retezec:string;BufferTo:Word); Var I: Word; posuv:Byte; Ordinal: Byte; Begin posuv:=6; {default} For I:=1 to Length(retezec) do Begin Ordinal:=Ord(retezec[I]); Case Ordinal of {znaky o jine delce nez 5 ... nastavit jiny posuv} {+} 214: posuv:=4; {I} 73: posuv:=4; {*} 42: posuv:=4; {/} 47: posuv:=8; {a} 97: posuv:=7; {i} 105: posuv:=4; {j} 106: posuv:=4; {k} 107: posuv:=5; {l} 108: posuv:=4; {m} 109: posuv:=7; {p} 112: posuv:=7; {q} 113: posuv:=7; {t} 116: posuv:=5; {u} 117: posuv:=7; {w} 119: posuv:=8; { } 160: posuv:=7; {Ą} 161: posuv:=4; {Ł} 163: posuv:=7; { } 133: posuv:=7; {} 156: posuv:=5; End; {Case End} WriteZnak(X,Y,retezec[I],BufferTo); Inc(X,posuv); posuv:=6; {default} End; End; Procedure WriteNumber(x,y:Word;Cislo:Longint;Small:Boolean;BufferTo:Word); Var MZbytek,MRozdil,delitel: Longint; Zapisovat:Boolean; posuv,pocet:Byte; Begin posuv:=0; Zapisovat:=False; delitel:=1000000; For pocet:=0 to 6 do Begin If delitel>0 then Begin MRozdil:=Cislo div delitel; MZbytek:=Cislo mod delitel; End else Begin MRozdil:=0; MZbytek:=0; End; If MRozdil>0 then Zapisovat:=True; If Zapisovat=True then If Small=False then Begin WriteCifra(x+posuv,y,MRozdil,BufferTo); Inc(posuv,6); End else Begin WriteSmallCifra(x+posuv,y,MRozdil,BufferTo); Inc(posuv,5); End; Cislo:=MZbytek; If delitel>0 then delitel:=delitel div 10; End; If (Zapisovat=False) And (MRozdil=0) then If Small=False then WriteCifra(x+posuv,y,MRozdil,BufferTo) else WriteSmallCifra(x+posuv,y,MRozdil,BufferTo); End; {SECTION MAP XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Procedure RLEDekompresMap; Var WritedBA: Byte; {znak A} WritedBB: Byte; {je-li komprese tak stejny jako znak A} WritedBC: Byte; {pocet kolikrat tam je znak A } I,A,posun: Word; Begin I:=0; posun:=0; While not (posun=Map.DelkaRLE) do Begin WritedBA:=mem[Map.MapBufferRLE:posun]; {nacteme A} Inc(posun); If posun=Map.DelkaRLE then {je-li konec zapsat a BREAK} Begin mem[Map.MapBuffer:I]:=WritedBA; Break; End; WritedBB:=mem[Map.MapBufferRLE:posun]; {nacteme B} Inc(posun); If posun=Map.DelkaRLE then {je-li konec zapsat a BREAK} Begin mem[Map.MapBuffer:I]:=WritedBA; mem[Map.MapBuffer:I+1]:=WritedBB; Break; End; If WritedBA=WritedBB then {jsou-li dva stejne tzn. nasleduje pocet} Begin WritedBC:=mem[Map.MapBufferRLE:posun]; {muzeme nacist pocet} Inc(posun); For A:=1 to WritedBC do Begin mem[Map.MapBuffer:I]:=WritedBA; {zapisujeme WritedBC krat} Inc(I); End; End else {jsou dva ruzne} Begin mem[Map.MapBuffer:I]:=WritedBA; {zapisme jeden a navrat nahoru} Inc(I); Dec(posun); {posuneme index o jednu nazpet} End; End; {While End} End; Procedure LoadMapFile(soubor: string; pozice: Longint); Var F: File; I: Word; Begin Assign(F,soubor); Reset(F,1); Seek(F,pozice); BlockRead(F,Map.DelkaRLE,2); For I:=0 to Map.DelkaRLE do BlockRead(F,mem[Map.MapBufferRLE:I],1); Close(F); RLEDekompresMap; End; Procedure SetMapByte(MapOffset:Word; bajt:Byte); Assembler; Asm MOV AX, Map.MapBuffer MOV ES, AX MOV DI, MapOffset XOR AX, AX MOV AL, bajt STOSB End; Function GetMapByte(MapOffset: Word): Byte; Assembler; Asm PUSH DS MOV SI, Map.MapBuffer MOV DS, SI MOV SI, MapOffset LODSB {AL:=DS:SI} POP DS End; {SECTION KEYBOARD XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} {$F+} Procedure KeyboardHandler(Flags, CS, IP, AX, BX, CX, DX,SI, DI, DS, ES, BP: Word); Interrupt; Begin PresseDKey:=Port[$60]; If PresseDKey<128 then Key[PresseDKey]:=True; If PresseDKey>128 then Key[PresseDKey-128]:=False; Port[$20]:=$20; End; {$F-} Procedure InitKeyboard; Begin GetIntVec(9, @BIOSKeyboardHandler); SetIntVec(9, Addr(KeyboardHandler)); End; Procedure ShutdownKeyboard; Begin SetIntVec(9, @BIOSKeyboardHandler); End; {SECTION XMS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Function DetekujXms: Word; { Vrati 0, pokud je ovladac XMS nainstalovany.} { zmeni global. prom. xmsAdr, xmsVersion, ovlXmsVersion a hmaDetect} Var vrat:word; Begin asm mov vrat,1 { predpokladame chybu } mov ax,4300h { sluzba 4300h - XMS, zjisti pritomnost XMS} int 2Fh { multiplexni preruseni (preruseni nainstalovanych ovladacu)} cmp al,80h { (pokud mame v al 80h je XMS) } jnz @konec { ...XMS neni, tak skocime na konec... } mov vrat,0 { XMS je!!! } mov ax,4310h { sluzba 4310h, vrat adresu obsluzneho programu } int 2Fh mov word ptr [xmsadr],bx { do xmsAdr si dame adresu kde mame ovladac } mov word ptr [xmsadr+2],es mov ah,00h {vrat stav XMS} call [xmsadr] mov [xmsVersion],ax { verze xms v BCD } mov [ovlXmsVersion],bx { verze ovladace. Opet v BCD } mov [hmaDetect],dx { true/false } @konec: End; DetekujXms:=vrat; End; Procedure GetSizeXms(var celkemXMS,blokXMS: Word); { V celkem vraci celkovou (volnou?) velikost Xms a v blok kolik si maximalne muzeme alokovat pro 1 blok. } { Vetsinou jsou obe velikosti shodne. } Var celkem,blok:word; Begin asm mov ah,08h {zjisti velikost XMS} call [xmsadr] mov [xmsChyba],bl { chyba? } mov [celkem],dx mov [blok],dx end; celkemXMS:=celkem; blokXMS:=blok; End; Function AlokujXms(kolik: Word): Word; { Kolik je v Kb. Vraci handle (rukojet) alokovaneho bloku. } Var vrat:word; Begin Asm mov ah,09h {alokuj XMS} mov dx,[kolik] call [xmsadr] mov [vrat],dx mov [xmsChyba],bl { chyba? } End; AlokujXms:=vrat; End; Procedure UvolniXms(handle: Word); { Vsechny bloky, ktere jsme si alokovali bychom meli uvolnit. } { Jinak budou az do restartu systemu nepouzitelne pro jine aplikace. } Begin Asm mov ah,0ah mov dx,[handle] call [xmsadr] mov [xmsChyba],bl { chyba? } End; End; Procedure MoveToXMS(Handle: Word; XMSOffset: LongInt; Var Source; BlockLength: LongInt); Var ParamBlock: XMSParamBlock; XSeg,PSeg,POfs: Word; Begin XMSchyba:=0; With ParamBlock Do Begin Length:=BlockLength; SHandle:=0; SOffset[1]:=Ofs(Source); SOffset[2]:=Seg(Source); DHandle:=Handle; DOffset[1]:=Word(XMSOffset AND $FFFF); DOffset[2]:=Word(XMSOffset SHR 16); End; PSeg:=Seg(ParamBlock); POfs:=Ofs(ParamBlock); XSeg:=Seg(XMSAdr); Asm Push DS Mov AH,0Bh Mov SI,POfs Mov BX,XSeg Mov ES,BX Mov BX,PSeg Mov DS,BX Call [ES:XMSAdr] Or AX,AX Jne @@1 Mov XMSChyba,BL @@1: Pop DS End; End; Procedure MoveFromXMS(Handle: Word; XMSOffset: LongInt; Var Dest; BlockLength: LongInt); Var ParamBlock: XMSParamBlock; XSeg,PSeg,POfs: Word; Begin XMSChyba:=0; With ParamBlock Do Begin Length:=BlockLength; SHandle:=Handle; SOffset[1]:=Word(XMSOffset AND $FFFF); SOffset[2]:=Word(XMSOffset SHR 16); DHandle:=0; DOffset[1]:=Ofs(Dest); DOffset[2]:=Seg(Dest); End; PSeg:=Seg(ParamBlock); POfs:=Ofs(ParamBlock); XSeg:=Seg(XMSAdr); Asm Push DS Mov AH,0Bh Mov SI,POfs Mov BX,XSeg; Mov ES,BX Mov BX,PSeg Mov DS,BX Call [ES:XMSAdr] Or AX,AX Jne @@1 Mov XMSChyba,BL @@1: Pop DS End; End; {SECTION TIMER XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Procedure Wait(ms: Word); Begin delaycounter:=0; waiting:=True; While delaycounter<ms*8 do Begin End; waiting:=False; delaycounter:=0; End; Procedure Sound(Hertz: Word); Assembler; Asm MOV BX,SP MOV BX,&Hertz MOV AX,34DDh MOV DX,0012h CMP DX,BX JNB @J1 DIV BX MOV BX,AX IN AL,61h TEST AL,03h JNZ @J2 OR AL,03h OUT 61h,AL MOV AL,-4Ah OUT 43h,AL @J2: MOV AL,BL OUT 42h,AL MOV AL,BH OUT 42h,AL @J1: End; Procedure Silence; Assembler; Asm IN AL,61h AND AL,0FCh OUT 61h,AL End; Procedure Stopky_Start; Begin stopky:=0; StopkyTics:=0; StopkyActive:=True; End; Procedure Stopky_Stop; Begin StopkyActive:=False; End; Function Stopky_GetNumber: LongInt; Begin Stopky_GetNumber:=StopkyTics; End; Procedure ClearSPBuffer; Var I: Word; Begin Inline($FA); {CLI} For I:=0 to 32767 do mem[SPBufferSeg:I]:=0; Inline($FB); {STI} End; Procedure TimerHandler; Interrupt; Begin {zpozdovac} If waiting=True then Inc(delaycounter); {je prave jedna milisekunda} {prehravani rawu} If RawHraje then Begin vzorek:=mem[SPBufferSeg:OffsetSpeakeru]; Asm mov al,vzorek shr al,6 and al,2 out 61h,al in al,40h xchg al,ah in al,40h xchg al,ah mov dx,ax End; Inc(Sample[PrehravanyZvuk].Pocitadlo); If Sample[PrehravanyZvuk].Pocitadlo=Sample[PrehravanyZvuk].Delka then Begin RawHraje:=False; ClearSPBuffer; End; If OffsetSpeakeru<32768 then Inc(OffsetSpeakeru) else OffsetSpeakeru:=0; End; {prehravani zvuku} If player=80 then If PrehravatZvuk=True then Begin If memW[SoundDataSeg:memW[ZvukTabSeg:CisloZvuku*4]*2+PosuvZ*2]>0 then Sound(memW[SoundDataSeg:memW[ZvukTabSeg:CisloZvuku*4]*2+PosuvZ*2]) else Sound(10); {Silence;} Inc(PosuvZ); If PosuvZ>memW[ZvukTabSeg:CisloZvuku*4+2] then {prehrali jsme celou delku zvuku} Begin PrehravatZvuk:=False; PosuvZ:=0; Silence; End End; {helper pro vypocet fps kazde 2 sekundy} If player=80 then {je setina vteriny ?} Begin If fps_helper<200 then Inc(fps_helper) else fps_helper:=0; End; {stopky} If StopkyActive=True then Begin If stopky<7 then Begin Inc(stopky); End else Begin stopky:=0; Inc(StopkyTics); End; End; {If Player=80 then: je prave jedna setina vteriny} If player<80 then Inc(player) else player:=0; {volat BIOS obsluhu preruseni ?} clock_ticks:=clock_ticks+counter; If clock_ticks>=$10000 then Begin clock_ticks:=clock_ticks-$10000; asm pushf end; BIOSTimerHandler; End else Port[$20]:=$20; {konec preruseni} End; Procedure InitTimer; Var I: Word; Begin fps_helper:=0; clock_ticks:=0; counter:=$1234DD div 8000; GetIntVec(8,@BIOSTimerHandler); SetIntVec(8,Addr(TimerHandler)); Port[$43]:=$34; Port[$40]:=counter mod 256; Port[$40]:=counter div 256; PrehravatZvuk:=False; GetMem(SoundDataP,4000); SoundDataSeg:=Seg(SoundDataP^); GetMem(ZvukTabP,208); ZvukTabSeg:=Seg(ZvukTabP^); GetMem(SPBuffer,32768); SPBufferSeg:=Seg(SPBuffer^); GetMem(XMSTransfer,32768); XMSTransferSeg:=Seg(XMSTransfer^); For I:=0 to 3999 do mem[SoundDataSeg:I]:=0; {vymaz bufferu} For I:=0 to 207 do mem[ZvukTabSeg:I]:=0; {vymaz bufferu} For I:=0 to 4207 do mem[RLEKompressedSeg:I]:=0; {vymaz bufferu} For I:=0 to 4207 do mem[RLESeg:I]:=0; {vymaz bufferu} For I:=0 to 32767 do mem[SPBufferSeg:I]:=0; {speaker buffer} For I:=0 to 32767 do mem[XMSTransferSeg:I]:=0; {XMS transfer buffer} If DetekujXMS=0 then GetSizeXMS(XMSCelkemPotreba,XMSBlokPotreba); If XMSCelkemPotreba>32 then If XMSBlokPotreba>32 then else Begin WriteLN('XMS ERROR'); End; End; Procedure ShutdownAllXMSBuffers; Var I: Byte; Begin If PocetRawu>0 then For I:=0 to PocetRawu do UvolniXMS(Sample[I].Handle); End; Procedure ShutdownTimer; Begin Port[$43]:=$34; Port[$40]:=0; Port[$40]:=0; SetIntVec(8, @BIOSTimerHandler); PrehravatZvuk:=False; FreeMem(SoundDataP,4000); FreeMem(ZvukTabP,208); FreeMem(SPBuffer,32768); FreeMem(XMSTransfer,32768); ShutdownAllXMSBuffers; End; Procedure MovArrayTo2; {RLE => SoundData a ZvukTab} Var I,A: Word; Begin A:=0; For I:=0 to 1999 do Begin memW[SoundDataSeg:I*2]:=mem[RLESeg:A]; memW[SoundDataSeg:I*2]:=(memW[SoundDataSeg:I*2] SHL 8) OR mem[RLESeg:A+1]; Inc(A,2); End; For I:=0 to 99 do Begin memW[ZvukTabSeg:I*2]:=mem[RLESeg:A]; memW[ZvukTabSeg:I*2]:=(memW[ZvukTabSeg:I*2] SHL 8) OR mem[RLESeg:A+1]; Inc(A,2); End; End; Procedure LoadSNDFile(Filename:String;Pozice:LongInt); Var I: Word; ReadByte: Byte; Begin Assign(F,Filename); Reset(F,1); Seek(F,Pozice); BlockRead(F,RLEdelka,2); {nacist delku} For I:=1 to RLEdelka do Begin BlockRead(F,ReadByte,1); mem[RLEKompressedSeg:I-1]:=ReadByte; End; RLEDekompress; {RLEkompressed => RLE} MovArrayTo2; {RLE => SoundData a ZvukTab} Close(F); End; Procedure LoadRAWFile(filename:String;Pozice:LongInt;N:Byte); {do 32KB} Var F: File; ReadByte: Byte; I,Velikost: Word; Begin Assign(F,filename); Reset(F,1); Seek(F,Pozice); BlockRead(F,Sample[N].Delka,4); For I:=0 to Sample[N].Delka-1 do Begin BlockRead(F,ReadByte,1); mem[XMSTransferSeg:I]:=ReadByte; End; Velikost:=(Sample[N].Delka div 1000)+1; Sample[N].Handle:=AlokujXMS(Velikost); MoveToXMS(Sample[N].Handle,0,mem[XMSTransferSeg:0],Sample[N].Delka); Close(F); Inc(PocetRawu); End; Procedure PlaySound(Sample:Byte); Begin PrehravatZvuk:=True; {sdelime handleru int8 ze chceme prehravat} CisloZvuku:=Sample; {predame ktery zvuk se ma hrat} PosuvZ:=0; {nastavime na zacatek zvuku} Silence; {reproduktor -> TICHO} End; Procedure PlayRaw(Cislo:Byte); Var I: Word; Begin Inline($FA); {CLI} For I:=0 to 32767 do mem[SPBufferSeg:I]:=0; If Odd(Sample[Cislo].Delka) then MoveFromXMS(Sample[Cislo].Handle,0,mem[SPBufferSeg:0],Sample[Cislo].Delka-1) else MoveFromXMS(Sample[Cislo].Handle,0,mem[SPBufferSeg:0],Sample[Cislo].Delka); Sample[Cislo].Pocitadlo:=0; PrehravanyZvuk:=Cislo; OffsetSpeakeru:=0; RawHraje:=True; Inline($FB); {STI} End; Procedure StopPlay; Begin RawHraje:=False; PrehravatZvuk:=False; End; Function FPS2s: Boolean; Begin If fps_helper<100 then FPS2s:=False {false v prvni vterine} else FPS2s:=True; {true ve druhe vterine} End; {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX} Begin End. {klavesy xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} {2} 1 {16} Q {30} A {45} X {1} Esc {59} F1 {72} KeyPadUp {3} 2 {17} W {31} S {46} C {15} TAB {60} F2 {80} KeyPadDown {4} 3 {18} E {32} D {47} V {28} Enter {61} F3 {75} KeyPadleft {5} 4 {19} R {33} F {48} B {14} BackSpace {62} F4 {77} KeyPadRight {6} 5 {20} T {34} G {49} N {57} Space {63} F5 {7} 6 {21} Y {35} H {50} M {64} F6 {71} KeyPadHome {8} 7 {22} U {36} J {12} Minus {65} F7 {79} KeyPadEnd {9} 8 {23} I {37} K {13} Plus {66} F8 {73} KeyPadPgUp {10} 9 {24} O {38} L {53} Lomitko {67} F9 {81} KeyPadPgDn {11} 0 {25} P {44} Z {55} Hvezdicka {68} F10 {82} KeyPadIns {87} F11 {83} KeyPadDel {26} HranataZavorka1 {58} CapsLock {88} F12 {27} HranataZavorka2 {69} NumLock {41} Semicolon {70} ScrollLock {29} LeftControl {39} Strednik {76} KeyPad5 {56} LeftAlt {40} Uvozovka {78} KeyPadPlus {42} LeftShift {51} Carka {74} KeyPadMinus {54} RightShift {52} Tecka {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}