|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 27648 (0x6c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Puz_Main, seg_005396
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
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; se 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;
--\x0c
------------------------------------------------------------------------------
-- PuzzlePending - XPending entry point for the other module.
------------------------------------------------------------------------------
function Puzzle_Pending return S_Natural is
begin
return X_Pending (Dpy);
end Puzzle_Pending;
--\x0c
------------------------------------------------------------------------------
-- 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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
----RepaintTitle - puts the program title in the title bar
procedure Repaint_Title (Method : Title_Method) is separate;
--\x0c
------------------------------------------------------------------------------
-- 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;
--\x0c
------------------------------------------------------------------------------
-- 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;
--\x0c
procedure Repaint_Number_Tiles is separate;
--\x0c
------------------------------------------------------------------------------
-- Setup - Perform initial window creation, etc.
------------------------------------------------------------------------------
procedure Setup (Display : X_String; Geometry : X_String) is separate;
--\x0c
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;
--\x0c
procedure Calculate_Speed;
procedure Calculate_Stepsize;
procedure Reset is separate;
--\x0c
------------------------------------------------------------------------------
-- Sets the global variable Move_Steps based on speed
-- specified on the command line;
------------------------------------------------------------------------------
procedure Calculate_Speed is separate;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
procedure Process_Expose (Event : in out X_Event) is separate;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
procedure Figure_Puzzle_Size (Size : String) is separate;
--\x0c
procedure Main (Display : X_String := "";
Geometry : X_String := "";
Size : String := "";
Speed : Natural := 0;
New_Colormap : Boolean := False) is separate;
--\x0c
------------------------------------------------------------------------------
-- 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;
nblk1=1a
nid=16
hdr6=32
[0x00] rec0=34 rec1=00 rec2=01 rec3=002
[0x01] rec0=1f rec1=00 rec2=02 rec3=06e
[0x02] rec0=1a rec1=00 rec2=03 rec3=07c
[0x03] rec0=00 rec1=00 rec2=18 rec3=00e
[0x04] rec0=19 rec1=00 rec2=04 rec3=01a
[0x05] rec0=25 rec1=00 rec2=17 rec3=006
[0x06] rec0=03 rec1=00 rec2=05 rec3=010
[0x07] rec0=1e rec1=00 rec2=06 rec3=00e
[0x08] rec0=02 rec1=00 rec2=15 rec3=016
[0x09] rec0=21 rec1=00 rec2=07 rec3=012
[0x0a] rec0=28 rec1=00 rec2=08 rec3=01e
[0x0b] rec0=17 rec1=00 rec2=09 rec3=002
[0x0c] rec0=00 rec1=00 rec2=1a rec3=004
[0x0d] rec0=1a rec1=00 rec2=0a rec3=056
[0x0e] rec0=1a rec1=00 rec2=0b rec3=026
[0x0f] rec0=20 rec1=00 rec2=0c rec3=01e
[0x10] rec0=1d rec1=00 rec2=0d rec3=088
[0x11] rec0=1f rec1=00 rec2=0e rec3=012
[0x12] rec0=03 rec1=00 rec2=19 rec3=008
[0x13] rec0=28 rec1=00 rec2=0f rec3=00c
[0x14] rec0=22 rec1=00 rec2=10 rec3=034
[0x15] rec0=20 rec1=00 rec2=11 rec3=030
[0x16] rec0=20 rec1=00 rec2=12 rec3=052
[0x17] rec0=27 rec1=00 rec2=13 rec3=010
[0x18] rec0=22 rec1=00 rec2=14 rec3=001
[0x19] rec0=a0 rec1=00 rec2=00 rec3=000
tail 0x21700893c8197894cc5c5 0x42a00088462063203
Free Block Chain:
0x16: 0000 00 00 00 1e 80 10 20 20 20 3a 20 58 5f 57 69 6e ┆ : X_Win┆