language-Modula2-0.1: examples/Modula-2_Libraries/andrea-m2/lib/eth-hamburg/simplewin.mod
IMPLEMENTATION MODULE SimpleWindows;
(* SMG Window management with a simple syntax *)
(* J. Andrea, Aug.12/91 - routines updated *)
(* JAA, Dec 1985, with regards to Gary Doucette *)
(* This code may be freely used and distributed, it may not be sold. *)
FROM SYSTEM IMPORT ADDRESS;
FROM SSDefinitions IMPORT SS$_NORMAL;
FROM SMGDefinitions IMPORT
(* constants *)
SMG$C_ASCII,
SMG$K_TOP, SMG$M_BORDER, SMG$V_BORDER,
SMG$M_UP,
SMG$M_NORMAL, SMG$M_BOLD, SMG$M_REVERSE,
SMG$M_BLINK, SMG$M_UNDERLINE;
FROM ScreenManagementProcedures IMPORT
(* procedures *)
SMG$CREATE_PASTEBOARD, SMG$CREATE_VIRTUAL_DISPLAY,
SMG$DELETE_CHARS,
SMG$DELETE_LINE, SMG$DELETE_PASTEBOARD,
SMG$DELETE_VIRTUAL_DISPLAY,
SMG$DRAW_LINE, SMG$DRAW_RECTANGLE,
SMG$ERASE_CHARS, SMG$ERASE_DISPLAY,
SMG$ERASE_LINE, SMG$GET_DISPLAY_ATTR,
SMG$INSERT_CHARS, SMG$INSERT_LINE,
SMG$LABEL_BORDER, SMG$MOVE_VIRTUAL_DISPLAY,
SMG$PASTE_VIRTUAL_DISPLAY, SMG$POP_VIRTUAL_DISPLAY,
SMG$PUT_CHARS, SMG$PUT_LINE,
SMG$PUT_WITH_SCROLL,
SMG$REPAINT_SCREEN,
SMG$REPASTE_VIRTUAL_DISPLAY, SMG$RESTORE_PHYSICAL_SCREEN,
SMG$RING_BELL, SMG$SAVE_PHYSICAL_SCREEN,
SMG$SET_CURSOR_ABS, SMG$SET_CURSOR_REL,
SMG$SET_PHYSICAL_CURSOR, SMG$SCROLL_DISPLAY_AREA,
SMG$UNPASTE_VIRTUAL_DISPLAY,
SMG$CHANGE_VIRTUAL_DISPLAY;
TYPE
PasteBoard = CARDINAL; (* hidden *)
Display = CARDINAL; (* hidden *)
VAR
insert_line_clr_flag :INTEGER;
save_screen_row_begin, save_screen_row_end :INTEGER;
pasteboard_initial_erase :INTEGER;
erase_pasteborard_on_delete :INTEGER;
put_line_wrap_flag :CARDINAL;
put_line_direction :CARDINAL;
put_chars_rendition :CARDINAL;
(* ------------------------------------------------------------------ *)
PROCEDURE CreateDisplay( VAR display :Display;
rows, cols :CARDINAL;
border :BOOLEAN );
VAR
use_border :INTEGER;
BEGIN (* CreateDisplay *)
IF border THEN
use_border := SMG$M_BORDER;
ELSE
use_border := SMG$V_BORDER;
END; (* if *)
action_status := SS$_NORMAL =
SMG$CREATE_VIRTUAL_DISPLAY( rows, cols, display,
BITSET(use_border), BITSET(SMG$M_NORMAL),
SMG$C_ASCII );
END CreateDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE CreatePasteBoard( VAR pasteboard :PasteBoard );
VAR
rows, cols :CARDINAL;
BEGIN (* CreatePasteBoard *)
action_status := SS$_NORMAL =
SMG$CREATE_PASTEBOARD( pasteboard, 'TT:', rows, cols,
pasteboard_initial_erase );
END CreatePasteBoard;
(* ------------------------------------------------------------------ *)
PROCEDURE DeleteChars( display :Display;
n_chars :CARDINAL;
row, col :CARDINAL );
BEGIN (* DeleteChars *)
action_status := SS$_NORMAL =
SMG$DELETE_CHARS( display, n_chars, row, col );
END DeleteChars;
(* ------------------------------------------------------------------ *)
PROCEDURE DeleteDisplay( display :Display );
BEGIN (* DeleteDisplay *)
action_status := SS$_NORMAL = SMG$DELETE_VIRTUAL_DISPLAY( display );
END DeleteDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE DeleteLine( display :Display;
start_row :CARDINAL;
n_rows :CARDINAL );
BEGIN (* DeleteLine *)
action_status := SS$_NORMAL =
SMG$DELETE_LINE( display, start_row, n_rows );
END DeleteLine;
(* ------------------------------------------------------------------ *)
PROCEDURE DeletePasteBoard( pasteboard :PasteBoard );
BEGIN (* DeletePasteBoard *)
action_status := SS$_NORMAL =
SMG$DELETE_PASTEBOARD( pasteboard,
BITSET(erase_pasteborard_on_delete) );
END DeletePasteBoard;
(* ------------------------------------------------------------------ *)
PROCEDURE DrawLine( display :Display;
start_row, start_col :CARDINAL;
end_row , end_col :CARDINAL );
BEGIN (* DrawLine *)
action_status := SS$_NORMAL =
SMG$DRAW_LINE( display, start_row, start_col, end_row, end_col,
BITSET(SMG$M_NORMAL), BITSET(SMG$M_NORMAL) );
END DrawLine;
(* ------------------------------------------------------------------ *)
PROCEDURE DrawRectangle( display :Display;
top_left_row :CARDINAL;
top_left_col :CARDINAL;
bot_right_row :CARDINAL;
bot_right_col :CARDINAL );
BEGIN (* DrawRectangle *)
action_status := SS$_NORMAL =
SMG$DRAW_RECTANGLE( display, top_left_row, top_left_col,
bot_right_row, bot_right_col,
BITSET(SMG$M_NORMAL), BITSET(SMG$M_NORMAL) );
END DrawRectangle;
(* ------------------------------------------------------------------ *)
PROCEDURE EraseChars( display :Display;
n_chars :CARDINAL;
row, col :CARDINAL );
BEGIN (* EraseChars *)
action_status := SS$_NORMAL =
SMG$ERASE_CHARS( display, n_chars, row, col );
END EraseChars;
(* ------------------------------------------------------------------ *)
PROCEDURE EraseDisplay( display :Display;
start_row, start_col :CARDINAL;
end_row , end_col :CARDINAL );
BEGIN (* EraseDisplay *)
action_status := SS$_NORMAL =
SMG$ERASE_DISPLAY( display, start_row, start_col,
end_row, end_col );
END EraseDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE EraseLine( display :Display;
row, col :CARDINAL );
BEGIN (* EraseLine *)
action_status := SS$_NORMAL = SMG$ERASE_LINE( display, row, col );
END EraseLine;
(* ------------------------------------------------------------------ *)
PROCEDURE InsertChars( display :Display;
text :ARRAY OF CHAR;
row, col :CARDINAL );
BEGIN (* InsertChars *)
action_status := SS$_NORMAL =
SMG$INSERT_CHARS( display, text, row, col,
BITSET(SMG$M_NORMAL),
BITSET(SMG$M_NORMAL),
SMG$C_ASCII );
END InsertChars;
(* ------------------------------------------------------------------ *)
PROCEDURE InsertLine( display :Display;
row :CARDINAL;
text :ARRAY OF CHAR );
BEGIN (* InsertLine *)
action_status := SS$_NORMAL =
SMG$INSERT_LINE( display, row, text, SMG$M_UP,
BITSET(SMG$M_NORMAL), BITSET(SMG$M_NORMAL),
insert_line_clr_flag, SMG$C_ASCII );
END InsertLine;
(* ------------------------------------------------------------------ *)
PROCEDURE LabelBorder( display :Display;
text :ARRAY OF CHAR );
VAR
display_attr,
video_attr, char_set :CARDINAL;
units, height, width :CARDINAL;
BEGIN (* LabelBorder *)
action_status := SS$_NORMAL =
SMG$GET_DISPLAY_ATTR( display, height, width,
BITSET(display_attr), BITSET(video_attr), char_set );
units := ( width - LEN( text ) ) DIV 2;
action_status := SS$_NORMAL =
SMG$LABEL_BORDER( display, text, SMG$K_TOP, units,
BITSET(SMG$M_NORMAL), BITSET(SMG$M_NORMAL),
SMG$C_ASCII );
END LabelBorder;
(* ------------------------------------------------------------------ *)
PROCEDURE MoveCursor( display :Display;
delta_row, delta_col :CARDINAL );
BEGIN (* MoveCursor *)
action_status := SS$_NORMAL =
SMG$SET_CURSOR_REL( display, delta_row, delta_col );
END MoveCursor;
(* ------------------------------------------------------------------ *)
PROCEDURE MoveDisplay( display :Display;
pasteboard :PasteBoard;
row, col :CARDINAL );
BEGIN (* MoveDisplay *)
action_status := SS$_NORMAL =
SMG$MOVE_VIRTUAL_DISPLAY( display,
pasteboard,
row, col,
ADDRESS( display ) );
END MoveDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE PasteDisplay( display :Display;
pasteboard :PasteBoard;
row, col :CARDINAL );
BEGIN (* PasteDisplay *)
action_status := SS$_NORMAL =
SMG$PASTE_VIRTUAL_DISPLAY( display,
pasteboard,
row, col,
ADDRESS( display ) );
END PasteDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE PopDisplay( display :Display;
pasteboard :PasteBoard );
BEGIN (* PopDisplay *)
action_status := SS$_NORMAL =
SMG$POP_VIRTUAL_DISPLAY( display, pasteboard );
END PopDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE PutChars( display :Display;
text :ARRAY OF CHAR;
row, col :CARDINAL );
BEGIN (* PutChars *)
action_status := SS$_NORMAL = SMG$PUT_CHARS( display, text,
row, col, 1,
BITSET(put_chars_rendition),
BITSET(put_chars_rendition),
SMG$C_ASCII );
END PutChars;
(* ------------------------------------------------------------------ *)
PROCEDURE PutLine( display :Display;
text :ARRAY OF CHAR;
line_adv :CARDINAL );
BEGIN (* PutLine *)
action_status := SS$_NORMAL = SMG$PUT_LINE( display, text,
INTEGER( line_adv ),
BITSET( put_chars_rendition ),
BITSET( put_chars_rendition ),
BITSET( put_line_wrap_flag ),
SMG$C_ASCII,
SMG$M_UP );
END PutLine;
(* ------------------------------------------------------------------ *)
PROCEDURE PutWithScroll( display :Display;
text :ARRAY OF CHAR );
BEGIN (* PutWithScroll *)
action_status := SS$_NORMAL = SMG$PUT_WITH_SCROLL( display, text,
BITSET( put_line_direction ),
BITSET( put_chars_rendition ),
BITSET( put_chars_rendition ),
put_line_wrap_flag,
SMG$C_ASCII );
END PutWithScroll;
(* ------------------------------------------------------------------ *)
PROCEDURE RepaintScreen( pasteboard :PasteBoard );
BEGIN (* RepaintScreen *)
action_status := SS$_NORMAL = SMG$REPAINT_SCREEN( pasteboard );
END RepaintScreen;
(* ------------------------------------------------------------------ *)
PROCEDURE RepasteDisplay( display :Display;
pasteboard :PasteBoard;
row, col :CARDINAL );
BEGIN (* RepasteDisplay *)
action_status := SS$_NORMAL =
SMG$REPASTE_VIRTUAL_DISPLAY( display, pasteboard,
row, col, display );
END RepasteDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE RestoreScreen( pasteboard :PasteBoard;
display :Display );
BEGIN (* RestoreScreen *)
action_status := SS$_NORMAL =
SMG$RESTORE_PHYSICAL_SCREEN( pasteboard, display );
END RestoreScreen;
(* ------------------------------------------------------------------ *)
PROCEDURE RingBell( display :Display );
BEGIN (* RingBell *)
action_status := SS$_NORMAL =
SMG$RING_BELL( display, 1 );
END RingBell;
(* ------------------------------------------------------------------ *)
PROCEDURE SaveScreen( pasteboard :PasteBoard;
VAR display :Display );
BEGIN (* SaveScreen *)
action_status := SS$_NORMAL =
SMG$SAVE_PHYSICAL_SCREEN( pasteboard, display,
save_screen_row_begin, save_screen_row_end );
END SaveScreen;
(* ------------------------------------------------------------------ *)
PROCEDURE SetCursor( display :Display;
row, col :CARDINAL );
BEGIN (* SetCursor *)
action_status := SS$_NORMAL =
SMG$SET_CURSOR_ABS( display, row, col );
END SetCursor;
(* ------------------------------------------------------------------ *)
PROCEDURE SetPhysicalCursor( pasteboard :PasteBoard;
row, col :CARDINAL );
BEGIN (* SetPhysicalCursor *)
action_status := SS$_NORMAL =
SMG$SET_PHYSICAL_CURSOR( pasteboard, row, col );
END SetPhysicalCursor;
(* ------------------------------------------------------------------ *)
PROCEDURE ScrollDisplay( display :Display;
direction :CARDINAL;
count :CARDINAL );
VAR
display_attr,
video_attr, char_set,
height, width :CARDINAL;
BEGIN (* ScrollDisplay *)
action_status := SS$_NORMAL =
SMG$GET_DISPLAY_ATTR( display, height, width,
BITSET( display_attr ),
BITSET( video_attr ), char_set );
action_status := SS$_NORMAL =
SMG$SCROLL_DISPLAY_AREA( display, 1, 1, height, width,
BITSET( direction ), count );
END ScrollDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE UnpasteDisplay( display :Display;
pasteboard :PasteBoard );
BEGIN (* UnpasteDisplay *)
action_status := SS$_NORMAL =
SMG$UNPASTE_VIRTUAL_DISPLAY( display, pasteboard );
END UnpasteDisplay;
(* ------------------------------------------------------------------ *)
PROCEDURE AddBorder( display :Display );
VAR
display_attributes, video_attributes, char_set :CARDINAL;
rows, cols :CARDINAL;
BEGIN (* AddBorder *)
action_status := SS$_NORMAL =
SMG$GET_DISPLAY_ATTR( display, rows, cols,
BITSET( display_attributes ),
BITSET( video_attributes ),
char_set );
IF action_status THEN
action_status := SS$_NORMAL =
SMG$CHANGE_VIRTUAL_DISPLAY( display, rows, cols,
BITSET( SMG$M_BORDER ),
BITSET( video_attributes ),
char_set );
END; (* if *)
END AddBorder;
(* ------------------------------------------------------------------ *)
PROCEDURE RemoveBorder( display :Display );
VAR
display_attributes, video_attributes, char_set :CARDINAL;
rows, cols :CARDINAL;
BEGIN (* RemoveBorder *)
action_status := SS$_NORMAL =
SMG$GET_DISPLAY_ATTR( display, rows, cols,
BITSET( display_attributes ),
BITSET( video_attributes ),
char_set );
IF action_status THEN
action_status := SS$_NORMAL =
SMG$CHANGE_VIRTUAL_DISPLAY( display, rows, cols,
BITSET( SMG$M_BORDER ),
BITSET( video_attributes ),
char_set );
END; (* if *)
END RemoveBorder;
(* ------------------------------------------------------------------ *)
PROCEDURE ChangeDisplayVideo( display :Display;
new_video :VideoAttributes );
VAR
display_attributes, video_attributes, char_set :CARDINAL;
rows, cols :CARDINAL;
BEGIN (* ChangeDisplayVideo *)
action_status := SS$_NORMAL =
SMG$GET_DISPLAY_ATTR( display, rows, cols,
BITSET( display_attributes ),
BITSET( video_attributes ),
char_set );
IF action_status THEN
(* get the new attributes *)
video_attributes := SMG$M_NORMAL;
IF video_bold IN new_video THEN
video_attributes := video_attributes + SMG$M_BOLD;
END;
IF video_reverse IN new_video THEN
video_attributes := video_attributes + SMG$M_REVERSE;
END;
IF video_blink IN new_video THEN
video_attributes := video_attributes + SMG$M_BLINK;
END;
IF video_underline IN new_video THEN
video_attributes := video_attributes + SMG$M_UNDERLINE;
END;
action_status := SS$_NORMAL =
SMG$CHANGE_VIRTUAL_DISPLAY( display, rows, cols,
BITSET( display_attributes ),
BITSET( video_attributes ),
char_set );
END; (* if *)
END ChangeDisplayVideo;
(* ------------------------------------------------------------------ *)
PROCEDURE ChangeDefaults;
BEGIN (* ChangeDefaults *)
END ChangeDefaults;
BEGIN (* SimpleWindows *)
action_status := TRUE;
insert_line_clr_flag := 0;
save_screen_row_begin := 0;
save_screen_row_end := 0;
pasteboard_initial_erase := 0; (* yes *)
erase_pasteborard_on_delete := 0; (* no *)
put_line_wrap_flag := 0;
put_line_direction := SMG$M_UP;
put_chars_rendition := SMG$M_NORMAL;
END SimpleWindows.