[Back to COLOR SWAG index] [Back to Main SWAG index] [Original]
Unit Palette;
Interface
Type
PalType = Array [0..768] of Byte;
Var
FadePal : Array [0..768] of Real;
Fadeend,
FadeStep,
FadeCount,
FadeStart : Byte;
FadeToPal : ^PalType;
DoneFade : Boolean;
Procedure GetPCXPalettePas (PCXBuf,P:Pointer;PalOffset:Word);
Procedure GetPCXPaletteAsm (PCXBuf,P:Pointer;PalOffset:Word);
Procedure WritePalettePas (Start,Finish:Byte;P:Pointer);
Procedure WritePaletteAsm (Start,Finish:Byte;P:Pointer);
Procedure ReadPalettePas (Start,Finish:Byte;P:Pointer);
Procedure ReadPaletteAsm (Start,Finish:Byte;P:Pointer);
Procedure SetupFade (Start,Finish:Byte;P:Pointer;Step:Byte);
Procedure FadePalette;
Procedure Oreo (Start,Finish:Integer);
Implementation
Procedure CLI; Inline ($FA);
Procedure STI; Inline ($FB);
Procedure SetupFade (Start,Finish:Byte;P:Pointer;Step:Byte);
Var
CurPal : Array [0..767] of Byte;
ToPal : ^PalType;
I,PalOfs,
NumColors : Word;
RealStep,
RealToColor,
RealCurColor : Real;
begin
ToPal := Ptr (Seg(P^),Ofs(P^));
ReadPaletteAsm (0,255,@CurPal);
PalOfs := Start * 3;
NumColors := (Finish - Start + 1) * 3;
RealStep := Step;
For I := 0 to NumColors-1 do begin
RealCurColor := CurPal [PalOfs+I];
RealToColor := ToPal^[PalOfs+I];
FadePal [PalOfs+I] := (RealCurColor - RealToColor) / RealStep;
end;
FadeStep := 0;
FadeCount := Step;
FadeStart := Start;
Fadeend := Finish;
FadeToPal := P;
DoneFade := False;
end;
Procedure FadePalette;
Var
I,
PalOfs,
NumColors : Word;
CurPal : Array [0..767] of Byte;
Fact,
RealToColor : Real;
begin
Inc (FadeStep);
Fact := FadeCount - FadeStep;
NumColors := (Fadeend - FadeStart + 1) * 3;
ReadPaletteAsm (0,255,@CurPal);
PalOfs := FadeStart * 3;
For I := 0 to NumColors - 1 do begin
RealToColor := FadeToPal^[PalOfs+I];
CurPal[PalOfs+I] := Round (RealToColor + Fact * FadePal[PalOfs+I]);
end;
WritePaletteAsm (FadeStart,Fadeend,@CurPal);
DoneFade := FadeStep = FadeCount;
end;
Procedure Oreo (Start,Finish:Integer);
Var
I,PalOfs : Word;
CurPal : Array [0..767] of Byte;
Red,
Blue,
Green : Real;
Gray : Byte;
begin
ReadPaletteAsm (0,255,@CurPal);
For I := Start to Finish do begin
PalOfs := I * 3;
Red := CurPal[PalOfs + 0];
Green := CurPal[PalOfs + 1];
Blue := CurPal[PalOfs + 2];
Gray := Round ((0.30 * Red) + (0.59 * Green) + (0.11 * Blue));
CurPal[PalOfs + 0] := Gray;
CurPal[PalOfs + 1] := Gray;
CurPal[PalOfs + 2] := Gray;
end;
WritePaletteAsm (Start,Finish,@CurPal);
end;
Procedure GetPCXPalettePas (PCXBuf,P:Pointer;PalOffset:Word);
Var
I : Word;
InByte : Byte;
begin
PCXBuf := Ptr (Seg(PCXBuf^),Ofs(PCXBuf^)+PalOffset);
For I := 0 to 767 do begin
InByte := Mem [Seg(PCXBuf^):Ofs(PCXBuf^)+I];
InByte := InByte shr 2;
Mem [Seg(P^):Ofs(P^)+I] := InByte;
end;
end;
Procedure WritePalettePas (Start,Finish:Byte;P:Pointer);
Var
I,
NumColors : Word;
InByte : Byte;
begin
P := Ptr (Seg(P^),Ofs(P^)+Start*3);
NumColors := (Finish - Start + 1) * 3;
CLI;
Port [$03C8] := Start;
For I := 0 to NumColors do begin
InByte := Mem [Seg(P^):Ofs(P^)+I];
Port [$03C9] := InByte;
end;
STI;
end;
Procedure ReadPalettePas (Start,Finish:Byte;P:Pointer);
Var
I,
NumColors : Word;
InByte : Byte;
begin
P := Ptr (Seg(P^),Ofs(P^)+Start*3);
NumColors := (Finish - Start + 1) * 3;
CLI;
Port [$03C7] := Start;
For I := 0 to NumColors do begin
InByte := Port [$03C9];
Mem [Seg(P^):Ofs(P^)+I] := InByte;
end;
STI;
end;
Procedure GetPCXPaletteAsm (PCXBuf,P:Pointer;PalOffset:Word);
Assembler;
Asm
push ds
lds si,PCXBuf
mov ax,PalOffset
add si,ax
les di,P
mov cx,768
@@1:
lodsb
shr al,1
shr al,1
stosb
loop @@1
pop ds
end;
Procedure WritePaletteAsm (Start,Finish:Byte;P:Pointer); Assembler;
Asm
push ds
lds si,P
cld
xor bh,bh { P^ points to the beginning of the palette }
mov bl,Start { data. Since we can specify the Start and }
xor ax,ax { Finish color nums, we have to point our }
mov al,Start { Pointer to the Start color. There are 3 }
shl ax,1 { Bytes per color, so the Start color is: }
add ax,bx { Palette Ofs = @P + Start * 3 }
add si,ax { ds:si -> offset in color data }
xor ch,ch { Next, we have to determine how many colors}
mov cl,Finish { we will be updating. This simply is: }
sub cl,Start { NumColors = Finish - Start + 1 }
inc cx
(*
push es
push dx
push ax
xor ax,ax { get address of status register }
mov es,ax { from segment 0 }
mov dx,3BAh { assume monochrome addressing }
test Byte ptr es:[487h],2 { is mono display attached? }
jnz @@11 { yes, address is OK }
mov dx,3DAh { no, must set color addressing }
@@11:
in al,dx { read in status }
jmp @@21
@@21:
test al,08h { is retrace on> (if ON, bit = 1) }
jz @@13 { no, go wait For start }
@@12:
{ yes, wait For it to go off }
in al,dx
jmp @@22
@@22:
test al,08h { is retrace off? }
jnz @@12 { no, keep waiting }
@@13:
in al,dx
jmp @@23
@@23:
test al,08h { is retrace on? }
jz @@13 { no, keep on waiting }
pop ax
pop dx
pop es *)
mov al,Start { We are going to bypass the BIOS routines }
mov dx,03C8h { to update the palette Registers. For the }
out dx,al { smoothest fades, there is no substitute }
cli { turn off interrupts temporarily }
inc dx
@@1:
lodsb { Get the red color Byte }
jmp @@2 { Delay For a few clock cycles }
@@2:
out dx,al { Write the red register directly }
lodsb { Get the green color Byte }
jmp @@3 { Delay For a few clock cycles }
@@3:
out dx,al { Write the green register directly }
lodsb { Get the blue color Byte }
jmp @@4 { Delay For a few clock cycles }
@@4:
out dx,al { Write the blue register directly }
loop @@1
sti { turn interrupts back on }
pop ds
end;
Procedure ReadPaletteAsm (Start,Finish:Byte;P:Pointer); Assembler;
Asm
les di,P
cld
xor bh,bh { P^ points to the beginning of the palette }
mov bl,Start { buffer. We have to calculate where in the}
xor ax,ax { buffer we need to start at. Because each }
mov al,Start { color has three Bytes associated With it }
shl ax,1 { the starting ofs is: }
add ax,bx { Palette Ofs = @P + Start * 3 }
add si,ax { es:di -> offset in color data }
xor ch,ch { Next, we have to determine how many colors}
mov cl,Finish { we will be reading. This simply is: }
sub cl,Start { NumColors = Finish - Start + 1 }
inc cx
mov al,Start { We are going to bypass the BIOS routines }
mov dx,03C7h { to read in from the palette Registers. }
out dx,al { This is the fastest method to do this. }
mov dx,03C9h
cli { turn off interrupts temporarily }
@@1:
in al,dx { Read in the red color Byte }
jmp @@2 { Delay For a few clock cycles }
@@2:
stosb { Store the Byte in the buffer }
in al,dx { Read in the green color Byte }
jmp @@3 { Delay For a few clock cycles }
@@3:
stosb { Store the Byte in the buffer }
in al,dx { Read in the blue color Byte }
jmp @@4 { Delay For a few clock cycles }
@@4:
stosb { Store the Byte in the buffer }
loop @@1
sti { turn interrupts back on }
end;
end.
{
**********************************************
Here's the testing Program
**********************************************
}
Program MCGATest;
Uses
Crt,Dos,MCGALib,Palette;
Var
Stop,
Start : LongInt;
Regs : Registers;
PicBuf,
StorageBuf : Pointer;
FileLength : Word;
Pal,
BlackPal : Array [1..768] of Byte;
Const
NumTimes = 100;
Procedure LoadBuffer (S:String;Buf:Pointer);
Var
F : File;
BlocksRead : Word;
begin
Assign (F,S);
Reset (F,1);
BlockRead (F,Buf^,65000,FileLength);
Close (F);
end;
Procedure Pause;
Var
Ch : Char;
begin
Repeat Until KeyPressed;
While KeyPressed do Ch := ReadKey;
end;
Procedure Control;
begin
SetGraphMode ($13);
LoadBuffer ('E:\NAVAJO.PCX',PicBuf);
GetPCXPaletteAsm (PicBuf,@Pal,FileLength-768);
WritePalettePas (0,255,@Pal);
DisplayPCX (0,0,PicBuf);
FillChar (BlackPal,SizeOf(BlackPal),0);
Pause;
SetupFade (0,255,@BlackPal,20);
Repeat FadePalette Until DoneFade;
Pause;
SetupFade (0,255,@Pal,20);
Repeat FadePalette Until DoneFade;
Pause;
Oreo (0,255);
Pause;
SetupFade (0,255,@Pal,20);
Repeat FadePalette Until DoneFade;
Pause;
end;
Procedure Init;
begin
GetMem (PicBuf,65500);
end;
begin
Init;
Control;
end.
[Back to COLOR SWAG index] [Back to Main SWAG index] [Original]