⟦a3f842f7e⟧

E3 Source Code



separate (Decision_System.Fruit_Rule_Bundle)

package body Put_Block_On_New_Tower_Rule is

    function Premiss return Fact_Queries is
        use Fruit_Frames;
    begin
        return (Markers.Exist ((Name => Is_Equal (Top_Block_Marker_Name))),
                Markers.Exist ((Name => Is_Equal (Selected_Block_Marker_Name))),
                Markers.Exist ((Name => Is_Equal
                                           (Top_Copied_Model_Marker_Name))),
                Markers.Exist ((Name => Is_Equal (Model_Marker_Name))));
    end Premiss;


    procedure Action (Objects : Fact_Collection) is  
        use Visual_System;
        use Fruit_Frames;
        Top_Block_Marker        : Fact_Name renames Objects (1);
        Selected_Marker         : Fact_Name renames Objects (2);
        Top_Copied_Model_Marker : Fact_Name renames Objects (3);  
        Model_Marker            : Fact_Name renames Objects (4);
        Moving_Possible         : Boolean := True;  
        The_Label               : Labels;

        procedure Search_Next_Block_In_Model is
        begin
            Moving_Possible := True;
            Moving_Possible := Move (Model_Marker_Id, Up);

            if (Get_Label (Model_Marker_Id) = Null_Label) or
               (not Moving_Possible) then
                -- the model has been copied
                Markers.Delete (Model_Marker);
            end if;
        end Search_Next_Block_In_Model;


        procedure Place_On_Table_Marker_On_The_Bottom_Right is
        begin
            Moving_Possible := True;
            while Moving_Possible loop
                Moving_Possible := Move (On_Table_Marker_Id, Down);
            end loop;
            Moving_Possible := True;
            while Moving_Possible loop
                Moving_Possible := Move (On_Table_Marker_Id, Right);
            end loop;
        end Place_On_Table_Marker_On_The_Bottom_Right;


        procedure Move_To_Next_Place is
        begin
            Moving_Possible := True;
            Moving_Possible := Move (On_Table_Marker_Id, Left);
            if not Moving_Possible then
                -- go on upper level
                Moving_Possible := Move (On_Table_Marker_Id, Up);
                Moving_Possible := True;
                while Moving_Possible loop
                    Moving_Possible := Move (On_Table_Marker_Id, Right);
                end loop;
            end if;
        end Move_To_Next_Place;


        function Is_Table_Marker
                    (In_Column_Marked_With : Marker_Ids) return Boolean is
            Level     : Integer := 0;
            Moving    : Boolean := True;  
            In_Column : Boolean := False;
        begin  
            while Moving loop  
                if Is_Same (In_Column_Marked_With, On_Table_Marker_Id)  
                    then
                    In_Column := True;
                end if;
                Moving := Move (On_Table_Marker_Id, Down);  
                Level  := Level + 1;
            end loop;

            --replace on_table_marker on initial place
            for I in 1 .. Level - 1 loop
                Moving := Move (On_Table_Marker_Id, Up);
            end loop;

            return In_Column;
        end Is_Table_Marker;


        procedure Move_Top_Block_On_Free_Place is  
            Moving_Down : Boolean := True;
        begin  
            while (Get_Label (On_Table_Marker_Id) /= Null_Label) loop
                Move_To_Next_Place;
            end loop;


            -- is the free block in the column where the selected_block is ?
            if Is_Table_Marker (In_Column_Marked_With =>
                                   Top_Block_Marker_Id) then
                Move_To_Next_Place;
                Move_Top_Block_On_Free_Place;  
            elsif Is_Table_Marker (In_Column_Marked_With =>
                                      Top_Copied_Model_Marker_Id) then
                --the free block is on the copied_model top : search another free place
                Move_To_Next_Place;
                Move_Top_Block_On_Free_Place;  
            else
                -- have found a free place
                Put_Block (Block_Marked_With_Id    => Top_Block_Marker_Id,
                           On_Marked_Place_With_Id => On_Table_Marker_Id);
                Markers.Delete (Top_Block_Marker);
            end if;
        end Move_Top_Block_On_Free_Place;


    begin

        if Is_Same (Selected_Block_Marker_Id, Top_Block_Marker_Id) then
            -- when the selected block is on the top of a stack

            Put_Block (Block_Marked_With_Id    => Selected_Block_Marker_Id,
                       On_Marked_Place_With_Id => Top_Copied_Model_Marker_Id);
            Moving_Possible := Move (Top_Copied_Model_Marker_Id, Up);

            Markers.Delete (Selected_Marker);
            Markers.Delete (Top_Block_Marker);

            Search_Next_Block_In_Model;

        else
            -- first the top of the stack must be moved away until the
            -- selected block is on the top

            -- to search a free place:place first table_marker on bottom right
            -- of the table
            Place_On_Table_Marker_On_The_Bottom_Right;

            -- move top block on free place (because selected block is not on top)
            Move_Top_Block_On_Free_Place;

        end if;
    end Action;


end Put_Block_On_New_Tower_Rule;
DataMuseum.dk

Rational R1000/400

⟦a3f842f7e⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
