Posted By: Jovo (Jovo) on 'CZprogram'
Title:     Odpovedi
Date:      Tue Mar 11 18:02:17 1997

Ahoj,
  VGA Paleta : No jestli nevis co je to retrace, tak si sezen pcgpe (zkus pres 
parkera hledat PCGPE10.ZIP, nebo si prolez simtel) tam najdes Asphyxia VGA 
traineers a tam to vsechno je, jinak 

Procedure WaitRetrace; Assembler;
{Thanx goes  to PCGPE}
Asm
    push dx {aby to nerozhazelo registry pri CALLech}
    push ax
    mov   dx,3DAh
@@1:
    in    al,dx
    and   al,08h
    jnz   @@1
@@2:
    in    al,dx
    and   al,08h
    jz    @@2
    pop ax
    pop dx
@@WaitNot:
End;

Operace s VGA Paletou : 
unit palette;
{
Co to je :
----------
    - Unita pro Vetsinu paletovych operaci nad paletou VGA
    - Vsechny casove kriticke operace jsou v ASM
    - povedlo se mi to  , teda az na maly hacek u FadeTo, mozna ho
      nekdy odstranim
Co to dela :
------------
    - meni, cte, zapisuje paletu VGA a dela to taky ruzne efekty
      (linearizace palety, fadind)
Vyrobil :
---------
    - Vyhotoveno : prubezne od ledna 96 az do ted
    - xhovor00@dcse.fee.vutbr.cz , jinak Jovo
    - s pouzitim PCGPE a dalsi vetese ('stuff')
}

interface

  const
        maxcol      = 255; {max pocet barev}
        MaxPalCol   = 63;  {maximalni velikost R/G/B slozky}
        MinPalCol   =  0;  {minimalni velikost R/G/B slozky}
        StartPal    =  1;  {OD ktere bary se bude zapisovat paleta}
        EndPal      =  255;  {DO ktere bary se bude zapisovat paleta}

  type
      tRGB    = array [1..3] of byte;
      TPaleta = array [0..maxcol] of tRGB;

  var RGBBlack,RGBRed,RGBGreen,RGBBlue,RGBWhite,
      RGBYellow,RGBCyan,RGBMangenta:tRGB;
          {cerna,cervena,modra,bila,zluta,Cyan a Mangenta RGB barva,
           no proste vsechny kombinace 00,00,00 x 63,63,63}
      OldSystemPalette : Tpaleta;
        {uschovana puvodni paleta, lze ji obnovit volanim SetOldPal}

{---------------------------}
{Operace nad paletou.}
{Pozn.: je-li v hlavicce DEL - je to DELAY - zpozdeni nejakych kroku}

  procedure SetOldPal;
    {nastavi puvodni paletu (paleta pri spusteni unity GR13h}
  function  GetMax(var pal:Tpaleta):byte;
    {vrati max velikost ze vsech slozek RGB}
  procedure ReadPal (var pal : Tpaleta);
  procedure WritePal (var pal : Tpaleta);
    {cteni a zapis palety}
  procedure ReadCol(ColNum:byte;var RGB:tRgb);
  procedure WriteCol(ColNum:byte;var RGB:tRgb);
    {precteni a zapis jedine barvy (jeji cislo je ColNum)}
  procedure DecPal(var Pal:Tpaleta);
    {snizi vsechny hodnoty v palete o 1. Zadna ze slosek RGB nepodtece to 0}
  procedure IncPal(Var Pal1,Pal2:Tpaleta);
    {provede 'fadeing' z prvni palety do druhe. Nevsima si overscanu.}
  procedure FadeOut(del:word);
    {FADE TO BLACK - blba hra , ale tohle je dobry efekt}
  procedure FadeTo(var pal2:Tpaleta;del:word);
    {Prechazi ze stavajici palety na barvy palety PAL2}
  procedure CycleDown(var pal:Tpaleta);
  procedure Cycleup(var pal:Tpaleta);
    {Protoci paletu dolu nebo nahoru. Obe operace zachovaji Overscan}
  procedure LinearPal(Rs,Re,Gs,Ge,Bs,Be:byte; Var Pal:Tpaleta);
    {vyrobi linearni paletu. Xs - pocatecni
                             Xe - koncova sytost barvy
                             pro R,G,B}
  Procedure LinearPalWhite( Var Pal:Tpaleta);
    {vyrobi bilou linearni paletu}
  Procedure LinearPalBlack( Var Pal:Tpaleta);
    {vyrobi cernou linearni paletu :) }
  Procedure LinearPalRed( Var Pal:Tpaleta);
    {vyrobi cervenou linearni paletu}
  Procedure LinearPalGreen( Var Pal:Tpaleta);
    {vyrobi zelenou linearni paletu}
  Procedure LinearPalBlue( Var Pal:Tpaleta);
    {vyrobi modrou linearni paletu}
  Procedure LinearPalYellow( Var Pal:Tpaleta);
    {vyrobi zlutou linearni paletu}
  Procedure LinearPalCyan( Var Pal:Tpaleta);
    {vyrobi svetle modrou linearni paletu}
  Procedure LinearPalMangenta( Var Pal:Tpaleta);
    {vyrobi fialovou linearni paletu}
  Procedure FillPal(var Pal:Tpaleta;var RGB:tRGB);
    {vyplni paletu o STARTPAL do ENDPAL barvou definovanou v RGB}

implementation
uses crt;{huh , to jen kvuli pouziti DELAY(word);}

Procedure WaitRetrace; Assembler;
{Thanx goes  to PCGPE}
Asm
    push dx {aby to nerozhazelo registry pri CALLech}
    push ax
    mov   dx,3DAh
@@1:
    in    al,dx
    and   al,08h
    jnz   @@1
@@2:
    in    al,dx
    and   al,08h
    jz    @@2
    pop ax
    pop dx
@@WaitNot:
End;

Procedure WriteCol(ColNum:byte;var RGB:tRgb);
  { This sets the Red, Green and Blue values of a certain color }
assembler;
   asm
      mov bx,ds
        mov    dx,3c8h
        mov    al,[colNum]
        out    dx,al
        inc    dx
        lds    si,RGB
        mov    cx,3
    rep outsb

      mov ds,bx
   end;

procedure WriteColOld2(ColNum:byte;var RGB:tRgb);
{predpoklada, ze byla provedena funkce SchovejPaletuVGA}
begin
  Port[$3c8] := ColNum;
  Port[$3c9] := RGB[1];
  Port[$3c9] := RGB[2];
  Port[$3c9] := RGB[3];
end;


Procedure ReadCol(ColNum:byte;var RGB:tRgb);
  { This sets the Red, Green and Blue values of a certain color }
assembler;
   asm
        mov    dx,3c7h
        mov    al,[colNum]
        out    dx,al
        inc    dx
        inc    dx
        les    di,RGB
        mov    cx,3
    rep insb

   end;

procedure ReadColOld2(ColNum:byte;var RGB:tRgb);
begin
  Port[$3c7] := ColNum;
  RGB[1] := Port[$3c9];
  RGB[2] := Port[$3c9];
  RGB[3] := Port[$3c9];
end;

procedure WritePal (var Pal : Tpaleta);
assembler;
   asm
      mov bx,ds {pekna nahrada pushnuti, ne<}
        mov    dx,3c8h
        mov    ax,StartPal
        out    dx,al
        inc    dx
        lds    si,Pal
        add    si,3*StartPal
        mov    cx,3*(EndPal-StartPal+1)

        call WaitRetrace
    rep outsb

      mov ds,bx
   end;

procedure WritePalOld2 (var pal : Tpaleta);
var i:integer;
begin;
  waitretrace;
  for i:=StartPal to EndPal div 2 do
    WriteCol(i,pal[i]);
  waitretrace;
  for i:=EndPal div 2+1 to EndPal do
    WriteCol(i,pal[i]);
end;

procedure ReadPal (var Pal : Tpaleta);
assembler;
   asm
        mov    dx,3c8h
        mov    ax,StartPal
        out    dx,al
        inc    dx
        les    di,Pal
        add    di,3*StartPal
        mov    cx,3*(EndPal-StartPal+1)

        call WaitRetrace
    rep insb

   end;


procedure ReadPalOld2 (var pal : Tpaleta);
var i:integer;
begin;
  for i:=StartPal to EndPal do
    ReadCol(i,pal[i]);
end;

procedure LinearPal(Rs,Re,Gs,Ge,Bs,Be:byte; Var Pal:Tpaleta);
var i:integer;
begin;
    for i:=0 to maxcol do
        begin;
          pal[i,1]:= Trunc ( i * (Re - Rs) / MaxCol + Rs) ;
          pal[i,2]:= Trunc ( i * (Ge - Gs) / MaxCol + Gs) ;
          pal[i,3]:= Trunc ( i * (Be - Bs) / MaxCol + Bs) ;
        end;
end;
{!!}
Procedure LinearPalWhite( Var Pal:Tpaleta);
begin;
  LinearPal(0,MaxPalCol,0,MaxPalCol,0,MaxPalCol,pal);
end;

Procedure LinearPalBlack( Var Pal:Tpaleta);
begin;
  LinearPal(0,0,0,0,0,0,pal);
end;

Procedure LinearPalRed( Var Pal:Tpaleta);
begin;
  LinearPal(0,MaxPalCol,0,0,0,0,pal);
end;

Procedure LinearPalGreen( Var Pal:Tpaleta);
begin;
  LinearPal(0,0,0,MaxPalCol,0,0,pal);
end;

Procedure LinearPalBlue( Var Pal:Tpaleta);
begin;
  LinearPal(0,0,0,0,0,MaxPalCol,pal);
end;

Procedure LinearPalYellow( Var Pal:Tpaleta);
begin;
  LinearPal(0,63,0,63,0,0,Pal);
end;

Procedure LinearPalCyan( Var Pal:Tpaleta);
begin;
    LinearPal(0,0,0,63,0,63,Pal);
end;

Procedure LinearPalMangenta( Var Pal:Tpaleta);
begin;
    LinearPal(0,63,0,0,0,63,Pal);
end;


Procedure FillPal(var Pal:Tpaleta;var RGB:tRGB);
var i:integer;
begin;
  for i:=StartPal to EndPal do pal[i]:=RGB;
end;

procedure SetOldPal;
begin;
  WritePal(OldSystemPalette);
end;

function GetMax(var pal:Tpaleta):byte;
{zjisti maximalni velikost vsech barevnych slozek}
assembler;
asm
    push ds
    lds si,pal
    xor bx,bx
    xor cx,cx
  @@dalsi:
    cmp bx,maxcol
    je @@konec
    inc cx
    cmp cx,(maxcol+1)*3
    je @@konec
    lodsb
    cmp bl,al
    jae @@dalsi
      mov bl,al
    jmp @@dalsi
  @@konec:
    xor ax,ax
    mov al,bl
    pop ds
end;





procedure CycleDown(var pal:Tpaleta);
{shodi paletu o jednu barvu dolu. Zachovava Overscan(barva[0])}
assembler;
var ovRGB,RGB:tRGB;
asm
    mov bx,ds {push ds}
    cld
    lds si,pal

    {les di,ovRGB{uschovani overscanu}
    mov ax,seg ovRGB
    mov es,ax
    mov di,offset ovRGB
    mov cx,3
    rep movsb

    {les di,rgb{uschovani prvni barvy}
    mov ax,seg RGB
    mov es,ax
    mov di,offset RGB
    mov cx,3
    rep movsb



    les di,pal
    add di,3
    mov cx,(maxcol-1)*3
    rep movsb

    {lds si,RGB{zapis posledni barvy}
    mov ax,seg RGB
    mov ds,ax
    mov si,offset RGB
    mov cx,3
    rep movsb

    les di,pal

    {lds si,ovRGB{zapis puvodniho overscanu}
    mov ax,seg ovRGB
    mov ds,ax
    mov si,offset ovRGB
    mov cx,3
    rep movsb


    mov ds,bx{pop ds}
end;

procedure CycleUp(var pal:Tpaleta);
{prida  o jednu barvu nahoru. Zachovava Overscan(barva[0])}
assembler;
var ovRGB,RGB:tRGB;
asm
    mov bx,ds{push ds}
    cld
    lds si,pal
    {les di,ovRGB{uschovani overscanu}
    mov ax,seg ovRGB
    mov es,ax
    mov di,offset ovRGB
    mov cx,3
    rep movsb

    {les di,rgb{uschovani posledni barvy}
    lds si,pal
    add si,(256-1)*3
    mov ax,seg RGB
    mov es,ax
    mov di,offset RGB
    mov cx,3
    rep movsb

    les di,pal
    lds si,pal
    add si,(256-1)*3
    add di,(256)*3
    mov cx,255*3
    std                 {ufffff, nez jsem na to prisel}
    rep movsb

    cld
    les di,pal
    {lds si,ovRGB{zapis puvodniho overscanu}
    mov ax,seg ovRGB
    mov ds,ax
    mov si,offset ovRGB
    mov cx,3
    rep movsb

    les di,pal
    add di,3
    {lds si,RGB{zapis prvni barvy}
    mov ax,seg RGB
    mov ds,ax
    mov si,offset RGB
    mov cx,3
    rep movsb
    mov ds,bx{pop ds}
end;

procedure DecPal(var Pal:Tpaleta);
{snizi vsechny hodnoty v palete o 1. Nepodtece to 0}
{tak tady me Jusoft poblil , eeeeh , pobil :)}
assembler;
asm
       mov bx,ds{push ds}
       mov cx,256*3
       les di,pal
       lds si,pal
@@zmensuj:
       mov di,si
       lodsb
       cmp al,0
       je @@OK         {hruza , co ?}

       dec al
       stosb
@@OK:
       loop @@zmensuj
       mov ds,bx{pop  ds}

(*
{Jusoft wrote: Zkusim to trosku jinac}
{jo a obcas to havaruje :) }
    push ds
    mov  cx,256*3
    mov  di,OFFSET pal
@@zmensuj:
    cmp  Byte Ptr [di],0
    je   @@Ok
    dec  Byte Ptr [di]
@@Ok:
    inc  di
    loop @@zmensuj
    pop  ds

*)

end;




procedure FadeOut(del:word);
{  :-)   }
var pal:Tpaleta;
    max,i:byte;
begin;
  ReadPal(pal);
  max:=GetMax(pal);
  for i:=0 to max  do
    begin;
      DecPal(pal);
      WritePal(pal);
      delay(del);
    end;
end;

procedure IncPal(Var Pal1,Pal2:Tpaleta);
{provede 'fadeing' z prvni palety do druhe. Nevsima si overscanu.}
var j,k:byte;
begin;
  for j:=1 to 255 do
    for k:=1 to 3 do
      if pal1[j,k]<pal2[j,k] then inc(pal1[j,k])
      else if pal1[j,k]>pal2[j,k] then dec(pal1[j,k]);
end;

procedure FadeTo(var pal2:Tpaleta;del:word);
{provede fading z puvodni palety do druhe. Stavajici paleta bude znicena
 (prepsana pal2)  :) }
var i,j,k:byte;
    pal1:Tpaleta;
begin;
  ReadPal(pal1);
  for i:=0 to GetMax(pal2) do
    begin;
      IncPal(pal1,pal2);
      WritePal(pal1);
      delay(del);
    end;
  writepal(pal2);
end;



begin;
  RGBBlack [1] := MinPalCol; RGBBlack[2] := MinPalCol; RGBBlack[3] := 
MinPalCol;
  RGBWhite [1] := maxPalCol; RGBWhite[2] := maxPalCol; RGBWhite[3] := 
maxPalCol;

  RGBRed   [1] := maxPalCol; RGBRed  [2] := MinPalCol; RGBRed  [3] := 
MinPalCol;
  RGBGreen [1] := MinPalCol; RGBGreen[2] := maxPalCol; RGBGreen[3] := 
MinPalCol;
  RGBBlue  [1] := MinPalCol; RGBBlue [2] := MinPalCol; RGBBlue [3] := 
maxPalCol;

  RGBYellow   [1] := maxPalCol; RGBWhite[2] := maxPalCol; RGBWhite[3] := 
minPalCol;
  RGBCyan     [1] := minPalCol; RGBWhite[2] := maxPalCol; RGBWhite[3] := 
maxPalCol;
  RGBMangenta [1] := maxPalCol; RGBWhite[2] := minPalCol; RGBWhite[3] := 
maxPalCol;

  ReadPal(OldSystemPalette);
  writeln('pouzita UNITa : ''PALETTE''');
end.

Hele nemlatte me : tenhle kod docela funguje a vo co jde ? :)






ODPOVED 2 :
  fonty v protectu pod BP 7.0 ?  Proc ne, ale ja mam dojem, ze (zatim mi 
stacil zakladni bitmapak 8x8) chyba bude nejspis v .BGIcku. Hm, nemohl bys 
rict, kde ti to krachne ?


Jovo.

PS: Sorry za takovou dylku, ale taky jsem byl zacatecnik (a ted ses teda co, 
bracho ? :)  a podobne posty mi dooooost pomohly. Kdyby to nekdo chtel trosku 
povysvetlovat, rad odpovim, ale nejlepe na :
xhovor00@stud.fee.vutbr.cz
OK ?