Otherware/Otherware_1_SB_Development.iso/mac/developm/source/image144.sit/Functions.p

Text File | 1992-03-30 | 44.0 KB | 1,729 lines

unit Functions;

{}

interface


    uses
        QuickDraw, Palettes, Picker, PrintTraps, globals, Utilities, Graphics, File1, File2, Analysis, Camera, Lut;


    procedure ApplyTable (var table: LookupTable);
    procedure ApplyLookupTable;
    procedure MakeBinary;
    procedure Filter (ftype: FilterType; pass: integer; var table: FateTable);
    procedure PhotoMode;
    function AllSameSize: boolean;
    procedure EnhanceContrast;
    procedure EqualizeHistogram;
    procedure Convolve (name: str255; RefNum: integer);
    procedure PlotSurface;
    procedure MakeSkeleton;
    procedure DoErosion;
    procedure DoDilation;
    procedure DoOpening;
    procedure DoClosing;
    procedure SetBinaryCount;
    procedure SetIterations;
    procedure ChangeValues (v1, v2, v3: integer);
    procedure DoPropagate (MenuItem: integer);
    procedure DoArithmetic (MenuItem: integer; constant: extended);
    procedure SortPalette (item: integer);
    procedure NewPlotSurface;


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}
        var
            line: LinePtr;
            i: integer;
    begin
        line := LinePtr(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}


procedure PutLineUsingMask (h, v, count: integer; var line: LineType);
    var
        aLine, MaskLine: LineType;
        i: integer;
        SaveInfo: InfoPtr;
begin
    if count > MaxLine then
        count := MaxLine;
    GetLine(h, v, count, aline);
    SaveInfo := Info;
    Info := UndoInfo;
    GetLine(h, v, count, MaskLine);
    for i := 0 to count - 1 do
        if MaskLine[i] = BlackIndex 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);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    if TooWide then
        exit(ApplyTable);
    ShowWatch;
    with info^.RoiRect, info^ do begin
            if RoiType <> RectRoi then
                UseMask := SetupMask
            else
                UseMask := false;
            SetupUndoFromClip;
            WhatToUndo := UndoTransform;
            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;


function DoApplyTableDialogBox: boolean;
    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;
            DoApplyTableDialogBox := false
        end
    else
        DoApplyTableDialogBox := true;
end;


procedure ApplyLookupTable;
    var
        table: LookupTable;
        ConvertingColorPic, GrayScaleImage: boolean;
        i: integer;
begin
    with info^ do begin
            GrayScaleImage := (LUTMode = Grayscale) or (LUTMode = CustomGrayscale);
            ConvertingColorPic := not GrayScaleImage and not DensitySlicing;
            if ConvertingColorPic then
                KillRoi;
            if DensitySlicing and (not macro) then begin
                    if not DoApplyTableDialogBox then
                        exit(ApplyLookupTable);
                end;
            if thresholding then
                BinaryPic := true;
            GetLookupTable(table);
            if GrayscaleImage or ConvertingColorPic then
                ResetGrayMap;
            ApplyTable(table);
            if ConvertingColorPic then
                WhatToUndo := NothingToUndo;
            if DensityCalibrated then begin
                    DensityCalibrated := false;
                    for i := 0 to 255 do
                        cvalue[i] := i;
                end;
        end; {with}
end;


procedure MakeBinary;
    var
        table: LookupTable;
        SaveBackground, SaveForeground: integer;
begin
    if not DensitySlicing and not Thresholding then
        PutMessage('Sorry, but you must be thresholding or density slicing to use Make Binary.')
    else begin
            ThresholdToForeground := true;
            NonThresholdToBackground := true;
            SaveBackground := BackgroundIndex;
            SaveForeground := ForegroundIndex;
            BackgroundIndex := WhiteIndex;
            ForegroundIndex := BlackIndex;
            GetLookupTable(table);
            ResetGrayMap;
            ApplyTable(table);
            BackgroundIndex := SaveBackground;
            ForegroundIndex := SaveForeground;
            info^.BinaryPic := true;
        end;
end;


procedure Filter (ftype: FilterType; pass: integer; var table: FateTable);
    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, trect: rect;
        L1, L2, L3, result: LineType;
        pt: point;
        a: SortArray;
        AutoSelectAll, UseMask: boolean;
        L, T, R, B, index, code: integer;
        StartTicks: LongInt;
begin
    if NotinBounds then
        exit(Filter);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        with info^ do begin
                SelectAll(false);
                SetPort(wptr);
                PenNormal;
                PenPat(pat[PatIndex]);
                FrameRect(wrect);
            end;
    if TooWide then
        exit(Filter);
    ShowWatch;
    if info^.RoiType <> RectRoi then
        UseMask := SetupMask
    else
        UseMask := false;
    if pass = 0 then begin
            SetupUndoFromClip;
            ShowMessage(CmdPeriodToStop);
            WhatToUndo := UndoFilter;
        end;
    frame := info^.RoiRect;
    StartTicks := TickCount;
    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;
                        fshadow:
                            for c := 1 to width - 2 do begin
                                    tmp := L2[C + 1] + L2[C + 2] + L3[C + 1] + L3[C + 2] * 2 - L1[C] * 2 - L1[C + 1] - L2[C];
                                    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 = BlackIndex 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 (2040 - sum) >= BinaryThreshold then
                                                center := WhiteIndex;
                                        end;
                                    result[c - 1] := center;
                                end;
                        Dilation:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = WhiteIndex 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 >= BinaryThreshold then
                                                center := BlackIndex;
                                        end;
                                    result[c - 1] := center;
                                end;
                        OutlineFilter:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = BlackIndex then begin
                                            if (L2[c] = WhiteIndex) or (L1[c + 1] = WhiteIndex) or (L2[c + 2] = WhiteIndex) or (L3[c + 1] = WhiteIndex) then
                                                center := BlackIndex
                                            else
                                                center := WhiteIndex;
                                        end;
                                    result[c - 1] := center;
                                end;

                        Skeletonize:
                            for c := 1 to width - 2 do begin
                                    center := L2[c + 1];
                                    if center = BlackIndex then begin
                                            index := 0;
                                            if L1[c] = BlackIndex then
                                                index := bor(index, 1);
                                            if L1[c + 1] = BlackIndex then
                                                index := bor(index, 2);
                                            if L1[c + 2] = BlackIndex then
                                                index := bor(index, 4);
                                            if L2[c + 2] = BlackIndex then
                                                index := bor(index, 8);
                                            if L3[c + 2] = BlackIndex then
                                                index := bor(index, 16);
                                            if L3[c + 1] = BlackIndex then
                                                index := bor(index, 32);
                                            if L3[c] = BlackIndex then
                                                index := bor(index, 64);
                                            if L2[c] = BlackIndex then
                                                index := bor(index, 128);
                                            code := table[index];
                                            if odd(pass) then begin
                                                    if (code = 2) or (code = 3) then begin
                                                            center := WhiteIndex;
                                                            PixelsRemoved := PixelsRemoved + 1;
                                                        end;
                                                end
                                            else begin {even pass}
                                                    if (code = 1) or (code = 3) then begin
                                                            center := WhiteIndex;
                                                            PixelsRemoved := PixelsRemoved + 1;
                                                        end;
                                                end;
                                        end; {if}
                                    result[c - 1] := center;
                                end; {for}
                    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;
                            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;
                                    if AutoSelectAll then
                                        KillRoi;
                                    exit(filter)
                                end;
                        end;
                end; {for row:=...}
            trect := frame;
            InsetRect(trect, 1, 1);
            ShowTime(StartTicks, trect, '');
        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 the background color and then redraws}
{the contents of the active image window . }
    var
        tPort: GrafPtr;
        event: EventRecord;
        WinRect: rect;
        SaveVisRgn: rgnHandle;
begin
    if info <> NoInfo then
        with info^ do begin
                KillRoi;
                if OptionKeyWasDown 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 WaitNextEvent(mDownMask + KeyDownMask, Event, 5, nil);
                with wptr^ do begin
                        DisposeRgn(visRgn);
                        visRgn := SaveVisRgn;
                    end;
                RestoreScreen;
                SetPort(tPort);
                FlushEvents(EveryEvent, 0);
                if OptionKeyWasDown then begin
                        MoveWindow(wptr, WinRect.left, WinRect.top, false);
                    end;
            end
    else
        beep;
end;


function AllSameSize: boolean;
{Returns true if all currently open Images have the same dimensions.}
    var
        i: integer;
        SameSize: Boolean;
        TempInfo: InfoPtr;
begin
    if nPics = 0 then begin
            AllSameSize := false;
            exit(AllSameSize);
        end;
    SameSize := true;
    for i := 1 to nPics do begin
            TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon);
            SameSize := SameSize and EqualRect(Info^.PicRect, TempInfo^.PicRect);
        end;
    AllSameSize := SameSize;
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
                SetupLutUndo;
                ColorStart := min;
                ColorEnd := max;
                DrawMap;
                UpdateLUT;
                changes := true;
                IdentityFunction := false;
            end;
    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;
    FindThresholdingMode;
    ComputeResults;
    isum := 0;
    for i := 0 to 255 do
        isum := isum + histogram[i];
    ScaleFactor := 255.0 / isum;
    sum := 0;
    with info^ do begin
            SetupLutUndo;
            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;
            SetupPseudocolor;
            changes := true;
            DrawMap;
            IdentityFunction := false;
        end; {with info}
    if AutoSelectAll then
        KillRoi;
end;


procedure GetKernel (var kernel: ktype; var n: integer; var name: str255; RefNum: integer);
    var
        rLine: rLineType;
        i, count, nValues, nRows: integer;
begin
    count := 0;
    nRows := 0;
    InitTextInput(name, RefNum);
    while not TextEof and (nRows <= 63) do begin
            GetLineFromText(rLine, nValues);
            if count <> 0 then
                nRows := nRows + 1;
            if nRows = 1 then
                n := nValues;
            for i := 1 to nValues do begin
                    count := count + 1;
                    kernel[count - 1] := round(rLine[i]);
                end;
        end;
    if count <> (n * n) then
        n := 0;
end;


procedure DoOnePixel (nLess1, BytesPerLine: 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 + BytesPerLine;
            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=BytesPerLine}
{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);
    const
        skip = 7;
    var
        row, width, column, value, error: integer;
        margin, i, nless1: integer;
        frame, MaskRect, tRect: rect;
        AutoSelectAll, ScalingNeeded: boolean;
        SrcCenter, DstCenter, sum, max, offset, wsum, cscale, StartTicks: LongInt;
        MinResult, MaxResult: LongInt;
        p: ptr;
        str, str2: str255;
        ScaleFactor: extended;
begin
    if NotinBounds or NotRectangular then
        exit(DoConvolution);
    StopDigitizing;
    AutoSelectAll := not Info^.RoiShowing;
    if AutoSelectAll then
        SelectAll(false);
    SetupUndoFromClip;
    WhatToUndo := UndoFilter;
    frame := info^.RoiRect;
    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;
            SetPort(wptr);
            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);
            NumToString(wsum, str2);
            ValuesMessage := Concat(str, ' x ', str, ' kernel', cr, 'sum = ', str2, cr, cr, CmdPeriodToStop);
            ShowValues;
            if wsum <> 0 then
                cscale := wsum
            else
                cscale := 1;
            offset := -(n div 2) * BytesPerRow - BytesPerRow - n div 2;
            nless1 := n - 1;
            StartTicks := TickCount;
            str := '';
            if ScaleConvolutions then begin
                    MinResult := MaxLongInt;
                    MaxResult := -MaxLongInt;
                    row := top;
                    while row < bottom do begin
                            SrcCenter := ord4(ClipBufInfo^.PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                            column := left;
                            while column < (left + width) do begin
                                    DoOnePixel(nless1, BytesPerRow, SrcCenter + offset, sum, kernel);
                                    value := sum div cscale;
                                    if value < MinResult then
                                        MinResult := value;
                                    if value > MaxResult then
                                        MaxResult := value;
                                    SrcCenter := SrcCenter + skip;
                                    column := column + skip;
                                end; {while column}
                            row := row + skip;
                        end; {while row...}
                    ScalingNeeded := (MinResult < 0) or (MaxResult > 255);
                    if ScalingNeeded then
                        ScaleFactor := 253.0 / (MaxResult - MinResult)
                    else
                        ScaleFactor := 1.0;
                    RealToString(ScaleFactor, 1, 4, str);
                    str := concat('min=', long2str(MinResult), cr, 'max=', long2str(MaxResult), cr, 'scale factor= ', str);
                    for row := top to bottom - 1 do begin
                            SrcCenter := ord4(ClipBufInfo^.PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                            DstCenter := ord4(PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                            for column := left to left + width - 1 do begin
                                    DoOnePixel(nless1, BytesPerRow, SrcCenter + offset, sum, kernel);
                                    value := sum div cscale;
                                    if ScalingNeeded then begin
                                            if value < MinResult then
                                                value := MinResult;
                                            if value > MaxResult then
                                                value := MaxResult;
                                            value := round((value - MinResult) * ScaleFactor + 1);
                                        end;
                                    p := ptr(DstCenter);
                                    p^ := BAND(value, 255);
                                    SrcCenter := SrcCenter + 1;
                                    DstCenter := DstCenter + 1;
                                end; {for column:=}
                            SetRect(MaskRect, left, row, right, row + 1);
                            UpdateScreen(MaskRect);
                            if CommandPeriod then begin
                                    UpdatePicWindow;
                                    beep;
                                    exit(DoConvolution)
                                end;
                        end; {for row:=...}
                end  {Scale Convolutions}
            else
                for row := top to bottom - 1 do begin
                        SrcCenter := ord4(ClipBufInfo^.PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                        DstCenter := ord4(PicBaseAddr) + LongInt(row) * BytesPerRow + left;
                        for column := left to left + width - 1 do begin
                                DoOnePixel(nless1, BytesPerRow, SrcCenter + offset, sum, kernel);
                                value := sum div cscale;
                                if value < MinResult then
                                    MinResult := value;
                                if value > MaxResult then
                                    MaxResult := value;
                                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);
                        UpdateScreen(MaskRect);
                        if CommandPeriod then begin
                                UpdatePicWindow;
                                beep;
                                exit(DoConvolution)
                            end;
                    end; {for row:=...}
            ShowTime(StartTicks, frame, str);
        end; {with}
    UpdatePicWindow;
    SetupRoiRect;
    if AutoSelectAll then
        KillRoi;
end;


procedure Convolve (name: str255; RefNum: integer);
    var
        kernel: ktype;
        n, count: integer;
begin
    if name = '' then begin
            if not OpenTextFile(name, RefNum) then
                exit(convolve)
            else
                KernelsRefNum := RefNum;
        end;
    DisableDensitySlice;
    GetKernel(kernel, n, name, RefNum);
    count := n * n;
    UpdatePicWindow;
    if (n >= 3) and (n <= 63) then
        DoConvolution(kernel, n)
    else
        PutMessage('Kernels must be n x n square matrices with 3 <= n <= 63.');
end;


procedure PlotSurface;
    var
        hend, vend, h, v, DataWidth, DataHeight, i: integer;
        htemp, vtemp, ivalue: integer;
        skip, DataLeft, DataRight, DataTop, DataBottom: integer;
        hLoc, vLoc, hMin, hMax, vMin, vMax, MinIValue, MaxIValue: integer;
        hstart, vstart, dh, dv, hbase, vbase, vscale, nPlotLines, CalValue: extended;
        peak, MaxPeak, hinc, vinc, nLines, MinCValue, MaxCValue: extended;
        poly: PolyHandle;
        SaveInfo, PlotInfo: InfoPtr;
        aLine: LineType;
        MaskRect: rect;
        AutoSelectAll, ApplyLUT: boolean;
        table: LookupTable;
        StartTicks: LongInt;

    procedure FindVinc;
    begin
        with PlotInfo^.PicRect do begin
                vstart := 5.0 + MaxPeak - 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(PlotSurface);
    StopDigitizing;
    DisableDensitySlice;
    SetForegroundColor(BlackIndex);
    SetBackgroundColor(WhiteIndex);
    SaveInfo := Info;
    if not NewPicWindow('Surface Plot', NewPicWidth, NewPicHeight) then begin
            KillRoi;
            exit(PlotSurface)
        end;
    PlotInfo := info;
    info := SaveInfo;
    AutoSelectAll := not Info^.RoiShowing;
    ShowWatch;
    if AutoSelectAll then
        SelectAll(true);
    if TooWide then
        exit(PlotSurface);
    with info^ do
        ApplyLUT := ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction);
    if ApplyLUT then
        GetLookupTable(table);
    Measure;
    UndoLastMeasurement(true);
    with results do begin
            MinIValue := MinIndex;
            MaxIValue := MaxIndex;
        end;
    if ApplyLut then begin
            MinIvalue := table[MinIValue];
            MaxIvalue := table[MaxIValue];
        end;
    MinCValue := 10e100;
    MaxCValue := -10e100;
    for i := MinIValue to MaxIValue do begin
            ivalue := i;
            if ApplyLUT then
                ivalue := table[ivalue];
            calValue := cvalue[i];
            if calValue < minCValue then
                minCValue := calValue;
            if calValue > maxCValue then
                maxCValue := calValue;
        end;
    WhatToUndo := NothingToUndo;
    with results do
        if (MaxValue - MinValue) <> 0.0 then
            vscale := (255.0 / (MaxValue - MinValue)) * 0.5
        else
            vscale := 0.5;
    with info^.RoiRect do begin
            DataLeft := left;
            DataRight := right;
            DataTop := top;
            DataBottom := bottom;
            DataWidth := DataRight - DataLeft;
            DataHeight := DataBottom - DataTop;
        end;
    dh := (0.65 * PlotInfo^.PicRect.right) / DataWidth;
    dv := -0.4 * dh;
    hstart := 5.0;
    vinc := 2.0;
    MaxPeak := (MaxCValue - MinCValue) * vscale * 0.5;
    FindVinc; {First estimate}
    MaxPeak := MaxPeak * 2.0;
    hmin := DataRight + round(MaxPeak / dv);
    if hmin < 0 then
        hmin := 0;
    vmax := DataTop + round(MaxPeak / vinc);
    if vmax > DataBottom then
        vmax := DataBottom;
    MaxPeak := 0.0;
    vloc := DataTop;
    skip := 3;
    repeat
        hloc := hmin;
        repeat
            ivalue := MyGetPixel(hloc, vloc);
            if ApplyLUT then
                ivalue := table[ivalue];
            calValue := cvalue[ivalue];
            peak := (calValue - MinCValue) * vscale + (DataRight - hloc) * dv - (vloc - DataTop) * vinc;
            if peak > MaxPeak then
                MaxPeak := peak;
            hloc := hloc + skip;
        until hloc > DataRight;
        vloc := vloc + skip;
    until vloc > vmax;
    FindVinc;
    v := DataTop;
    StartTicks := TickCount;
    SetPort(GrafPtr(PlotInfo^.osPort));
    PenNormal;
    repeat
        hmax := 0;
        vmin := 9999;
        poly := OpenPoly;
        hbase := hstart;
        vbase := vstart;
        Info := SaveInfo;
        GetLine(DataLeft, v, DataWidth, aLine);
        info := PlotInfo;
        if ApplyLUT then
            ApplyTableToLine(@aLine, table, DataWidth);
        MoveTo(round(hbase), round(vbase - vscale * (cvalue[aLine[0]] - MinCValue)));
        for i := 0 to DataWidth - 1 do begin
                hbase := hbase + dh;
                vbase := vbase + dv;
                hLoc := round(hbase);
                vLoc := round(vbase - vscale * (cvalue[aLine[i]] - MinCValue));
                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 * (cvalue[aLine[0]] - MinCValue)));
        hmin := round(hstart);
        vmax := round(vstart);
        ClosePoly;
        ErasePoly(poly);
        FramePoly(poly);
        KillPoly(poly);
        SetRect(MaskRect, hmin, vmin, hmax, vmax);
        UpdateScreen(MaskRect);
        hstart := hstart + hinc;
        vstart := vstart + vinc;
        v := v + skip;
    until (v >= DataBottom) or CommandPeriod;
    ShowTime(StartTicks, SaveInfo^.RoiRect, '');
    if CommandPeriod then
        beep;
    info^.changes := true;
end;


procedure NewPlotSurface;
    var
        hend, vend, h, v, DataWidth, DataHeight, i: integer;
        htemp, vtemp, ivalue, dh, dv, hbase, vbase: integer;
        skip, DataLeft, DataRight, DataTop, DataBottom: integer;
        hLoc, vLoc, hMin, hMax, vMin, vMax, MinIValue, MaxIValue: integer;
        hstart, vstart, vscale, nPlotLines, CalValue, edh, edv: extended;
        peak, MaxPeak, hinc, vinc, nLines, MinCValue, MaxCValue: extended;
        poly: PolyHandle;
        SaveInfo, PlotInfo: InfoPtr;
        aLine: LineType;
        MaskRect: rect;
        AutoSelectAll, ApplyLUT: boolean;
        table: LookupTable;
        StartTicks: LongInt;

    procedure FindVinc;
    begin
        with PlotInfo^.PicRect do begin
                vstart := 5.0 + MaxPeak - edv * 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 + edh * DataWidth) < right;
            end;
    end;

begin
    if NotRectangular or NotInBounds then
        exit(NewPlotSurface);
    StopDigitizing;
    DisableDensitySlice;
    SetForegroundColor(BlackIndex);
    SetBackgroundColor(WhiteIndex);
    SaveInfo := Info;
    if not NewPicWindow('Surface Plot', NewPicWidth, NewPicHeight) then begin
            KillRoi;
            exit(NewPlotSurface)
        end;
    PlotInfo := info;
    info := SaveInfo;
    AutoSelectAll := not Info^.RoiShowing;
    ShowWatch;
    if AutoSelectAll then
        SelectAll(true);
    if TooWide then
        exit(NewPlotSurface);
    with info^ do
        ApplyLUT := ((LutMode = GrayScale) or (LutMode = CustomGrayscale)) and (not IdentityFunction);
    if ApplyLUT then
        GetLookupTable(table);
    Measure;
    UndoLastMeasurement(true);
    with results do begin
            MinIValue := MinIndex;
            MaxIValue := MaxIndex;
        end;
    if ApplyLut then begin
            MinIvalue := table[MinIValue];
            MaxIvalue := table[MaxIValue];
        end;
    MinCValue := 10e100;
    MaxCValue := -10e100;
    for i := MinIValue to MaxIValue do begin
            ivalue := i;
            if ApplyLUT then
                ivalue := table[ivalue];
            calValue := cvalue[i];
            if calValue < minCValue then
                minCValue := calValue;
            if calValue > maxCValue then
                maxCValue := calValue;
        end;
    WhatToUndo := NothingToUndo;
    with results do
        if (MaxValue - MinValue) <> 0.0 then
            vscale := (255.0 / (MaxValue - MinValue)) * 0.5
        else
            vscale := 0.5;
    with info^.RoiRect do begin
            DataLeft := left;
            DataRight := right;
            DataTop := top;
            DataBottom := bottom;
            DataWidth := DataRight - DataLeft;
            DataHeight := DataBottom - DataTop;
        end;
    edh := (0.65 * PlotInfo^.PicRect.right) / DataWidth;
    dh := round(edh);
    edv := -0.4 * edh;
    dv := round(edv);
    hstart := 5.0;
    vinc := 2.0;
    MaxPeak := (MaxCValue - MinCValue) * vscale * 0.5;
    FindVinc; {First estimate}
    MaxPeak := MaxPeak * 2.0;
    hmin := DataRight + round(MaxPeak / edv);
    if hmin < 0 then
        hmin := 0;
    vmax := DataTop + round(MaxPeak / vinc);
    if vmax > DataBottom then
        vmax := DataBottom;
    MaxPeak := 0.0;
    vloc := DataTop;
    skip := 3;
    repeat
        hloc := hmin;
        repeat
            ivalue := MyGetPixel(hloc, vloc);
            if ApplyLUT then
                ivalue := table[ivalue];
            calValue := cvalue[ivalue];
            peak := (calValue - MinCValue) * vscale + LongInt(DataRight - hloc) * dv - (vloc - DataTop) * vinc;
            if peak > MaxPeak then
                MaxPeak := peak;
            hloc := hloc + skip;
        until hloc > DataRight;
        vloc := vloc + skip;
    until vloc > vmax;
    FindVinc;
    v := DataTop;
    StartTicks := TickCount;
    SetPort(GrafPtr(PlotInfo^.osPort));
    PenNormal;
    repeat
        hmax := 0;
        vmin := 9999;
        poly := OpenPoly;
        hbase := round(hstart);
        vbase := round(vstart);
        Info := SaveInfo;
        GetLine(DataLeft, v, DataWidth, aLine);
        info := PlotInfo;
        if ApplyLUT then
            ApplyTableToLine(@aLine, table, DataWidth);
        MoveTo(hbase, vbase - round(vscale * (cvalue[aLine[0]] - MinCValue)));
        for i := 0 to DataWidth - 1 do begin
                hbase := hbase + dh;
                vbase := vbase + dv;
                hLoc := hbase;
                vLoc := vbase - round(vscale * (cvalue[aLine[i]] - MinCValue));
                LineTo(hloc, vloc);
                if hloc > hmax then
                    hmax := hloc;
                if vloc < vmin then
                    vmin := vloc;
            end;
        LineTo(hbase, vbase);
        LineTo(round(hstart), round(vstart));
        LineTo(round(hstart), round(vstart - vscale * (cvalue[aLine[0]] - MinCValue)));
        hmin := round(hstart);
        vmax := round(vstart);
        ClosePoly;
        ErasePoly(poly);
        FramePoly(poly);
        KillPoly(poly);
        SetRect(MaskRect, hmin, vmin, hmax, vmax);
        UpdateScreen(MaskRect);
        hstart := hstart + hinc;
        vstart := vstart + round(vinc);
        v := v + skip;
    until (v >= DataBottom) or CommandPeriod;
    ShowTime(StartTicks, SaveInfo^.RoiRect, '');
    if CommandPeriod then
        beep;
    info^.changes := true;
end;


procedure MakeSkeleton;
{This table-driven parallel thinning routine is based on an algorithm}
{by Zhang and Suen(CACM, March 1984, 236-239). There is}
{an entry in the table for each of the 256 possible 3x3 neighborhood}
{configurations. An entry of '1' means delete pixel on first pass, '2' means}
{delete pixel on second pass, and '3' means delete on either pass. There is a}
{routine in 'user.p' that will draw all 256 neighborhoods.}
    const
        s999 = '01234567890123456789012345678901';
        s000 = '00030033003130330000000030203033';
        s032 = '00000000300000003000000030003022';
        s064 = '00000000000000000000000000000000';
        s096 = '30000000200020003000000030003020';
        s128 = '03330013000000010000000000000001';
        s160 = '31000000000000002000000000000000';
        s192 = '33130013000000010000000000000000';
        s224 = '3301000100000000330100002200200';
    var
        table: FateTable;
        s: str255;
        i, pass: integer;
begin
    s := concat(s000, s032, s064, s096, s128, s160, s192, s224);
    for i := 0 to 254 do
        table[i] := ord(s[i + 1]) - ord('0');
    table[255] := 0;
    pass := 0;
    repeat
        PixelsRemoved := 0;
        filter(skeletonize, pass, table);
        pass := pass + 1;
        if not CommandPeriod then
            filter(skeletonize, pass, table);
        pass := pass + 1;
    until (PixelsRemoved = 0) or CommandPeriod;
end;


procedure DoErosion;
    var
        i: integer;
        t: FateTable;
begin
    for i := 0 to BinaryIterations - 1 do begin
            filter(Erosion, i, t);
            if CommandPeriod then
                leave;
        end;
end;


procedure DoDilation;
    var
        i: integer;
        t: FateTable;
begin
    for i := 0 to BinaryIterations - 1 do begin
            filter(Dilation, i, t);
            if CommandPeriod then
                leave;
        end;
end;


procedure DoOpening;
    var
        i: integer;
        t: FateTable;
begin
    for i := 0 to BinaryIterations - 1 do begin
            filter(Erosion, i, t);
            if CommandPeriod then
                exit(DoOpening);
        end;
    for i := 0 to BinaryIterations - 1 do begin
            filter(Dilation, i + BinaryIterations, t);
            if CommandPeriod then
                exit(DoOpening);
        end;
end;

procedure DoClosing;
    var
        i: integer;
        t: FateTable;
begin
    for i := 0 to BinaryIterations - 1 do begin
            filter(Dilation, i, t);
            if CommandPeriod then
                exit(DoClosing);
        end;
    for i := 0 to BinaryIterations - 1 do begin
            filter(Erosion, i + BinaryIterations, t);
            if CommandPeriod then
                exit(DoClosing);
        end;
end;

procedure SetBinaryCount;
    var
        TempCount: integer;
        Canceled: boolean;
begin
    TempCount := GetInt('Neighborhood Pixel Count(1-8):', BinaryCount, Canceled);
    if Canceled then
        exit(SetBinaryCount);
    if (TempCount >= 1) and (TempCount <= 8) then begin
            BinaryCount := TempCount;
            BinaryThreshold := BinaryCount * 255
        end
    else
        beep;
end;

procedure SetIterations;
    var
        TempIterations: integer;
        Canceled: boolean;
begin
    TempIterations := GetInt('Number of Iterations:', BinaryIterations, Canceled);
    if Canceled then
        exit(SetIterations);
    if (TempIterations >= 1) and (TempIterations < 100) then
        BinaryIterations := TempIterations
    else
        beep;
end;

procedure ChangeValues (v1, v2, v3: integer);
  {Changes all pixels in the current selection with a value in the range v1 to v2 to a value of v3.}
    var
        id, i, value: integer;
        table: LookupTable;
begin
    if macro then
        id := ok
    else begin
            ParamText(long2str(v1), long2str(v3), '', '');
            id := alert(700, nil);
        end;
    if id = ok then begin
            for i := 0 to 255 do begin
                    value := i;
                    if (value >= v1) and (value <= v2) then
                        value := v3;
                    table[i] := value;
                end;
            ApplyTable(table);
        end;
end;

procedure DoPropagate (MenuItem: integer);
      {Copies the current Look-Up Table, spatial calibration, or density calibration to all open windows.}
    var
        TempInfo: InfoPtr;
        i: integer;

    procedure CopyLUTInfo;
    begin
        with info^ do begin
                TempInfo^.RedLUT := RedLUT;
                TempInfo^.GreenLUT := GreenLUT;
                TempInfo^.BlueLUT := BlueLUT;
                TempInfo^.ColorStart := ColorStart;
                TempInfo^.ColorEnd := ColorEnd;
                TempInfo^.nColors := nColors;
                TempInfo^.LutMode := LUTMode;
                TempInfo^.cTable := cTable;
            end;
    end;

    procedure CopySpatialCalibration;
        var
            SaveInfo: InfoPtr;
    begin
        with info^ do begin
                TempInfo^.xSpatialScale := xSpatialScale;
                TempInfo^.ySpatialScale := ySpatialScale;
                TempInfo^.PixelAspectRatio := PixelAspectRatio;
                TempInfo^.RawspatialScale := RawspatialScale;
                TempInfo^.ScaleMagnification := ScaleMagnification;
                TempInfo^.Units := Units;
                TempInfo^.UnitsID := UnitsID;
                TempInfo^.FullUnits := FullUnits;
                TempInfo^.changes := true;
                TempInfo^.SpatiallyCalibrated := SpatiallyCalibrated;
            end;
        SaveInfo := Info;
        Info := TempInfo;
        UpdateTitleBar;
        Info := SaveInfo;
    end;

    procedure CopyDensityCalibration;
        var
            SaveInfo: InfoPtr;
    begin
        with info^ do begin
                TempInfo^.DensityCalibrated := DensityCalibrated;
                TempInfo^.ZeroClip := ZeroClip;
                TempInfo^.fit := fit;
                TempInfo^.nCoefficients := nCoefficients;
                TempInfo^.Coefficient := Coefficient;
                TempInfo^.UnitOfMeasure := UnitOfMeasure;
                TempInfo^.changes := true;
            end;
        SaveInfo := Info;
        Info := TempInfo;
        UpdateTitleBar;
        Info := SaveInfo;
    end;

begin
    for i := 1 to nPics do begin
            TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon);
            case MenuItem of
                1:
                    CopyLUTInfo;
                2:
                    CopySpatialCalibration;
                3:
                    CopyDensityCalibration;
            end; {case}
        end;
    WhatToUndo := NothingToUndo;
end;

procedure DoArithmetic (MenuItem: integer; constant: extended);
    var
        table: LookupTable;
        i: integer;
        tmp: LongInt;
        LogScale: extended;
        Canceled: boolean;
begin
    canceled := false;
    if not macro then
        case menuItem of
            AddItem:
                constant := GetReal('Constant to add:', 25, Canceled);
            SubtractItem:
                constant := GetReal('Constant to subtract:', 25, Canceled);
            MultiplyItem:  begin
                    constant := GetReal('Constant to multiply by:', 1.25, Canceled);
                    if constant < 0.0 then begin
                            PutMessage('Constant must be positive.');
                            exit(DoArithmetic);
                        end;
                end;
            DivideItem:  begin
                    constant := GetReal('Constant to divide by:', 1.25, Canceled);
                    if constant <= 0.0 then begin
                            PutMessage('Constant must be nonzero and positive.');
                            exit(DoArithmetic);
                        end;
                end;
            LogItem:  begin
                    constant := 0.0;
                    LogScale := 255.0 / ln(255.0);
                end;
        end; {case}
    if Canceled then
        exit(DoArithmetic);
    for i := 0 to 255 do begin
            case MenuItem of
                AddItem:
                    tmp := round(i + constant);
                SubtractItem:
                    tmp := round(i - constant);
                MultiplyItem:
                    tmp := round(i * constant);
                DivideItem:
                    tmp := round(i / constant);
                LogItem:
                    if i = 0 then
                        tmp := 0
                    else
                        tmp := round(ln(i) * LogScale);
            end;
            if tmp < 0 then
                tmp := 0;
            if tmp > 255 then
                tmp := 255;
            table[i] := tmp;
        end;
    ApplyTable(table);
end;


procedure SortPalette (item: integer);
    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;
     {Selection sort routine from "Algorithms" by Robert Sedgewick.}
        var
            i, j, min: integer;
            t: HSVRec;
    begin
        for i := 2 to 254 do begin
                min := i;
                for j := i + 1 to 245 do
                    if HSVArray[j].hsv.lHue < HSVArray[min].hsv.lHue then
                        min := j;
                t := HSVArray[min];
                HSVArray[min] := HSVArray[i];
                HSVArray[i] := t;
            end;
    end;

    procedure SortBySaturation;
        var
            i, j, min: integer;
            t: HSVRec;
    begin
        for i := 2 to 254 do begin
                min := i;
                for j := i + 1 to 245 do
                    if HSVArray[j].hsv.lSaturation < HSVArray[min].hsv.lSaturation then
                        min := j;
                t := HSVArray[min];
                HSVArray[min] := HSVArray[i];
                HSVArray[i] := t;
            end;
    end;

    procedure SortByValue;
        var
            i, j, min: integer;
            t: HSVRec;
    begin
        for i := 2 to 254 do begin
                min := i;
                for j := i + 1 to 245 do
                    if HSVArray[j].hsv.lValue < HSVArray[min].hsv.lValue then
                        min := j;
                t := HSVArray[min];
                HSVArray[min] := HSVArray[i];
                HSVArray[i] := t;
            end;
    end;

begin
    ShowWatch;
    DisableDensitySlice;
    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;
            case item of
                byHueItem:
                    SortByHue;
                bySaturationItem:
                    SortBySaturation;
                byBrightnessItem:
                    SortByValue;
            end;
            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;
            SetupPseudocolor;
        end; {with}
end;


end.