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

Text File | 1995-02-08 | 10.4 KB | 459 lines | [TEXT/PJMM]

program Precog; {but I think LifeEdit is a better description /Ingemar}

{• An itty bitty bytes™ revival project, updated by Kenneth A. Long.}
{• Made to run in Symantec's THINK C™ on 27 December 1994.}
{• Original author unknown.  Original source for Aztec C.}

{More fun with Pascal! And simpler code! And update events! And draggable window!}
{Fixed by Ingemar jan 1995. No color support, though.}

    const
        lastMenu = 3;
        appleMenu = 1;
        fileMenu = 2;
        optMenu = 3;
        iQuit = 1;
        windowID = 260;

    const
        hSize = 36;
        vSize = 36;
        hSizePlus1 = 37;
        vSizePlus1 = 37;
        hSpace = 169 + 8;
        vSpace = 158;
        pixSize = 4;

    function max (a, b: Integer): Integer;
    begin
        if a > b then
            max := a
        else
            max := b;
    end;
    function min (a, b: Integer): Integer;
    begin
        if a < b then
            min := a
        else
            min := b;
    end;

    var
        myMenus: array[1..lastMenu] of MenuHandle;
        userDone: Boolean;
        screenPort: GrafPtr;
        myWindow: WindowPtr;
        myEvent: EventRecord;
        whichWindow: WindowPtr;
        windowCode: Integer;

    type
        GenArr = array[0..vSizePlus1, 0..hSizePlus1] of Boolean;

    var
        gen1, gen2, gen3, gen4, gen5, gen6: GenArr;
        mouseLoc: Point;
        textRect: Rect;
        oldX, oldY: LongInt;


{*** SetUpMenus - set up menus.}

    procedure SetUpMenus;
        var
            i: Integer;
    begin
        for i := 1 to lastMenu do
            myMenus[i] := GetMenu(i);

        AddResMenu(myMenus[appleMenu], 'DRVR');

        for i := 1 to lastMenu do
            InsertMenu(myMenus[i], 0);

        DrawMenuBar;
    end; {SetUpMenus}


{*** SetUp - init toolbox and the window.}

    procedure SetUp;
    begin
{$ifc undefined THINK_PASCAL}
        InitGraf(@thePort);
        InitFonts;
        InitWindows;
        InitMenus;
        TEInit;
        InitDialogs(nil);
{$endc}
        InitCursor;
        SetEventMask(everyEvent - keyUpMask);
        SetUpMenus;
        myWindow := GetNewWindow(windowID, nil, WindowPtr(-1));
        SetPort(myWindow);
    end; {SetUp}


{*** Life - process one step of the Life algorithm.}

    function Life (h, v: Integer; genPtr: GenArr): Boolean;
        var
            neighbor: Integer;
    begin
        neighbor := 0;
        if genPtr[v - 1, h - 1] then
            neighbor := neighbor + 1;
        if genPtr[v - 1, h] then
            neighbor := neighbor + 1;
        if genPtr[v - 1, h + 1] then
            neighbor := neighbor + 1;
        if genPtr[v, h - 1] then
            neighbor := neighbor + 1;
        if genPtr[v, h + 1] then
            neighbor := neighbor + 1;
        if genPtr[v + 1, h - 1] then
            neighbor := neighbor + 1;
        if genPtr[v + 1, h] then
            neighbor := neighbor + 1;
        if genPtr[v + 1, h + 1] then
            neighbor := neighbor + 1;

        Life := (neighbor = 3) or (genPtr[v][h] and (neighbor = 2));
    end; {Life}


{*** NextGeneration - Process a rectangle with the Life algorithm}

    procedure NextGeneration (minH, minV, maxH, maxV: Integer; var srcGen, destGen: GenArr);
        var
            left, right, up, down: Integer;
            i, j: Integer;
    begin
        left := max(minH, 1);
        right := min(maxH, hSize);
        up := max(minV, 1);
        down := min(maxV, vSize);
        for i := up to down do
            for j := left to right do
                destGen[i, j] := Life(j, i, srcGen);
    end; {NextGeneration}


{*** DrawGen - Draw all or part of a generation array}

    procedure DrawGen (minH, minV, maxH, maxV: Integer; var gen: GenArr; offH, offV: Integer; drawWhite: Boolean);
        var
            left, right, up, down: Integer;
            i, j: Integer;
            patPtr2: Pattern;
            cell: Rect;
    begin
        left := max(minH, 1);
        right := min(maxH, hSize);
        up := max(minV, 1);
        down := min(maxV, vSize);
        for i := up to down do
            for j := left to right do
                begin
                    if not gen[i, j] then
                        patPtr2 := white
                    else
                        patPtr2 := black;
                    if gen[i, j] or drawWhite then
                        begin
                            cell.top := i * pixSize + offV;
                            cell.left := j * pixSize + offH;
                            cell.bottom := i * pixSize + offV + pixSize - 1;
                            cell.right := j * pixSize + offH + pixSize - 1;
                            FillRect(cell, patPtr2);
                        end;
                end;
    end; {DrawGen}


{*** Update - handle update events.}

    procedure Update;
        var
            i, j: Integer;
            box: Rect;
    begin
        BeginUpdate(myWindow);
        EraseRect(myWindow^.portRect);
        for i := 1 to 2 do
            for j := 1 to 3 do
                begin
                    SetRect(box, hSpace * (j - 1) + 2, vSpace * (i - 1) + 2, hSpace * (j - 1) + hSize * pixSize + 5, vSpace * (i - 1) + vSize * pixSize + 5);
                    FrameRect(box);
                end;
        DrawGen(1, 1, hSize, vSize, gen1, 0, 0, false);
        DrawGen(1, 1, hSize, vSize, gen2, hSpace, 0, false);
        DrawGen(1, 1, hSize, vSize, gen3, hSpace * 2, 0, false);
        DrawGen(1, 1, hSize, vSize, gen4, 0, vSpace, false);
        DrawGen(1, 1, hSize, vSize, gen5, hSpace, vSpace, false);
        DrawGen(1, 1, hSize, vSize, gen6, hSpace * 2, vSpace, false);
        EndUpdate(myWindow);
    end; {Update}


{*** Clear - erase everything.}

    procedure Clear;
        var
            i, j: Integer;
    begin
        for i := 0 to vSize + 1 do
            for j := 0 to hSize + 1 do
                begin
                    gen1[i][j] := false;
                    gen2[i][j] := false;
                    gen3[i][j] := false;
                    gen4[i][j] := false;
                    gen5[i][j] := false;
                    gen6[i][j] := false;
                end;
        InvalRect(myWindow^.portRect);
{Update;}
    end; {Clear}


{*** DoAbout - show the About message.}

    procedure DoAbout;
        const
            line01 = 'An itty bitty bytes™ revival project, brought back from the dead by';
            line02 = 'Kenneth A. Long on 27 December 1994.';
            line03 = 'Author unknown - found in a file on:';
            line04 = 'ftp mrcnext.cso.uiuc.edu /pub/mac/MUG, called "life editor"';
            line05 = 'Added DoAbout routine and fixed up the mouse position';
            line06 = 'indicator (no need for ANSI lib) and modernized the code (a little).';
            line07 = 'Click to return.';
            line08 = 'Improved further, in a couple of ways, by Ingemar january 1995.';
    begin
        EraseRect(myWindow^.portRect);
        MoveTo(20, 20);
        DrawString(line01);
        MoveTo(20, 30);
        DrawString(line02);

        MoveTo(20, 50);
        DrawString(line03);
        MoveTo(20, 60);
        DrawString(line04);

        MoveTo(20, 80);
        DrawString(line05);
        MoveTo(20, 90);
        DrawString(line06);

        MoveTo(20, 120);
        DrawString(line07);

        MoveTo(20, 180);
        DrawString(line08);

        while not Button do
            ;
        InvalRect(myWindow^.portRect);
        Update;
    end; {DoAbout}


{*** DoCommand - handle menu selections.}

    function DoCommand (mResult: LongInt): Boolean;
        var
            refNum: Integer;
            theMenu: Integer;
            theItem: Integer;
            name: Str255;
            savePort: GrafPtr;
            returns: Boolean;

    begin
        returns := false;
        theMenu := HiWord(mResult); {• Menu.}
        theItem := LoWord(mResult); {• Item.}
        case theMenu of
            0:
                ;
            appleMenu:
                if theItem = 1 then
                    DoAbout
                else
                    begin
                        GetPort(savePort);
                        GetItem(myMenus[appleMenu], theItem, name);
                        refNum := OpenDeskAcc(name);
                        SetPort(savePort);
                    end;
            fileMenu:
                returns := true;
            optMenu:
                Clear;
        end; {case}
        HiliteMenu(0);
        DoCommand := returns;
    end; {DoCommand}


{*** Edit - process a mouse down in the editable area.}

    procedure Edit;
        var
            cell: Rect;
            h, v: Integer;
            newColor: Boolean;
            patPtr1{, patPtr2, patPtr3, patPtr4, patPtr5, patPtr6}
            : Pattern;
    begin
        GetMouse(mouseLoc);
        h := mouseLoc.h div pixSize;
        v := mouseLoc.v div pixSize;
        if (v > vSize) or (v < 1) or (h > hSize) or (h < 1) then
            begin
                SysBeep(5);
                exit(Edit);
            end;
        gen1[v][h] := not gen1[v][h];
        if gen1[v][h] then
            patPtr1 := black
        else
            patPtr1 := white;
        newColor := gen1[v][h];

        repeat
            cell.top := v * pixSize;
            cell.left := h * pixSize;
            cell.bottom := v * pixSize + 3;
            cell.right := h * pixSize + 3;
            FillRect(cell, patPtr1);
            gen1[v][h] := newColor;

        {Process the parts of the arrays that might change}
            NextGeneration(h - 1, v - 1, h + 1, v + 1, gen1, gen2);
            NextGeneration(h - 2, v - 2, h + 2, v + 2, gen2, gen3);
            NextGeneration(h - 3, v - 3, h + 3, v + 3, gen3, gen4);
            NextGeneration(h - 4, v - 4, h + 4, v + 4, gen4, gen5);
            NextGeneration(h - 5, v - 5, h + 5, v + 5, gen5, gen6);

    {Update the parts that might have changed}
{DrawGen(h - 0, v - 0, h + 0, v + 0, gen1, 0, 0, true); - not necessary}
            DrawGen(h - 1, v - 1, h + 1, v + 1, gen2, hSpace, 0, true);
            DrawGen(h - 2, v - 2, h + 2, v + 2, gen3, hSpace * 2, 0, true);
            DrawGen(h - 3, v - 3, h + 3, v + 3, gen4, 0, vSpace, true);
            DrawGen(h - 4, v - 4, h + 4, v + 4, gen5, hSpace, vSpace, true);
            DrawGen(h - 5, v - 5, h + 5, v + 5, gen6, hSpace * 2, vSpace, true);

            GetMouse(mouseLoc);
            h := mouseLoc.h div pixSize;
            v := mouseLoc.v div pixSize;

            if (v > vSize) or (v < 1) or (h > hSize) or (h < 1) then
                begin
                    SysBeep(5);
                    exit(Edit);
                end;

        until not Button;
    end; {Edit}


{*** MainEventLoop - standard event processing. A few things are still missing, though.}

    procedure MainEventLoop;
        var
            xPos, yPos: LongInt;
            mousePos: array[0..19] of char;
            mouseX, mouseY: Str255;
    begin
        FlushEvents(everyEvent, 0);
        repeat
            SystemTask;
            if (GetNextEvent(everyEvent, myEvent)) then
                case myEvent.what of
                    mouseDown:
                        begin
                            windowCode := FindWindow(myEvent.where, whichWindow);
                            case windowCode of
                                inSysWindow:
                                    SystemClick(myEvent, whichWindow);

                                inMenuBar:
                                    userDone := DoCommand(MenuSelect(myEvent.where));

                                inContent:
                                    if (Button) then
                                        Edit;

                                inDrag:
                                    begin
                                        if (whichWindow <> FrontWindow) and (BitAnd(myEvent.modifiers, cmdKey) = 0) then
                                            SelectWindow(whichWindow);
                                        DragWindow(whichWindow, myEvent.where, screenBits.bounds);
                                    end;

                            end; {case windowCode}
                        end; {mouseDown}

                    keyDown, autoKey:
                        if BAnd(myEvent.modifiers, cmdKey) <> 0 then
                            userDone := DoCommand(MenuKey(char(BAnd(myEvent.message, charCodeMask))));

                    updateEvt:
                        Update;

                end; {case myEvent.what}

            GetMouse(mouseLoc);
            xPos := mouseLoc.h div pixSize;
            yPos := mouseLoc.v div pixSize;
            if (xPos <> oldX) or (yPos <> oldY) then
                begin
                    EraseRect(textRect);
                    if (xPos >= 1) and (xPos <= hSize) and (yPos >= 1) and (yPos <= vSize) then
                        begin
                            NumToString(xPos, mouseX);
                            MoveTo(5, 158);
                            DrawString('X:');
                            MoveTo(17, 158);
                            DrawString(mouseX);

                            NumToString(yPos, mouseY);
                            MoveTo(40, 158);
                            DrawString('Y:');
                            MoveTo(52, 158);
                            DrawString(mouseY);
                        end; {if xPos >=1…}
                    oldX := xPos;
                    oldY := yPos;
                end {if xPos<>oldX…}
        until userDone;
    end; {MainEventLoop}


{*** Init - set the cursor to a cross and init the text rect.}

    procedure Init;
        var
            cross: CursHandle;
            i: Integer;
    begin
        cross := GetCursor(crossCursor);
        SetCursor(cross^^);

        TextSize(9);
        SetRect(textRect, 0, 149, 75, 159);
    end; {Init}


{*** main program}

begin
    SetUp;
    Init;
    Clear;
    MainEventLoop;
end.