[Back to COLOR SWAG index] [Back to Main SWAG index] [Original]

    Unit palette;
    {$O+}
    Interface

    Uses Dos,Crt;

    Procedure Set_palette(slot:Word; sred,sgreen,sblue : Byte);
    Procedure Get_palette(Var slot,gred,ggreen,gblue : Byte);
    Procedure fade_in(dly : Word ; dvsr : Byte);   {Delay (ms),divisor (10-64)}
    Procedure fade_out(dly : Word ; dvsr : Byte);
    Procedure restore_palette;
    Procedure swap_color(first,last:Byte);
    Function VGASystem: Boolean;
    Procedure remap;
    Procedure restoremap;

    Const
      sl     : Array[0..15] of Byte =(0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);
      v_red  : Array[0..15] of Byte =(0,0,0,0,42,42,42,42,21,21,21,21,63,63,63,63);
      v_green: Array[0..15] of Byte =(0,0,42,42,0,0,21,42,21,21,63,63,21,21,63,63);
      v_blue : Array[0..15] of Byte =(0,42,0,42,0,42,0,42,21,63,21,63,21,63,21,63);

    Var
      s_red, s_green, s_blue : Array[0..15] of Real;

    Implementation

    Procedure disable_refresh;
    Var
      regs : Registers;
    begin
      With regs do
      begin
        AH:=$12;
        BL:=$36;
        AL:=$01;
      end;
      Intr($10,regs);
    end;

    Procedure enable_refresh;
    Var
      regs : Registers;
    begin
      With regs do
      begin
        AH:=$12;
        BL:=$36;
        AL:=$00;
      end;
      Intr($10,regs);
    end;

    Function VGASystem: Boolean;
    {}
    Var  Regs : Registers;
    begin
      With Regs do
      begin
        Ax := $1C00;
        Cx := 7;
        Intr($10,Regs);
        If Al = $1C then  {VGA}
        begin
          VGASystem := True;
          Exit;
        end;
        Ax := $1200;
        Bl := $32;
        Intr($10,Regs);
        If Al = $12 then {MCGA}
        begin
          VGASystem := True;
          Exit;
        end;
      end; {with}
    end; {of func NoSnowSystem}

    Procedure remap;
    Var
      regs : Registers;
      idx  : Byte;
    begin
      if VGASystem then
      begin
        With regs do
        begin
          AL:=0;
          AH:=11;
        end;
        For idx:=0 to 15 do
        begin
          regs.BH:=idx;
          regs.BL:=idx;
          Intr($10,Regs);
        end;
      end;
    end;

    Procedure restoremap;
    Var
      regs : Registers;
      idx  : Byte;
    begin
      if VGASystem then
      begin
        With regs do
        begin
          AL:=0;
          AH:=11;
        end;
        For idx:=0 to 15 do
        begin
          regs.BH:=sl[idx];
          regs.BL:=idx;
          Intr($10,Regs);
        end;
      end;
    end;

    Procedure Set_palette(slot:Word; sred,sgreen,sblue : Byte);
    Var
      regs : Registers;
    begin
      With regs do
      begin
        AL:=$10;
        AH:=$10;
        BX:=slot;
        DH:=sred;
        CH:=sgreen;
        CL:=sblue;
      end;
      Intr($10,Regs);
    end;

    Procedure Get_palette(Var slot,gred,ggreen,gblue : Byte);
    Var
      regs : Registers;
    begin
      With regs do
      begin
        AL:=21;
        AH:=16;
        BX:=slot;
      end;
      Intr($10,Regs);
      With regs do
      begin
        gred:=DH;
        ggreen:=CH;
        gblue:=CL;
      end;
    end;

    Procedure restore_palette;
    Var index:Byte;
    begin
      For index:=0 to 15 do
          set_palette(sl[index],v_red[index],v_green[index],v_blue[index]);
    end;
    Procedure fade_out(dly : Word ; dvsr : Byte);
    Var index,idx : Byte;
    begin
      For index:=0 to 15 do
      begin
        s_red[index]:=v_red[index];
        s_green[index]:=v_green[index];
        s_blue[index]:=v_blue[index];
      end;
      For idx:=1 to dvsr do
      begin
        For index:=0 to 15 do
        begin
          set_palette(sl[index],trunc(s_red[index]),trunc(s_green[index]),trunc(s_blue[index]));
          s_red[index]:=s_red[index]-(v_red[index]/dvsr);
          s_green[index]:=s_green[index]-(v_green[index]/dvsr);
          s_blue[index]:=s_blue[index]-(v_blue[index]/dvsr);
        end;
        Delay(dly)
      end;
    end;

    Procedure fade_in(dly : Word ; dvsr : Byte);
    Var index,idx2:Byte;
    begin
      FillChar(s_red,Sizeof(S_red),#0);
      FillChar(s_green,Sizeof(S_green),#0);
      FillChar(s_blue,Sizeof(s_blue),#0);
      For idx2:=1 to dvsr do
      begin
        For index:=0 to 15 do
        begin
          set_palette(sl[index],trunc(s_red[index]),trunc(s_green[index]),trunc(s_blue[index]));
          s_red[index]:=s_red[index]+(v_red[index]/dvsr);
          s_green[index]:=s_green[index]+(v_green[index]/dvsr);
          s_blue[index]:=s_blue[index]+(v_blue[index]/dvsr);
        end;
      Delay(dly);
      end;
    end;

    Procedure swap_color(first,last:Byte);
    Var f1,f2,f3,l1,l2,l3:Byte;
    begin
      Get_Palette(sl[first],f1,f2,f3);
      Get_Palette(sl[last],l1,l2,l3);
      Set_Palette(sl[first],l1,l2,l3);
      Set_Palette(sl[last],f1,f2,f3);
    end;

    begin
      restoremap;
    end.

[Back to COLOR SWAG index] [Back to Main SWAG index] [Original]