[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]