Celestin Apprentice 4/Apprentice-Release4.iso/Source Code/Pascal/Snippets/GammaFade/GammaPaslib.p

Text File | 1995-08-06 | 11.7 KB | 435 lines | [TEXT/MWPS]

Unit GammaPaslib;

{--------------------------------------------------------------------------------------------------------------- }
{ File "gamma.p" - Source for Altering the Gamma Tables of GDevices from Gamma.c                                 }
{   Last updated 6/29/95, MJS                                                                                     }
{--------------------------------------------------------------------------------------------------------------- }
{    7-13-95    ported to pascal  by Matthew Xavier Mora [e-mail]                                         }
{     7-18-95     fixed all the porting bugs and got it to work in think pascal                                     }
{----------------------------------------------------------------------------------------------------------------}
{     7-18-95 ported to CW (68k and PPC) by Bill Catambay (pretty easy), cleaned the code a bit (no more labels),     }
{           brought back Matthew's delay fade routines (in main program).                                             }
{----------------------------------------------------------------------------------------------------------------}



{---------------------------------------------------------------------------------------------------------------}
{    This is the Source Code for the Gamma Utils Library file. Use this to build                                    }
{        new functionality into the library or make an A4-based library.                                         }
{    See the header file "gamma.h" for much more information. -- MJS                                                }
{---------------------------------------------------------------------------------------------------------------}
Interface

Uses
    Traps, Video, ToolUtils, Devices;

Const
    kGammaUtilsSig = 'GAMA';
    kGetDeviceListTrapNum = $AA29;

Type
    globalGammasPtr = ^globalGammas;
    globalGammasHdl = ^globalGammasPtr;
    globalGammas = record
        size, dataOffset: Integer;
        saved, hacked: GammaTblHandle;
        theGDevice: GDHandle;
        next: globalGammasHdl;
        end;
    gammaData = packed array[0..100000] of Byte;  {used to set the gamma}
    gammaDataPtr = ^gammaData;

Var
    gammaUtilsInstalled: OSType;
    gammaTables: globalGammasHdl;
    gammaFaded: boolean;

{ Function Prototypes}

{    These routines help you determine whether you can use the Gamma Table Utils}
{        on the current machine. The first checks all attached monitors, and the }
{        second just checks the indicated monitor. Each returns TRUE if you can }
{        use the functions, or FALSE if you can't. • Note: Before calling any other}
{        Gamma Table function below, use this function to see if you are allowed.}

{ * ****************************************************************************** *}
Function IsGammaAvailable: Boolean;
Function IsOneGammaAvailable (theGDevice: GDHandle): Boolean;


{    These routines must bracket any calls to the Gamma Table functions, perhaps}
{        at the head and tail of your main(). The first sets up the data structures}
{        necessary to save and restore the state of your monitors. The second}
{        disposes of all the internal data structures, but does not reset the}
{        monitors to their original states. Both return the error code if some}
{        part failed. }

{ * ****************************************************************************** *}
Function SetupGammaTools: OSErr;
Function DisposeGammaTools: OSErr;

{    Use the first function to Fade each of your monitors to some percentage of their}
{        initial brightness (100 = bright, 0 = dim). Repeatedly call this to ramp your}
{        monitors up or down. The second function performs the same function, but only}
{        for the specified monitor. Both return any applicable error codes.}
{    Be sure to set up the necessary save-state data structures before you start by}
{        calling the compatibility and initialization functions. }

{ * ****************************************************************************** *}
Function DoGammaFade (percent: Integer): OSErr;
Function DoOneGammaFade (theGDevice: GDHandle;
                               percent: Integer): OSErr;


{    These routines are low-level interfaces to the device drivers for the monitors.}
{        Use them at your own risk.}
Function GetDevGammaTable (theGDevice: GDHandle;
                              Var theTable: GammaTblPtr): OSErr;
Function SetDevGammaTable (theGDevice: GDHandle;
                               Var theTable: GammaTblPtr): OSErr;


Procedure DelayFadeToBlack (delayTicks: longint);
Procedure FadeToBlack (speed: integer);
Procedure FadeFromBlack (speed: integer);
Procedure DelayFadeFromBlack (delayTicks: longint);


Implementation

Function IsGammaAvailable: Boolean;

Var
   theGDevice: GDHandle;

    Begin
    IsGammaAvailable := false;
    If (NGetTrapAddress(kGetDeviceListTrapNum, ToolTrap) =
        NGetTrapAddress(_Unimplemented, ToolTrap)) Then
          exit(IsGammaAvailable);
    theGDevice := GetDeviceList;
    While (theGDevice <> Nil) Do
        Begin
        If (TestDeviceAttribute(theGDevice, screenDevice) And
            TestDeviceAttribute(theGDevice, noDriver)) Then
            exit(IsGammaAvailable);
        If (theGDevice^^.gdType = fixedType) Then
            exit(IsGammaAvailable);
        theGDevice := GetNextDevice(theGDevice);
        End;
    IsGammaAvailable := true; {If we made it this far then its true}
    End;


Function IsOneGammaAvailable (theGDevice: GDHandle): Boolean;

    Begin
    IsOneGammaAvailable := false;
    If (NGetTrapAddress(kGetDeviceListTrapNum, ToolTrap) =
        NGetTrapAddress(_Unimplemented, ToolTrap)) Then
          exit(IsOneGammaAvailable);
    If (TestDeviceAttribute(theGDevice, screenDevice) And
        TestDeviceAttribute(theGDevice, noDriver)) Then
          exit(IsOneGammaAvailable);
    If (theGDevice^^.gdType = fixedType) Then
          exit(IsOneGammaAvailable);
    IsOneGammaAvailable := true;
    End;


Function SetupGammaTools: OSErr;

Var
   errorCold: Integer;
   tempHdl: globalGammasHdl;
   masterGTable: GammaTblPtr;
   theGDevice: GDHandle;

    Begin
    If (gammaUtilsInstalled = kGammaUtilsSig) Then
        Begin
        SetupGammaTools := -1;
        exit(SetupGammaTools);
        End;
    gammaTables := Nil;
    gammaUtilsInstalled := kGammaUtilsSig;
    gammaFaded := FALSE;
    theGDevice := GetDeviceList;
    While (theGDevice <> Nil) Do
        Begin
        errorCold := GetDevGammaTable(theGDevice, masterGTable);
        If (errorCold <> 0) Then
            Begin
            SetupGammaTools := errorCold;
            exit(SetupGammaTools);
            End;
        tempHdl := globalGammasHdl(NewHandle(sizeof(globalGammas)));
        If (tempHdl = Nil) Then
            Begin
            SetupGammaTools := MemError;
            exit(SetupGammaTools);
            End;
        With masterGTable^ Do
            Begin
            tempHdl^^.size := sizeof(GammaTbl) + gFormulaSize + (gChanCnt * gDataCnt * gDataWidth Div 8);
            tempHdl^^.dataOffset := gFormulaSize;
            tempHdl^^.theGDevice := theGDevice;
            End;
        tempHdl^^.saved := GammaTblHandle(NewHandle(tempHdl^^.size));
        If (tempHdl^^.saved = Nil) Then
            Begin
            SetupGammaTools := MemError;
            exit(SetupGammaTools);
            End;
        tempHdl^^.hacked := GammaTblHandle(NewHandle(tempHdl^^.size));
        If (tempHdl^^.hacked = Nil) Then
            Begin
            SetupGammaTools := MemError;
            exit(SetupGammaTools);
            End;
        BlockMove(Ptr(masterGTable), Ptr(tempHdl^^.saved^), tempHdl^^.size);
        tempHdl^^.next := gammaTables;
        gammaTables := tempHdl;
        theGDevice := GetNextDevice(theGDevice)
        End;
    SetupGammaTools := 0;
    End;

Function DoGammaFade (percent: Integer): OSErr;

Var
   errorCold: Integer;
   thesize, i, theNum: LongInt;
   tempHdl: globalGammasHdl;
   gdp: gammaDataPtr;
   tempLong: Longint;

    Begin
    If (gammaUtilsInstalled <> kGammaUtilsSig) Then
        Begin
        DoGammaFade := -1;
        exit(DoGammaFade);
        End;
    tempHdl := gammaTables;
    While (tempHdl <> Nil) Do
        Begin
        With tempHdl^^ Do
            Begin
            BlockMove(Ptr(saved^), Ptr(hacked^), size);
            tempLong := ord(@hacked^^.gFormulaData) + dataOffset;
            gdp := gammaDataPtr(ord(@hacked^^.gFormulaData) + dataOffset);
            thesize := hacked^^.gChanCnt * hacked^^.gDataCnt;
            End;
        For i := 0 To thesize - 1 Do
            Begin
            theNum := gdp^[i];
            theNum := (theNum * percent) Div 100;
            gdp^[i] := theNum;
            End;
        errorCold := SetDevGammaTable(tempHdl^^.theGDevice, tempHdl^^.hacked^);
        If (errorCold <> 0) Then
            Begin
            DoGammaFade := errorCold;
            exit(DoGammaFade);
            End;
        tempHdl := tempHdl^^.next;
        End;
    DoGammaFade := 0;
    End;

Function DoOneGammaFade (theGDevice: GDHandle;
                           percent: Integer): OSErr;

Var
   errorCold: Integer;
   thesize, i, theNum: LongInt;
   tempHdl: globalGammasHdl;
   gdp: gammaDataPtr;

    Begin
    If (gammaUtilsInstalled <> kGammaUtilsSig) Then
        DoOneGammaFade := -1;
    tempHdl := gammaTables;
    While ((tempHdl <> Nil) And (theGDevice <> tempHdl^^.theGDevice)) Do
        tempHdl := tempHdl^^.next;
    With tempHdl^^ Do
        Begin
        BlockMove(Ptr(saved^), Ptr(hacked^), size);
        gdp := gammaDataPtr(ord(@hacked^^.gFormulaData) + dataOffset);
        thesize := hacked^^.gChanCnt * hacked^^.gDataCnt;
        End;
    For i := 0 To thesize - 1 Do
        Begin
        theNum := gdp^[i];
        theNum := (theNum * percent) Div 100;
        gdp^[i] := theNum;
        End;
    errorCold := SetDevGammaTable(tempHdl^^.theGDevice, tempHdl^^.hacked^);
    DoOneGammaFade := errorCold;
    End;

Function DisposeGammaTools: OSErr;

Var
   tempHdl, nextHdl: globalGammasHdl;

    Begin
    If (gammaUtilsInstalled <> kGammaUtilsSig) Then
        Begin
        DisposeGammaTools := -1;
        exit(DisposeGammaTools);
        End;
    tempHdl := gammaTables;
    While (tempHdl <> Nil) Do
        Begin
        HLock(Handle(tempHdl));
        With tempHdl^^ Do
            Begin
            nextHdl := next;
            DisposeHandle(Handle(saved));
            DisposeHandle(Handle(hacked));
            HUnLock(Handle(tempHdl));
            DisposeHandle(Handle(tempHdl));
            tempHdl := nextHdl;
            End;
        End;
    gammaUtilsInstalled := '    ';
    DisposeGammaTools := 0;
    End;

Function GetDevGammaTable (theGDevice: GDHandle;
                       Var theTable: GammaTblPtr): OSErr;

Var
   errorCold: Integer;
   myCPB: ParmBlkPtr;

    Begin
    theTable := Nil;
    If Not IsOneGammaAvailable(theGDevice) Then
        Begin
        GetDevGammaTable := -1;
        exit(GetDevGammaTable);
        End;
    myCPB := ParmBlkPtr(NewPtrClear(sizeof(ParamBlockRec)));
    If (myCPB = Nil) Then
        Begin
        GetDevGammaTable := MemError;
        exit(GetDevGammaTable);
        End;
    myCPB^.csCode := cscGetGamma;
    myCPB^.ioCRefNum := theGDevice^^.gdRefNum;
    myCPB^.csParam[0] := HiWord(longint(@theTable));
    myCPB^.csParam[1] := LoWord(longint(@theTable));
    errorCold := PBStatus(myCPB, false);
    DisposePtr(Ptr(myCPB));
    GetDevGammaTable := errorCold;
    End;

Function SetDevGammaTable (theGDevice: GDHandle;
                       Var theTable: GammaTblPtr): OSErr;

Var
   myCPB: ParmBlkPtr;
   errorCold: Integer;
   cTab: CTabHandle;
   saveGDevice: GDHandle;

    Begin
    If Not IsOneGammaAvailable(theGDevice) Then
        Begin
        SetDevGammaTable := -1;
        exit(SetDevGammaTable);
        End;
    myCPB := ParmBlkPtr(NewPtrClear(sizeof(ParamBlockRec)));
    If (myCPB = Nil) Then
        Begin
        SetDevGammaTable := MemError;
        exit(SetDevGammaTable);
        End;
    myCPB^.csCode := cscSetGamma;
    myCPB^.ioCRefNum := theGDevice^^.gdRefNum;
    myCPB^.csParam[0] := HiWord(longint(@theTable));
    myCPB^.csParam[1] := LoWord(longint(@theTable));
    errorCold := PBControl(myCPB, false);
    If (errorCold = 0) Then
        Begin
        saveGDevice := GetGDevice;
        SetGDevice(theGDevice);
        cTab := theGDevice^^.gdPMap^^.pmTable;
        SetEntries(0, cTab^^.ctSize, cTab^^.ctTable);
        SetGDevice(saveGDevice);
        End;
    DisposePtr(Ptr(myCPB));
    SetDevGammaTable := errorCold;
    End;

Procedure DelayFadeToBlack (delayTicks: longint);

Var
    i: integer;
    oe: integer;
    finalTicks: longint;

    begin
    i := 100;
    while i > 0 do
        begin
        oe := DoGammaFade(i);
        i := i - 1;
        Delay(delayTicks, finalTicks);
           end;
    gammaFaded := TRUE;
    end;

Procedure FadeToBlack (speed: integer);

Var
    i: integer;
    oe: integer;

    begin
    i := 100;
    while (i >= 0) do
        begin
        oe := DoGammaFade(i);
        i := i - speed;
        end;
    gammaFaded := TRUE;
    end;

Procedure FadeFromBlack (speed: integer);

Var
    i: integer;
    oe: integer;

    begin
    i := 0;
    while (i <= 100) do
        begin
        oe := DoGammaFade(i);
        i := i + speed;
        end;
    gammaFaded := FALSE;
    end;

Procedure DelayFadeFromBlack (delayTicks: longint);

Var
    i: integer;
    oe: integer;
    finalTicks: longint;

    begin
    i := 0;
    while (i <= 100) do
        begin
        oe := DoGammaFade(i);
        i := i + 1;
        Delay(delayTicks, finalTicks);
        end;
    gammaFaded := FALSE;
    end;

End.