Бывалый
Профиль
Группа: Участник
Сообщений: 180
Регистрация: 16.7.2003
Где: Россия - Уфа
Репутация: нет
Всего: 1
|
| Код | unit NPCX;
interface
uses NGlob,
Crt,
NGraph;
procedure DisplayPCX (FileName: String);
procedure SetPCXPal (FileName: String);
procedure NormPalette;
type
{ Структура заголовка PCX файла }
TPCXHeader = record
Manuf : Byte; { Всегда = 10 }
Hard : Byte; { Version information }
Cod : Byte; { Run-length encoding (=1) }
BitPrePix : Byte; { Bits per pixel }
X1 : Word; { Picture dimensions (incl) }
Y1 : Word; { }
X2 : Word; { }
Y2 : Word; { }
HorizRes : Word; { Display horiz resolution }
VertRes : Word; { Display vert resolution }
Pal : array[1..48] of Byte; { Pallete }
VMode : Byte; { (ignored) }
NUmbOFPlan : Byte; { Number of planes (ver 2.5=0)}
BytePerLine : Word; { Bytes per line }
Col : Word; { Palette Info (1=col, 2=gray)}
ScanHor : Word; { Scanner resolution }
ScanVer : Word; { }
Extra : array[1..54] of Byte; { Extra space (filler) }
end;
implementation
procedure DisplayPCX (FileName: String);
var
PCXFile: File;
Header: TPCXHeader;
Body: Pointer;
NumRead, ByteCnt,
DispStr, DispByte, CurShift: Word;
Plan, Numb, RealCount: Byte;
Value: Byte;
DataP, CarPtr: ^Byte;
Change: Boolean;
BuffSize, i: Word;
procedure PCXEnd;
begin
Close (PCXFile);
FreeMem (Body, BuffSize);
end;
procedure PCXBegin;
begin
Assign (PCXFile, FileName);
Reset (PCXFile, 1);
BlockRead (PCXFile, Header, SizeOf (TPCXHeader), NumRead);
BuffSize := 10000;
GetMem (Body, BuffSize);
CarPtr := ActBlPtr;
DispByte := 0;
Plan := 0;
DispStr := 0;
end;
procedure UnPack;
begin
if (DataP^ >= $C0) then begin
Numb := DataP^ - $C0;
Inc (LongInt (DataP)); Inc (ByteCnt);
if (ByteCnt >= NumRead) then begin
Seek (PCXFile, FilePos (PCXFile) - 1);
Numb := 0;
end;
Value := DataP^;
Inc (LongInt (DataP)); Inc (ByteCnt);
end
else begin
Numb := 1;
Value := DataP^;
Inc (LongInt (DataP)); Inc (ByteCnt);
end;
end;
procedure ChangePlan;
begin
DispByte := 0;
Inc (Plan);
if (Plan = Header.NumbOfPlan) then begin
Plan := 0;
Inc (DispStr);
Inc (LongInt (CarPtr), Header.HorizRes);
end;
end;
procedure EOLControl;
begin
if (DispByte + Numb < Header.BytePerLine) then begin
RealCount := Numb;
Numb := 0;
Change := False;
end
else begin
RealCount := Header.BytePerLine - DispByte;
Numb := Numb - RealCount;
Change := True;
end;
end;
begin
PCXBegin;
while (NumRead <> 0) do begin
BlockRead (PCXFile, Body^, BuffSize, NumRead);
DataP := Addr (Body^);
ByteCnt := 0;
while (ByteCnt < NumRead) do begin
UnPack;
while (Numb > 0) do begin
EOLControl;
for i:=1 to RealCount do begin
CurShift := DispByte;
asm
les di, CarPtr
add di, CurShift
mov al, Value
mov byte ptr es:[di], al
end;
Inc (DispByte);
end;
if Change then begin
ChangePlan;
if (DispStr = Header.VertRes) then begin
PCXEnd;
Exit;
end;
end;
end;
end;
end;
PCXEnd;
end;
procedure NormPalette;
var
Pal: array [1..768] of Byte absolute Palette;
i: Word;
begin
for i:=1 to 768 do Pal[i] := Pal[i] shr 2;
end;
procedure SetPCXPal (FileName: String);
var
PCXFile: File;
NumRead: Word;
Ident, i: Byte;
begin
Assign (PCXFile, FileName);
Reset (PCXFile, 1);
Seek (PCXFile, FileSize (PCXFile) - 769);
BlockRead (PCXFile, Ident, 1, NumRead);
BlockRead (PCXFile, Palette, 768, NumRead);
Close (PCXFile);
NormPalette;
end;
end.
|
Добавлено @ 02:53 | Код | unit NGlob;
interface
const
{================= Переменные для экрана и блоков =================}
ActBlPtr: Pointer = Ptr ($A000, 0);
ActBX: Word = 320;
ActBY: Word = 200;
VisBlPtr: Pointer = Ptr ($A000, 0);
VisBX: Word = 320;
VisBY: Word = 200;
VBlockNum = 20;
ActBlock: Byte = 1;
VisBlock: Byte = 1;
ActXMin: Word = 0;
ActXMax: Word = 320;
ActYMin: Word = 0;
ActYMax: Word = 200*320;
VisXMin: Word = 0;
VisXMax: Word = 320;
VisYMin: Word = 0;
VisYMax: Word = 200*320;
ScrDelay: LongInt = 0;
{ Переменная для отсчета времени }
OScrTime: LongInt = 0;
type
TRGB = record R, G, B: Byte end;
TVBlock = record
Free: Boolean;
PutX, PutY: Integer;
SizeX, SizeY: Word;
BlPtr: Pointer;
end;
TPtr = record Offs, Segm: Word end;
THead = record X, Y: Word end;
PHead = ^THead;
PWord = ^Word;
PByte = ^Byte;
PPointer = ^Pointer;
TPalette = array [0..255] of TRGB;
var
Palette: TPalette;
VMCount: Byte;
VBlock: array [1..VBlockNum] of TVBlock;
implementation
end. |
Добавлено @ 02:54 | Код | unit NGraph;
interface
uses NGlob,
Dos;
function SetGraph: Boolean;
procedure ClsGraph;
procedure SetRGBColor (Color: Word; R, G, B: Byte);
procedure SetPalette (var Pal);
procedure Line (X1, Y1, X2, Y2: Integer; Color: Byte);
procedure Bar (X1, Y1, X2, Y2: Integer; Color: Byte);
procedure PutPixel (X1, Y1: Integer; Color: Byte);
function GetPixel (X1, Y1: Integer): Byte;
procedure InitBlocks;
procedure GetBlock (var NBlock: Byte; SzX, SzY: Word);
procedure FreeBlock (var NBlock: Byte);
procedure PutBlock (NBlock: Byte);
procedure PutBlockXY (NBlock: Byte; X, Y: Integer);
procedure CutBlock (NBlock: Byte);
procedure CutBlockXY (NBlock: Byte; X, Y: Integer);
procedure FillBlock (NBlock, Color: Byte);
procedure SetActBlock (NBlock: Byte);
procedure TGetMem (var P: Pointer; Size: Word);
procedure ErrMsg (Msg: String);
procedure ScrOFF;
procedure ScrSlowOFF;
procedure ScrON;
procedure ScrSlowON;
procedure Wait;
procedure Sync;
implementation
function SetGraph: Boolean;
label NotVGA;
begin
SetGraph := FALSE;
asm
mov ax, 1A00h
int 10h
cmp al, 1Ah
jne NotVGA
mov bl, 10h
mov ah, 12h
int 10h
mov VMCount, bl
mov ax, 0013h
int 10h
end;
SetGraph := TRUE;
ScrOFF;
NotVGA:
end;
procedure ClsGraph; assembler;
asm
mov ax, 0003h
int 10h
mov ax, 1202h
mov bl, 30h
int 10h
end;
procedure SetRGBColor (Color: Word; R, G, B: Byte); assembler;
asm
mov ax, 1010h
mov bx, Color
mov dh, R
mov ch, G
mov cl, B
int 10h
end;
procedure SetPalette (var Pal); assembler;
asm
mov dx, 3C8h
mov al, 0
out dx, al
push ds
lds si, Pal
mov bx, 2
@@Nxt:
cli
mov dx, 3DAh
@@Wait2:
in al, dx
test al, 08h
jz @@Wait2
mov cx, 128*3
mov dx, 3C9h
@@PalLoop:
lodsb
out dx, al
loop @@PalLoop
dec bx
cmp bx, 0
jne @@Nxt
sti
pop ds
end;
procedure Line (X1, Y1, X2, Y2: Integer; Color: Byte); assembler;
var
DiagYInc, DiagXInc, Diag_count,
StrXInc, StrYInc, StrCount,
ShortDist: Word;
asm
mov cx, 1
mov dx, 1
mov di, Y2
sub di, Y1
jge @@Keep_Y
neg dx
neg di
@@Keep_Y:
mov DiagYInc, dx
mov si, X2
sub si, X1
jge @@Keep_X
neg cx
neg si
@@Keep_X:
mov DiagXInc,cx
cmp si, di
jge @@Horz_seg
mov cx, 0
xchg si, di
jmp @@Save_values
@@Horz_seg:
mov dx, 0
@@Save_values:
mov ShortDist, di
mov StrXInc, cx
mov StrYInc, dx
{Вычисление вы равнивания}
mov ax, ShortDist
shl ax, 1
mov StrCount, ax { SD*2 -> столько раз прямая }
sub ax, si
mov bx, ax { BX - (SD*2-LD) }
sub ax, si
mov Diag_count, ax { (SD-LD)*2 -> столько раз диагональ }
mov cx, X1
mov dx, Y1
inc si { SI - длинная дистанция }
mov es, word ptr ActBlPtr[2]
{ Основной цикл }
@@MainLoop:
dec si
jl @@Done
{ Выводится точка X-CX Y-DX }
cmp cx, ActBX
jae @@Hole
cmp dx, ActBY
jae @@Hole
push dx
mov di, word ptr ActBlPtr
mov ax, ActBX
mul dx
add di, ax
add di, cx
mov al, Color
mov byte ptr es:[di], al
pop dx
@@Hole:
cmp bx, 0
jge @@Diag_line
add cx, StrXInc
add dx, StrYInc
add bx, StrCount
jmp @@MainLoop
@@Diag_line:
add cx, DiagXInc
add dx, DiagYInc
add bx, Diag_count
jmp @@MainLoop
@@Done:
end;
procedure Bar (X1, Y1, X2, Y2: Integer; Color: Byte);
var
XCount, YCount, XInc: Integer;
begin
XCount := X2 - X1;
YCount := Y2 - Y1;
XInc := ActBX - XCount;
asm
les di, ActBlPtr
mov ax, Y1
mov bx, ActBX
mul bx
add ax, X1
add di, ax
mov dx, YCount
@@NxtStr:
mov al, Color
mov cx, XCount
rep stosb
dec dx
add di, XInc
cmp dx, 0
jg @@NxtStr
end;
end;
procedure PutPixel (X1, Y1: Integer; Color: Byte); assembler;
asm
les di, ActBlPtr
mov ax, Y1
mov bx, ActBX
mul bx
add ax, X1
add di, ax
mov al, Color
stosb
end;
function GetPixel (X1, Y1: Integer): Byte; assembler;
asm
les di, ActBlPtr
mov ax, Y1
mov bx, ActBX
mul bx
add ax, X1
add di, ax
mov al, byte ptr es:[di]
end;
procedure InitBlocks;
var
i: Byte;
begin
for i:=1 to VBlockNum do
with VBlock[i] do Free := TRUE;
with VBlock [VisBlock] do begin
Free := FALSE;
SizeX := 320;
SizeY := 200;
BlPtr := VisBlPtr;
end;
SetActBlock (VisBlock);
end;
procedure GetBlock (var NBlock: Byte; SzX, SzY: Word);
var
i: Byte;
Size: Word;
begin
i:=0;
repeat
Inc (i);
until VBlock[i].Free or (i > VBlockNum);
if i > VBlockNum then ErrMsg ('Not enough VBlocks');
NBlock := i;
with VBlock[i] do begin
Free := FALSE;
SizeX := SzX;
SizeY := SzY;
TGetMem (BlPtr, SizeX*SizeY);
end;
end;
procedure FreeBlock (var NBlock: Byte);
begin
with VBlock[NBlock] do begin
FreeMem (BlPtr, SizeX*SizeY);
Free := TRUE;
end;
end;
procedure FillBlock (NBlock, Color: Byte);
var
Count: Word;
DstPtr: Pointer;
begin
with VBlock [NBlock] do begin
Count := SizeX*SizeY;
DstPtr := BlPtr;
end;
asm
les di, DstPtr
mov al, Color
mov ah, al
mov cx, Count
shr cx, 1
rep stosw
end;
end;
procedure PutBlock (NBlock: Byte);
var
Count: Word;
SrcPtr, DstPtr: Pointer;
SzX, SzY, XInc: Word;
begin
with VBlock [NBlock] do begin
SzX := SizeX;
SzY := SizeY;
SrcPtr := BlPtr;
XInc := ActBX - SizeX;
DstPtr := Pointer (LongInt (ActBlPtr) + PutY * ActBX + PutX);
end;
if (SzX=0) or (SzY=0) then Exit;
asm
push ds
les di, DstPtr
lds si, SrcPtr
mov dx, SzY
@@NxtStr:
mov cx, SzX
rep movsb
add di, XInc
dec dx
cmp dx, 0
jg @@NxtStr
pop ds
end;
end;
procedure PutBlockXY (NBlock: Byte; X, Y: Integer);
var
Count: Word;
SrcPtr, DstPtr: Pointer;
SzX, SzY, XInc: Word;
begin
with VBlock [NBlock] do begin
SzX := SizeX;
SzY := SizeY;
SrcPtr := BlPtr;
XInc := ActBX - SzX;
DstPtr := Pointer (LongInt (ActBlPtr) + Y * ActBX + X);
end;
if (SzX=0) or (SzY=0) then Exit;
asm
push ds
les di, DstPtr
lds si, SrcPtr
mov dx, SzY
@@NxtStr:
mov cx, SzX
rep movsb
add di, XInc
dec dx
cmp dx, 0
jg @@NxtStr
pop ds
end;
end;
procedure CutBlock (NBlock: Byte);
var
SrcPtr, DstPtr: Pointer;
SzX, SzY, PX, PY, XInc: Integer;
begin
with VBlock [NBlock] do begin
SzX := SizeX; SzY := SizeY;
DstPtr := BlPtr;
XInc := ActBX - SzX;
SrcPtr := Pointer (LongInt (ActBlPtr) + PutY * ActBX + PutX);
end;
if (SzX=0) or (SzY=0) then Exit;
asm
push ds
les di, DstPtr
lds si, SrcPtr
mov dx, SzY
@@NxtStr:
mov cx, SzX
rep movsb
add si, XInc
dec dx
cmp dx, 0
jg @@NxtStr
pop ds
end;
end;
procedure CutBlockXY (NBlock: Byte; X, Y: Integer);
var
SrcPtr, DstPtr: Pointer;
SzX, SzY, XInc: Word;
begin
with VBlock [NBlock] do begin
SzX := SizeX;
SzY := SizeY;
DstPtr := BlPtr;
XInc := ActBX - SzX;
SrcPtr := Pointer (LongInt (ActBlPtr) + Y * ActBX + X);
end;
if (SzX=0) or (SzY=0) then Exit;
asm
push ds
les di, DstPtr
lds si, SrcPtr
mov dx, SzY
@@NxtStr:
mov cx, SzX
rep movsb
add si, XInc
dec dx
cmp dx, 0
jg @@NxtStr
pop ds
end;
end;
procedure SetActBlock (NBlock: Byte);
begin
ActBlock := NBlock;
with VBlock [ActBlock] do begin
ActBlPtr := BlPtr;
ActBX := SizeX;
ActBY := SizeY;
ActXMin := 0;
ActXMax := ActBX;
ActYMin := TPtr (BlPtr).Offs;
ActYMax := TPtr (BlPtr).Offs + SizeY * ActBX;
end;
end;
procedure TGetMem (var P: Pointer; Size: Word);
var
St: String [11];
TstSize, TstAvail: LongInt;
begin
TstSize := Size;
TstAvail := MaxAvail;
if TstAvail < TstSize then begin
Str (TstSize - TstAvail, St);
ErrMsg ('Not enough memory :' + St + ' Byte');
end;
GetMem (P, Size);
end;
procedure ErrMsg (Msg: String);
begin
ClsGraph;
WriteLn (Msg);
Halt (1);
end;
procedure ScrOFF;
var
TmpPal: array [0..255] of TRGB;
i: Byte;
begin
for i:=0 to 255 do
with TmpPal[i] do begin
R := 0; G := 0; B:=0;
end;
SetPalette (TmpPal);
end;
procedure ScrSlowOFF;
var
TmpPal: array [0..255] of TRGB;
i, j: Byte;
NScrTime: LongInt absolute $0040:$006C;
begin
for j:=64 downto 1 do begin
for i:=0 to 255 do
with TmpPal[i] do begin
R := Palette[i].R * j div 64;
G := Palette[i].G * j div 64;
B := Palette[i].B * j div 64;
end;
repeat until NScrTime - OScrTime > 0;
OScrTime := NScrTime;
SetPalette (TmpPal);
end;
end;
procedure ScrON;
var
TmpPal: array [0..255] of TRGB;
i: Byte;
begin
for i:=0 to 255 do
with TmpPal[i] do begin
R := 0; G := 0; B:=0;
end;
SetPalette (Palette);
end;
procedure ScrSlowON;
var
TmpPal: array [0..255] of TRGB;
i, j: Byte;
NScrTime: LongInt absolute $0040:$006C;
begin
for j:=1 to 64 do begin
for i:=0 to 255 do
with TmpPal[i] do begin
R := Palette[i].R * j div 64;
G := Palette[i].G * j div 64;
B := Palette[i].B * j div 64;
end;
repeat until NScrTime - OScrTime > 0;
OScrTime := NScrTime;
SetPalette (TmpPal);
end;
end;
procedure Wait;
var
NScrTime: LongInt absolute $0040:$006C;
begin
if NScrTime > 5 then
repeat
until NScrTime - OScrTime > ScrDelay;
OScrTime := NScrTime;
end;
procedure Sync; assembler;
asm
mov dx, 3DAh
@@Wait:
in al, dx
test al, 08h
jz @@Wait
end;
end. |
|
Просмотр BMP файла в Паскаль-программах, Это интересно! 
Загрузка ...
Старый добрый ДОС! Поэтому парни помогите. Я сам знаю, что не правильно палитру устанавливаю. Может у кого есть исходник, может кто-то уже что-то писал на эту тему? 
