Carousel Volume 2 #1/carousel.iso/mactosh/lang/p_image1.sit/LSP Source/Functions.p

Text File | 1989-07-27 | 33.2 KB | 1,365 lines

unit Functions;

{}

interface


    uses
        QuickDraw, OSIntf, PickerIntf, ToolIntf, PrintTraps, globals, Utilities, Graphics, FileUnit, Analysis, Camera;


    procedure ApplyTable (var table: LookupTable);
    procedure ApplyLookupTable;
    procedure MakeBinary;
    procedure Filter (ftype: FilterType; FirstPass: boolean);
    procedure PhotoMode;
    procedure Animate;
    procedure EnhanceContrast;
    procedure EqualizeHistogram;
    procedure SortPalette;
    procedure Convolve;
    procedure Do3DPlot;
    procedure MakeSkeleton;


implementation

    const
        MaxW = 4000;

    type
        ktype = array[0..MaxW] of integer;

    var
        PixelsRemoved: LongInt;

    procedure ApplyTableToLine (data: ptr; var table: LookupTable; width: LongInt);
{$IFC false}
        type
            lptr = ^LineType;
        var
            line: lptr;
            i: integer;
    begin
        line := lptr(data);
        for i := 0 to width - 1 do
            Line^[i] := table[Line^[i]];
    end;
{$ENDC}

{a0 = data}
{a1 = lookup table}
{d0 = width }
{d1 = pixel value}
inline
    $4E56, $0000, {  link a6,#0}
    $48E7, $C0C0, {  movem.l a0-a1/d0-d1,-(sp)}
    $206E, $000C, {  move.l 12(a6),a0}
    $226E, $0008, {  move.l 8(a6),a1}
    $202E, $0004, {  move.l 4(a6),d0}
    $5380,       {  subq.l #1,d0}
    $4281,       {  clr.l d1}
    $1210,       {L move.b (a0),d1}
    $10F1, $1000, {  move.b 0(a1,d1.w),(a0)+}
    $51C8, $FFF8, {  dbra d0,L}
    $4CDF, $0303, {  movem.l (sp)+,a0-a1/d0-d1}
    $4E5E,       {  unlk a6}
    $DEFC, $000C; {  add.w #12,sp}


function SetupMask: boolean;
{Creates a mask in the undo buffer for operating on non-rectangular}
{selections . Assumes SetupUndoFromClip has been called . }
    var
        tPort: GrafPtr;
begin
    if info^.PicSize > UndoBufSize then begin
            SetupMask := false;
            exit(SetupMask)
        end;
    GetPort(tPort);
    with Info^ do begin
            SetPort(GrafPtr(osPort));
            with osPort^ do
                if fgcolor = bkcolor then
                    bkColor := 255 - ForegroundColor;
            PenNormal;
            EraseRect(osroiRect);
            PaintRgn(osroiRgn);
            osPort^.bkColor := BackgroundColor;
        end;
    SetPort(tPort);
    SetupUndo; {Copy mask to undo buffer.}
    if info^.PicSize <= ClipBufSize then begin
            UndoFromClip := true;
            RestoreUndoBuf := false;
            undo;
            RestoreUndoBuf := true;
        end;
    UndoInfoRec := info^;
    UndoInfo := @UndoInfoRec;
    with UndoInfo^ do begin
            PicBaseAddr := UndoBuf;
            BytesPerRow := PixelsPerLine;
        end;
    SaveInfo := Info;
    SetupMask := true;
end;


procedure PutLineUsingMask (h, v, count: integer; var line: LineType);
    var
        aLine, MaskLine: LineType;
        i: integer;
begin
    GetLine(h, v, count, aline);
    Info := UndoInfo;
    GetLine(h, v, count, MaskLine);
    for i := 0 to count - 1 do
        if MaskLine[i] = ForegroundColor then
            aLine[i] := line[i];
    info := SaveInfo;
    PutLine(h, v, count, aLine);
end;


procedure ApplyTable; {(var table: LookupTable)}
    var
        width, NumberOfLines, i, hloc, vloc: integer;
        offset: LongInt;
        p: ptr;
        UseMask: boolean;
        TempLine: LineType;
        AutoSelectAll: boolean;
begin
    if NotInBounds then
        exit(ApplyTable);
    if RunningOn030 and (info^.PictureType = Camera) then begin
            PutMessage('Apply LUT is not allowed in the Camera window on 68030 CPUs.', '', '');
            exit(ApplyTable);
        end;
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    ShowWatch;
    WhatToUndo := UndoTransform;
    SetupUndoFromClip;
    with info^.osroiRect, info^ do begin
            if RoiType <> RectRoi then
                UseMask := SetupMask
            else
                UseMask := false;
            offset := LongInt(top) * BytesPerRow + left;
            if UseMask then
                p := @TempLine
            else
                p := ptr(ord4(PicBaseAddr) + offset);
            width := right - left;
            NumberOfLines := bottom - top;
            hloc := left;
            vloc := top;
        end;
    if width > 0 then
        for i := 1 to NumberOfLines do
            if UseMask then begin
                    GetLine(hloc, vloc, width, TempLine);
                    ApplyTableToLine(p, table, width);
                    PutLineUsingMask(hloc, vloc, width, TempLine);
                    vloc := vloc + 1
                end
            else begin
                    ApplyTableToLine(p, table, width);
                    p := ptr(ord4(p) + info^.BytesPerRow);
                end;
    with info^ do begin
            UpdateScreen(roiRect);
            Info^.changes := true;
        end;
    SetupRoiRect;
    if AutoSelectAll then
        KillRoi;
end;


procedure DoApplyTableDialogBox;
    const
        Button1 = 3;
        Button2 = 4;
        Button3 = 5;
        Button4 = 6;
    var
        mylog: DialogPtr;
        item: integer;
        SaveA, SaveB: boolean;

    procedure SetButtons;
    begin
        SetDialogItem(mylog, Button1, ord(ThresholdToForeground));
        SetDialogItem(mylog, Button2, ord(not ThresholdToForeground));
        SetDialogItem(mylog, Button3, ord(NonThresholdToBackground));
        SetDialogItem(mylog, Button4, ord(not NonThresholdToBackground));
    end;

begin
    InitCursor;
    SaveA := ThresholdToForeground;
    SaveB := NonThresholdToBackground;
    mylog := GetNewDialog(40, nil, pointer(-1));
    SetButtons;
    OutlineButton(MyLog, ok, 16);
    repeat
        ModalDialog(nil, item);
        if (item = Button1) or (item = button2) then begin
                ThresholdToForeground := not ThresholdToForeground;
                SetButtons;
            end;
        if (item = Button3) or (item = button4) then begin
                NonThresholdToBackground := not NonThresholdToBackground;
                SetButtons;
            end;
    until (item = ok) or (item = cancel);
    DisposDialog(mylog);
    if item = cancel then begin
            ThresholdToForeground := SaveA;
            NonThresholdToBackground := SaveB;
        end;
end;


procedure ApplyLookupTable;
    var
        table: LookupTable;
        ConvertingColorPic: boolean;
begin
    with info^ do
        ConvertingColorPic := not ((LUTMode = Grayscale) or (LUTMode = CustomGrayscale));
    if thresholding then
        DoApplyTableDialogBox;
    GetLookupTable(table);
    ResetGrayMap;
    ApplyTable(table);
    if ConvertingColorPic then
        WhatToUndo := NothingToUndo;
end;


procedure MakeBinary;
    var
        table: LookupTable;
        SaveBackground, SaveForeground: integer;
begin
    if not thresholding and (info^.deltax > 1) then
        PutMessage('Sorry, but you must be thresholding to use Make Binary.', '', '')
    else begin
            ThresholdToForeground := true;
            NonThresholdToBackground := true;
            SaveBackground := BackgroundColor;
            SaveForeground := ForegroundColor;
            BackgroundColor := WhiteC;
            ForegroundColor := BlackC;
            GetLookupTable(table);
            ResetGrayMap;
            ApplyTable(table);
            BackgroundColor := SaveBackground;
            ForegroundColor := SaveForeground;
            info^.BinaryPic := true;
        end;
end;


procedure Filter (ftype: FilterType; FirstPass: boolean);
    const
        PixelsPerUpdate = 5000;
    var
        row, width, r1, r2, r3, c, value, error, sum, center: integer;
        tmp, mark, NewMark, LinesPerUpdate, LineCount: integer;
        t1, t2, t3, t4: integer;
        MaskRect, frame: rect;
        L1, L2, L3, result: LineType;
        tPort: GrafPtr;
        pt: point;
        a: SortArray;
        AutoSelectAll, UseMask: boolean;
        OptionKeyWasDown: boolean;
        L, T, R, B: integer;
begin
    if NotinBounds then
        exit(Filter);
    OptionKeyWasDown := OptionKeyDown;
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then begin
            SelectAll(false);
            PenNormal;
            PenPat(pat[PatIndex]);
            FrameRect(info^.wrect);
        end;
    ShowWatch;
    WhatToUndo := UndoFilter;
    if FirstPass then
        SetupUndoFromClip;
    if info^.RoiType <> RectRoi then
        UseMask := SetupMask
    else
        UseMask := false;
    with info^ do
        if ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction) then
            ApplyLookupTable;
    frame := info^.osroiRect;
    with frame, Info^ do begin
            changes := true;
            RoiShowing := false;
            if left > 0 then
                left := left - 1;
            if right < PicRect.right then
                right := right + 1;
            width := right - left;
            LinesPerUpdate := PixelsPerUpdate div width;
            if ftype = ReduceNoise then
                LinesPerUpdate := LinesPerUpdate div 3;
            GetLine(left, top, width, L2);
            GetLine(left, top + 1, width, L3);
            Mark := roiRect.top;
            LineCount := 0;
            for row := top + 1 to bottom - 1 do begin
       {Move Convolution Window Down}
                    BlockMove(@L2, @L1, width);
                    BlockMove(@L3, @L2, width);
                    GetLine(left, row + 1, width, L3);
       {Process One Row}
                    case ftype of
                        EdgeDetect:
                            for c := 1 to width - 2 do begin
                                    t1 := L1[c] + L1[c + 1] + L1[c + 2] - L3[c] - L3[c + 1] - L3[c + 2];
                                    t1 := abs(t1);
                                    t2 := L1[c + 2] + L2[c + 2] + L3[c + 2] - L1[c] - L2[c] - L3[c];
                                    t2 := abs(t2);
                                    if t1 > t2 then
                                        tmp := t1
                                    else
                                        tmp := t2;
                                    if OptionKeyWasDown then begin
                                            if tmp > 255 then
                                                tmp := 255;
                                            if tmp < 0 then
                                                tmp := 0;
                                        end
                                    else if tmp > 35 then
                                        tmp := 255
                                    else
                                        tmp := 0;
                                    result[c - 1] := tmp;
                                end;
                        ReduceNoise:  {Median Filter}
                            for c := 1 to width - 2 do begin
                                    a[1] := L1[c];
                                    a[2] := L1[c + 1];
                                    a[3] := L1[c + 2];
                                    a[4] := L2[c];
                                    a[5] := L2[c + 1];
                                    a[6] := L2[c + 2];
                                    a[7] := L3[c];
                                    a[8] := L3[c + 1];
                                    a[9] := L3[c + 2];
                                    result[c - 1] := FindMedian(a);
                                end;
                        Dither:  {Floyd-Steinberg Algorithm}
                            for c := 1 to width - 2 do begin
                                    value := L2[c + 1];
                                    if value < 128 then begin
                                            result[c - 1] := 0;
                                            error := -value;
                                        end
                                    else begin
                                            result[c - 1] := 255;
                                            error := 255 - value
                                        end;
                                    tmp := L2[c + 2];              {A}
                                    tmp := tmp - (7 * error) div 16;
                                    if tmp < 0 then
                                        tmp := 0;
                                    if tmp > 255 then
                                        tmp := 255;
                                    L2[c + 2] := tmp;
                                    tmp := L3[c + 2];              {B}
                                    tmp := tmp - error div 16;
                                    if tmp < 0 then
                                        tmp := 0;
                                    if tmp > 255 then
                                        tmp := 255;
                                    L3[c + 2] := tmp;
                                    tmp := L3[c + 1];              {C}
                                    tmp := tmp - (5 * error) div 16;
                                    if tmp < 0 then
                                        tmp := 0;
                                    if tmp > 255 then
                                        tmp := 255;
                                    L3[c + 1] := tmp;
                                    tmp := L3[c];                {D}
                                    tmp := tmp - (3 * error) div 16;
                                    if tmp < 0 then
                                        tmp := 0;
                                    if tmp > 255 then
                                        tmp := 255;
                                    L3[c] := tmp;
                                end;
                        UnweightedAvg:
                            for c := 1 to width - 2 do begin
                                    tmp := (L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 1] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]) div 9;
                                    if tmp > 255 then
                                        tmp := 255;
                                    if tmp < 0 then
                                        tmp := 0;
                                    result[c - 1] := tmp;
                                end;
                        WeightedAvg:
                            for c := 1 to width - 2 do begin
                                    tmp := (L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 1] * 4 + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2]) div 12;
                                    if tmp > 255 then
                                        tmp := 255;
                                    if tmp < 0 then
                                        tmp := 0;
                                    result[c - 1] := tmp;
                                end;
                        fsharpen:
                            for c := 1 to width - 2 do begin
                                    if OptionKeyWasDown then
                                        tmp := L2[c + 1] * 9 - L1[c] - L1[c + 1] - L1[c + 2] - L2[c] - L2[c + 2] - L3[c] - L3[c + 1] - L3[c + 2]
                                    else begin
                                            tmp := L2[c + 1] * 12 - L1[c] - L1[c + 1] - L1[c + 2] - L2[c] - L2[c + 2] - L3[c] - L3[c + 1] - L3[c + 2];
                                            tmp := tmp div 4;
                                        end;
                                    if tmp > 255 then
                                        tmp := 255;
                                    if tmp < 0 then
                                        tmp := 0;
                                    result[c - 1] := tmp;
                                end;
                        Erosion:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = BlackC then begin
                                            sum := L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2];
                                            if sum < 1275 then
                                                center := WhiteC;
                                        end;
                                    result[c - 1] := center;
                                end;
                        Dilation:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = WhiteC then begin
                                            sum := L1[c] + L1[c + 1] + L1[c + 2] + L2[c] + L2[c + 2] + L3[c] + L3[c + 1] + L3[c + 2];
                                            if sum > 765 then
                                                center := BlackC;
                                        end;
                                    result[c - 1] := center;
                                end;
                        OutlineFilter:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = BlackC then begin
                                            if (L2[c] = WhiteC) or (L1[c + 1] = WhiteC) or (L2[c + 2] = WhiteC) or (L3[c + 1] = WhiteC) then
                                                center := BlackC
                                            else
                                                center := WhiteC;
                                        end;
                                    result[c - 1] := center;
                                end;
                        Skeletonize:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = BlackC then begin
                                            L := L2[c];
                                            T := L1[c + 1];
                                            R := L2[c + 2];
                                            B := L3[c + 1];
                                            sum := L1[c] + T + L1[c + 2] + L + R + L3[c] + B + L3[c + 2];
                                            if sum < 1275 then
                                                if not (((L <> BlackC) and (R <> BlackC)) or ((T <> BlackC) and (B <> BlackC))) then begin
                                                        center := WhiteC;
                                                        L2[c + 1] := 128;
                                                        PixelsRemoved := PixelsRemoved + 1;
                                                    end;
                                        end;
                                    result[c - 1] := center;
                                end;
                    end; {case}
                    if UseMask then
                        PutLineUsingMask(left + 2, row, width - 3, result)
                    else
                        PutLine(left + 2, row, width - 3, result);
                    LineCount := LineCount + 1;
                    if LineCount = LinesPerUpdate then begin
                            pt.h := roiRect.left;
                            pt.v := row + 1;
                            OffscreenToScreen(pt);
                            NewMark := pt.v;
                            with roiRect do
                                SetRect(MaskRect, left, mark, right, NewMark);
                            UpdateScreen(MaskRect);
                            LineCount := 0;
                            Mark := NewMark;
                            if magnification > 1.0 then
                                Mark := Mark - 1;
                            if CommandPeriod then begin
                                    UpdatePicWindow;
                                    beep;
                                    PixelsRemoved := 0;
                                    exit(filter)
                                end;
                        end;
                end; {for row:=...}
        end; {with}
    if LineCount > 0 then begin
            with frame do
                SetRect(MaskRect, left, mark, right, bottom);
            UpdateScreen(MaskRect)
        end;
    SetupRoiRect;
    if AutoSelectAll then
        KillRoi;
end;


procedure PhotoMode;
{Erases the screen to black and then redraws the contents of the}
{active picture window . Thanks to Matthew Russotto}
{for the tip about using PaintBehind to restore the screen . }
    var
        tPort: GrafPtr;
        event: EventRecord;
        WinRect: rect;
        SaveVisRgn: rgnHandle;
begin
    if info <> NoInfo then
        with info^ do begin
                if OptionKeyDown then begin {Move window up to top of screen.}
                        GetWindowRect(wptr, WinRect);
                        MoveWindow(wptr, WinRect.left, 0, false);
                    end;
                with wptr^ do begin
                        SaveVisRgn := visRgn;
                        visRgn := NewRgn;
                        RectRgn(visRgn, ScreenBits.Bounds);
                    end;
                FlushEvents(EveryEvent, 0);
                GetPort(tPort);
                EraseScreen;
                UpdatePicWindow;
                repeat
                until GetNextEvent(mDownMask + KeyDownMask, Event);
                with wptr^ do begin
                        DisposeRgn(visRgn);
                        visRgn := SaveVisRgn;
                    end;
                RestoreScreen;
                SetPort(tPort);
                FlushEvents(EveryEvent, 0);
            end
    else
        beep;
end;


procedure Animate;
    var
        TempInfo: InfoPtr;
        n, last, DelayTicks: integer;
        tPort: GrafPtr;
        Event: EventRecord;
        ch: char;
        b: boolean;
        SourceRect, DestRect: rect;
        SingleStep, GoForward, NewKeyDown: boolean;
        SaveLUTMode: LUTModeType;
        SaveVisRgn: RgnHandle;
begin
    if nPics < 2 then begin
            PutMessage('There must be at least two picture windows open in order to do animation.', '', '');
            exit(Animate)
        end;
    SaveLutMode := info^.LutMode;
    last := nPics;
    getPort(tPort);
    EraseScreen;
    SetPort(info^.wptr);
    FlushEvents(EveryEvent, 0);
    DelayTicks := 0;
    n := 1;
    GoForward := true;
    SingleStep := false;
    with info^ do begin
            SetPort(wptr);
            with wptr^ do begin
                    SaveVisRgn := visRgn;
                    visRgn := NewRgn;
                    RectRgn(visRgn, ScreenBits.Bounds);
                end;
        end;
    repeat
        repeat
            b := GetNextEvent(EveryEvent, Event);
            NewKeyDown := event.what = KeyDown;
        until (not SingleStep) or NewKeyDown or (event.what = MouseDown);
        if NewKeyDown then begin
                Ch := chr(BitAnd(Event.message, 127));
                SingleStep := false;
                case ord(ch) of
                    28:
                        begin
                            SingleStep := true;
                            GoForward := false;
                            DelayTicks := 0
                        end; {left}
                    29:
                        begin
                            SingleStep := true;
                            GoForward := true;
                            DelayTicks := 0
                        end;  {right}
                    57:
                        DelayTicks := 0;  {9}
                    56:
                        DelayTicks := 1;  {8}
                    55:
                        DelayTicks := 3;  {7}
                    54:
                        DelayTicks := 5;  {6}
                    53:
                        DelayTicks := 8;  {5}
                    52:
                        DelayTicks := 12; {4}
                    51:
                        DelayTicks := 18; {3}
                    50:
                        DelayTicks := 30; {2}
                    49:
                        DelayTicks := 60; {1}
                    otherwise
                        ;
                end;
            end;
        if DelayTicks <> 0 then
            delay(DelayTicks, ticks);
        if GoForward then begin
                n := n + 1;
                if n > last then
                    n := 1
            end
        else begin
                n := n - 1;
                if n < 1 then
                    n := last
            end;
        TempInfo := pointer(WindowPeek(PicWindow[n])^.RefCon);
        with TempInfo^ do begin
                if (LutMode <> SaveLutMode) or (LutMode = Custom) or (LutMode = CustomGrayscale) or SingleStep then
                    LoadLut(cTable);
                SaveLutMode := LutMode;
                with TempInfo^ do begin
                        hlock(handle(osPort^.portPixMap));
                        hlock(handle(CGrafPort(ThePort^).PortPixMap));
                        CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(ThePort^).PortPixMap)^^, SrcRect, wrect, SrcCopy, nil);
                        hunlock(handle(osPort^.portPixMap));
                        hunlock(handle(CGrafPort(ThePort^).PortPixMap));
                    end;
            end; {with}
    until event.what = MouseDown;
    RestoreScreen;
    SetPort(tPort);
    with info^.wptr^ do begin
            DisposeRgn(visRgn);
            visRgn := SaveVisRgn;
        end;
    UpdatePicWindow;
    ShowCursor;
    FlushEvents(EveryEvent, 0);
end;


procedure EnhanceContrast;
    var
        AutoSelectAll: boolean;
        min, max, i, threshold: integer;
        found: boolean;
        sum: LongInt;
begin
    with info^ do
        if (LUTMode <> GrayScale) and (LUTMode <> CustomGrayscale) then begin
                PutMessage('Sorry, but you can only contrast enhance grayscale images.', '', '');
                exit(EnhanceContrast)
            end;
    if NotInBounds or (ClipBuf = nil) then
        exit(EnhanceContrast);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    if info^.RoiType = RectRoi then
        GetRectHistogram
    else
        GetNonRectHistogram;
    sum := 0;
    for i := 0 to 255 do
        sum := sum + histogram[i];
    threshold := sum div 5000;
    i := -1;
    repeat
        i := i + 1;
        found := histogram[i] > threshold;
    until found or (i = 255);
    min := i;
    i := 256;
    repeat
        i := i - 1;
        found := histogram[i] > threshold;
    until found or (i = 0);
    max := i;
    if max > min then
        with info^ do begin
                p1x := 255 - max;
                p1y := 0;
                p2x := 255 - min;
                p2y := 255;
                SetGrayScaleLUT;
                DrawGrayMap;
                WhatToUndo := UndoContrastEnhancement;
            end;
    info^.changes := true;
    IdentityFunction := false;
    if AutoSelectAll then
        KillRoi;
end;


procedure EqualizeHistogram;
    var
        AutoSelectAll: boolean;
        i, sum, v: integer;
        isum: LongInt;
        ScaleFactor: extended;
begin
    with info^ do
        if (LUTMode <> GrayScale) and (LutMode <> CustomGrayscale) then begin
                PutMessage('Sorry, but you can only do histogram equalization on grayscale images.', '', '');
                exit(EqualizeHistogram)
            end;
    if NotInBounds or (ClipBuf = nil) then
        exit(EqualizeHistogram);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    if info^.RoiType = RectRoi then
        GetRectHistogram
    else
        GetNonRectHistogram;
    ComputeResults;
    isum := 0;
    for i := 0 to 255 do
        isum := isum + histogram[i];
    ScaleFactor := 255.0 / isum;
    sum := 0;
    with info^ do begin
            for i := 255 downto 0 do
                with cTable[i].rgb do begin
                        sum := round(sum + histogram[i] * ScaleFactor);
                        if sum > 255 then
                            sum := 255;
                        v := sum * 256;
                        red := v;
                        green := v;
                        blue := v;
                    end;
            LoadLUT(cTable);
            LUTMode := CustomGrayscale;
            changes := true;
        end;
    DrawGrayMap;
    WhatToUndo := UndoEqualization;
    IdentityFunction := false;
    if AutoSelectAll then
        KillRoi;
end;


procedure SortPalette;
    type
        MyHSVColor = record
                lHue, lSaturation, lValue: LongInt;
            end;
        HSVRec = record
                index: integer;
                hsv: MyHSVColor;
            end;
        HSVArrayType = array[0..255] of HSVRec;
    var
        TempTable: MyCSpecArray;
        i: integer;
        HSVArray: HSVArrayType;
        h, s, v: LongInt;
        fHue, fSaturation, fValue: fixed;
        TempHSV: HSVColor;
        table: LookupTable;

    procedure SortByHue;
        var
            i, j: integer;
            x: HSVRec;
    begin
        for i := 2 to 254 do begin
                for j := 254 downto i do
                    if HSVArray[j - 1].hsv.lHue > HSVArray[j].hsv.lHue then begin
                            x := HSVArray[j - 1];
                            HSVArray[j - 1] := HSVArray[j];
                            HSVArray[j] := x;
                        end;
            end;
    end;

    procedure SortBySaturation;
        var
            i, j: integer;
            x: HSVRec;
    begin
        for i := 2 to 254 do begin
                for j := 254 downto i do
                    if HSVArray[j - 1].hsv.lSaturation > HSVArray[j].hsv.lSaturation then begin
                            x := HSVArray[j - 1];
                            HSVArray[j - 1] := HSVArray[j];
                            HSVArray[j] := x;
                        end;
            end;
    end;

    procedure SortByValue;
        var
            i, j: integer;
            x: HSVRec;
    begin
        for i := 2 to 254 do begin
                for j := 254 downto i do
                    if HSVArray[j - 1].hsv.lValue > HSVArray[j].hsv.lValue then begin
                            x := HSVArray[j - 1];
                            HSVArray[j - 1] := HSVArray[j];
                            HSVArray[j] := x;
                        end;
            end;
    end;

begin
    ShowWatch;
    StopThresholding;
    with info^ do begin
            for i := 1 to 254 do begin
                    HSVArray[i].index := i;
                    rgb2hsv(cTable[i].rgb, TempHSV);
                    with TempHSV do begin
                            fHue := SmallFract2Fix(hue);
                            fSaturation := SmallFract2Fix(saturation);
                            fValue := SmallFract2Fix(value);
                        end;
                    with HSVArray[i].hsv do begin
                            lHue := LongInt(band(fHue, $ffff));
                            lSaturation := LongInt(band(fSaturation, $ffff));
                            lValue := LongInt(band(fValue, $ffff));
                        end;
                end;
{SortBySaturation;}
            SortByValue;
            SortByHue;
            for i := 1 to 254 do begin
                    with HSVArray[i].hsv do begin
                            TempHSV.hue := Fix2SmallFract(fixed(lHue));
                            TempHSV.saturation := Fix2SmallFract(fixed(lSaturation));
                            TempHSV.value := Fix2SmallFract(fixed(lValue));
                        end;
                    hsv2rgb(TempHSV, cTable[i].rgb);
                end;
            LoadLUT(cTable);
            if info <> NoInfo then begin
                    table[0] := 0;
                    table[255] := 255;
                    for i := 1 to 254 do
                        table[HSVArray[i].index] := i;
                    ApplyTable(table);
                end;
            WhatToUndo := NothingToUndo;
        end; {with}
end;


function GetNum (f: integer; var EndOfLine, done: boolean): integer;
    var
        err: osErr;
        a: packed array[1..2] of char;
        c: char;
        ByteCount, L: LongInt;
        str: str255;
begin
    str := '';
    EndOfLine := false;
    repeat
        ByteCount := 1;
        err := fsRead(f, ByteCount, @a);
        c := a[1];
        done := err <> NoErr;
    until ((c >= '0') and (c <= '9')) or (c = '-') or done;
    if not done then begin
            str := concat(str, c);
            repeat
                ByteCount := 1;
                err := fsRead(f, ByteCount, @a);
                c := a[1];
                EndOfLine := c = return;
                done := err <> NoErr;
                if not done and (c >= '0') and (c <= '9') then
                    str := concat(str, c);
            until (c < '0') or (c > '9') or done;
            StringToNum(str, L);
            GetNum := L;
        end
    else
        GetNum := -MaxInt;
end;


function GetKernel (var kernel: ktype; var n, count: integer; var name: str255): boolean;
    var
        where: Point;
        typeList: SFTypeList;
        reply: SFReply;
        err: OSErr;
        f, i, w, max: integer;
        EndOfLine, done: boolean;
begin
    where.v := 120;
    where.h := 120;
    typeList[0] := 'TEXT';
    SFGetFile(Where, '', nil, 1, typeList, nil, reply);
    i := 0;
    if reply.good then
        with reply do begin
                ShowWatch;
                err := FSOpen(fname, vRefNum, f);
                err := SetFPos(f, fsFromStart, 0);
                n := 0;
                max := MaxW;
                repeat
                    w := GetNum(f, EndOfLine, done);
                    if (n = 0) and EndOfLine then begin
                            n := i + 1;
                            max := n * n;
                        end;
                    if i < max then
                        kernel[i] := w
                    else
                        done := true;
                    if w <> -MaxInt then
                        i := i + 1;
                until done;
                err := fsclose(f);
                count := i;
                name := fname;
                GetKernel := true;
            end
    else
        GetKernel := false;
end;


procedure DoOnePixel (nLess1, PixelsPerLine: integer; corner: LongInt; var sum: LongInt; var kernel: ktype);
{$IFC false}
    var
        row, column, k: integer;
        pp: ptr;
begin
    k := 0;
    sum := 0;
    for row := 0 to nless1 do begin
            corner := corner + PixelsPerLine;
            pp := ptr(corner);
            for column := 0 to nless1 do begin
                    sum := sum + band(pp^, 255) * kernel[k];
                    k := k + 1;
                    pp := ptr(ord(pp) + 1);
                end;
        end;
end;
{$ENDC}

{a0=^corner/^sum}
{a1=^kernel}
{a2=^pixels}

{d0=n-1}
{d1=PixelsPerLine}
{d2=sum}
{d3=n-1(outer loop)}
{d4=n-1(inner loop)}
{d5=temp}

inline
    $4E56, $0000, {  link    a6,#0}
    $48E7, $FCE0,  {  movem.l    a0-a2/d0-d5,-(sp)}
    $4280,              {  clr.l    d0}
    $302E, $0012, {  move.w    18(a6),d0}
    $4281,              {  clr.l    d1}
    $322E, $0010, {  move.w    16(a6),d1}
    $206E, $000C, {  movea.l    12(a6),a0}
    $226E, $0004, {  movea.l    4(a6),a1}

    $4282,             {  clr.l    d2}
    $2600,             {  move.l    d0,d3}

    $D1C1,             {A adda.l    d1,a0}
    $2448,            {  move.l    a0,a2}
    $2800,            {  move.l    d0,d4}
    $4285,            {B clr.l    d5                   (2)}
    $1A1A,             {  move.b    (a2)+,d5    (6) }
    $CBD9,             {  muls    (a1)+,d5     (29!)}
    $D485,             {  add.l    d5,d2          (2)}
    $51CC, $FFF6, {  dbra    d4,B                (6)}
    $51CB, $FFEC, {  dbra    d3,A}

    $206E, $0008, {  move.l    8(a6),a0}
    $2082,              {  move.l    d2,(a0)}
    $4CDF, $073F, {  movem.l    (sp)+,a0-a2/d0-d5}
    $4E5E,              {  unlk    a6}
    $DEFC, $0010; {  add.w    #16,sp}



procedure DoConvolution (var kernel: ktype; n: integer);
    var
        row, width, column, value, error: integer;
        margin, i, nless1: integer;
        frame, MaskRect, tRect: rect;
        AutoSelectAll: boolean;
        SrcCenter, DstCenter, sum, max, offset, wsum, cscale: LongInt;
        p: ptr;
        str: str255;
begin
    if NotinBounds or NotRectangular then
        exit(DoConvolution);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    SetupUndoFromClip;
    WhatToUndo := UndoFilter;
    frame := info^.osroiRect;
    with frame, Info^ do begin
            if ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction) then
                ApplyLookupTable;
            changes := true;
            margin := n div 2;
            if left < margin then
                left := left + margin;
            if right > (PicRect.right - margin) then
                right := right - margin;
            if top < margin then
                top := top + margin;
            if bottom > (PicRect.bottom - margin) then
                bottom := bottom - margin;
            PenNormal;
            PenPat(pat[PatIndex]);
            tRect := frame;
            OffscreenToScreenRect(tRect);
            FrameRect(tRect);
            width := right - left;
            max := n * n - 1;
            wsum := 0;
            for i := 0 to max do
                wsum := wsum + kernel[i];
            NumToString(n, str);
            str := Concat(str, 'x', str, ' kernel');
            PutRMessage(1, str, MaxInt);
            PutRMessage(2, 'Sum= ', wsum);
            if wsum <> 0 then
                cscale := wsum
            else
                cscale := 1;
            offset := -(n div 2) * PixelsPerLine - PixelsPerLine - n div 2;
            nless1 := n - 1;
            for row := top to bottom - 1 do begin
                    SrcCenter := ord4(ClipBufInfo^.PicBaseAddr) + LongInt(row) * PixelsPerLine + left;
                    DstCenter := ord4(PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                    for column := left to left + width - 1 do begin
                            DoOnePixel(nless1, PixelsPerLine, SrcCenter + offset, sum, kernel);
                            value := sum div cscale;
                            if value > 255 then
                                value := 255;
                            if value < 0 then
                                value := 0;
                            p := ptr(DstCenter);
                            p^ := BAND(value, 255);
                            SrcCenter := SrcCenter + 1;
                            DstCenter := DstCenter + 1;
                        end; {for column:=}
                    SetRect(MaskRect, left, row, right, row + 1);
                    OffscreenToScreenRect(MaskRect);
                    UpdateScreen(MaskRect);
                    if CommandPeriod then begin
                            UpdatePicWindow;
                            beep;
                            exit(DoConvolution)
                        end;
                end; {for row:=...}
        end; {with}
    UpdatePicWindow;
    SetupRoiRect;
    if AutoSelectAll then
        KillRoi;
end;


procedure MakeWindowFromKernel (var kernel: ktype; n: integer; name: str255);
    var
        h, v, value, i, min, offset: integer;
begin
    if NewPicWindow(name, 256, 256) then begin
            SelectAll(true);
            DoOperation(eraseOp);
            KillRoi;
            min := 9999;
            for i := 0 to n * n - 1 do
                if kernel[i] < min then
                    min := kernel[i];
            if min < 0 then
                offset := -min
            else
                offset := 0;
            i := 0;
            for v := 0 to n - 1 do
                for h := 0 to n - 1 do begin
                        value := kernel[i] + offset;
                        PutPixel(h, v, value);
                        i := i + 1;
                    end;
        end;
end;


procedure Convolve;
    var
        kernel: ktype;
        n, count: integer;
        error: boolean;
        str1, str2, name: str255;
        ok: boolean;
        OptionKeyWasDown: boolean;
begin
    OptionKeyWasDown := OptionKeyDown;
    ok := GetKernel(kernel, n, count, name);
    if not ok then
        exit(convolve);
    error := false;
    if n > 63 then begin
            error := true;
            str1 := 'Kernel size must be <= 63.';
        end;
    if count < (n * n) then begin
            error := true;
            str1 := 'Not enough kernel coefficients.';
        end;
    if OptionKeyWasDown then begin
            MakeWindowFromKernel(kernel, n, name);
            exit(convolve);
        end;
    if not error then begin
            UpdatePicWindow;
            DoConvolution(kernel, n);
        end
    else
        PutMessage(str1, '', '');
end;


procedure Do3DPlot;
    var
        hend, vend, h, v, DataWidth, DataHeight, i: integer;
        htemp, vtemp, MinValue, MaxValue, value: integer;
        SaveForeground, SaveBackground, skip: integer;
        hLoc, vLoc, hMin, hMax, vMin, vMax: integer;
        hstart, vstart, dh, dv, hbase, vbase, vscale, nPlotLines: extended;
        peak, MaxPeak, hinc, vinc, nLines: extended;
        tPort: GrafPtr;
        poly: PolyHandle;
        SaveInfo: InfoPtr;
        aLine: LineType;
        MaskRect: rect;
        AutoSelectAll, ApplyLUT: boolean;
        table: LookupTable;

    procedure FindVinc;
    begin
        with info^.PicRect do begin
                vstart := 5.0 + vscale * (MaxPeak - MinValue) - dv * DataWidth;
                skip := round(DataHeight / ((bottom - vstart - 5.0) / vinc));
                if skip = 0 then
                    skip := 1;
                nPlotLines := DataHeight / skip;
                vinc := (bottom - vstart - 5.0) / nPlotLines;
                vinc := vinc / 0.95;
                repeat
                    vinc := vinc * 0.95;
                    hinc := vinc / 2.0;
                until (5.0 + hinc * nPlotLines + dh * DataWidth) < right;
            end;
    end;

begin
    if NotRectangular or NotInBounds then
        exit(Do3DPlot);
    if RunningOn030 and (info^.PictureType = Camera) then begin
            PutMessage('3D Plotting is not allowed in the Camera window on 68030 CPUs.', '', '');
            exit(Do3DPlot);
        end;
    StopDigitizing;
    StopThresholding;
    AutoSelectAll := not Info^.RoiShowing;
    ShowWatch;
    if AutoSelectAll then
        SelectAll(true);
    Measure;
    UndoLastMeasurement;
    with results do begin
            MinValue := round(min);
            MaxValue := round(max)
        end;
    with info^ do
        if ScaleToFitWindow or (magnification <> 1.0) then
            UnZoom;
    with info^ do
        ApplyLUT := ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction);
    if ApplyLUT then
        GetLookupTable(table);
    if ApplyLUT then begin
            MinValue := table[MinValue];
            MaxValue := table[MaxValue];
        end;
    KillRoi;
    SetupUndo;
    if not AutoSelectAll then
        RedoSelection := true;
    WhatToUndo := UndoPlot;
    UndoInfoRec := info^;
    UndoInfo := @UndoInfoRec;
    with UndoInfo^ do begin
            PicBaseAddr := UndoBuf;
            BytesPerRow := PixelsPerLine;
        end;
    SaveInfo := Info;
    GetPort(tPort);
    with Info^, info^.osroiRect do begin
            SaveForeground := ForegroundColor;
            SaveBackground := BackgroundColor;
            SetForegroundColor(BlackC);
            SetBackgroundColor(WhiteC);
            changes := true;
            SetPort(GrafPtr(osPort));
            PenNormal;
            EraseRect(PicRect);
            UpdatePicWindow;
            vscale := 0.5;
            DataWidth := right - left;
            DataHeight := bottom - top;
            dh := (0.65 * PicRect.right) / DataWidth;
            dv := -0.4 * dh;
            hstart := 5.0;
            vinc := 2.0;
            MaxPeak := (MaxValue - MinValue) * vscale;
            MaxPeak := MaxPeak * 0.5;
            FindVinc; {First estamate}
            MaxPeak := MaxPeak * 2.0;
            hmin := right + round(MaxPeak / dv);
            if hmin < 0 then
                hmin := 0;
            vmax := top + round(MaxPeak / vinc);
            if vmax > bottom then
                vmax := bottom;
            MaxValue := 0;
            MaxPeak := 0.0;
            vloc := top;
            Info := UndoInfo;
            skip := 3;
            repeat
                hloc := hmin;
                repeat
                    value := MyGetPixel(hloc, vloc);
                    if ApplyLUT then
                        value := table[value];
                    peak := value + (right - hloc) * dv - (vloc - top) * vinc;
                    if peak > MaxPeak then
                        MaxPeak := peak;
                    hloc := hloc + skip;
                until hloc > right;
                vloc := vloc + skip;
            until vloc > vmax;
            FindVinc;
            v := top;
            repeat
                hmax := 0;
                vmin := 9999;
                Info := UndoInfo;
                poly := OpenPoly;
                hbase := hstart;
                vbase := vstart;
                GetLine(left, v, DataWidth, aLine);
                if ApplyLUT then
                    ApplyTableToLine(@aLine, table, DataWidth);
                MoveTo(round(hbase), round(vbase - vscale * (aLine[0] - MinValue)));
                for i := 0 to DataWidth - 1 do begin
                        hbase := hbase + dh;
                        vbase := vbase + dv;
                        hLoc := round(hbase);
                        vLoc := round(vbase - vscale * (aLine[i] - MinValue));
                        LineTo(hloc, vloc);
                        if hloc > hmax then
                            hmax := hloc;
                        if vloc < vmin then
                            vmin := vloc;
                    end;
                LineTo(round(hbase), round(vbase));
                LineTo(round(hstart), round(vstart));
                LineTo(round(hstart), round(vstart - vscale * (aLine[0] - MinValue)));
                hmin := round(hstart);
                vmax := round(vstart);
                ClosePoly;
                ErasePoly(poly);
                FramePoly(poly);
                KillPoly(poly);
                info := SaveInfo;
                SetRect(MaskRect, hmin, vmin, hmax, vmax);
                OffscreenToScreenRect(MaskRect);
                UpdateScreen(MaskRect);
                hstart := hstart + hinc;
                vstart := vstart + vinc;
                v := v + skip;
            until (v >= bottom) or CommandPeriod;
        end; {with}
    if CommandPeriod then
        beep;
    SetForegroundColor(SaveForeground);
    SetBackgroundColor(SaveBackground);
    SetPort(tPort);
end;


procedure MakeSkeleton;
begin
    PixelsRemoved := 0;
    filter(skeletonize, true);
    if PixelsRemoved <> 0 then
        repeat
            PixelsRemoved := 0;
            filter(skeletonize, false);
        until PixelsRemoved = 0;
end;


end.