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

    {
     Hello, could somone tell me how to fade a screen out..
    }

    { --------------------------------------------------------------------- }
    { Palette Unit (Text and Graphics modes)                                }
    { Author: Geoff Watts, 27-07-92                                         }
    { Usable Procedures:                                                    }
    {   fadeup    -- fade the palette up                                    }
    {   fadedown  -- fade the palette down                                  }
    {   getpal256 -- fill the parameter Pal With the palette values         }
    {   setpal256 -- fill the palette values With the parameter Pal         }
    {   cpuType   -- determines wether the cpu is 8086/88 or different      }
    { --------------------------------------------------------------------- }

    Unit Palette;
    Interface
    Uses Dos;
    { structure in which the palette inFormation is stored }
    Type
      PaletteType = Array[0..255,1..3] of Byte; { 256 Red/Green/Blue (RGB)    }
    Var
      OlPlt  : PaletteType;                     { internal palette structure  }
                                                { which contains the standard }
                                                { palette                     }
      SetPal256: Procedure (Var Pal : PaletteType); { the Procedure determined    }
                                                    { at run time                 }
    { Forward declarations }
    Procedure SetPal86 (Var Pal : PaletteType);
    Procedure SetPal286 (Var Pal : PaletteType);
    Procedure FadeUp;
    Procedure FadeDown;
    Function  CpuType : Boolean;
    Implementation
    {
        GetPal256:
            Load Pal Structure With the 256 RGB palette
            values.
    }
    Procedure GetPal256 (Var Pal : PaletteType);
    Var
      loope : Word;
    begin
      port[$3C7] := 0;
      { when a read is made on port $3C9 it increment port $3C7 so no changing }
      { of the register port ($3C7) needs to be perFormed here                 }
      For loope := 0 to 255 do
        begin
          Pal[loope,1] := port[$3C9];   { Read red value   }
          Pal[loope,2] := port[$3C9];   { Read green value }
          Pal[loope,3] := port[$3C9];   { Read blue value  }
        end;
    end;
    {
        SetPal86:
            Loads the palette Registers With the values in
            Pal.
        86/88 instructions.
    }
    Procedure SetPal86 (Var Pal : PaletteType);
    begin
      Asm
        push    ds      { preserve segment Registers }
        push    es
        mov cx,256 * 3  { 256 RBG values             }
        mov dx,03DAh
        { by waiting For the retrace to end it avoids static }
        { when the palette is altered                        }
    @retrace1:
        in  al,dx       { wait For no retrace        }
        and al,8        { check For retrace          }
        jnz @retrace1   { so loop Until it goes low  }
    @retrace2:
        in  al,dx       { wait For retrace           }
        and al,8        { check For retrace          }
        jz  @retrace2   { so loop Until it goes high }
        lds si, Pal     { ds:si = @Pal               }
        mov dx,3c8h     { set up For a blitz-white   }
        mov al,0        { from this register         }
        cli             { disable interrupts         }
        out dx,al       { starting register          }
        inc dx          { set up to update DAC       }
        cld             { clear direction flag       }
    @outnext:
        { the following code is what I have found to be the  }
        { most efficient way to emulate the "rep outsb"      }
        { instructions on the 8086/88                       }
        lodsb               { load al With ds:[si]       }
        out dx,al           { out al to port in dx       }
        loop    @outnext    { loop cx times              }
        sti                 { end of critical section    }
        pop es
        pop ds              { restore segment Registers  }
      end;
    end;
    {$G+}       { turn on 286 instruction generation }

    { --------------------------------------------------------------------- }
    { Palette Unit (Text and Graphics modes)                                }
    { --------------------------------------------------------------------- }
    {
        SetPal286:
            Loads the palette Registers With the values in
            Pal.
        286+ instructions.
    }
    Procedure SetPal286 (Var Pal : PaletteType);
    begin
      Asm
        push    ds      { preserve segment Registers }
        push    es
        mov cx,256 * 3  { 256 RBG values             }
        mov dx,03dah
        { by waiting For the retrace to end it avoids static }
        { when the palette is altered                        }
    @retrace1:
        in  al,dx       { wait For no retrace        }
        and al,8        { check For retrace          }
        jnz @retrace1   { so loop Until it goes low  }
    @retrace2:
        in  al,dx       { wait For retrace           }
        and al,8        { check For retrace          }
        jz  @retrace2   { so loop Until it goes high }
        lds si, Pal     { ds:si = @Pal               }
        mov dx,3c8h     { set up For a blitz-white   }
        mov al,0        { from this register         }
        cli             { disable interrupts         }
        out dx,al       { starting register          }
        inc dx          { set up to update DAC       }
        cld             { clear direction flag       }
        rep outsb       { 768 multiple out's         }
                        { rapid update acheived      }
        sti             { end of critical section    }
        pop es
        pop ds          { restore segment Registers  }
      end; { Asm }
    end; { SetPal286 }
    {$G-}               { turn off 286 instructions }
    {
        fadedown:
            fades the palette down With little or no static
    }
    Procedure fadedown;
    Var
      Plt     : PaletteType;
      i, j, k : Integer;
    begin
      plt := olplt;
      For k := 0 to 63 do
        begin
          For j := 0 to 255 do
        For i := 1 to 3 do
              if Plt[j,i] <> 0 then
                dec(Plt[j,i]);      { decrease palette numbers gradually }
          SetPal256(Plt);           { gradually fade down the palette    }
        end;
    end;
    {
        fadeup:
            fades the palette up With little or no static
    }
    Procedure fadeup;
    Var
      Plt     : PaletteType;
      i, j, k : Integer;
    begin
      GetPal256(Plt);           { Load current palette }
      For k := 1 to 63 do
        begin
          For j := 0 to 255 do
            For i := 1 to 3 do
              if Plt[j,i] <> OlPlt[j,i] then
                inc(Plt[j,i]);      { bring palette back to the norm }
            SetPal256(Plt);         { gradually fades up the palette }
                                    { to the normal values           }
        end;
    end;
    {
        CpuType:
            determines cpu Type so that we can use 286 instructions
    }
    Function CpuType : Boolean;
    Var cpu : Byte;
    begin
      Asm
        push sp
        pop  ax
        cmp  sp,ax                  { stack Pointer treated differently on }
        je   @cpu8086               { the 8086 Compared to all others      }
        mov  cpu,0
        jmp  @cpufound
    @cpu8086:
        mov cpu,1
    @cpufound:
      end; { Asm }
      cpuType := (cpu = 1);
    end;
    begin
      { determine the cpu Type so that we can use faster routines }
      if CpuType then
        SetPal256 := SetPal286
      else
        SetPal256 := SetPal86;
      { load the standard palette }
      GetPal256(OlPlt);
    end.

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