⟦946e8d0cc⟧

E3 Source Code



-- UNIT: procedure HANOI
-- FILES: hanoi.a termspec.a termbody.a
-- AUTHOR (non-VERDIX): Colin Runciman
-- COMPILE: a.make hanoi -o hanoi -v -f hanoi.a term*.a
-- PURPOSE: demonstrate solution to "Towers of Hanoi" problem and a.make
-- DESCRIPTION: shows consecutive positions of disks on three columns
--              to move a tower from one column to another in such a way
--              that no disk ever rests on a smaller one.
--              Usage: hanoi
-- .......................................................................... --

-- with Simple_Io;
with Text_Io;
use Text_Io;
-- use Simple_Io;
with Terminal;
use Terminal;

procedure Hanoi is

-------------------------------------------
-- Data structures to represent the problem
-------------------------------------------

    subtype Pole_No is Integer range 1 .. 3;
    Pole_Height : constant Integer := 6;
    subtype Height is Integer range 0 .. Pole_Height;
    Max_Ring_No : constant Integer := Pole_Height - 1;
    subtype Ring_No is Integer range 0 .. Max_Ring_No;
    Term_Ch : Character := 'V';

    Base_Depth : constant Integer := Screen_Depth - 1;

    type Ring_Array is array (Integer range <>) of Ring_No;

    type Pole_With_Rings is
        record
            Rings : Ring_Array (1 .. Pole_Height);
            Ring_Height : Ring_No;
        end record;
    Poles : array (Pole_No) of Pole_With_Rings :=
       ((Rings => (5, 4, 3, 2, 1, 0), Ring_Height => 5),
        (Rings => (0, 0, 0, 0, 0, 0), Ring_Height => 0),
        (Rings => (0, 0, 0, 0, 0, 0), Ring_Height => 0));

    procedure Draw_Ring (P : Pole_No; H : Height; R : Ring_No) is
        type Layer is (Top, Bottom);
        Ring_Picture : constant array (Ring_No, Layer) of String (1 .. 12) :=
           (("     ||     ", "     ||     "), ("     --     ", "    |01|    "),
            ("    ----    ", "   | 02 |   "), ("   ------   ", "  |  03  |  "),
            ("  --------  ", " |   04   | "), (" ---------- ", "|    05    |"));
        Down : constant Integer := Base_Depth - H * 2;
        Across : constant Integer := (P - 1) * 26 + 2;
    begin
        -- minimise cursor movement/character traffic
        -- drawing non-zero ring never over-writes a larger ring, so can
        -- send minimal amount
        if R = 0 then
            Fix_Cursor (Down, Across);
            Put (Ring_Picture (R, Top));
            Fix_Cursor (Down + 1, Across);
            Put (Ring_Picture (R, Bottom));
        else
            -- top of picture is two chars smaller than bottom
            Fix_Cursor (Down, Across + 6 - R); -- include leading blanks
            Put (Ring_Picture (R, Top) (7 - R .. 6 + R)); -- slice central part
            Fix_Cursor (Down + 1, Across + 5 - R);
            Put (Ring_Picture (R, Bottom) (6 - R ..
                                              7 + R)); -- slice central part
        end if;
    end Draw_Ring;

    procedure Draw_Start is
    begin
        Clear_Screen;
        Fix_Cursor (2, 1);
        Put ("-- Towers of Hanoi --");
        Fix_Cursor (Base_Depth, 1);
        for I in 1 .. 66 loop
            Put ('=');
        end loop;
        for P in Pole_No loop
            for R in Ring_No loop
                Draw_Ring (P, Pole_Height - R, Ring_No'(0));
            end loop;
        end loop;
        for R in 1 .. Max_Ring_No loop
            Draw_Ring (1, Pole_Height - R, R);
        end loop;
    end Draw_Start;


----------------------------------------------------------------------
-- SOLVE expresses a suitable variant of the usual recursive solution.
----------------------------------------------------------------------

    procedure Solve (R : Ring_No; Start_Pole, Finish_Pole : Pole_No) is

        procedure Move_Ring (From, To : Pole_No) is
            R : Ring_No := Poles (From).Rings (Poles (From).Ring_Height);
        begin
            Lift_Ring:
                declare
                    Old_H : constant Height := Poles (From).Ring_Height;
                begin
                    for H in Old_H .. Pole_Height loop
                        Draw_Ring (From, H, Ring_No'(0));
                        exit when H = Pole_Height;
                        Draw_Ring (From, H + 1, R);
                    end loop;
                    Poles (From).Rings (Old_H) := Ring_No'(0);
                    Poles (From).Ring_Height := Old_H - 1;
                end Lift_Ring;

            Drop_Ring:
                declare
                    New_H : constant Height := Poles (To).Ring_Height + 1;
                begin
                    Draw_Ring (To, Pole_Height, R);
                    for H in reverse New_H .. Pole_Height - 1 loop
                        Draw_Ring (To, H + 1, Ring_No'(0));
                        Draw_Ring (To, H, R);
                    end loop;
                    Poles (To).Ring_Height := New_H;
                    Poles (To).Rings (New_H) := R;
                end Drop_Ring;
        end Move_Ring;
    begin
        if R > 0 then
            declare
                Other_Pole : constant Pole_No := 6 - Start_Pole - Finish_Pole;
            begin
                Solve (R - 1,
                       Start_Pole => Start_Pole,
                       Finish_Pole => Other_Pole);
                Move_Ring (From => Start_Pole, To => Finish_Pole);
                Solve (R - 1,
                       Start_Pole => Other_Pole,
                       Finish_Pole => Finish_Pole);
            end;
        end if;
    end Solve;
----------------------------
-- Outermost body of program
----------------------------
begin
    Put ("Terminal type ( F(acit), V(T100), H(P2648), 1(FREEDOM100 ) > ");
    Text_Io.Get (Term_Ch);
    case Term_Ch is
        when 'F' | 'f' | 'V' | 'v' =>
            Term := Vt100;
        when 'H' | 'h' =>
            Term := Hp;
        when '1' =>
            Term := Freedom100;
        when others =>
            Term := Vt100;
    end case;
    Draw_Start;
    Solve (Max_Ring_No, Start_Pole => 1, Finish_Pole => 3);
    Solve (Max_Ring_No, Start_Pole => 3, Finish_Pole => 1);
end Hanoi;
pragma Main;
-- .......................................................................... --
--
-- DISTRIBUTION AND COPYRIGHT:
--
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--
-- DISCLAIMER:
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
DataMuseum.dk

Rational R1000/400

⟦946e8d0cc⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
