⟦d446c28ba⟧

TextFile

with Text_Io;  
with Puz_Puzzle;  
use Puz_Puzzle;

with Xlbt_Arithmetic;  
use Xlbt_Arithmetic;  
with Xlbt_Atom_Defs;  
use Xlbt_Atom_Defs;  
with Xlbt_Basic;  
use Xlbt_Basic;  
with Xlbt_Color;  
use Xlbt_Color;  
with Xlbt_Event;  
use Xlbt_Event;  
with Xlbt_Event2;  
use Xlbt_Event2;  
with Xlbt_Font;  
use Xlbt_Font;  
with Xlbt_Hint;  
use Xlbt_Hint;  
with Xlbt_Gc;  
use Xlbt_Gc;  
with Xlbt_Geometry;  
use Xlbt_Geometry;  
with Xlbt_Graphics;  
use Xlbt_Graphics;  
with Xlbt_Key;  
use Xlbt_Key;  
with Xlbt_Pointer;  
use Xlbt_Pointer;  
with Xlbt_Rm;  
use Xlbt_Rm;  
with Xlbt_String;  
use Xlbt_String;  
with Xlbt_Visual;  
use Xlbt_Visual;  
with Xlbt_Window;  
use Xlbt_Window;

with Xlbp_Bitmap;  
use Xlbp_Bitmap;  
with Xlbp_Color;  
use Xlbp_Color;  
with Xlbp_Cursor;  
use Xlbp_Cursor;  
with Xlbp_Display;  
use Xlbp_Display;  
with Xlbp_Event;  
use Xlbp_Event;  
with Xlbp_Font;  
use Xlbp_Font;  
with Xlbp_Gc;  
use Xlbp_Gc;  
with Xlbp_Geometry;  
use Xlbp_Geometry;  
with Xlbp_Graphics;  
use Xlbp_Graphics;  
with Xlbp_Hint;  
use Xlbp_Hint;  
with Xlbp_Rm;  
use Xlbp_Rm;  
with Xlbp_Sync;  
use Xlbp_Sync;  
with Xlbp_Text;  
use Xlbp_Text;  
with Xlbp_Window;  
use Xlbp_Window;  
with Xlbp_Window_Information;  
use Xlbp_Window_Information;  
with Xlbp_Window_Property;  
use Xlbp_Window_Property;

package body Puz_Main is
------------------------------------------------------------------------------
-- Originally: main.c
------------------------------------------------------------------------------
-- Puzzle - (C) Copyright 1987, 1988 Don Bennett.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice appear in all copies and that
-- both that copyright notice and this permission notice appear in
-- supporting documentation.
------------------------------------------------------------------------------

    Server_Bug     : constant Boolean := True;  
    Geb_Server_Bug : constant Boolean := True;

------------------------------------------------------------------------------
--  Puzzle
--
-- Don Bennett, HP Labs
--
-- this is the interface code for the puzzle program.
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- #include "ac.cursor"
------------------------------------------------------------------------------

    Ac_Width  : constant := 16;  
    Ac_Height : constant := 16;  
    Ac_X_Hot  : constant := 8;  
    Ac_Y_Hot  : constant := 8;

    Ac_Bits : constant U_Char_Array :=  
       (16#00#, 16#00#, 16#80#, 16#01#, 16#C0#, 16#03#, 16#E0#, 16#07#,  
        16#80#, 16#01#, 16#88#, 16#11#, 16#8C#, 16#31#, 16#FE#, 16#7F#,  
        16#FE#, 16#7F#, 16#8C#, 16#31#, 16#88#, 16#11#, 16#80#, 16#01#,  
        16#E0#, 16#07#, 16#C0#, 16#03#, 16#80#, 16#01#, 16#00#, 16#00#);

------------------------------------------------------------------------------
-- #include "ac_mask"
------------------------------------------------------------------------------

    Ac_Mask_Width  : constant := 16;  
    Ac_Mask_Height : constant := 16;

    Ac_Mask_Bits : constant U_Char_Array :=  
       (16#C0#, 16#03#, 16#C0#, 16#03#, 16#E0#, 16#07#, 16#F0#, 16#0F#,  
        16#E8#, 16#17#, 16#DC#, 16#3B#, 16#FF#, 16#FF#, 16#FF#, 16#FF#,  
        16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#DC#, 16#3B#, 16#E8#, 16#17#,  
        16#F0#, 16#0F#, 16#E0#, 16#07#, 16#C0#, 16#03#, 16#C0#, 16#03#);

    Terminate_Program : exception;

    Puzzle_Border_Width : constant := 2;

    Title_Window_Height : constant := 25;  
    C_Boundary_Height   : constant := 3;

    C_Box_Width  : constant := 10;  
    C_Box_Height : constant := 10;

    Min_Tile_Height : constant := 32;  
    Min_Tile_Width  : constant := 32;

    Max_Steps     : constant := 1000;  
    Default_Speed : constant := 2;

    First_Call : Boolean := True;

    type Title_Method is (Title_Tiles, Title_Text, Title_Animated);

    Box_Width  : S_Long := C_Box_Width;  
    Box_Height : S_Long := C_Box_Height;


    Tile_Height      : S_Long;  
    Tile_Width       : S_Long;  
    Text_X_Start     : S_Long;  
    Title_Win_Height : S_Long;  
    Boundary_Height  : S_Long;  
    Tile_Win_Height  : S_Long;

    Fg_Pixel : X_Pixel;  
    Bg_Pixel : X_Pixel;

    type Window_Geom is  
        record  
            Root         : X_Window;  
            X            : S_Long;  
            Y            : S_Long;  
            Width        : S_Long;  
            Height       : S_Long;  
            Border_Width : S_Long;  
            Depth        : S_Long;  
        end record;

    Puzzle_Win_Info : Window_Geom;

    Puzzle_Root     : X_Window;  
    Title_Window    : X_Window := None_X_Window;  
    Tile_Window     : X_Window;  
    Scramble_Window : X_Window;  
    Solve_Window    : X_Window;

    Title_Font_Name : constant X_String := "fixed-screen-r-13";  
    Tile_Font_Name  : constant X_String := "fixed-screen-b-13";

    Title_Font_Info : X_Font_Struct;  
    Tile_Font_Info  : X_Font_Struct;

    Puzzle_On_Top : Boolean := True;


    Use_Display : Boolean := False;

    type S_Short_Array is array (S_Natural range <>) of S_Short;

    Tiles_Per_Second : S_Natural;  
    Move_Steps       : S_Natural;  
    Vert_Step_Size   : U_Short_Array (0 .. Max_Steps - 1);  
    Hori_Step_Size   : U_Short_Array (0 .. Max_Steps - 1);

    Old_Height : S_Long := S_Long (U_Short'Last);  
    Old_Width  : S_Long := S_Long (U_Short'Last);

    function Indx (X, Y : S_Long) return S_Long is
        -- #define indx(x,y)   (((y)*Puzzle_Width) + (x))
    begin  
        return Y * Puzzle_Width + X;  
    end Indx;

    function Is_Digit (X : Character) return Boolean is
        -- #define isdigit(x)  ((x)>= '0' && (x) <= '9')
    begin  
        return X in '0' .. '9';  
    end Is_Digit;

    function Ulx (X, Y : S_Long) return S_Long is
        -- #define ulx(x,y)    ((x)*Tile_Width)
    begin  
        return X * Tile_Width;  
    end Ulx;

    function Llx (X, Y : S_Long) return S_Long is
        -- #define llx(x,y)    ((x)*Tile_Width)
    begin  
        return X * Tile_Width;  
    end Llx;

    function Urx (X, Y : S_Long) return S_Long is
        -- #define urx(x,y)    (((x)+1)*Tile_Width - 1)
    begin  
        return (X + 1) * Tile_Width - 1;  
    end Urx;

    function Lrx (X, Y : S_Long) return S_Long is
        -- #define lrx(x,y)    (((x)+1)*Tile_Width - 1)
    begin  
        return (X + 1) * Tile_Width - 1;  
    end Lrx;

    function Uly (X, Y : S_Long) return S_Long is
        -- #define uly(x,y)    ((y)*Tile_Height)
    begin  
        return Y * Tile_Height;  
    end Uly;

    function Ury (X, Y : S_Long) return S_Long is
        -- #define ury(x,y)    ((y)*Tile_Height)
    begin  
        return Y * Tile_Height;  
    end Ury;

    function Lly (X, Y : S_Long) return S_Long is
        -- #define lly(x,y)    (((y)+1)*Tile_Height - 1)
    begin  
        return (Y + 1) * Tile_Height - 1;  
    end Lly;

    function Lry (X, Y : S_Long) return S_Long is
        -- #define lry(x,y)    (((y)+1)*Tile_Height - 1)
    begin  
        return (Y + 1) * Tile_Height - 1;  
    end Lry;

    function Max (A, B : S_Long) return S_Long is  
    begin  
        if A > B then  
            return A;  
        else  
            return B;  
        end if;  
    end Max;

    function Min (A, B : S_Long) return S_Long is  
    begin  
        if A < B then  
            return A;  
        else  
            return B;  
        end if;  
    end Min;

--\f

------------------------------------------------------------------------------
-- PuzzlePending - XPending entry point for the other module.
------------------------------------------------------------------------------

    function Puzzle_Pending return S_Natural is  
    begin  
        return X_Pending (Dpy);  
    end Puzzle_Pending;

--\f

------------------------------------------------------------------------------
-- SetupDisplay - eastablish the connection to the X server.
------------------------------------------------------------------------------

    procedure Setup_Display (Server : X_String) is  
        Error : X_Error_String;  
        Env   : constant X_String :=  
           X_Display_Name (Server);  
    begin  
        X_Open_Display (Env, Dpy, Error);  
        if "=" (Dpy, None_X_Display) then  
            Text_Io.Put_Line ("Unable to open display: " & To_String (Server) &  
                              ": " & To_String (Err (Error)));  
            raise Program_Error;  
        end if;  
        Screen := X_Default_Screen (Dpy);  
    end Setup_Display;

--\f

    procedure X_Query_Window (Window :        X_Window;  
                              Frame  : in out Window_Geom) is  
        Succ : X_Status;  
    begin  
        X_Get_Geometry (Dpy, Window.Drawable, Frame.Root,  
                        S_Short (Frame.X), S_Short (Frame.Y),  
                        U_Short (Frame.Width), U_Short (Frame.Height),  
                        U_Short (Frame.Border_Width),  
                        U_Char (Frame.Depth),  
                        Succ);  
    end X_Query_Window;

--\f

    procedure Rect_Set (W      : X_Window;  
                        X      : S_Long;  
                        Y      : S_Long;  
                        Width  : S_Long;  
                        Height : S_Long;  
                        Pixel  : X_Pixel) is  
    begin  
        X_Set_Foreground (Dpy, Rect_Gc, Pixel);  
        X_Fill_Rectangle (Dpy, W.Drawable, Rect_Gc, S_Short (X),  
                          S_Short (Y), U_Short (Width), U_Short (Height));  
    end Rect_Set;

--\f

    procedure Move_Area (W      : X_Window;  
                         Src_X  : S_Long;  
                         Src_Y  : S_Long;  
                         Dst_X  : S_Long;  
                         Dst_Y  : S_Long;  
                         Width  : S_Long;  
                         Height : S_Long) is  
    begin  
        X_Copy_Area (Dpy, W.Drawable, W.Drawable, Gc, S_Short (Src_X),  
                     S_Short (Src_Y), U_Short (Width), U_Short (Height),  
                     S_Short (Dst_X), S_Short (Dst_Y));  
    end Move_Area;

--\f

----RepaintTitle - puts the program title in the title bar

    procedure Repaint_Title (Method : Title_Method) is separate;

--\f

------------------------------------------------------------------------------
-- RepaintBar - Repaint the bar between the title window and
--              the tile window;
------------------------------------------------------------------------------

    procedure Repaint_Bar is  
        Pixel : X_Pixel;  
    begin

        X_Fill_Rectangle (Dpy, Puzzle_Root.Drawable, Gc,  
                          0, S_Short (Title_Win_Height),  
                          U_Short (Puzzle_Win_Info.Width),  
                          U_Short (Boundary_Height));

    end Repaint_Bar;

--\f

------------------------------------------------------------------------------
-- RepaintTiles - draw the numbers in the tiles to match the
--                locations array;
------------------------------------------------------------------------------

    procedure Repaint_Number_Tiles;

    procedure Repaint_Tiles is  
    begin  
        Repaint_Number_Tiles;  
    end Repaint_Tiles;

--\f

    procedure Repaint_Number_Tiles is separate;

--\f

------------------------------------------------------------------------------
-- Setup - Perform initial window creation, etc.
------------------------------------------------------------------------------

    procedure Setup (Display : X_String; Geometry : X_String) is separate;

--\f

    function Sizechanged return Boolean is  
    begin  
        X_Query_Window (Puzzle_Root, Puzzle_Win_Info);

        if Puzzle_Win_Info.Width = Old_Width and then  
           Puzzle_Win_Info.Height = Old_Height then  
            return False;  
        else  
            return True;  
        end if;  
    end Sizechanged;

--\f

    procedure Calculate_Speed;  
    procedure Calculate_Stepsize;

    procedure Reset is separate;

--\f

------------------------------------------------------------------------------
-- Sets the global variable Move_Steps based on speed
-- specified on the command line;
------------------------------------------------------------------------------

    procedure Calculate_Speed is separate;

--\f

    procedure Calculate_Stepsize is  
        Remain : S_Long;  
        Sum    : S_Long;  
        Error  : S_Long;  
    begin

        Sum    := Tile_Height / Move_Steps;  
        Remain := Tile_Height rem Move_Steps;  
        for I in 0 .. Move_Steps - 1 loop  
            Vert_Step_Size (I) := U_Short (Sum);  
            if Remain > 0 then  
                Vert_Step_Size (I) := Vert_Step_Size (I) + 1;  
                Remain             := Remain - 1;  
            end if;  
        end loop;

        Sum    := Tile_Width / Move_Steps;  
        Remain := Tile_Width rem Move_Steps;  
        for I in 0 .. Move_Steps - 1 loop  
            Hori_Step_Size (I) := U_Short (Sum);  
            if Remain > 0 then  
                Hori_Step_Size (I) := Hori_Step_Size (I) + 1;  
                Remain             := Remain - 1;  
            end if;  
        end loop;

    end Calculate_Stepsize;

--\f

    procedure Reset_Logging;  
    procedure Save_Logging_State;


    procedure Slide_Pieces (Event : X_Event) is  
        X : S_Long;  
        Y : S_Long;  
    begin

        X := S_Long (Event.Button.X) / Tile_Width;  
        Y := S_Long (Event.Button.Y) / Tile_Height;  
        if X = Space_X or else Y = Space_Y then  
            Move_Space_To (Indx (X, Y));  
        end if;  
        Flush_Logging;

    end Slide_Pieces;

--\f

    procedure Process_Visibility (Event : X_Event) is  
    begin

        if "=" (Event.Visibility.State, Visibility_Unobscured) then  
            Puzzle_On_Top := True;  
        else  
            Puzzle_On_Top := False;  
            Abort_Solving;  
        end if;

    end Process_Visibility;

--\f

    procedure Process_Expose (Event : in out X_Event) is separate;

--\f

    procedure Process_Button (Event : X_Event) is  
        W : X_Window;  
    begin

        W := Event.Window;  
        if "=" (W, Tile_Window) then  
            if Solving_Status then  
                Abort_Solving;  
            else  
                Slide_Pieces (Event);  
            end if;  
        elsif "=" (W, Scramble_Window) then  
            Abort_Solving;  
            Scramble;  
            Repaint_Tiles;  
        elsif "=" (W, Solve_Window) then  
            Solve;  
        elsif "=" (W, Title_Window) and then  
              "=" (Event.Button.Button, Button_2) then  
            raise Terminate_Program;  
        end if;

    end Process_Button;

--\f

    procedure Get_Next_Event (Event : in out X_Event);  
    procedure Process_Event  (Event : in out X_Event);

    procedure Process_Input is  
        Event : X_Event;  
    begin  
        loop  
            Get_Next_Event (Event);  
            Process_Event (Event);  
        end loop;  
    end Process_Input;

--\f

    procedure Process_Events is  
        Event : X_Event;  
    begin  
        while X_Pending (Dpy) /= 0 loop  
            Get_Next_Event (Event);  
            Process_Event (Event);  
        end loop;  
    end Process_Events;

--\f

    procedure Get_Next_Event (Event : in out X_Event) is  
        Succ : X_Status;  
    begin  
        X_Check_Mask_Event  
           (Dpy, (Visibility_Change_Mask => True, others => False),  
            Event, Succ);  
        if Succ = Failed then  
            X_Check_Mask_Event  
               (Dpy, (Exposure_Mask => True, others => False), Event, Succ);  
            if Succ = Failed then  
                X_Next_Event (Dpy, Event);  
            end if;  
        end if;  
    end Get_Next_Event;

--\f

    procedure Process_Event (Event : in out X_Event) is  
    begin

        case Event.Kind is  
            when Button_Press =>  
                if not Puzzle_On_Top then  
                    X_Raise_Window (Dpy, Puzzle_Root);  
                    X_Put_Back_Event (Dpy, Event);  
                else  
                    Process_Button (Event);  
                end if;

            when Expose =>  
                Process_Expose (Event);

            when Visibility_Notify =>  
                Process_Visibility (Event);

            when others =>  
                null;  
        end case;

    end Process_Event;

--\f

    procedure Figure_Puzzle_Size (Size : String) is separate;

--\f

    procedure Main (Display      : X_String := "";  
                    Geometry     : X_String := "";  
                    Size         : String   := "";  
                    Speed        : Natural  := 0;  
                    New_Colormap : Boolean  := False) is separate;

--\f

------------------------------------------------------------------------------
-- Output Routines -
------------------------------------------------------------------------------

    procedure Display_Log_Move_Space (First_X, First_Y, Last_X, Last_Y : S_Long;  
                                      Dir : Direction);

    procedure Reset_Logging is  
    begin  
        null;  
    end Reset_Logging;

    procedure Flush_Logging is  
    begin  
        null;  
    end Flush_Logging;

    procedure Save_Logging_State is  
    begin  
        null;  
    end Save_Logging_State;

    procedure Log_Move_Space  
                 (First_X, First_Y, Last_X, Last_Y : S_Long; Dir : Direction) is  
    begin  
        Display_Log_Move_Space (First_X, First_Y, Last_X, Last_Y, Dir);  
    end Log_Move_Space;

-- #ifdef UNDEFINED
-- /** this stuff really isn't worth it; **/
--
-- static int prevDir := -1;
-- static int prevFirstX, prevFirstY, prevLastX, prevLastY;
--
-- resetLogging()
-- {
--     prevDir := -1;
-- }
--
-- flushLogging()
-- {
--     if (prevDir !:= -1)
--     displayLogMoveSpace(prevFirstX,prevFirstY,prevLastX,prevLastY,prevDir);
--     prevDir := -1;
-- }
--
-- saveLoggingState(fx,fy,lx,ly,dir)
-- int fx,fy,lx,ly,dir;
-- {
--     prevDir := dir;
--     prevFirstX := fx;
--     prevFirstY := fy;
--     prevLastX := lx;
--     prevLastY := ly;
-- }
--
-- LogMoveSpace(first_x,first_y,last_x,last_y,dir)
-- int first_x,first_y,last_x,last_y,dir;
-- {
--     if (prevDir = -1)
--     /** we don't already have something to move **/
--     saveLoggingState(first_x,first_y,last_x,last_y,dir);
--     else if (prevDir = dir) {
--     /** we're going in the same direction **/
--     prevLastX := last_x;
--     prevLastY := last_y;
--     }
--     else {
--     flushLogging();
--     saveLoggingState(first_x,first_y,last_x,last_y,dir);
--     }
-- }
-- #endif /* UNDEFINED */

    procedure Display_Log_Move_Space (First_X, First_Y, Last_X, Last_Y : S_Long;  
                                      Dir : Direction) is separate;  
end Puz_Main;
DataMuseum.dk

Rational R1000/400 Tapes

⟦d446c28ba⟧ TextFile

Derivation

TextFile
