Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/Pascal/Snippets/CollectPictColors 1.0/CLUTBuilder.p

Text File | 1995-10-05 | 9.4 KB | 323 lines | [TEXT/PJMM]

{ ------------------------------------------------------------------------------}
{#}
{#    Apple Macintosh Developer Technical Support}
{#}
{#    KnowsPICT  by Jon Zap}
{#}
{#    CLUTBuilder.p    -    Pascal Source}
{#}
{#    Copyright © 1989 Apple Computer, Inc.}
{#    All rights reserved.}
{#}
{# Pascal version 1995 by Guess Who}
{#}
{# this file contains functions used to pull colors from a PICT.  You activate it by}
{# calling CollectColors(PicHandle) with PicHandle set to a PICT that you have already}
{# loaded into memory.  It will almost invariably return a (handle to a) color table}
{# (that contains at least black and white) however the color table is not at all clean}
{# in the current implementation.  It is probably ok if you run it through NewPalette.}
{# If it runs across a direct pixmap it won't bomb but it won't add any colors to the}
{# color table.}
{#}
{# WARNING: This code has been tested but it has not been tested thoroughly;}
{# USE AT YOUR OWN RISK!}
{------------------------------------------------------------------------------ }

unit CLUTBuilder;

interface

{$IFC UNDEFINED THINK_PASCAL}
    uses
        Types, QuickDraw, Memory;
{$ENDC}

    function CollectColors (fromPicture: PicHandle; var depthPtr: Integer; var directFlagPtr: Boolean): CTabHandle;

implementation

    var
        gColorError: OSErr;    (* to report errors from bottlenecks. *)
        gColorTable: CTabHandle;    (* to collect colors from bottlenecks. *)
        gNextCSpec: Integer;        (* next CSpec entry in color table *)
        foundDirect: Boolean;        (* set to true if we uncover a direct pixmap *)
        maxPixDepth: Integer;      (* depth of deepest pixmap found *)

(* Add a color to the color table. *)
    procedure AddRGBColor (rgb: RGBColor); {rgb var?}
        var
            numSpecs, sizeInBytes: LongInt;
            i, ctSize: Integer;
            TablePtr: CTabPtr;
            rgbx: RGBColor;
    begin
        if gColorError <> noErr then
            exit(AddRGBColor);

        TablePtr := gColorTable^;
        ctSize := TablePtr^.ctSize;
        for i := 0 to ctSize do
            begin
                rgbx := TablePtr^.ctTable[i].rgb;
                if (rgbx.red = rgb.red) and (rgbx.green = rgb.green) and (rgbx.blue = rgb.blue) then
                    exit(AddRGBColor);        (* if already there, done *)
            end;
        gColorTable^^.ctSize := gColorTable^^.ctSize + 1;
        numSpecs := LongInt(gColorTable^^.ctSize);    (* add a colorspec to table *)
        sizeInBytes := (numSpecs * sizeof(ColorSpec)) + sizeof(ColorTable);
        SetHandleSize(Handle(gColorTable), sizeInBytes);
        gColorError := MemError;
        if gColorError = noErr then
            begin
                gColorTable^^.ctTable[numSpecs].rgb := rgb;
                gColorTable^^.ctTable[numSpecs].value := 0;
            end;
    end; {AddRGBColor}

(* Add the contents of another color table to our color table.*)
    procedure AddColorTable (cTab: CTabHandle);
        var
            index, size: Integer;
            color: RGBColor;
    begin
        size := cTab^^.ctSize;        {CW får Bus Error här!}
        for index := 0 to size do
            begin
                color := cTab^^.ctTable[index].rgb;
                AddRGBColor(color);
            end;
    end; {AddColorTable}

(* Add the foreground color of the current port to the color table. *)
    procedure AddRGBForeColor;
    begin
{$IFC UNDEFINED THINK_PASCAL}
        AddRGBColor(CGrafPtr(qd.thePort)^.rgbFgColor);
{$ELSEC}
        AddRGBColor(CGrafPtr(thePort)^.rgbFgColor);
{$ENDC}
    end; {AddRGBForeColor}

(* Add the background color of the current port to the color table. *)
    procedure AddRGBBackColor;
    begin
{$IFC UNDEFINED THINK_PASCAL}
        AddRGBColor(CGrafPtr(qd.thePort)^.rgbBkColor);
{$ELSEC}
        AddRGBColor(CGrafPtr(thePort)^.rgbBkColor);
{$ENDC}
    end; {AddRGBBackColor}

(* Add colors from a PixPat to a color table. *)
    procedure AddPixPat (pPat: PixPatHandle);
    begin
        case pPat^^.patType of
            0:        (* one-bit patterns are drawn in the foreground and background color. *)
                begin
                    AddRGBForeColor;
                    AddRGBBackColor;
                end;
            1:        (* Type 1 PixPats have a color table. *)
                AddColorTable(pPat^^.patMap^^.pmTable);
        end; {case}
    end; {AddPixPat}

(* Add colors from the pen PixPat to the color table. *)
    procedure AddPenPixPat;
    begin
{$IFC UNDEFINED THINK_PASCAL}
        AddPixPat(CGrafPtr(qd.thePort)^.pnPixPat);
{$ELSEC}
        AddPixPat(CGrafPtr(thePort)^.pnPixPat);
{$ENDC}
    end; {AddPenPixPat}

(* Add colors from the fill PixPat to the color table. *)
    procedure AddFillPixPat;
    begin
{$IFC UNDEFINED THINK_PASCAL}
        AddPixPat(CGrafPtr(qd.thePort)^.fillPixPat);
{$ELSEC}
        AddPixPat(CGrafPtr(thePort)^.fillPixPat);
{$ENDC}
    end; {AddFillPixPat}

(* Add colors because we are about to draw an object. *)
    procedure AddVerb (verb: GrafVerb);
    begin
        case verb of
            frame, paint: (* Framed and painted objects are drawn in the pen PixPat. *)
                AddPenPixPat;
            erase: (* Erased objects are drawn in the background color. *)
                AddRGBBackColor;
            fill:
            (* Filled objects are drawn in the fill PixPat.  The fillPixPat is}
{                a pattern used to record fill commands for pictures.  First, a}
{                command to set the fillPixPat is recorded, then the fill command}
{                is recorded. *)
                AddFillPixPat;
        end;
    end;

(* bottleneck routines follow . . . *)

    procedure ColorTextProc (byteCount: Integer; textBuf: Ptr; numer, denom: Point);
    (* Text is drawn with the foreground and background colors.*)
    begin
        AddRGBForeColor;
        AddRGBBackColor;
    end; {ColorTextProc}

    procedure ColorLineProc (newPt: Point);
 (* Lines are drawn with the pen PixPat. *)
    begin
        AddPenPixPat;
    end; {ColorLineProc}

    procedure ColorRectProc (verb: GrafVerb; r: Rect);
    begin
        AddVerb(verb);
    end;

    procedure ColorRRectProc (verb: GrafVerb; r: Rect; ovalWidth: Integer; ovalHeight: Integer);
    begin
        AddVerb(verb);
    end;

    procedure ColorOvalProc (verb: GrafVerb; r: Rect);
    begin
        AddVerb(verb);
    end;

    procedure ColorArcProc (verb: GrafVerb; r: Rect; startAngle, arcAngle: Integer);
    begin
        AddVerb(verb);
    end;

    procedure ColorPolyProc (verb: GrafVerb; poly: PolyHandle);
    begin
        AddVerb(verb);
    end;

    procedure ColorRgnProc (verb: GrafVerb; rgn: RgnHandle);
    begin
        AddVerb(verb);
    end;

    procedure ColorBitsProc (bitPtr: BitMapPtr; srcRect, dstRect: Rect; mode: Integer; maskRgn: RgnHandle);
        type
            PixMapHandlePtr = ^PixMapHandle;
        var
            aPixMap: PixMapPtr;
            tempRB: Integer;

    (* Get the PixMap that we are about to draw.  SrcBits might be a BitMap, or}
{        one of two different kinds of PixMap pointers.  *)
    begin
        tempRB := bitPtr^.rowBytes;            (* local copy of rowBytes *)
        if tempRB < 0 then                    (* high bit set? *)
            begin
                if BAnd(tempRB, $3000) <> 0 then        (* next to high bit set? *)
                {if BSL(tempRB, 1) < 0 then            <- unsafe, since it depends on how BSL casts the argument    }
                    aPixMap := PixMapHandlePtr(bitPtr)^^    (* ptr to PixMap handle *)
                else
                    aPixMap := PixMapPtr(bitPtr);        (* pointer to a PixMap *)
                if aPixMap^.pixelSize > maxPixDepth then    (* deepest pixmap so far? *)
                    maxPixDepth := aPixMap^.pixelSize;
                if aPixMap^.pixelType = 16 then
                    begin
                        foundDirect := true;
                        exit(ColorBitsProc);                                (* direct pixmap?  eek! *)
                    end;
                AddColorTable(aPixMap^.pmTable);        (* it has its own color table. *)
            end
        else
        (* It's just a BitMap; it will use the background and foreground colors. *)
            begin
                AddRGBBackColor;
                AddRGBForeColor;
            end;
    end;



    function MakeColor (r, g, b: Integer): RGBColor;
    begin
        MakeColor.red := r;
        MakeColor.green := g;
        MakeColor.blue := b;
    end;



    function CollectColors (fromPicture: PicHandle; var depthPtr: Integer; var directFlagPtr: Boolean): CTabHandle;
        var
            colors: CTabHandle;
            bottlenecks: CQDProcs;
{      Set the bottlenecks.  These bottlenecks will figure out what colors are in    }
{        a picture, but won't draw anything.    }
{    Note: the bottlenecks are installed in thePort, which must be a color port. }
        var
            whiteRGB: RGBColor;
            blackRGB: RGBColor;
    begin

        whiteRGB := MakeColor($FFFF, $FFFF, $FFFF);
        blackRGB := MakeColor(0, 0, 0);


        SetStdCProcs(bottlenecks);
        bottlenecks.textProc := @ColorTextProc;
        bottlenecks.lineProc := @ColorLineProc;
        bottlenecks.rectProc := @ColorRectProc;
        bottlenecks.rRectProc := @ColorRRectProc;
        bottlenecks.ovalProc := @ColorOvalProc;
        bottlenecks.arcProc := @ColorArcProc;
        bottlenecks.polyProc := @ColorPolyProc;
        bottlenecks.rgnProc := @ColorRgnProc;
        bottlenecks.bitsProc := @ColorBitsProc;

    (* Create a color table containing black and white. *)
        foundDirect := false;    (* haven't found a direct pixmap yet *)
        maxPixDepth := 1;        (* assume we will find a bitmap *)
        colors := CTabHandle(NewHandle(sizeof(ColorTable) + sizeof(ColorSpec)));
        if colors <> nil then
            begin
                colors^^.ctSize := 1; (* 2 entries *)
                colors^^.ctFlags := $8000;
        {colors^^.transIndex := $8000;}
                colors^^.ctSeed := GetCTSeed;
                colors^^.ctTable[0].rgb := whiteRGB; (*first entry is white*)
                colors^^.ctTable[1].rgb := blackRGB; (*second entry is black*)
        (* Now play back the picture to get the colors.  The dstRect doesn't}
{            matter since our bottlenecks will never actually draw. We use global}
{            variables (gColorError and gColorTable) to communicate with the}
{            bottlenecks. *)
{$IFC UNDEFINED THINK_PASCAL}
                qd.thePort^.grafProcs := @bottlenecks;
{$ELSEC}
                thePort^.grafProcs := @bottlenecks;
{$ENDC}
                gColorError := noErr;
                gColorTable := colors;
                DrawPicture(fromPicture, fromPicture^^.picFrame);
{$IFC UNDEFINED THINK_PASCAL}
                qd.thePort^.grafProcs := nil;
{$ELSEC}
                thePort^.grafProcs := nil;
{$ENDC}
                depthPtr := maxPixDepth;
                directFlagPtr := foundDirect;

        (* Fail if error occurred while within the color bottlenecks. *)
                if gColorError <> noErr then
                    begin
                        DisposeHandle(Handle(colors));
                        colors := nil;
                    end;
            end;
        CollectColors := colors;
        Exit(CollectColors);
    end;

end.