% ****************************************************** % ****************************************************** % ****************************************************** % * % * W I N D O W T O O L S % * % * Tools for Simula. % * % ****************************************************** % * % * Designed and programmed by Bjorn Kirkerud % * % * Start: Fall 1988 % * X10-version: Summer 1989 % * X11-version: Spring 1990 % * Redesigned: December 1991 % * Minor additions: October 1992 % * Added buttons and % * other tools for % * interaction: October 1992 % * Minor changes: Spring 1993 % * Redesigned and extended: % * Summer 1993 % * Extended and corrected: % * Winter and spring 1994 % * % ****************************************************** % If you do not use the cim-compiler, uncomment % the line below: class windowtools; begin integer version = 3.2;; end; external class Settools; external class Utilities; % If you do not use the cim-compiler, comment out the % line below: % class windowtools; begin integer version = 3.2;; end; class XDisplay; % Visible attributes (used only in XWindow): % procedure add_window(w); ref(XWindow) w; % procedure remove_window(WindowID); integer WindowID; % procedure Destroy_subwindows(windowID); integer windowID; % procedure handle_event; % procedure handle_pending_events; % ref(XFont) procedure find_font(font_name); text font_name; % procedure set_trace; % procedure unset_trace; % Boolean event_trace; begin ref(set) windows, fonts; procedure CreateDisplay; begin external C procedure xopendisplay is integer procedure XOpenDisplay;; external C procedure xeventpointer is integer procedure XEventPointer;; if XOpenDisplay = 0 then error("Windowtools failed in opening the display! "); event_pointer := XEventPointer; windows :- new set; fonts :- new set; end; ref(XFont) procedure find_font(font_name); text font_name; begin ref(Xfont) f; f :- fonts.find_element(font_name); if f == none then begin f :- new XFont(font_name); if not f.font_exists then f :- none else fonts.add_element(f); end; find_font :- f; end; procedure add_window(w); ref(XWindow) w; windows.add_element(w); ref(XWindow) procedure find_window(WindowID); integer WindowID; find_window :- windows.find_element(int_as_text(WindowID)); procedure remove_window(WindowID); integer WindowID; windows.remove_element(int_as_text(WindowID)); procedure Destroy_subwindows(windowID); integer windowID; begin procedure destroy(w); ref(element) w; if w qua XWindow .parentID = windowID then w qua XWindow.Destroy; windows.for_each_element(destroy); end; integer event_pointer; integer last_button_down_x, last_button_down_y; procedure handle_pending_events; begin external C procedure xpending is integer procedure XPending;; while XPending > 0 do handle_event; end; ref(sequence) own_event_queue; procedure create_own_event(wnd); ref(XWindow) wnd; own_event_queue.append(new own_event(wnd)); % Which window was the last to wait for alarms : integer waiting_for_alarm; procedure alarm_set(WindowID); integer WindowID; waiting_for_alarm := WindowID; procedure handle_event; begin external C procedure xpending is integer procedure XPending;; if XPending = 0 and then not own_event_queue.is_empty then begin own_event_queue.top qua own_event.wnd.handle_wakeup; own_event_queue.pop; end else handle_exo_event; end; procedure handle_exo_event; begin external C procedure xnextevent is procedure XNextEvent(event); integer event;; external C procedure xeventtype is integer procedure XEventType(event); integer event;; external C procedure xclientmessage is Boolean procedure XClientMessage(event); integer event;; external C procedure xeventwindow is integer procedure XEventWindow(event); integer event;; procedure SkipSimilarEvents; begin external C procedure xchecktypedeventwindow is Boolean procedure XCheckTypedEventWindow(event); integer event;; while XCheckTypedEventWindow(event_pointer) do; end; % Event-codes (defined in /local/x11/include/X11/X.h): integer KeyPress = 2, KeyRelease = 3, ButtonPress = 4, ButtonRelease = 5, MotionNotify = 6, EnterNotify = 7, LeaveNotify = 8, % FocusIn = 9, % FocusOut = 10, % KeymapNotify = 11, Expose = 12, GraphicsExpose = 13, NoExpose = 14, VisibilityNotify = 15, CreateNotify = 16, DestroyNotify = 17, UnmapNotify = 18, MapNotify = 19, ConfigureNotify = 22, % ConfigureRequest = 23, AlarmNotify = 33; integer windowid, event_type; integer mouse_epsilon = 10; ref(XWindow) window_of_event, wnd; XNextEvent(event_pointer); event_type := if XClientMessage(event_pointer) then AlarmNotify else XEventType(event_pointer); windowid := XEventWindow(event_pointer); window_of_event :- find_window(windowid); if event_trace then begin outtext(if event_type = AlarmNotify then " Alarm" else if event_type = EnterNotify then " Enter-event" else if event_type = LeaveNotify then " Leave-event" else if event_type = DestroyNotify then " Destroy-event" else if event_type = ConfigureNotify then " Configure-event" else if event_type = Expose then " Expose-event" else if event_type = ButtonPress then " ButtonDown" else if event_type = ButtonRelease then " ButtonUp" else if event_type = KeyPress then " KeyDown" else if event_type = KeyRelease then " KeyUp" else if event_type = NoExpose then " Noexpose-event" else if event_type = MapNotify then " Map-event" else if event_type = UnmapNotify then " UnMap-event" else if event_type = MotionNotify then " Motion-event" else (" Unspecified event (" & int_as_text(event_type) & ")")); outtext(" in window " & int_as_text(windowID)); if window_of_event == none then outtext(" (not in display!)"); if event_type = ButtonPress or event_type = ButtonRelease or event_type = MotionNotify or event_type = KeyPress or event_type = KeyRelease then begin % if not start_time_set then % begin start_time := time_of_event; start_time_set := true end; % outtext(", time: "); outint(time_of_event - start_time, 0); outtext(", x, y: "); outint(x_of_event, 0); outtext(", "); outint(y_of_event, 0); end; if event_type = ButtonPress or event_type = ButtonRelease then begin outtext(", button "); outint(button_number, 0) end else if event_type = KeyPress or event_type = KeyRelease then begin character c; integer kc; c := key_of_event; kc := key_code; if 32 <= rank(c) and rank(c) < maxrank then begin outtext(", key: "); outchar(c) end else begin outtext(", key-rank: "); outint(rank(c), 0) end; outtext(", key-code: "); outint(kc, 0); end; outimage; end; wnd :- window_of_event; if wnd =/= none then begin if event_type = ButtonPress or event_type = ButtonRelease or event_type = MotionNotify or event_type = KeyPress or event_type = KeyRelease then begin wnd.x_of_event := x_of_event; wnd.y_of_event := y_of_event; wnd.time_of_event := time_of_event; end; if event_type = KeyPress then begin character c; c := key_of_event; if 0 < rank(c) and rank(c) <= maxrank then begin Boolean sh; procedure Check_button(b); ref(element) b; inspect b when Button do if shortcut = c then begin handle_button_click(0); sh := true end; sh := false; if not(wnd in InputWindow and then wnd qua InputWindow.input_allowed) then begin wnd.children.for_each_element(Check_button); if not sh then windows.for_each_element(Check_button); end; if not sh then wnd.handle_key_down(c); end else wnd.handle_special_key_down(key_code); end else if event_type = KeyRelease then begin character c; c := key_of_event; if 0 < rank(c) and rank(c) <= maxrank then wnd.handle_key_up(c) else wnd.handle_special_key_up(key_code); end else if event_type = ButtonPress then begin wnd.handle_button_down(button_number); last_button_down_x := x_of_event; last_button_down_y := y_of_event; end else if event_type = ButtonRelease then begin wnd.handle_button_up(button_number); if abs(last_button_down_x - x_of_event) + abs(last_button_down_y - y_of_event) < mouse_epsilon then wnd.handle_button_click(button_number); end else if event_type = EnterNotify then wnd.handle_enter_window else if event_type = LeaveNotify then wnd.handle_leave_window else if event_type = MotionNotify then begin SkipSimilarEvents; wnd.handle_pointer_motion(x_of_event, y_of_event); end else if event_type = DestroyNotify then begin wnd.handle_destroy; remove_window(wnd.windowID); % the_display.remove_window(windowID); end else if event_type = ConfigureNotify then begin wnd.GetActualGeometry; wnd.ReplaceSubWindows; inspect wnd when SubWindow do if parent.elastic then parent.SetSizeToSubWindowSize; wnd.handle_configure; end else if event_type = MapNotify then wnd.mapped := true else if event_type = UnMapNotify then wnd.mapped := false else if event_type = Expose then begin % procedure showlabel(child); ref(element) child; % if child qua SubWindow.mapped % then child qua SubWindow.ShowCurrentLabel; SkipSimilarEvents; wnd.Refresh; wnd.ShowLabels; % if wnd.children =/= none % then wnd.children.for_each_element(showlabel); end else if event_type = NoExpose then SkipSimilarEvents else if event_type = AlarmNotify then begin if waiting_for_alarm = windowid and then wnd.alarm_sensitized then wnd.handle_alarm; end; end; end handle_event; % ****************************************************** % * % * Procedures to get event-data: % * % ****************************************************** integer procedure time_of_event; begin external C procedure xeventtime is integer procedure XEventTime(e); integer e;; time_of_event := XEventTime(event_pointer); end; integer procedure x_of_event; begin external C procedure xeventx is integer procedure XEventX(e); integer e;; x_of_event := XEventX(event_pointer); end; integer procedure y_of_event; begin external C procedure xeventy is integer procedure XEventY(e); integer e;; y_of_event := XEventY(event_pointer); end; integer procedure key_code; begin external C procedure xeventkeycode is integer procedure XEventKeycode(e); integer e;; key_code := XEventKeycode(event_pointer); end; character procedure key_of_event; begin external C procedure xlookupstring is integer procedure XLookupString(event, keybuffer, maxlength, keysym, status); text keybuffer; integer event, maxlength, keysym, status;; integer key_length, keysym, status; text key_buffer; integer key_buffer_length = 2; key_buffer :- blanks(key_buffer_length); key_length := XLookupString(event_pointer, key_buffer, key_buffer_length, keysym, status); key_of_event := if key_length = 0 then char(0) else key_buffer.sub(1,1).getchar; end; integer procedure button_number; begin external C procedure xeventbutton is integer procedure XEventButton(e); integer e;; button_number := XEventButton(event_pointer); end; integer start_time; Boolean start_time_set; Boolean event_trace; procedure set_trace; event_trace := true; procedure unset_trace; event_trace := false; own_event_queue :- new sequence; CreateDisplay; end Xdisplay; element class own_event(wnd); ref(XWindow) wnd;; % ****************************************************** % ****************************************************** % * % * Declaration of the class XGraphicalContext: % * % ****************************************************** % ****************************************************** class XGraphicalContext(the_window); ref(XWindow) the_window; % Visible attributes; % integer struct_pointer; % procedure SetLineWidth(width); integer width; % procedure SetXFont(fnt); ref(XFont) fnt; % Boolean procedure SetStipple(stp); ref(Bitmap) stp; begin integer struct_pointer; integer current_linewidth, current_foreground, current_background; ref(XFont) current_font; ref(Bitmap) current_stipple; Boolean BlackonWhite; procedure SetBlackonWhite; begin external C procedure xsetblackonwhite is procedure XSetBlackonWhite(gc); integer gc;; XSetBlackonWhite(struct_pointer); BlackonWhite := true; end; procedure SetWhiteonBlack; begin external C procedure xsetwhiteonblack is procedure XSetWhiteonBlack(gc); integer gc;; XSetWhiteonBlack(struct_pointer); BlackonWhite := false; end; % procedure SwapForeBack; % begin % external C procedure xswapforeback is % procedure XSwapForeBack(gc); integer gc;; % XSwapForeBack(struct_pointer); % end; procedure SetForeground(pix); integer pix; if pix >= 0 then begin external C procedure xsetforeground is procedure XSetForeground(gc, fgpix); integer gc, fgpix;; current_foreground := pix; XSetForeground(struct_pointer, pix) end; procedure SetLineWidth(width); integer width; begin external C procedure xsetlinewidth is procedure XSetLineWidth(gc_pointer, linewidth); integer gc_pointer, linewidth;; current_linewidth := width; XSetLineWidth(struct_pointer, width); end; procedure SetXFont(fnt); ref(XFont) fnt; if fnt =/= none then begin external C procedure xsetfont is procedure XSetFont(gc_pointer, fontID); integer gc_pointer, fontID;; current_font :- fnt; XSetFont(struct_pointer, fnt.fontID); end; Boolean procedure SetStipple(stp); ref(Bitmap) stp; if stp == none then SetStipple := false else begin external C procedure xsetstipple is procedure XSetStipple(gc_pointer, stipple); integer gc_pointer, stipple;; XSetStipple(struct_pointer, stp.BitmapID); current_stipple :- stp; SetStipple := true; end; procedure SetNoStipple; begin external C procedure xsetnostipple is procedure XSetNoStipple(gc_pointer); integer gc_pointer;; XSetNoStipple(struct_pointer); end; % procedure SetTile(t); ref(Bitmap) t; % begin % external C procedure xsettile is % procedure XSetTile(gc_pointer, tile); % integer gc_pointer, tile;; % tile :- t; % XSetTile(struct_pointer, t.BitmapID); % end; ref(XGraphicalContext) procedure copyfrom(gc); ref(XGraphicalContext) gc; if gc =/= none then begin SetLineWidth(gc.current_linewidth); SetXFont(gc.current_font); SetForeground(gc.current_foreground); % if gc.BlackOnWhite then SetBlackonWhite else SetWhiteonBlack; % SetStipple(gc.current_stipple); copyfrom :- this XGraphicalContext; end; procedure Create; begin external C procedure xcreategc is integer procedure XCreateGC(WindowID); integer WindowID;; struct_pointer := XCreateGC(the_window.windowID); end; ref(XGraphicalContext) procedure Invert; begin external C procedure xcreateinvertgc is integer procedure XCreateInvertGC(WindowID); integer WindowID;; struct_pointer := XCreateInvertGC(the_window.windowID); if BlackOnWhite then SetBlackonWhite else SetWhiteonBlack; SetLineWidth(current_linewidth); SetXFont(current_font); % SetStipple(current_stipple); Invert :- this XGraphicalContext; end; Create; end of XGraphicalContext; % ****************************************************** % ****************************************************** % * % * Declaration of the class XFont: % * % ****************************************************** % ****************************************************** element class XFont(font_name); value font_name; text font_name; % Visible attributes: % text procedure key; % integer fontID; % Boolean procedure font_exists; % integer procedure width_of_text(tt); text tt; % integer procedure font_height; % integer procedure font_ascent; % integer procedure font_descent; % integer procedure max_char_width; % integer procedure min_char_width; % integer procedure font_lbearing; % integer procedure font_rbearing; % integer procedure font_minrank; % integer procedure font_maxrank; % integer procedure leftbearing_of_char(c); character c; % integer procedure rightbearing_of_char(c); character c; % integer procedure width_of_char(c); character c; % integer procedure height_of_char(c); character c; % integer procedure ascent_of_char(c); character c; % integer procedure descent_of_char(c); character c; % Boolean procedure fixed_width; begin text procedure key; key :- font_name; integer procedure width_of_text(tt); text tt; if tt == notext then width_of_text := 0 else begin text ct; external C procedure xtextwidth is integer procedure XTextWidth(font_struct, tt); integer font_struct; text tt;; ct :- copy(tt); width_of_text := XTextWidth(font_struct, ct); end; integer procedure font_ascent; begin external C procedure xfontascent is integer procedure XFontAscent(font_struct); integer font_struct;; font_ascent := XFontAscent(font_struct); end; integer procedure font_descent; begin external C procedure xfontdescent is integer procedure XFontDescent(font_struct); integer font_struct;; font_descent := XFontDescent(font_struct); end; integer procedure font_height; begin external C procedure xfontheight is integer procedure XFontHeight(font_struct); integer font_struct;; font_height := XFontHeight(font_struct); end; integer procedure max_char_width; begin external C procedure xfontmaxwidth is integer procedure XFontMaxWidth(font_struct); integer font_struct;; max_char_width := XFontMaxWidth(font_struct); end; integer procedure min_char_width; begin external C procedure xfontminwidth is integer procedure XFontMinWidth(font_struct); integer font_struct;; min_char_width := XFontMinWidth(font_struct); end; integer procedure font_lbearing; begin external C procedure xfontlbearing is integer procedure XFontLBearing(font_struct); integer font_struct;; font_lbearing := XFontLBearing(font_struct); end; integer procedure font_rbearing; begin external C procedure xfontrbearing is integer procedure XFontRBearing(font_struct); integer font_struct;; font_rbearing := XFontRBearing(font_struct); end; integer procedure font_minrank; begin external C procedure xfontminchar is integer procedure XFontMinchar(font_struct); integer font_struct;; font_minrank := XFontMinChar(font_struct); end; integer procedure font_maxrank; begin external C procedure xfontmaxchar is integer procedure XFontMaxchar(font_struct); integer font_struct;; font_maxrank := XFontMaxChar(font_struct); end; integer procedure leftbearing_of_char(c); character c; if not(0 < rank(c) and rank(c) <= maxrank) then leftbearing_of_char := 0 else begin integer rk; external C procedure xcharlbearing is integer procedure XCharLBearing(font_struct, rank); integer font_struct, rank;; rk := rank(c) - font_minrank; leftbearing_of_char := XCharLBearing(font_struct, rk); end; integer procedure rightbearing_of_char(c); character c; if not(0 < rank(c) and rank(c) <= maxrank) then rightbearing_of_char := 0 else begin integer rk; external C procedure xcharrbearing is integer procedure XCharRBearing(font_struct, rank); integer font_struct, rank;; rk := rank(c) - font_minrank; rightbearing_of_char := XCharRBearing(font_struct, rk); end; integer procedure width_of_char(c); character c; if not(0 < rank(c) and rank(c) <= maxrank) then width_of_char := 0 else begin integer rk; external C procedure xcharwidth is integer procedure XCharWidth(font_struct, rank); integer font_struct, rank;; rk := rank(c) - font_minrank; width_of_char := XCharWidth(font_struct, rk); end; integer procedure height_of_char(c); character c; height_of_char := if not(0 < rank(c) and rank(c) <= maxrank) then 0 else ascent_of_char(c) + descent_of_char(c); integer procedure ascent_of_char(c); character c; if not(0 < rank(c) and rank(c) <= maxrank) then ascent_of_char := 0 else begin integer rk; external C procedure xcharascent is integer procedure XCharAscent(font_struct, rank); integer font_struct, rank;; rk := rank(c) - font_minrank; ascent_of_char := XCharAscent(font_struct, rk); end; integer procedure descent_of_char(c); character c; if not(0 < rank(c) and rank(c) <= maxrank) then descent_of_char := 0 else begin integer rk; external C procedure xchardescent is integer procedure XCharDescent(font_struct, rank); integer font_struct, rank;; rk := rank(c) - font_minrank; descent_of_char := XCharDescent(font_struct, rk); end; Boolean procedure fixed_width; begin external C procedure xfontmaxwidth is integer procedure XFontMaxWidth(font_struct); integer font_struct;; external C procedure xfontminwidth is integer procedure XFontMinWidth(font_struct); integer font_struct;; fixed_width := XFontMaxWidth(font_struct) = XFontMinWidth(font_struct); end; integer font_struct, ! a pointer (for C) to a XFont-struct; fontID; ! unique ID of this XFont; Boolean procedure font_exists; font_exists := font_struct <> 0; procedure Create; begin external C procedure xloadqueryfont is integer procedure XLoadQueryFont(font_name); text font_name;; external C procedure xfontid is integer procedure XFontID(font_struct); integer font_struct;; font_struct := XLoadQueryFont(font_name); fontID := if font_exists then XFontID(font_struct) else 0; end; Create; if not font_exists then outline("No font " & font_name); end of XFont; class Bitmap(BitmapID); integer BitmapID;; class Pixmap(PixmapID); integer PixmapID;; % ****************************************************** % % XWindow: % % ****************************************************** element class XWindow; % Visible attributes: % integer windowID, parentID; % integer procedure DisplayWidth; % integer procedure DisplayHeight; % Boolean procedure HighResolutionScreen; virtual: procedure CreateWindow is procedure CreateWindow;; procedure Refresh is procedure Refresh;; procedure handle_key_down is procedure handle_key_down(key); character key;; procedure handle_key_up is procedure handle_key_up(key); character key;; procedure handle_special_key_down is procedure handle_special_key_down(key_code); integer key_code;; procedure handle_special_key_up is procedure handle_special_key_up(key_code); integer key_code;; procedure handle_button_down is procedure handle_button_down(button); integer button;; procedure handle_button_click is procedure handle_button_click(button); integer button;; procedure handle_button_up is procedure handle_button_up(button); integer button;; procedure handle_pointer_motion is procedure handle_pointer_motion(x, y); integer x, y;; procedure handle_enter_window is procedure handle_enter_window;; procedure handle_leave_window is procedure handle_leave_window;; procedure handle_destroy is procedure handle_destroy;; procedure handle_configure is procedure handle_configure;; procedure handle_alarm is procedure handle_alarm;; procedure handle_wakeup is procedure handle_wakeup;; procedure Perform is procedure Perform(heading); text heading;; procedure PerformIn is procedure PerformIn(heading, wnd); text heading; ref(SubWindow) wnd;; procedure Wait is ref(XWindow) procedure Wait;; procedure ClickInRadioPanel is procedure ClickInRadioPanel(rb); ref(RadioPanel) rb;; procedure ClickInButton is procedure ClickInButton(b); ref(Button) b;; procedure LineChoice is procedure LineChoice(line); text line;; procedure LineChoiceIn is procedure LineChoiceIn(line, line_number, wnd); text line; integer line_number; ref(SubWindow) wnd;; procedure AllowInput is ref(XWindow) procedure AllowInput;; procedure DisallowInput is ref(XWindow) procedure DisallowInput;; procedure AllowChoice is ref(XWindow) procedure AllowChoice;; procedure InputInSubwindow is procedure InputInSubwindow(sw); ref(SubWindow) sw;; procedure SizeChange_in_SubWindow is procedure SizeChange_in_SubWindow(wnd); ref(SubWindow) wnd;; procedure SetFont is ref(XWindow) procedure SetFont(font_name); text font_name;; procedure SetHeadFont is ref(XWindow) procedure SetHeadFont(font_name); text font_name;; procedure SetSizeSub is procedure SetSizeSub;; procedure SetColumns is ref(XWindow) procedure SetColumns(ncolumns); integer ncolumns;; procedure SetMaxChars is ref(XWindow) procedure SetMaxChars(c); integer c;; procedure SetLines is ref(XWindow) procedure SetLines(lines); integer lines;; procedure Owner is ref(XWindow) procedure Owner;; procedure TopWindow is ref(XWindow) procedure TopWindow;; procedure MakeEmpty is ref(XWindow) procedure MakeEmpty;; procedure MakeHeadWindow is ref(XWindow) procedure MakeHeadWindow(heading); text heading;; procedure SetHeading is ref(XWindow) procedure SetHeading(heading); text heading;; procedure SetLabel is ref(XWindow) procedure SetLabel(a_label); text a_label;; procedure ShowCurrentLabel is procedure ShowCurrentLabel;; procedure PlaceCentered is ref(XWindow) procedure PlaceCentered;; procedure PlaceUpLeft is ref(XWindow) procedure PlaceUpLeft;; procedure PlaceUpRight is ref(XWindow) procedure PlaceUpRight;; procedure PlaceDownLeft is ref(XWindow) procedure PlaceDownLeft;; procedure PlaceDownRight is ref(XWindow) procedure PlaceDownRight;; procedure PlaceAfter is ref(XWindow) procedure PlaceAfter(wnd); ref(XWindow) wnd;; procedure PlaceBefore is ref(XWindow) procedure PlaceBefore(wnd); ref(XWindow) wnd;; procedure PlaceBelow is ref(XWindow) procedure PlaceBelow(wnd); ref(XWindow) wnd;; procedure PlaceAbove is ref(XWindow) procedure PlaceAbove(wnd); ref(XWindow) wnd;; procedure PlaceRightof is ref(XWindow) procedure PlaceRightof(wnd); ref(XWindow) wnd;; procedure PlaceLeftof is ref(XWindow) procedure PlaceLeftof(wnd); ref(XWindow) wnd;; procedure PlaceRightBelow is ref(XWindow) procedure PlaceRightBelow(wnd); ref(XWindow) wnd;; procedure PlaceLeftBelow is ref(XWindow) procedure PlaceLeftBelow(wnd); ref(XWindow) wnd;; procedure SetFancy is ref(XWindow) procedure SetFancy;; procedure window_kind is text procedure window_kind;; begin % ****************************************************** % ****************************************************** % * % * Connections to the environment: % * % ****************************************************** % ****************************************************** ref(XDisplay) the_display; ! A pointer to the XDisplay that owns this window; integer windowID; ! An integer which uniquely identifies this window. ! It is assigned a value by the X-system when ! this window is created; integer parentID; ! Identifies the parent of this window; ref(sequence) children; ref(XWindow) procedure add_window(w); ref(XWindow) w; begin % if children == none then children :- new sequence; children.append(w); add_window :- this XWindow; end; ref(ItemWindow) last_itemwindow; ref(XWindow) procedure add_itemwindow(w); ref(ItemWindow) w; begin w.prev_itemwindow :- last_itemwindow; if last_itemwindow =/= none then last_itemwindow.next_itemwindow :- w; last_itemwindow :- w; add_itemwindow :- this XWindow; end; text window_key; text procedure key; begin if window_key == notext then window_key :- int_as_text(windowID); key :- window_key; end; text procedure window_kind; window_kind :- "XWindow"; procedure CreateWindow;; procedure Initialize; begin InitializeGeometry; InitializeGraphics; InitializeSensitivity; children :- new sequence; end; integer procedure DisplayWidth; begin external C procedure xdisplaywidth is integer procedure XDisplayWidth;; DisplayWidth := XDisplayWidth; end; integer procedure DisplayHeight; begin external C procedure xdisplayheight is integer procedure XDisplayHeight;; DisplayHeight := XDisplayHeight; end; integer procedure DisplayWidthMM; begin external C procedure xdisplaywidthmm is integer procedure XDisplayWidthMM;; DisplayWidthMM := XDisplayWidthMM; end; integer procedure DisplayHeightMM; begin external C procedure xdisplayheightmm is integer procedure XDisplayHeightMM;; DisplayHeightMM := XDisplayHeightMM; end; Boolean procedure HighResolutionScreen; HighResolutionScreen := DisplayWidth*25.4/DisplayWidthMM > 87; % HighResolutionScreen := DisplayHeight > 1100; integer procedure ScreenDepth; begin external C procedure xscreendepth is integer procedure XScreenDepth;; ScreenDepth := XScreenDepth; end; integer procedure DefaultVisual; begin external C procedure xdefaultvisual is integer procedure XDefaultVisual;; DefaultVisual := XDefaultVisual; end; integer LeftButton = 1, CenterButton = 2, RightButton = 3; ref(XWindow) procedure SaveUnder; begin external C procedure xsaveunder is procedure XSaveUnder(WindowID); integer WindowID;; XSaveUnder(WindowID); SaveUnder :- this XWindow; end; ref(XWindow) procedure SetBackingStore; begin external C procedure xbackingstore is procedure XBackingStore(WindowID); integer WindowID;; XBackingStore(WindowID); SetBackingStore :- this XWindow; end; text procedure FetchCutBuffer; begin external C procedure xfetchbytes is text procedure XFetchBytes(nbytes); name nbytes; integer nbytes;; text bytes; integer nbytes; bytes :- XFetchBytes(nbytes); FetchCutBuffer :- bytes; end; procedure StoreInCutBuffer(t); text t; % if t =/= notext then begin external C procedure xstorebytes is procedure XStoreBytes(bytes, nbytes); text bytes; integer nbytes;; XStoreBytes(t, t.length); end; ref(SubWindow) LastSubwindow; ref(Button) procedure MakeButton(heading); text heading; MakeButton :- if fancy then MakeFancyButton(heading) else new Button(this XWindow, heading) .PlaceAfter(LastSubwindow) .Show; ref(FancyButton) procedure MakeFancyButton(heading); text heading; MakeFancyButton :- new FancyButton(this XWindow, heading) .PlaceAfter(LastSubwindow) .Show; ref(PromptWindow) procedure MakePromptWindow; MakePromptWindow :- (if fancy then MakeFancyPromptWindow else new PromptWindow(this XWindow)); % .PlaceLeftBelow(LastSubwindow); ref(PromptWindow) procedure MakeFancyPromptWindow; MakeFancyPromptWindow :- new PromptWindow(this XWindow) .SetFancy; ref(MessageWindow) procedure MakeMessageWindow; MakeMessageWindow :- new MessageWindow(this XWindow); ref(IntItemWindow) procedure MakeIntItemWindow; MakeIntItemWindow :- new IntItemWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(RealItemWindow) procedure MakeRealItemWindow; MakeRealItemWindow :- new RealItemWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(CharItemWindow) procedure MakeCharItemWindow; MakeCharItemWindow :- new CharItemWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(BoolItemWindow) procedure MakeBoolItemWindow; MakeBoolItemWindow :- new BoolItemWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(TextItemWindow) procedure MakeTextItemWindow; MakeTextItemWindow :- new TextItemWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(ScrollWindow) procedure MakeScrollWindow; MakeScrollWindow :- new ScrollWindow(this XWindow, 1000) .SetSize(width - 2*(depth_border + subwindow_spacing), height - 2*(depth_border + subwindow_spacing) - (if LastSubWindow == none then 0 else LastSubWindow.max_y)) .PlaceLeftBelow(LastSubWindow) .Show; ref(ListWindow) procedure MakeListWindow; MakeListWindow :- new ListWindow(this XWindow, 1000) .SetSize(width - 2*(depth_border + subwindow_spacing), height - 2*(depth_border + subwindow_spacing) - (if LastSubWindow == none then 0 else LastSubWindow.max_y)) .PlaceLeftBelow(LastSubWindow) .Show; ref(MultipleChoiceWindow) procedure MakeMultipleChoiceWindow; MakeMultipleChoiceWindow :- new MultipleChoiceWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(RadioPanel) procedure MakeRadioPanel; MakeRadioPanel :- new RadioPanel(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(MenuWindow) procedure MakeMenu; MakeMenu :- new MenuWindow(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(ParameterMenu) procedure MakeParameterMenu; MakeParameterMenu :- new ParameterMenu(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(ParameterList) procedure MakeParameterList; MakeParameterList :- new ParameterList(this XWindow) .PlaceAfter(LastSubwindow) .Show; ref(DrawWindow) procedure MakeDrawWindow; MakeDrawWindow :- new DrawWindow(this XWindow) .SetSize(width - 2*(depth_border + subwindow_spacing), height - 2*(depth_border + subwindow_spacing) - (if LastSubWindow == none then 0 else LastSubWindow.max_y)) .PlaceLeftBelow(LastSubwindow) .Show; procedure Perform(heading); text heading; begin chosen_button_heading :- heading; button_choice_made := true; end; procedure ClickInButton(b); ref(Button) b;; procedure PerformIn(heading, wnd); text heading; ref(SubWindow) wnd;; Boolean button_choice_made; text chosen_button_heading; text procedure ButtonChoice; begin button_choice_made := false; while not button_choice_made do handle_event; ButtonChoice :- chosen_button_heading; end; ref(XWindow) procedure Wait; Wait :- this XWindow; procedure InputInSubwindow(sw); ref(SubWindow) sw;; procedure SizeChange_in_SubWindow(wnd); ref(SubWindow) wnd;; ref(XWindow) procedure AllowInput; begin procedure a(wnd); ref(element) wnd; if wnd in XWindow then wnd qua XWindow.AllowInput; children.for_each_element(a); AllowInput :- this XWindow; end; ref(XWindow) procedure DisallowInput; begin procedure d(wnd); ref(element) wnd; if wnd in XWindow then wnd qua XWindow.DisAllowInput; children.for_each_element(d); DisAllowInput :- this XWindow; end; ref(XWindow) procedure AllowChoice; AllowChoice :- this XWindow; ref(XWindow) procedure DisallowChoice; DisallowChoice :- this XWindow; procedure ClickInRadioPanel(rb); ref(RadioPanel) rb;; procedure LineChoice(line); text line;; procedure LineChoiceIn(line, line_number, wnd); text line; integer line_number; ref(SubWindow) wnd;; ref(XWindow) procedure AllowButtonsInWindow; begin procedure allow(wnd); ref(element) wnd; if wnd in Button then wnd qua Button.Allow; children.for_each_element(allow); AllowButtonsInWindow :- this XWindow; end; ref(XWindow) procedure DisallowButtonsInWindow; begin procedure disallow(wnd); ref(element) wnd; if wnd in Button then wnd qua Button.DisAllow; children.for_each_element(disallow); DisallowButtonsInWindow :- this XWindow; end; % ****************************************************** % * % * Mapping etc.: % * % ****************************************************** Boolean mapped; ref(XWindow) procedure Show; begin external C procedure xmapwindow is procedure XMapWindow(WindowID); integer WindowID;; if not mapped then begin XMapWindow(windowID); while not mapped do the_display.handle_event; if this XWindow in MainWindow then GetActualGeometry; if head_window =/= none then head_window.Show; ShowCurrentLabel; end; Show :- this XWindow; end; ref(XWindow) procedure Hide; begin external C procedure xunmapwindow is procedure XUnmapWindow(WindowID); integer WindowID;; if mapped then begin XUnmapWindow(windowID); mapped := false; end; Hide :- this XWindow; end; ref(XWindow) procedure Raise; begin external C procedure xraisewindow is procedure XRaiseWindow(WindowID); integer WindowID;; XRaiseWindow(windowID); Raise :- this XWindow; end; procedure Destroy; begin external C procedure xdestroywindow is procedure XDestroyWindow(WindowID); integer WindowID;; the_display.Destroy_subwindows(windowID); XDestroyWindow(windowID); the_display.remove_window(windowID); end; ref(XWindow) procedure Clear; begin external C procedure xclearwindow is procedure XClearWindow(WindowID); integer WindowID;; XClearWindow(windowID); % MakeEmpty; Clear :- this XWindow; end; ref(XWindow) procedure Invert; Invert :- InvertRectangle(0, 0, width, height); ref(XWindow) procedure Fill; Fill :- FillRectangle(0, 0, width, height); procedure ShowLabels; begin procedure showlabel(child); ref(element) child; if child qua SubWindow.mapped then child qua SubWindow.ShowCurrentLabel; if children =/= none then children.for_each_element(showlabel); end; % ****************************************************** % * % * Events: % * % ****************************************************** procedure handle_event; the_display.handle_event; procedure handle_pending_events; the_display.handle_pending_events; procedure WakeUp; the_display.create_own_event(this XWindow); integer x_of_event, y_of_event, time_of_event; procedure InitializeSensitivity; begin if this XWindow in MainWindow then begin key_sensitize; button_sensitize end; alarm_sensitize; expose_sensitized := true; structure_sensitized := true; Sensitize; end; Boolean expose_sensitized, key_sensitized, button_press_sensitized, button_release_sensitized, enter_window_sensitized, leave_window_sensitized, pointer_motion_sensitized, structure_sensitized, alarm_sensitized; % ****************************************************** % * % * Procedures to sensitize and desensitize the window % * for various kinds of events: % * % ****************************************************** procedure button_sensitize; begin button_press_sensitized := true; button_release_sensitized := true; Sensitize; end; procedure button_desensitize; begin button_press_sensitized := false; button_release_sensitized := false; Sensitize; end; procedure key_sensitize; begin key_sensitized := true; Sensitize; end; procedure key_desensitize; begin key_sensitized := false; Sensitize; end; procedure alarm_sensitize; alarm_sensitized := true; procedure alarm_desensitize; alarm_sensitized := false; procedure enter_and_leave_sensitize; begin enter_window_sensitized := true; leave_window_sensitized := true; Sensitize; end; procedure enter_and_leave_desensitize; begin enter_window_sensitized := false; leave_window_sensitized := false; Sensitize; end; procedure pointer_motion_sensitize; begin pointer_motion_sensitized := true; Sensitize; end; procedure pointer_motion_desensitize; begin pointer_motion_sensitized := false; Sensitize; end; procedure Sensitize; begin external C procedure xselectinput is procedure XSelectInput(WindowID, EventMask); integer WindowID, EventMask;; integer KeyPressMaskVal = 1, ButtonPressMaskVal = 4, ButtonReleaseMaskVal = 8, EnterWindowMaskVal = 16, LeaveWindowMaskVal = 32, PointerMotionMaskVal = 64, StructureNotifyMaskVal = 131072, ExposureMaskVal = 32768; XSelectInput(windowID, (if key_sensitized then KeyPressMaskVal else 0) + (if button_press_sensitized then ButtonPressMaskVal else 0) + (if button_release_sensitized then ButtonReleaseMaskVal else 0) + (if enter_window_sensitized then EnterWindowMaskVal else 0) + (if leave_window_sensitized then LeaveWindowMaskVal else 0) + (if structure_sensitized then StructureNotifyMaskVal else 0) + (if pointer_motion_sensitized then PointerMotionMaskVal else 0) + (if expose_sensitized then ExposureMaskVal else 0)); end; % ****************************************************** % * % * Default versions of the virtual procedures that % * handle events of various kinds: % * % ****************************************************** procedure refresh;; procedure handle_destroy;; procedure handle_configure;; procedure handle_alarm;; procedure handle_key_down(key); character key;; procedure handle_key_up(key); character key;; procedure handle_special_key_down(key_code); integer key_code;; procedure handle_special_key_up(key_code); integer key_code;; procedure handle_button_click(button); integer button;; procedure handle_button_down(button); integer button;; procedure handle_button_up(button); integer button;; procedure handle_enter_window;; procedure handle_leave_window;; procedure handle_pointer_motion(x, y); integer x, y;; procedure handle_wakeup;; procedure set_trace; the_display.set_trace; procedure unset_trace; the_display.unset_trace; % ****************************************************** % * % * Setting the alarm-clock (only one for the system!) % * % ****************************************************** procedure SetAlarm(time); integer time; begin external C procedure xalarmclock is procedure XAlarmClock(WindowID, time); integer WindowID, time;; XAlarmClock(WindowID, time); the_display.alarm_set(WindowID); end; % ****************************************************** % * % * Geometry: % * % ****************************************************** integer current_width, current_height, current_minx, current_miny, current_border_width, subwindow_spacing, depth_border; procedure InitializeGeometry; begin current_width := 1; current_height := 1; current_minx := 0; current_minx := 1; current_border_width := 1; subwindow_spacing := 5; depth_border := 0; fancy := false; end; procedure write_geometry; begin sysout.outtext(window_kind & " w: " & int_as_text(width) & " h: " & int_as_text(height) & " mnx: " & int_as_text(min_x) & " mny: " & int_as_text(min_y)); sysout.outimage; end; integer procedure width; width := current_width; integer procedure height; height := current_height; integer procedure min_x; min_x := current_minx; integer procedure min_y; min_y := current_miny; integer procedure max_x; max_x := current_minx + current_width + 2*current_border_width; integer procedure max_y; max_y := current_miny + current_height + 2*current_border_width; integer procedure mid_x; mid_x := current_minx + current_border_width + current_width//2; integer procedure mid_y; mid_y := current_miny + current_border_width + current_height//2; integer procedure BorderWidth; BorderWidth := current_border_width; procedure GetActualGeometry; if the_display =/= none then begin integer depth, rootID; external C procedure xgetgeometry is Boolean procedure XGetGeometry( WindowID, rootID, x, y, width, height, borderwidth, depth); name rootID, x, y, width, height, borderwidth, depth; integer WindowID, rootID, x, y, width, height, borderwidth, depth;; XGetGeometry(windowID, rootID, current_minx, current_miny, current_width, current_height, current_border_width, depth); end; Boolean elastic; procedure SetElastic; elastic := true; ref(XWindow) procedure SetSize(new_width, new_height); integer new_width, new_height; begin external C procedure xresizewindow is procedure XResizeWindow(WindowID, width, height); integer WindowID, width, height;; current_width := max(1, new_width); current_height := max(1, new_height); if the_display =/= none then XResizeWindow(WindowID, current_width, current_height); if head_window =/= none then head_window.Place_and_size; SetSizeSub; Replace; SetSize :- this XWindow; end; procedure SetSizeSub;; ref(XWindow) procedure SetWidth(w); integer w; SetWidth :- SetSize(w, height); ref(XWindow) procedure SetHeight(h); integer h; SetHeight :- SetSize(width, h); ref(XWindow) procedure SetColumns(ncolumns); integer ncolumns; SetColumns :- SetWidth((ncolumns+1)*max_char_width + 2*depth_border); Boolean max_chars_set, max_lines_set; integer max_chars, max_lines; ref(XWindow) procedure SetMaxChars(c); integer c; begin max_chars := c; max_chars_set := true; SetMaxChars :- SetColumns(c); end; ref(XWindow) procedure SetLines(lines); integer lines; begin max_lines := lines; max_lines_set := true; SetLines :- SetHeight(max(head_height, max(1, depth_border)) + lines*font_height + font_descent + max(1, depth_border)); end; ref(XWindow) procedure SetSizeToSubwindowSize; begin integer sub_max_x, sub_max_y; procedure find_max(w); ref(element) w; inspect w when HeadWindow do when SubWindow do begin sub_max_x := max(sub_max_x, max_x); sub_max_y := max(sub_max_y, max_y); end; sub_max_x := minint0; sub_max_y := minint0; children.for_each_element(find_max); if sub_max_x > minint0 then begin integer new_w, new_h; new_w := sub_max_x + subwindow_spacing; new_h := sub_max_y + subwindow_spacing; if new_w <> width or new_h <> height then begin SetSize(new_w, new_h); ReplaceSubWindows; SetSizeToSubwindowSize; end; end; SetSizeToSubwindowSize :- this XWindow; end; % ref(XWindow) procedure SetSizeToSubwindowSize; % begin integer sub_min_x, sub_min_y, sub_max_x, sub_max_y; % procedure check_min(w); ref(element) w; % inspect w % when HeadWindow do % when SubWindow do % begin % sub_min_x := min(sub_min_x, min_x - label_width); % sub_min_y := min(sub_min_y, min_y); % end; % procedure find_minmax(w); ref(element) w; % inspect w % when HeadWindow do % when SubWindow do % begin % sub_max_x := max(sub_max_x, max_x); % sub_max_y := max(sub_max_y, max_y); % end; % sub_min_x := maxint; sub_min_y := maxint; % children.for_each_element(check_min); % if sub_min_x < 0 or sub_min_y < 0 then % begin % SetSize(width - sub_min_x, height - sub_min_y); % ReplaceSubwindows; % end; % sub_max_x := minint0; sub_max_y := minint0; % children.for_each_element(find_minmax); % if sub_max_x > minint0 then % begin integer new_w, new_h; % new_w := sub_max_x + subwindow_spacing; % new_h := sub_max_y + subwindow_spacing; % if new_w <> width or new_h <> height then % begin % SetSize(new_w, new_h); % ReplaceSubWindows; % SetSizeToSubwindowSize; % end; % end; % SetSizeToSubwindowSize :- this XWindow; % end; ref(XWindow) procedure SetHeightToSubwindowHeight; begin ref(XWindow) w; integer sub_max_y; procedure find_maxy(w); ref(element) w; sub_max_y := max(sub_max_y, w qua XWindow.max_y); sub_max_y := minint0; children.for_each_element(find_maxy); if sub_max_y > minint0 then SetHeight(sub_max_y + subwindow_spacing + depth_border); SetHeightToSubwindowHeight :- this XWindow; end; ref(XWindow) procedure SetWidthToSubwindowWidth; begin ref(XWindow) w; integer sub_max_x; procedure find_maxx(w); ref(element) w; sub_max_x := max(sub_max_x, w qua XWindow.max_x); sub_max_x := minint0; children.for_each_element(find_maxx); if sub_max_x > minint0 then SetWidth(sub_max_x + subwindow_spacing + depth_border); SetWidthToSubwindowWidth :- this XWindow; end; ref(XWindow) procedure MakeButtonsSameWidth; begin ref(XWindow) w; integer sub_max_w; procedure find_max_w(w); ref(element) w; if w in Button then sub_max_w := max(sub_max_w, w qua Button.width); procedure set_max_w(w); ref(element) w; if w in Button then w qua Button.SetWidth(sub_max_w); sub_max_w := minint0; children.for_each_element(find_max_w); if sub_max_w > minint0 then children.for_each_element(set_max_w); MakeButtonsSameWidth :- this XWindow; end; integer placed, PlacedUpLeft = 1, PlacedUpRight = 2, PlacedDownLeft = 3, PlacedDownRight = 4, PlacedAfter = 5, PlacedBefore = 6, PlacedLeftBelow = 7, PlacedRightBelow = 8, PlacedBelow = 9, PlacedAbove = 10, PlacedRightof = 11, PlacedLeftof = 12, PlacedCentered = 13, PlacedWithCenter = 14, PlacedAt = -1, placedat_x, placedat_y; ref(XWindow) procedure PlaceAt(minx, miny); integer minx, miny; begin external C procedure xmovewindow is procedure XMoveWindow(WindowID, x, y); integer WindowID, x, y;; % current_minx := max(0, minx); current_miny := max(0, miny); current_minx := minx; current_miny := miny; if the_display =/= none then XMoveWindow(WindowID, current_minx, current_miny); placed := PlacedAt; placedat_x := minx; placedat_y := miny; PlaceAt :- this XWindow; end; ref(XWindow) procedure PlaceWithCenterIn(x, y); integer x, y; begin PlaceWithCenterin :- PlaceAt(x - width//2, y - (height - head_height)//2); placed := PlacedWithCenter; placedat_x := x; placedat_y := y; end; ref(XWindow) preceding_window; procedure Replace; if placed = PlacedCentered then PlaceCentered else if placed = PlacedUpLeft then PlaceUpLeft else if placed = PlacedUpRight then PlaceUpRight else if placed = PlacedDownLeft then PlaceDownLeft else if placed = PlacedDownRight then PlaceDownRight else if placed = PlacedAfter then PlaceAfter(preceding_window) else if placed = PlacedBefore then PlaceBefore(preceding_window) else if placed = PlacedLeftBelow then PlaceLeftBelow(preceding_window) else if placed = PlacedRightBelow then PlaceRightBelow(preceding_window) else if placed = PlacedBelow then PlaceBelow(preceding_window) else if placed = PlacedAbove then PlaceAbove(preceding_window) else if placed = PlacedRightof then PlaceRightof(preceding_window) else if placed = PlacedLeftof then PlaceLeftof(preceding_window) else if placed = PlacedAt then PlaceAt(placedat_x, placedat_y) else if placed = PlacedWithCenter then PlaceWithCenterIn(placedat_x, placedat_y); procedure ReplaceSubWindows; begin procedure replace(w); ref(element) w; w qua SubWindow.replace; if children =/= none then begin LastSubWindow :- none; children.for_each_element(replace); end; end; Boolean fancy; ref(XWindow) procedure SetFancy; begin fancy := true; if head_window =/= none then head_window.SetFancy; SetFancy :- this XWindow; end; Boolean procedure IsFancy; IsFancy := fancy; ref(XWindow) procedure SetBorderWidth(new_borderwidth); integer new_borderwidth; begin external C procedure xsetwindowborderwidth is procedure XSetWindowBorderWidth(WindowID, bw); integer WindowID, bw;; current_border_width := max(0, new_borderwidth); XSetWindowBorderWidth(WindowID, current_border_width); SetBorderWidth :- this XWindow; end; integer procedure SubwindowSpacing; SubwindowSpacing := subwindow_spacing; ref(XWindow) procedure SetSubwindowSpacing(w); integer w; begin subwindow_spacing := max(0, w); SetSubwindowSpacing :- this XWindow; end; ref(XWindow) procedure SetDepthBorder(db); integer db; begin depth_border := max(0, db); SetDepthBorder :- this XWindow; end; integer procedure DepthBorder; DepthBorder := depth_border; ref(XWindow) procedure MakeEmpty; begin procedure me(wnd); ref(element) wnd; if wnd in XWindow then wnd qua XWindow.MakeEmpty; children.for_each_element(me); MakeEmpty :- this XWindow; end; ref(HeadWindow) head_window; ref(XWindow) procedure SetHeading(heading); text heading; SetHeading :- MakeHeadWindow(heading); ref(XWindow) procedure MakeHeadWindow(heading); text heading; begin if head_window == none then begin head_window :- new HeadWindow(this XWindow); SetHeight(head_height + height); end; head_window.SetHeading(heading); % if this XWindow in ItemWindow then begin integer w; w := 1.1*head_window.width_of_text(heading) + 4; if w > width then SetWidth(w); end; MakeHeadWindow :- this XWindow; end; integer procedure head_height; head_height := if head_window == none then 0 else (head_window.max_y + 2); % (head_window.max_y + head_window.head_gap); integer procedure head_width; head_width := if head_window == none then 0 else head_window.head_width; % ref(XWindow) procedure Thickborder(w); integer w; ref(XWindow) procedure Thickborder; begin integer i, hh, hw, w; w := DepthBorder; hh := if head_height = 0 then 0 else head_height + 2; hw := height - hh; % SetBlackonWhite; SetForeGround("black"); for i := 0 step 1 until w-1 do DrawRectangle(i, i + hh, width-2*i-1, hw-2*i-1); Thickborder :- this XWindow; end; % ref(XWindow) procedure Whiteborder(w); integer w; ref(XWindow) procedure Whiteborder; begin integer i, hh, hw, w; w := DepthBorder; hh := if head_height = 0 then 0 else head_height + 2; hw := height - hh; SetForeGround("white"); % SetWhiteonBlack; for i := 0 step 1 until w-1 do DrawRectangle(i, i + hh, width-2*i-1, hw-2*i-1); SetForeGround("black"); % SetBlackonWhite; Whiteborder :- this XWindow; end; ref(XWindow) procedure Upborder; begin integer i, hh, hw, w; w := DepthBorder; hh := if head_height = 0 then 0 else head_height + 2; hw := height - hh; if ScreenDepth < 4 then SetWhiteonBlack else SetForeground("gray12"); for i := 0 step 1 until w-1 do begin DrawLine(i, hh, i, height); DrawLine(0, i + hh, width, i + hh); end; if ScreenDepth < 4 then SetBlackonWhite else SetForeground("gray87"); for i := 1 step 1 until w do begin DrawLine(i, height - i, width, height - i); DrawLine(width - i, i + hh, width - i, height); end; SetForeground("black"); Upborder :- this XWindow; end; ref(XWindow) procedure Downborder; begin integer i, hh, hw, w; w := DepthBorder; hh := if head_height = 0 then 0 else head_height + 2; hw := height - hh; if ScreenDepth < 4 then SetBlackonWhite else SetForeground("gray87"); for i := 0 step 1 until w-1 do begin DrawLine(i, hh, i, height); DrawLine(0, i + hh, width, i + hh); end; if ScreenDepth < 4 then SetWhiteonBlack else SetForeground("gray12"); for i := 1 step 1 until w do begin DrawLine(i, height - i, width, height - i); DrawLine(width - i, i + hh, width - i, height); end; SetForeground("black"); Downborder :- this XWindow; end; % ****************************************************** % * % * Graphics: % * % ****************************************************** ref(XWindow) procedure DrawLine(x1, y1, x2, y2); integer x1, y1, x2, y2; begin external C procedure xdrawline is procedure XDrawLine(WindowID, gc_pointer, x1, y1, x2, y2); integer WindowID, gc_pointer, x1, y1, x2, y2;; XDrawLine(windowID, CurrentGC.struct_pointer, x1, y1, x2, y2); DrawLine :- this XWindow; end; ref(XWindow) procedure DrawInvertLine(x1, y1, x2, y2); integer x1, y1, x2, y2; begin integer gc; external C procedure xdrawline is procedure XDrawLine(WindowID, gc_pointer, x1, y1, x2, y2); integer WindowID, gc_pointer, x1, y1, x2, y2;; gc := InvertGC.struct_pointer; XDrawLine(windowID, gc, x1, y1, x2, y2); DrawInvertLine :- this XWindow; end; ref(XWindow) procedure DrawPoint(x, y); integer x, y; begin external C procedure xdrawpoint is procedure XDrawPoint(WindowID, gc_pointer, x, y); integer WindowID, gc_pointer, x, y;; XDrawPoint(windowID, CurrentGC.struct_pointer, x, y); DrawPoint :- this XWindow; end; ref(XWindow) procedure DrawInvertPoint(x, y); integer x, y; begin integer gc; external C procedure xdrawpoint is procedure XDrawPoint(WindowID, gc_pointer, x, y); integer WindowID, gc_pointer, x, y;; gc := InvertGC.struct_pointer; XDrawPoint(windowID, gc, x, y); DrawInvertPoint :- this XWindow; end; external C procedure xdrawpoints is procedure XDrawPoints(WindowID, gc_pointer, x, y, n, mode); integer WindowID, gc_pointer, n, mode; integer array x, y;; ref(XWindow) procedure DrawPolygon(x, y, n); integer array x, y; integer n; begin integer i; n := n - 1; for i := 1 step 1 until n do DrawLine(x(i-1), y(i-1), x(i), y(i)); DrawLine(x(n), y(n), x(0), y(0)); DrawPolygon :- this XWindow; end; ref(XWindow) procedure DrawArc(x1, y1, x2, y2, ang1, ang2); integer x1, y1, x2, y2; real ang1, ang2; begin integer x, y, w, h, iang1, iang2; ! Draws an arc inscribed in rectangle (x1, y1) - (x2, y2); ! The arc starts at angle ang1 and ends at ang1 + ang2; ! Both angles are counterclockwise from x-axis, i.e., 3 o'clock; external C procedure xdrawarc is procedure XDrawArc(WindowID, gc_pointer, x, y, width, height, ang1, ang2); integer WindowID, gc_pointer, x, y, width, height, ang1, ang2;; x := min(x1, x2); y := min(y1, y2); w := abs(x1 - x2); h := abs(y1 - y2); iang1 := 64*ang1; iang2 := 64*ang2; if w > 0 and h > 0 then XDrawArc(windowID, CurrentGC.struct_pointer, x, y, w, h, iang1, iang2); DrawArc :- this XWindow; end; ref(XWindow) procedure DrawCircle(center_x, center_y, radius); integer center_x, center_y, radius; DrawCircle :- DrawArc(center_x - radius, center_y - radius, center_x + radius, center_y + radius, 0, 360); ref(XWindow) procedure DrawEllipse(x1, y1, x2, y2); integer x1, y1, x2, y2; DrawEllipse :- DrawArc(x1, y1, x2, y2, 0, 360); ref(XWindow) procedure FillArc(x1, y1, x2, y2, ang1, ang2); integer x1, y1, x2, y2; real ang1, ang2; begin integer x, y, w, h, iang1, iang2, gc; external C procedure xfillarc is procedure XFillArc(WindowID, gc_pointer, x, y, width, height, ang1, ang2); integer WindowID, gc_pointer, x, y, width, height, ang1, ang2;; iang1 := 64*ang1; iang2 := 64*ang2; x := min(x1, x2); y := min(y1, y2); w := abs(x1 - x2); h := abs(y1 - y2); gc := FillGC.struct_pointer; if w > 0 and h > 0 then XFillArc(windowID, gc, x, y, w, h, iang1, iang2); FillArc :- this XWindow; end; ref(XWindow) procedure FillCircle(center_x, center_y, radius); integer center_x, center_y, radius; FillCircle :- FillArc(center_x - radius, center_y - radius, center_x + radius, center_y + radius, 0, 360); ref(XWindow) procedure FillEllipse(x1, y1, x2, y2); integer x1, y1, x2, y2; FillEllipse :- FillArc(x1, y1, x2, y2, 0, 360); ref(XWindow) procedure DrawRectangle(x, y, width, height); integer x, y, width, height; begin external C procedure xdrawrectangle is procedure XDrawRectangle(WindowID, gc_pointer, x, y, width, height); integer WindowID, gc_pointer, x, y, width, height;; XDrawRectangle(windowID, CurrentGC.struct_pointer, x, y, width, height); DrawRectangle :- this XWindow; end; ref(XWindow) procedure DrawInvertRectangle(x, y, width, height); integer x, y, width, height; begin integer gc; external C procedure xdrawrectangle is procedure XDrawRectangle(WindowID, gc_pointer, x, y, width, height); integer WindowID, gc_pointer, x, y, width, height;; gc := InvertGC.struct_pointer; XDrawRectangle(windowID, gc, x, y, width, height); DrawInvertRectangle :- this XWindow; end; ref(XWindow) procedure FillRectangle(x, y, width, height); integer x, y, width, height; begin integer gc; external C procedure xfillrectangle is procedure XFillRectangle(WindowID, gc_pointer, x, y, width, height); integer WindowID, gc_pointer, x, y, width, height;; gc := FillGC.struct_pointer; XFillRectangle(windowID, gc, x, y, width, height); FillRectangle :- this XWindow; end; ref(XWindow) procedure ClearRectangle(x, y, width, height); integer x, y, width, height; begin external C procedure xcleararea is procedure XClearArea(windowID, x, y, width, height); integer WindowID, x, y, width, height;; if width < 0 then begin width := -width; x := x - width end; if height < 0 then begin height := -height; y := y - height end; XClearArea(windowID, x, y, width, height); ClearRectangle :- this XWindow; end; ref(XWindow) procedure CopyRectangle(srcx, srcy, width, height, destx, desty); integer srcx, srcy, width, height, destx, desty; begin external C procedure xcopyarea is procedure XCopyArea(windowID, gc_pointer, srcx, srcy, width, height, destx, desty); integer WindowID, gc_pointer, srcx, srcy, width, height, destx, desty;; XCopyArea(windowID, CurrentGC.struct_pointer, srcx, srcy, width, height, destx, desty); CopyRectangle :- this XWindow; end; ref(XWindow) procedure WhiteRectangle(x, y, width, height); integer x, y, width, height; begin integer gc; external C procedure xfillrectangle is procedure XFillRectangle(WindowID, gc_pointer, x, y, width, height); integer WindowID, gc_pointer, x, y, width, height;; gc := WhiteGC.struct_pointer; XFillRectangle(windowID, gc, x, y, width, height); WhiteRectangle :- this XWindow; end; ref(XWindow) procedure InvertRectangle(x, y, width, height); integer x, y, width, height; begin integer gc; external C procedure xfillrectangle is procedure XFillRectangle(WindowID, gc_pointer, x, y, width, height); integer WindowID, gc_pointer, x, y, width, height;; gc := InvertGC.struct_pointer; XFillRectangle(windowID, gc, x, y, width, height); InvertRectangle :- this XWindow; end; ref(XWindow) procedure FillPolygon(x, y, n); integer array x, y; integer n; begin integer gc; external C procedure xfillpolygon is procedure XFillPolygon(WindowID, gc_pointer, x, y, n, mode); integer WindowID, gc_pointer, n, mode; integer array x, y;; gc := FillGC.struct_pointer; XFillPolygon(windowID, gc, x, y, n, 1); FillPolygon :- this XWindow; end; ref(XWindow) procedure SetLineWidth(linewidth); integer linewidth; begin if BlackGC =/= none then BlackGC.SetLineWidth(linewidth); if CurrentWhiteGC =/= none then CurrentWhiteGC.SetLineWidth(linewidth); if CurrentInvertGC =/= none then CurrentInvertGC.SetLineWidth(linewidth); CurrentGC.SetLineWidth(linewidth); SetLineWidth :- this XWindow; end; ref(XWindow) procedure SetBlackonWhite; begin SetForeGround("black"); % CurrentGC.SetBlackonWhite; % SetBlackonWhite :- this XWindow; end; ref(XWindow) procedure SetWhiteonBlack; begin SetForeGround("black"); % CurrentGC.SetWhiteonBlack; % SetWhiteonBlack :- this XWindow; end; ref(XWindow) procedure SetDrawStipple(stipplename); text stipplename; begin % if window_kind.length < 6 then else % if window_kind = "Item window" or window_kind.sub(1, 6) = "Button" then % outline("SetDrawStipple " & stipplename & " i " & window_kind); if stipplename = "black" then CurrentGC.SetBlackonWhite else if stipplename = "white" then CurrentGC.SetWhiteonBlack else CurrentGC.SetStipple(MakeBitmap(stipplename)); SetDrawStipple :- this XWindow; end; ref(XWindow) procedure SetNoStipple; begin CurrentGC.SetNoStipple; SetNoStipple :- this XWindow; end; ref(XGraphicalContext) BlackGC, CurrentGC, CurrentInvertGC, CurrentFillGC, CurrentWhiteGC; ref(XGraphicalContext) procedure InvertGC; begin if CurrentInvertGC == none then CurrentInvertGC :- new XGraphicalContext(this XWindow).Invert; InvertGC :- CurrentInvertGC; end; ref(XGraphicalContext) procedure FillGC; begin if CurrentFillGC == none then CurrentFillGC :- new XGraphicalContext(this XWindow); % .copyfrom(CurrentGC); FillGC :- CurrentFillGC; end; ref(XGraphicalContext) procedure WhiteGC; begin if CurrentWhiteGC == none then begin CurrentWhiteGC :- new XGraphicalContext(this XWindow) .copyfrom(CurrentGC); CurrentWhiteGC.SetWhiteonBlack; end; WhiteGC :- CurrentWhiteGC; end; procedure InitializeGraphics; begin BlackGC :- new XGraphicalContext(this XWindow); CurrentGC :- BlackGC; end; ref(XWindow) procedure SetFill(fillname); text fillname; begin integer pix; % FillGC.SetNostipple; CurrentFillGC :- none; FillGC; pix := pixel(fillname); if pix >= 0 then begin FillGC.SetForeground(pix) end else FillGC.SetStipple(MakeBitmap(fillname)); SetFill :- this XWindow; end; % ref(XWindow) procedure SetFill(fillname); text fillname; % begin % external C procedure xsetforeground is % procedure XSetForeground(gc, fgpix); integer gc, fgpix;; % integer gc; % pix := pixel(fillname); % gc := FillGC.struct_pointer; % if pix >= 0 % then XSetForeground(gc, pix) % else FillGC.SetStipple(MakeBitmap(fillname)); % SetFill :- this XWindow; % end; % begin % if fillname = "black" then FillGC.SetBlackonWhite else % if fillname = "white" then FillGC.SetWhiteonBlack else % FillGC.SetStipple(MakeBitmap(fillname)); % SetFill :- this XWindow; % end; integer procedure pixel(colorname); text colorname; begin external C procedure whitepixel is integer procedure WhitePixel;; external C procedure blackpixel is integer procedure BlackPixel;; pixel := if colorname = "black" then BlackPixel else if colorname = "white" then WhitePixel else if Screendepth < 4 then -1 else if colorname = "gray12" then 12 else if colorname = "gray25" then 10 else if colorname = "gray50" then 9 else if colorname = "gray75" then 2 else if colorname = "gray87" then 14 else -1; end; ref(XWindow) procedure SetForeground(foreground); text foreground; begin integer pix; pix := pixel(foreground); if pix >= 0 then begin if CurrentGC =/= none then begin CurrentGC.SetForeground(pix); CurrentGC.SetNostipple; end; end else SetDrawStipple(foreground); SetForeground :- this XWindow; end; % ref(XWindow) procedure SetForeground(foreground); text foreground; % begin % external C procedure xsetforeground is % procedure XSetForeground(gc, fgpix); integer gc, fgpix;; % integer pix; % pix := pixel(foreground); % if pix >= 0 % then XSetForeground(CurrentGC.struct_pointer, pix) % else SetDrawStipple(foreground); % SetForeground :- this XWindow; % end; ref(XWindow) procedure SetStipple(stp); ref(Bitmap) stp; begin FillGC.SetStipple(stp); Setstipple :- this XWindow; end; ref(Bitmap) procedure MakeBitmap(fillname); text fillname; begin external C procedure xgray12 is integer procedure XGray12(WindowID); integer WindowID;; external C procedure xgray25 is integer procedure XGray25(WindowID); integer WindowID;; external C procedure xgray50 is integer procedure XGray50(WindowID); integer WindowID;; external C procedure xgray75 is integer procedure XGray75(WindowID); integer WindowID;; external C procedure xgray87 is integer procedure XGray87(WindowID); integer WindowID;; external C procedure whitepixel is integer procedure WhitePixel;; if WhitePixel = 1 then begin if fillname = "gray12" then MakeBitmap :- new Bitmap(XGray12(windowID)) else if fillname = "gray25" then MakeBitmap :- new Bitmap(XGray25(windowID)) else if fillname = "gray50" then MakeBitmap :- new Bitmap(XGray50(windowID)) else if fillname = "gray75" then MakeBitmap :- new Bitmap(XGray75(windowID)) else if fillname = "gray87" then MakeBitmap :- new Bitmap(XGray87(windowID)) else if fillname =/= notext then MakeBitmap :- ReadBitmapFile(fillname) else MakeBitmap :- none; end else begin if fillname = "gray12" then MakeBitmap :- new Bitmap(XGray87(windowID)) else if fillname = "gray25" then MakeBitmap :- new Bitmap(XGray75(windowID)) else if fillname = "gray50" then MakeBitmap :- new Bitmap(XGray50(windowID)) else if fillname = "gray75" then MakeBitmap :- new Bitmap(XGray25(windowID)) else if fillname = "gray87" then MakeBitmap :- new Bitmap(XGray12(windowID)) else if fillname =/= notext then MakeBitmap :- ReadBitmapFile(fillname) else MakeBitmap :- none; end; % MakeBitmap :- % if fillname = "gray50" then new Bitmap(XGray50(windowID)) else % if fillname = "gray25" then new Bitmap(if WhitePixel = 1 % then XGray25(windowID) else XGray75(windowID)) else % if fillname = "gray75" then new Bitmap(if WhitePixel = 1 % then XGray75(windowID) else XGray25(windowID)) else % if fillname = "gray12" then new Bitmap(if WhitePixel = 1 % then XGray12(windowID) else XGray87(windowID)) else % if fillname = "gray87" then new Bitmap(if WhitePixel = 1 % then XGray87(windowID) else XGray12(windowID)) else % if fillname =/= notext then ReadBitmapFile(fillname) % else none; end; ref(Bitmap) procedure ReadBitmapFile(bitmapfilename); text bitmapfilename; begin integer status, bw, bh, xh, yh, bid; external C procedure xreadbitmapfile is integer procedure XReadBitmapFile(WindowID, bitmap_file, bitmap_width, bitmap_height, bitmap, x_hot, y_hot); name bitmap_width, bitmap_height, bitmap, x_hot, y_hot; integer WindowID; text bitmap_file; integer bitmap_width, bitmap_height, bitmap, x_hot, y_hot;; status := XReadBitmapFile(windowID, bitmapfilename, bw, bh, bid, xh, yh); if status <> 0 then ReadBitmapFile :- none else ReadBitmapFile :- new Bitmap(bid); % else new Bitmap(bid, bw, bh, xh, yh); end; ref(XWindow) procedure SetBackGround(fillname); text fillname; begin external C procedure xsetwindowbackground is procedure XSetWindowBackground(windowid, pix); integer windowid, pix;; integer pix; pix := pixel(fillname); if pix >= 0 then begin XSetWindowBackground(windowID, pix); if mapped then begin Hide; Show end; SetBackGround :- this XWindow; end else begin ref(Pixmap) bm; external C procedure xsetwindowbackgroundpixmap is procedure XSetWindowBackGroundPixMap(windowid, pix); integer windowid, pix;; bm :- MakePixmap(fillname); if bm =/= none then XSetWindowBackGroundPixMap(WindowID, bm.PixmapID); SetBackGround :- this XWindow; end; end; % ref(XWindow) procedure SetBackGround(fillname); text fillname; % if (fillname = "black" or fillname = "white") or else % (Screendepth >= 4 and then % (fillname = "gray12" or else fillname = "gray25" or else % fillname = "gray50" or else fillname = "gray75" or else % fillname = "gray87")) then % begin % external C procedure xsetwindowbackground is % procedure XSetWindowBackground(windowid, pix); % integer windowid, pix;; % external C procedure whitepixel is % integer procedure WhitePixel;; % external C procedure blackpixel is % integer procedure BlackPixel;; % integer pix; % pix := if fillname = "black" then BlackPixel else % if fillname = "white" then WhitePixel else % if fillname = "gray12" then 12 else % if fillname = "gray25" then 8 else % if fillname = "gray50" then 4 else % if fillname = "gray75" then 5 else % if fillname = "gray87" then 7 % else BlackPixel; % XSetWindowBackground(windowID, pix); % if mapped then begin Hide; Show end; % SetBackGround :- this XWindow; % end else % begin ref(Pixmap) bm; % external C procedure xsetwindowbackgroundpixmap is % procedure XSetWindowBackGroundPixMap(windowid, pix); % integer windowid, pix;; % bm :- MakePixmap(fillname); % if bm =/= none then XSetWindowBackGroundPixMap(WindowID, bm.PixmapID); % SetBackGround :- this XWindow; % end; ref(Pixmap) procedure MakePixmap(fillname); text fillname; begin external C procedure xgray12pixmap is integer procedure xgray12pixmap(windowID); integer windowID;; external C procedure xgray25pixmap is integer procedure xgray25pixmap(windowID); integer windowID;; external C procedure xgray50pixmap is integer procedure xgray50pixmap(windowID); integer windowID;; external C procedure xgray75pixmap is integer procedure xgray75pixmap(windowID); integer windowID;; external C procedure xgray87pixmap is integer procedure xgray87pixmap(windowID); integer windowID;; external C procedure whitepixel is integer procedure WhitePixel;; if WhitePixel = 1 then begin if fillname = "gray12" then MakePixmap :- new Pixmap(XGray12Pixmap(windowID)) else if fillname = "gray25" then MakePixmap :- new Pixmap(XGray25Pixmap(windowID)) else if fillname = "gray50" then MakePixmap :- new Pixmap(XGray50Pixmap(windowID)) else if fillname = "gray75" then MakePixmap :- new Pixmap(XGray75Pixmap(windowID)) else if fillname = "gray87" then MakePixmap :- new Pixmap(XGray87Pixmap(windowID)) else MakePixmap :- none; end else begin if fillname = "gray12" then MakePixmap :- new Pixmap(XGray87Pixmap(windowID)) else if fillname = "gray25" then MakePixmap :- new Pixmap(XGray75Pixmap(windowID)) else if fillname = "gray50" then MakePixmap :- new Pixmap(XGray50Pixmap(windowID)) else if fillname = "gray75" then MakePixmap :- new Pixmap(XGray25Pixmap(windowID)) else if fillname = "gray87" then MakePixmap :- new Pixmap(XGray12Pixmap(windowID)) else MakePixmap :- none; end; % MakePixmap :- % if fillname = "gray50" then new Pixmap(XGray50Pixmap(windowID)) else % if fillname = "gray25" then new Pixmap(if WhitePixel = 1 % then XGray25Pixmap(windowID) else XGray75Pixmap(windowID)) else % if fillname = "gray75" then new Pixmap(if WhitePixel = 1 % then XGray75Pixmap(windowID) else XGray25Pixmap(windowID)) else % if fillname = "gray12" then new Pixmap(if WhitePixel = 1 % then XGray12Pixmap(windowID) else XGray87Pixmap(windowID)) else % if fillname = "gray87" then new Pixmap(if WhitePixel = 1 % then XGray87Pixmap(windowID) else XGray12Pixmap(windowID)) % else none; end; ref(XFont) CurrentXFont; ref(XWindow) procedure SetFont(font_name); text font_name; SetFont :- SetXFont(new XFont(font_name)); ref(XWindow) procedure SetHeadFont(font_name); text font_name; begin if head_window =/= none then head_window.SetFont(font_name); SetHeadFont :- this XWindow; end; integer default_font_points = 12; text procedure DefaultFont; DefaultFont :- FontName("helvetica", default_font_points, true, false); Boolean Norsktekst; ref(XWindow) procedure SettNorskTekst; begin if not Norsktekst then begin Norsktekst := true; SetXFont(new Xfont(DefaultFont)) end; SettNorskTekst :- this XWindow; end; ref(XWindow) procedure SetEnglishText; begin if Norsktekst then begin Norsktekst := false; SetXFont(new Xfont(DefaultFont)) end; SetEnglishText :- this XWindow; end; % text current_typeface; % integer current_font_size; % Boolean current_bold_font, current_slanted_font; ref(XWindow) procedure SetTypeFace(typeface, size, bold, slanted); text typeface; integer size; Boolean bold, slanted; begin SetTypeFace :- SetFont(FontName(typeface, size, bold, slanted)); if FontExists then begin % current_typeface :- typeface; % current_font_size := size; % current_bold_font := bold; % current_slanted_font := slanted; % if head_window =/= none then % head_window.SetTypeFace("helvetica", size, bold, slanted); end; end; ref(XWindow) procedure SetSymbolFont(typeface, size); text typeface; integer size; begin SetSymbolFont :- SetFont(FontName(typeface, size, true, true)); if FontExists then begin % current_typeface :- typeface; % current_font_size := size; % current_bold_font := true; % current_slanted_font := true; end; end; text procedure FontName(typeface, size, bold, slanted); text typeface; integer size; Boolean bold, slanted; FontName :- if typeface = "present bullets" then ("*" & typeface & "*" & int_as_text(size) & "-" & int_as_text(10*size) & "*" & (if HighResolutionScreen then "100-100" else "75-75") & "*") else if typeface = "decwrite boxes" or typeface = "decwrite pictures" then ("*" & typeface & "*" & int_as_text(10*size) & "*" & (if HighResolutionScreen then "100-100" else "75-75") & "*") else if typeface = "symbol" or typeface = "itc zapfdingbats" then ("*" & typeface & "*" & int_as_text(10*size) & "*") else if typeface = "lucidasans" or typeface = "lucidasanstypewriter" then (typeface & "-" & (if typeface = "lucidasanstypewriter" then (if bold then "bold-" else notext) else (if bold and slanted then "bolditalic-" else if bold and not slanted then "bold-" else if not bold and slanted then "italic-" else notext)) & int_as_text(size)) else if typeface = "helvetica" or typeface = "courier" or typeface = "new century schoolbook" or typeface = "times" or typeface = "fixed" or typeface = "lucida" or typeface = "clean" or typeface = "lucidabright" or typeface = "lucidatypewriter" or typeface = "charter" then ("*" & typeface & "*" & (if bold then "bold" else "medium") & "-" & (if not slanted then "r" else (if typeface = "helvetica" or typeface = "courier" then "o" else "i")) & "-normal--*-" & int_as_text(10*size) & "-" & (if HighResolutionScreen then "100-100" else "75-75") & "*" & "iso8859-1") else typeface; ref(XWindow) procedure SetXFont(font); ref(XFont) font; begin if font =/= none and then font.font_exists and CurrentGC =/= none then begin CurrentXFont :- font; if BlackGC =/= none then BlackGC.SetXFont(CurrentXFont); if CurrentWhiteGC =/= none then CurrentWhiteGC.SetXFont(CurrentXFont); if CurrentInvertGC =/= none then CurrentInvertGC.SetXFont(CurrentXFont); LastFontOK := true; if max_chars_set then SetMaxChars(max_chars); if max_lines_set then SetLines(max_lines); end else LastFontOK := false; SetXFont :- this XWindow; end; Boolean LastFontOK; Boolean procedure FontExists; FontExists := LastFontOK; text procedure CurrentFontname; CurrentFontname :- if FontExists then CurrentXFont.font_name else notext; external C procedure getfontlist is integer procedure GetFontList(maxnames); integer maxnames;; external C procedure nextinfontlist is text procedure NextinFontList;; Boolean highlighting; ref(XWindow) procedure HighLightText(on); Boolean on; begin highlighting := on; HighLightText :- this XWindow; end; Boolean procedure newlinechar(c); character c; newlinechar := rank(c) = 10 or rank(c) = 13; ref(XWindow) procedure DrawText(x, y, t); integer x, y; text t; begin character c, d; integer p, cx, cy; cx := x; cy := y; t.setpos(1); p := 1; while t.more do begin c := t.getchar; if newlinechar(c) then begin if t.pos - 1 > p then XDrawText(cx, cy, t.sub(p, t.pos - 1 - p)); cy := cy + font_height; if t.more then begin d := t.getchar; if c = d or not newlinechar(d) then t.setpos(t.pos - 1); end; p := t.pos; end; end; if p <= t.length then XDrawText(cx, cy, t.sub(p, t.length - p + 1)); DrawText :- this XWindow; end; procedure XDrawText(x, y, t); integer x, y; text t; begin external C procedure xdrawstring is procedure XDrawString(WindowID, gc, x, y, t); integer WindowID, gc, x, y; text t;; external C procedure xdrawimagestring is procedure XDrawImageString(WindowID, gc, x, y, t); integer WindowID, gc, x, y; text t;; if t =/= notext then begin text ct; ct :- copy(t); if highlighting then begin CurrentGC.SetWhiteOnBlack; XDrawImageString(windowID, CurrentGC.struct_pointer, x, y, ct); CurrentGC.SetBlackOnWhite; end else XDrawString(windowID, CurrentGC.struct_pointer, x, y, ct); end; end; ref(XWindow) procedure DrawTextCenterIn(x, y, t); integer x, y; text t; DrawTextCenterIn :- DrawText(x - width_of_text(t)//2, y + (font_ascent - font_descent)//2, t); ref(XWindow) procedure DrawCenterText(t); text t; DrawCenterText :- DrawText((width - width_of_text(t))//2, (height + head_height + font_ascent - font_descent)//2, t); integer CenterPos = 1, RightPos = 2, LeftPos = 3, BottomPos = 4, TopPos = 5; ref(XWindow) procedure DrawTextPos(x, y, t, hpos, vpos); integer x, y; text t; integer hpos, vpos; begin integer tx, ty; tx := x - (if hpos = CenterPos then width_of_text(t)//2 else if hpos = RightPos then width_of_text(t) else 0); ty := y + (if vpos = CenterPos then (font_ascent - font_descent)//2 else if vpos = TopPos then font_ascent else -font_descent); DrawTextPos :- DrawText(tx, ty, t); end; integer procedure width_of_text(t); text t; width_of_text := if font_set then CurrentXFont.width_of_text(t) else 0; integer procedure font_ascent; font_ascent := if font_set then CurrentXFont.font_ascent else 0; integer procedure font_descent; font_descent := if font_set then CurrentXFont.font_descent else 0; integer procedure font_height; font_height := font_ascent + font_descent; integer procedure max_char_width; max_char_width := if font_set then CurrentXFont.max_char_width else 0; integer procedure font_lbearing; font_lbearing := if font_set then CurrentXFont.font_lbearing else 0; integer procedure font_rbearing; font_rbearing := if font_set then CurrentXFont.font_rbearing else 0; integer procedure font_minrank; font_minrank := if font_set then CurrentXFont.font_minrank else 0; integer procedure font_maxrank; font_maxrank := if font_set then CurrentXFont.font_maxrank else 0; integer procedure leftbearing_of_char(c); character c; leftbearing_of_char := if font_set then CurrentXFont.leftbearing_of_char(c) else 0; integer procedure rightbearing_of_char(c); character c; rightbearing_of_char := if font_set then CurrentXFont.rightbearing_of_char(c) else 0; integer procedure width_of_char(c); character c; width_of_char := if font_set then CurrentXFont.width_of_char(c) else 0; integer procedure height_of_char(c); character c; height_of_char := if font_set then CurrentXFont.height_of_char(c) else 0; integer procedure ascent_of_char(c); character c; ascent_of_char := if font_set then CurrentXFont.ascent_of_char(c) else 0; integer procedure descent_of_char(c); character c; descent_of_char := if font_set then CurrentXFont.descent_of_char(c) else 0; Boolean procedure font_set; font_set := CurrentXFont =/= none; % ****************************************************** % * % * Procedures to move and access the pointer % * % ****************************************************** ref(XWindow) procedure PlacePointer(x, y); integer x, y; begin external C procedure xwarppointer is procedure XWarpPointer(WindowID, x, y); integer WindowID, x, y;; XWarpPointer(windowID, x, y); PlacePointer :- this XWindow; end; ref(XWindow) procedure PlacePointerRight; PlacePointerRight :- PlacePointer(width - max_char_width, height//2); Boolean procedure PointerInside; begin external C procedure xquerypointer is Boolean procedure XQueryPointer( WindowID, rootID, childID, rootx, rooty, winx, winy, kbuttons); name rootID, childID, rootx, rooty, winx, winy, kbuttons; integer WindowID, rootID, childID, rootx, rooty, winx, winy, kbuttons;; integer rootID, childID, wID, rootx, rooty, winx, winy, kbuttons; Boolean b; b := XQueryPointer(parentID, rootID, wID, rootx, rooty, winx, winy, kbuttons); PointerInside := b and then wID = WindowID; end; Boolean procedure FindPointerPos(x, y); name x, y; integer x, y; begin integer rootID, childID, wID, rootx, rooty, winx, winy, kbuttons; external C procedure xquerypointer is Boolean procedure XQueryPointer( WindowID, rootID, childID, rootx, rooty, winx, winy, kbuttons); name rootID, childID, rootx, rooty, winx, winy, kbuttons; integer WindowID, rootID, childID, rootx, rooty, winx, winy, kbuttons;; FindPointerPos := XQueryPointer(parentID, rootID, wID, rootx, rooty, winx, winy, kbuttons); x := winx - current_minx - current_border_width; y := winy - current_miny - current_border_width; end; CreateWindow; end XWindow; XWindow class MainWindow(window_name); text window_name; virtual: procedure FindRoot is procedure FindRoot;; procedure TraceCreation is procedure TraceCreation;; begin procedure CreateWindow; begin external C procedure xcreatewindow is integer procedure XCreateWindow(parentID, window_name); integer parentID; text window_name;; FindRoot; if the_display =/= none then begin windowID := XCreateWindow(parentID, window_name); the_display.add_window(this XWindow); Initialize; SetXfont(the_display.find_font(DefaultFont)); TraceCreation; end; end CreateWindow; text procedure window_kind; window_kind :- "Main window" & window_name; procedure FindRoot; begin external C procedure xrootwindow is integer procedure XRootWindow;; the_display :- new XDisplay; parentID := XRootWindow; end; procedure TraceCreation; if the_display.event_trace then outline("Main window " & window_name & " with ID " & int_as_text(windowID) & " created"); ref(XWindow) procedure Owner; Owner :- none; ref(XWindow) procedure TopWindow; TopWindow :- this XWindow; ref(XWindow) procedure SetLabel(a_label); text a_label;; procedure ShowCurrentLabel;; integer procedure sw_gap; sw_gap := SubwindowSpacing; ref(XWindow) procedure PlaceCentered; PlaceCentered :- Placeat((DisPlayWidth - width)//2, (DisplayHeight - height - head_height)//2); ref(XWindow) procedure PlaceUpLeft; PlaceUpLeft :- Placeat(sw_gap, sw_gap); ref(XWindow) procedure PlaceUpRight; PlaceUpRight :- Placeat(DisPlayWidth - (max_x - min_x) - sw_gap, sw_gap); ref(XWindow) procedure PlaceDownLeft; PlaceDownLeft :- Placeat(sw_gap, DisplayHeight - (max_y - min_y) - sw_gap); ref(XWindow) procedure PlaceDownRight; PlaceDownRight :- Placeat(DisPlayWidth - (max_x - min_x) - sw_gap, DisplayHeight - (max_y - min_y) - sw_gap); ref(XWindow) procedure PlaceAfter(wnd); ref(XWindow) wnd; PlaceAfter :- if wnd == none then PlaceUpLeft else if wnd.max_x + 2*sw_gap + width > DisPlayWidth then PlaceLeftBelow(wnd) else PlaceAt(wnd.max_x + sw_gap, wnd.min_y); ref(XWindow) procedure PlaceBefore(wnd); ref(XWindow) wnd; PlaceBefore :- if wnd.min_x - 2*sw_gap < width then Placeat(DisPlayWidth - (max_x - min_x) - sw_gap, wnd.max_y + sw_gap) else Placeat(wnd.min_x - sw_gap - 2 - width, wnd.min_y); ref(XWindow) procedure PlaceLeftBelow(wnd); ref(XWindow) wnd; PlaceLeftBelow :- Placeat(sw_gap, (if wnd =/= none then wnd.max_y else 0) + sw_gap); ref(XWindow) procedure PlaceRightBelow(wnd); ref(XWindow) wnd; PlaceRightBelow :- Placeat(DisPlayWidth - (max_x - min_x) - sw_gap, (if wnd =/= none then wnd.max_y else 0) + sw_gap); ref(XWindow) procedure PlaceBelow(wnd); ref(XWindow) wnd; PlaceBelow :- Placeat(wnd.min_x, (if wnd =/= none then wnd.max_y else 0) + sw_gap); ref(XWindow) procedure PlaceAbove(wnd); ref(XWindow) wnd; PlaceAbove :- if wnd == none then PlaceUpLeft else Placeat(wnd.min_x, wnd.min_y - sw_gap - height); ref(XWindow) procedure PlaceRightof(wnd); ref(XWindow) wnd; PlaceRightof :- Placeat(wnd.max_x + sw_gap, wnd.min_y); ref(XWindow) procedure PlaceLeftof(wnd); ref(XWindow) wnd; PlaceLeftof :- Placeat(wnd.min_x - sw_gap - (max_x - min_x), wnd.min_y); % ref(XWindow) procedure PlaceTopRightof(wnd); ref(XWindow) wnd; % PlaceTopRightof :- Placeat(wnd.max_x + sw_gap, % parent_depth_border + sw_gap + parent_head_height); ref(GraphPage) procedure MakeGraphPage(hd); text hd; MakeGraphPage :- new GraphPage(hd, this MainWindow); end MainWindow; MainWindow class SideWindow(TopMainWindow); ref(MainWindow) TopMainWindow; begin procedure FindRoot; if TopMainWindow == none then error("Attempted creation of sidewindow without TopMainWindow!") else begin the_display :- TopMainWindow.the_display; parentID := TopMainWindow.parentID; end; text procedure window_kind; window_kind :- "Side window" & window_name & " of " & TopMainWindow.window_name; ref(XWindow) procedure owner; owner :- TopMainWindow; procedure TraceCreation; if the_display.event_trace then outline("Top window " & window_name & " with ID " & int_as_text(windowID) & " created"); end SideWindow; MainWindow class SimpleWindow; begin procedure TraceCreation; if the_display.event_trace then outline("Simple window " & window_name & " with ID " & int_as_text(windowID) & " created"); text procedure window_kind; window_kind :- "Simple window " & window_name; ref(PromptWindow) the_prompt_window; ref(ScrollWindow) the_scroll_window; procedure handle_configure; begin integer mxy; procedure conf(el); ref(element) el; begin ref(SubWindow) w; w :- el; if w in ScrollWindow then w.SetSize(width - 2*sw_gap, height - mxy - 2*sw_gap) else mxy := max(mxy, w.max_y); end; mxy := 0; children.for_each_element(conf); end; ref(PromptWindow) procedure MakePromptWindow; if the_prompt_window == none then begin the_prompt_window :- new PromptWindow(this XWindow) .PlaceLeftBelow(LastSubwindow); the_prompt_window.MakeOKButton; if fancy then the_prompt_window.SetFancy; MakePromptWindow :- the_prompt_window; end; ref(ScrollWindow) procedure MakeScrollWindow; if the_scroll_window == none then begin MakePromptWindow; the_Scroll_window :- new ScrollWindow(this XWindow, 1000) .PlaceLeftBelow(LastSubWindow) .SetSize(width - 2*sw_gap, height - 2*sw_gap - (if LastSubWindow == none then 0 else LastSubWindow.max_y)) .Show; MakeScrollWindow :- the_Scroll_window; end; ref(PromptWindow) procedure MakeFancyPromptWindow; MakeFancyPromptWindow :- MakePromptWindow.SetFancy; procedure MakePromptandScrollWindows; begin MakePromptWindow; MakeScrollWindow end; ref(XWindow) procedure MakeEmpty; begin MakeScrollWindow; the_Scroll_window.MakeEmpty; MakeEmpty :- this XWindow; end; text procedure ask_for_text(prompt); text prompt; begin MakePromptWindow; ask_for_text :- the_prompt_window.ask_for_text(prompt); end; integer procedure ask_for_int(prompt); text prompt; begin MakePromptWindow; ask_for_int := the_prompt_window.ask_for_int(prompt); end; character procedure ask_for_char(prompt); text prompt; begin MakePromptWindow; ask_for_char := the_prompt_window.ask_for_char(prompt); end; real procedure ask_for_real(prompt); text prompt; begin MakePromptWindow; ask_for_real := the_prompt_window.ask_for_real(prompt); end; Boolean procedure ask_for_Bool(prompt); text prompt; begin MakePromptWindow; ask_for_Bool := the_prompt_window.ask_for_Bool(prompt); end; text procedure be_om_text(prompt); text prompt; begin SettNorsktekst; be_om_text :- ask_for_text(prompt); end; integer procedure be_om_int(prompt); text prompt; begin SettNorsktekst; be_om_int := ask_for_int(prompt); end; character procedure be_om_char(prompt); text prompt; begin SettNorsktekst; be_om_char := ask_for_char(prompt); end; real procedure be_om_real(prompt); text prompt; begin SettNorsktekst; be_om_real := ask_for_real(prompt); end; Boolean procedure be_om_Bool(prompt); text prompt; begin SettNorsktekst; be_om_Bool := ask_for_Bool(prompt); end; ref(SimpleWindow) procedure outimage; begin MakeScrollWindow; the_scroll_window.putimage; outimage :- this SimpleWindow; end; ref(SimpleWindow) procedure outtext(t); text t; begin MakeScrollWindow; the_scroll_window.puttext(t); outtext :- this SimpleWindow; end; ref(SimpleWindow) procedure setpos(pos); integer pos; begin MakeScrollWindow; the_scroll_window.setpos(pos); setpos :- this SimpleWindow; end; ref(SimpleWindow) procedure outline(line); text line; outline :- outtext(line).outimage; ref(SimpleWindow) procedure outchar(c); character c; outchar :- outtext(char_as_text(c)); ref(SimpleWindow) procedure outint(i, w); integer i, w; begin text t; if w <= 0 then t :- int_as_text(i) else begin t :- blanks(w); t.putint(i) end; outint :- outtext(t); end; ref(SimpleWindow) procedure outfix(r, d, w); real r; integer d, w; begin text t; if w <= 0 then t :- real_as_text(r, d) else begin t :- blanks(w); t.putfix(r, d) end; outfix :- outtext(t); end; PlaceAt(10, 50); SetSize(max(600, DisplayWidth//2), max(600, DisplayHeight//2)); SetBackGround("gray25"); SetTypeface("helvetica", default_font_points, true, false); % MakeScrollWindow; Show; end SimpleWindow; XWindow class SubWindow(parent); ref(XWindow) parent; begin procedure CreateWindow; if parent == none then error("Attempted creation of subwindow without parent!") else begin external C procedure xcreatewindow is integer procedure XCreateWindow(parentID, window_name); integer parentID; text window_name;; the_display :- parent.the_display; parentID := parent.windowID; windowID := XCreateWindow(parentID, notext); the_display.add_window(this XWindow); parent.add_window(this XWindow); Initialize; SetXfont(parent.currentXFont); if parent.Norsktekst then SettNorsktekst; if the_display.event_trace then outline("Subwindow of " & int_as_text(parentID) & " with ID " & int_as_text(windowID) & " created"); end CreateSubWindow; text procedure window_kind; window_kind :- "Sub window"; procedure InputInSubwindow(sw); ref(SubWindow) sw; parent.InputInSubwindow(sw); procedure ClickinButton(b); ref(Button) b; parent.ClickinButton(b); ref(XWindow) procedure owner; owner :- parent; ref(XWindow) procedure TopWindow; TopWindow :- parent.TopWindow; integer procedure sw_gap; sw_gap := parent.SubwindowSpacing; ref(XWindow) procedure PlaceCentered; begin PlaceCentered :- Placeat((parent.width - width)//2, (parent.height - height + parent.head_height)//2); placed := PlacedCentered; end; ref(XWindow) procedure PlaceUpLeft; begin PlaceUpLeft :- Placeat(parent.DepthBorder + sw_gap + label_width, parent.DepthBorder + sw_gap + parent.head_height); parent.LastSubWindow :- this XWindow; Placed := PlacedUpLeft; end; ref(XWindow) procedure PlaceUpRight; begin PlaceUpRight :- Placeat(parent.width - (max_x - min_x) - (parent.DepthBorder + sw_gap), parent.DepthBorder + sw_gap + parent.head_height); Placed := PlacedUpRight; end; ref(XWindow) procedure PlaceDownLeft; begin PlaceDownLeft :- Placeat(parent.DepthBorder + sw_gap + label_width, parent.height - (max_y - min_y) - (parent.DepthBorder + sw_gap)); Placed := PlacedDownLeft; end; ref(XWindow) procedure PlaceDownRight; begin PlaceDownRight :- Placeat(parent.width - (max_x - min_x) - (parent.DepthBorder + sw_gap), parent.height - (max_y - min_y) - (parent.DepthBorder + sw_gap)); Placed := PlacedDownRight; end; ref(XWindow) procedure PlaceAfter(wnd); ref(XWindow) wnd; begin PlaceAfter :- if wnd == none then PlaceUpLeft else if wnd.max_x + 2*(sw_gap + BorderWidth) + width + label_width > parent.width then PlaceLeftBelow(wnd) else PlaceAt(wnd.max_x + sw_gap + label_width, wnd.min_y); parent.LastSubWindow :- this XWindow; preceding_window :- wnd; Placed := PlacedAfter; end; ref(XWindow) procedure PlaceBefore(wnd); ref(XWindow) wnd; begin PlaceBefore :- if wnd == none then PlaceUpLeft else if wnd.min_x - 2*(sw_gap + BorderWidth) < width then Placeat(parent.width - (max_x - min_x) - sw_gap, wnd.max_y + sw_gap) else Placeat(wnd.min_x - sw_gap - 2*BorderWidth - width - (if wnd in SubWindow then wnd qua SubWindow.label_width else 0), wnd.min_y); preceding_window :- wnd; Placed := PlacedBefore; end; ref(XWindow) procedure PlaceLeftBelow(wnd); ref(XWindow) wnd; begin PlaceLeftBelow :- if wnd == none then PlaceUpleft else PlaceAt(parent.DepthBorder + sw_gap + label_width, wnd.max_y + sw_gap); parent.LastSubWindow :- this XWindow; preceding_window :- wnd; Placed := PlacedLeftBelow; end; ref(XWindow) procedure PlaceRightBelow(wnd); ref(XWindow) wnd; begin PlaceRightBelow :- Placeat(parent.width - (max_x - min_x) - (parent.DepthBorder + sw_gap), (if wnd =/= none then wnd.max_y else 0) + sw_gap); preceding_window :- wnd; Placed := PlacedRightBelow; end; ref(XWindow) procedure PlaceBelow(wnd); ref(XWindow) wnd; begin PlaceBelow :- if wnd == none then Placeat(sw_gap, sw_gap) else Placeat(wnd.min_x, wnd.max_y + sw_gap); preceding_window :- wnd; Placed := PlacedBelow; end; ref(XWindow) procedure PlaceAbove(wnd); ref(XWindow) wnd; begin PlaceAbove :- if wnd == none then PlaceUpLeft else Placeat(wnd.min_x, wnd.min_y - sw_gap - height - 2*current_border_width); preceding_window :- wnd; Placed := PlacedAbove; end; ref(XWindow) procedure PlaceRightof(wnd); ref(XWindow) wnd; begin PlaceRightof :- if wnd == none then PlaceUpRight else Placeat(wnd.max_x + sw_gap + label_width, wnd.min_y); preceding_window :- wnd; Placed := PlacedRightof; end; ref(XWindow) procedure PlaceLeftof(wnd); ref(XWindow) wnd; begin PlaceLeftof :- if wnd == none then PlaceUpLeft else Placeat(wnd.min_x - sw_gap - (max_x - min_x) - (if wnd in SubWindow then wnd qua SubWindow.label_width else 0), wnd.min_y); preceding_window :- wnd; Placed := PlacedLeftof; end; % ref(XWindow) procedure PlaceTopRightof(wnd); ref(XWindow) wnd; % PlaceTopRightof :- Placeat(wnd.max_x + sw_gap, % parent.DepthBorder + sw_gap + parent.head_height); text current_label; integer procedure label_width; label_width := if current_label == notext then 0 else parent.width_of_text(current_label & "xx"); ref(XWindow) procedure SetLabel(a_label); text a_label; begin current_label :- a_label; Replace; % if current_label =/= notext then begin parent.Clear; parent.Refresh; parent.ShowLabels end; SetLabel :- this XWindow; end; procedure ShowCurrentLabel; if current_label =/= notext then parent.DrawTextPos(min_x - parent.width_of_text("x"), min_y + height//2, current_label, RightPos, CenterPos); end SubWindow; SubWindow class HeadWindow; begin text current_heading; integer head_gap = 2; text procedure window_kind; window_kind :- "Head window"; ref(XWindow) procedure SetHeading(heading); text heading; begin current_heading :- heading; Clear; Refresh; SetHeading :- this XWindow; end; integer procedure head_width; head_width := width_of_text(" " & current_heading & " "); procedure Place_and_size; begin PlaceAt(parent.DepthBorder + head_gap, parent.DepthBorder + head_gap); SetWidth(parent.width - 2*(parent.DepthBorder + head_gap + BorderWidth)); SetHeight(4*font_height//3); end; procedure Refresh; begin DrawCenterText(current_heading); if fancy and DepthBorder > 0 then UpBorder; % if fancy and DepthBorder > 0 then UpBorder(DepthBorder); end; ref(XWindow) procedure SetFancy; begin SetBackground("gray25"); SetDepthBorder(3); if not fancy then SetHeight(height + 2*DepthBorder); fancy := true; SetFancy :- this HeadWindow; end; procedure handle_button_click(button); integer button; parent.Raise; SetTypeFace("helvetica", 14, true, false); if parent.fancy then SetFancy; Place_and_size; button_sensitize; Show; end HeadWindow; SubWindow (heading); text heading; virtual: procedure Allow is ref(Button) procedure Allow;; procedure Disallow is ref(Button) procedure Disallow;; procedure SetActive is ref(Button) procedure SetActive;; procedure SetInactive is ref(Button) procedure SetInactive;; procedure Resize is procedure Resize;; procedure WriteLine is procedure WriteLine;; begin text procedure heading_and_key; if key_set then heading_and_key :- heading & " (" & char_as_text(shortcut) & ")" else heading_and_key :- heading; text procedure window_kind; window_kind :- "Button " & heading; text procedure current_heading; current_heading :- heading; Boolean allowed, active, key_set; Boolean waiting, mapped_at_start_of_waiting; character shortcut; ref(Button) procedure SetShortcut(k); character k; begin shortcut := k; key_set := true; % if allowed then parent.key_sensitize; parent.key_sensitize; Resize; Refresh; SetShortcut :- this Button; end; ref(Button) procedure Allow; begin allowed := true; % if key_set then parent.key_sensitize; % SetDrawStipple("black"); % if ScreenDepth > 1 then SetNoStipple; SetForeground("black"); Refresh; Allow :- this Button; end; ref(Button) procedure Disallow; begin allowed := false; % if key_set then parent.key_desensitize; if not active then % begin SetDrawStipple("gray50"); Refresh end; begin SetForeground("gray50"); Refresh end; Disallow :- this Button; end; Boolean procedure IsAllowed; IsAllowed := allowed; ref(Button) procedure SetActive; begin if not active then begin active := true; SetBackGround("gray75"); Refresh; % Whiteborder; Invert; end; SetActive :- this Button; end; ref(Button) procedure SetInactive; begin if active then begin active := false; SetBackGround("white"); Refresh; % Invert; end; SetInactive :- this Button; end; ref(Button) procedure SetActiveDisallow; begin SetActive; parent.DisallowButtonsInWindow; SetActiveDisAllow :- this Button; end; ref(Button) procedure SetInactiveAllow; begin parent.AllowButtonsInWindow; SetInactive; SetInactiveAllow :- this Button; end; ref(Button) procedure Click; begin handle_button_click(0); Click :- this Button; end; procedure handle_button_click(a_button); integer a_button; if allowed then begin if not active then begin parent.Perform(heading); parent.PerformIn(heading, this Button); parent.ClickInButton(this Button); end; if waiting then begin if not mapped_at_start_of_waiting then Hide; waiting := false; end; end; procedure handle_enter_window; if allowed then Thickborder; % if allowed then Thickborder(DepthBorder); procedure handle_leave_window; Whiteborder; % Whiteborder(DepthBorder); procedure StartWaiting; begin mapped_at_start_of_waiting := mapped; if not mapped_at_start_of_waiting then Show; waiting := true; Allow; end; procedure StopWaiting; begin if not mapped_at_start_of_waiting then Hide; waiting := false; Disallow; end; Boolean procedure IsWaiting; begin handle_pending_events; IsWaiting := waiting; end; ref(XWindow) procedure Wait; begin StartWaiting; while waiting do handle_event; Wait :- this XWindow; end; procedure WriteLine; DrawCenterText(heading_and_key); procedure Refresh; begin Clear; WriteLine; % if active then Invert; end; procedure Resize; SetSize(max(width, 2*width_of_text(" ") + width_of_text(heading_and_key)), max(height, head_height + 4*font_height//3)); % SetSize(max(width, 2*DepthBorder + 2*width_of_text(" ") % + width_of_text(heading_and_key)), % max(height, head_height + 2*DepthBorder % + 4*font_height//3)); ref(XWindow) procedure SetHeading(h); text h; begin heading :- h; % Resize; Refresh; SetHeading :- this XWindow; end; ref(XWindow) procedure SetFont(font_name); text font_name; begin SetXFont(new XFont(font_name)); Resize; Refresh; SetFont :- this XWindow; end; SetDepthBorder(3); Resize; enter_and_leave_sensitize; button_sensitize; % parent.key_sensitize; % This is done to give the user the % option to hit a key instead of clicking; SaveUnder; SetBackingStore; Allow; active := false; end Button; Button class FancyButton; begin integer active_border = 3, inside_border = 5, inside_pos, inside_mark = 4; Boolean inside; procedure Resize; SetSize(max(width, 2*max_char_width + width_of_text(heading_and_key)), max(height, head_height + 2*font_height)); ref(Button) procedure Allow; begin allowed := true; SetFill("gray75"); Refresh; rehighlight; Allow :- this FancyButton; end; ref(Button) procedure Disallow; begin allowed := false; SetFill("gray50"); Refresh; rehighlight; Disallow :- this FancyButton; end; ref(Button) procedure SetActive; begin if not active then begin active := true; ActiveBorder; if inside then mark_inside; end; SetActive :- this FancyButton; end; ref(Button) procedure SetInactive; begin if active then begin active := false; ActiveBorder; if inside then mark_inside else mark_outside; end; SetInactive :- this FancyButton; end; procedure WriteLine; begin SetBlackonWhite; DrawTextPos(width//2+2, (head_height + height)//2+1, heading_and_key, CenterPos, CenterPos); SetWhiteonBlack; DrawTextPos(width//2-1, (head_height + height)//2-1, heading_and_key, CenterPos, CenterPos); SetBlackonWhite; end; procedure rehighlight; if (inside and not PointerInside) or not allowed then mark_outside else if not inside and PointerInside and allowed then mark_inside; procedure handle_enter_window; if allowed then mark_inside; procedure handle_leave_window; mark_outside; procedure mark_inside; begin integer top, h; top := inside_pos + head_height; h := height - head_height - 2*inside_pos; WhiteRectangle(inside_pos, top, inside_mark, h); WhiteRectangle(width - inside_pos - inside_mark, top, inside_mark, h); inside := true; end; procedure mark_outside; begin integer top, h; top := inside_pos + head_height; h := height - head_height - 2*inside_pos; FillRectangle(inside_pos, top, inside_mark, h); FillRectangle(width - inside_pos - inside_mark, top, inside_mark, h); inside := false; end; procedure ActiveBorder; if active then Downborder else Upborder; % if active then Downborder(active_border) % else Upborder(active_border); procedure Refresh; begin Fill; WriteLine; ActiveBorder; if inside then mark_inside; end; SetDepthBorder(active_border); inside_pos := 2*active_border + 2; end FancyButton; SubWindow class InputWindow; % % Public procedures: % % ref(InputWindow) procedure AllowInput; % ref(InputWindow) procedure DisallowInput; % ref(InputWindow) procedure MakeEmpty; % virtual: procedure char_ok is Boolean procedure char_ok(key); character key;; procedure text_left is integer procedure text_left;; procedure cursor_x is integer procedure cursor_x;; procedure cursor_top is integer procedure cursor_top;; procedure cursor_height is integer procedure cursor_height;; procedure cursor_width is integer procedure cursor_width;; procedure show_current_text is procedure show_current_text;; procedure set_current_text is procedure set_current_text(t); text t;; procedure handle_left_arrow is procedure handle_left_arrow;; procedure handle_right_arrow is procedure handle_right_arrow;; procedure handle_down_arrow is procedure handle_down_arrow;; procedure handle_up_arrow is procedure handle_up_arrow;; procedure handle_return is procedure handle_return;; begin text current_text; Boolean input_allowed, cursor_pos_set, block_cursor, no_cursor, incrementable; integer cursor_pos, max_item_length; text procedure window_kind; window_kind :- "Input window"; Boolean left_justified, center_justified, right_justified; ref(InputWindow) procedure LeftJustify; begin left_justified := true; center_justified := false; right_justified := false; LeftJustify :- this InputWindow; end; ref(InputWindow) procedure RightJustify; begin left_justified := false; center_justified := false; right_justified := true; RightJustify :- this InputWindow; end; ref(InputWindow) procedure CenterJustify; begin left_justified := false; center_justified := true; right_justified := false; CenterJustify :- this InputWindow; end; ref(XWindow) procedure AllowInput; begin input_allowed := true; key_sensitize; % if not this InputWindow in CharItemWindow then LeftJustify; AllowInput :- this InputWindow; end; ref(XWindow) procedure DisallowInput; begin input_allowed := false; key_desensitize; % CenterJustify; DisallowInput :- this InputWindow; end; Boolean give_echo; ref(InputWindow) procedure NoEcho; begin give_echo := false; NoEcho :- this InputWindow; end; ref(InputWindow) procedure Echo; begin give_echo := true; Echo :- this InputWindow; end; procedure Refresh; begin % if DepthBorder > 0 then DownBorder; % if DepthBorder > 0 then DownBorder(DepthBorder); show_current_text; end; procedure show_current_text; begin text procedure stars; if current_text == notext then stars :- notext else begin text t; integer i; t :- blanks(current_text.length); for i := 1 step 1 until t.length do t.putchar('*'); stars :- t; end; ClearRectangle(DepthBorder, head_height + DepthBorder + 2, width - 2*DepthBorder, height - head_height - 2 - 2*DepthBorder); DrawTextPos(text_left, (height + head_height)//2, if give_echo then current_text else stars, LeftPos, CenterPos); end; procedure handle_enter_window; if input_allowed then begin ThickBorder; PlaceCursor end; % begin ThickBorder(DepthBorder); PlaceCursor end; procedure handle_leave_window; if input_allowed then begin RemoveCursor; WhiteBorder end; % begin RemoveCursor; DownBorder(DepthBorder) end; procedure handle_button_down(button); integer button; if button = LeftButton then StoreInCutBuffer(current_text) else if input_allowed then begin cursor_pos_set := true; RemoveCursor; cursor_pos := min(current_text.length, x_of_event//width_of_text("x")); if button = CenterButton then begin text t1, t2, t3; if cursor_pos = 0 then t1 :- notext else t1 :- current_text.sub(1, cursor_pos); t2 :- FetchCutBuffer; if cursor_pos = current_text.length then t3 :- notext else t3 :- current_text.sub(cursor_pos + 1, current_text.length - cursor_pos); set_current_text(t1 & t2 & t3); show_current_text; end; PlaceCursor; end; % procedure handle_button_down(button); integer button; % if input_allowed then % begin % cursor_pos_set := true; % RemoveCursor; % cursor_pos := min(current_text.length, % x_of_event//width_of_text("x")); % PlaceCursor; % end; procedure handle_special_key_down(key_code); integer key_code; begin integer left_arrow = 98, right_arrow = 100, up_arrow = 76, down_arrow = 120; if key_code = left_arrow then handle_left_arrow else if key_code = right_arrow then handle_right_arrow else if key_code = up_arrow then handle_up_arrow else if key_code = down_arrow then handle_down_arrow; end; integer return_code = 13; procedure handle_down_arrow;; procedure handle_up_arrow;; procedure handle_return; handle_down_arrow; procedure handle_right_arrow; begin RemoveCursor; if cursor_pos < current_text.length then cursor_pos := cursor_pos + 1; PlaceCursor; end; procedure handle_left_arrow; begin RemoveCursor; if cursor_pos > 0 then cursor_pos := cursor_pos - 1; PlaceCursor; end; procedure handle_key_down(key); character key; if input_allowed then begin text head, curr, tail; parent.InputInSubwindow(this InputWindow); if key = char(127) and cursor_pos > 0 then begin RemoveCursor; if cursor_pos = 1 then head :- notext else head :- current_text.sub(1, cursor_pos - 1); curr :- current_text.sub(cursor_pos, 1); if cursor_pos = current_text.length then tail :- notext else tail :- current_text.sub(cursor_pos + 1, current_text.length - cursor_pos); set_current_text(head & tail); cursor_pos := min(cursor_pos - 1, current_text.length); show_current_text; PlaceCursor; end else if char_ok(key) and then (current_text.length < max_item_length or incrementable or cursor_pos < current_text.length) then begin RemoveCursor; if current_text.length = max_item_length and incrementable and cursor_pos = current_text.length then begin SetMaxchars(max_chars + 6); parent.SizeChange_in_SubWindow(this InputWindow); end; if cursor_pos = 0 or else current_text == notext then head :- notext else head :- current_text.sub(1, cursor_pos); curr :- blanks(1); curr.putchar(key); if current_text == notext or else current_text.length = cursor_pos then tail :- notext else tail :- current_text.sub(cursor_pos + 1, current_text.length - cursor_pos); set_current_text(head & curr & tail); cursor_pos := cursor_pos + 1; show_current_text; PlaceCursor; end else if key = char(return_code) and then parent in PromptWindow then parent qua PromptWindow.ReturnKey else if key = char(return_code) then handle_return; end; procedure set_current_text(t); text t; if t == notext then current_text :- notext else begin character c; current_text :- blanks(min(t.length, max_item_length)); t.setpos(1); while t.more and current_text.more do begin c := t.getchar; if char_ok(c) then current_text.putchar(c); end; % current_text :- current_text.strip; end; Boolean procedure char_ok(key); character key; char_ok := 32 <= rank(key) and rank(key) <= maxrank; integer procedure text_border; text_border := DepthBorder + width_of_text("1")//2; integer procedure text_left; text_left := text_border; Boolean cursor_placed; procedure PlaceCursor; if cursor_pos_set and not cursor_placed and not no_cursor then begin text c; if 0 <= cursor_pos and cursor_pos < current_text.length then c :- current_text.sub(cursor_pos + 1, 1) else c :- " "; HighLightText(true); DrawTextPos(cursor_x, (height + head_height)//2, c, LeftPos, CenterPos); HighLightText(false); cursor_placed := true; end; procedure RemoveCursor; begin cursor_placed := false; show_current_text; end; ref(InputWindow) procedure SetBlockCursor; begin block_cursor := true; SetBlockCursor :- this InputWindow; end; ref(InputWindow) procedure SetLineCursor; begin block_cursor := false; SetLineCursor :- this InputWindow; end; integer procedure cursor_top; cursor_top := (if block_cursor then (height + head_height - font_ascent - font_descent)//2 else head_height + DepthBorder + 2); integer procedure cursor_height; cursor_height := if block_cursor then font_height + 2 else height - head_height - 2*DepthBorder - 2; integer procedure cursor_bottom; cursor_bottom := cursor_top + cursor_height; integer procedure cursor_width; cursor_width := 1 + (if not block_cursor or cursor_pos >= max_item_length then 0 else width_of_char(if current_text == notext or else cursor_pos >= current_text.length then ' ' else current_text.sub(cursor_pos + 1, 1).getchar)); integer procedure cursor_x; cursor_x := text_left - 1 + (if current_text == notext or else cursor_pos = 0 then 0 else width_of_text(current_text.sub(1, min(cursor_pos, current_text.length)))); ref(XWindow) procedure MakeEmpty; begin current_text :- notext; cursor_pos := 0; Refresh; MakeEmpty :- this InputWindow; end; external C procedure xsetarrowcursor is integer procedure XSetArrowCursor(WindowID); integer WindowID;; XSetArrowCursor(WindowID); enter_and_leave_sensitize; % key_sensitize; button_sensitize; DisallowInput; Echo; SetBackingStore; current_text :- notext; cursor_pos := 0; cursor_pos_set := true; incrementable := false; SetDepthBorder(2); max_item_length := 0; SetTypeFace("courier", default_font_points, true, false); SetBlockCursor; WhiteBorder; end InputWindow; InputWindow class ItemWindow; % % Public procedures: % % Subclasses: % % IntItemWindow % procedure putint(int); integer int; % integer procedure getint; % RealItemWindow % procedure putreal(r); real r; % real procedure getreal; % CharItemWindow % procedure putchar(char); character char; % character procedure getchar; % BoolItemWindow % procedure putBool(bool); Boolean bool; % Boolean procedure getBool; % TextItemWindow % procedure puttext(t); text t; % text procedure gettext; % TextHeadWindow % procedure puttext(t); text t; % virtual: procedure max_item_height is integer procedure max_item_height;; procedure max_item_width is integer procedure max_item_width;; procedure place_current_value is procedure place_current_value;; begin text procedure window_kind; window_kind :- "Item window"; procedure Resize; SetSize(max(if max_chars_set then 0 else width, max_item_width + 2*DepthBorder), max(height, head_height + max_item_height + 2*DepthBorder)); procedure SetSizeSub; max_item_length := max(1, if max_chars_set then max_chars else (width - 2*text_border)//max_char_width); integer procedure max_item_height; max_item_height := 4*font_height//3; integer procedure text_left; text_left := if left_justified then text_border else if center_justified then width//2 - width_of_text(current_text)//2 else if right_justified then width - text_border - width_of_text(current_text) else text_border; ref(XWindow) procedure SetFont(font_name); text font_name; begin SetXFont(new XFont(font_name)); Resize; Refresh; SetFont :- this XWindow; end; ref(Itemwindow) prev_itemwindow, next_itemwindow; procedure handle_down_arrow; if next_itemwindow =/= none then next_itemwindow.PlacePointerRight else owner.PlacePointer(max_x + SubWindowSpacing//2, mid_y); procedure handle_up_arrow; if prev_itemwindow =/= none then prev_itemwindow.PlacePointerRight; ref(XWindow) procedure SetMaxChars(c); integer c; begin c := max(c, 1); max_chars := c; max_chars_set := true; max_item_length := c; SetMaxChars :- SetWidth((c+1)*max_char_width + 3*depth_border + 2*BorderWidth); % SetColumns(c); end; max_item_length := 0; CenterJustify; parent.add_itemwindow(this ItemWindow); end ItemWindow; ItemWindow class IntItemWindow; % % Public: % Inherited from ItemWindow: % AllowInput, DisallowInput, % MakeEmpty % % procedure putint(int); integer int; % integer procedure getint; % begin integer minitem, maxitem; ref(IntItemWindow) procedure setlimits(mn, mx); integer mn, mx; begin minitem := mn; maxitem := mx; max_item_length := max(int_as_text(mn).length, int_as_text(mx).length); Resize; setlimits :- this IntItemWindow; end; Boolean procedure char_ok(key); character key; char_ok := digit(key) or else key = '-' or else key = '+'; integer procedure max_char_width; max_char_width := width_of_char('0'); integer procedure max_item_width; max_item_width := (2 + max_item_length)*width_of_char('0'); ref(IntItemWindow) procedure putint(int); integer int; begin current_text :- int_as_text(min(maxitem, max(minitem, int))); cursor_pos := current_text.length; Refresh; putint :- this IntItemWindow; end; integer procedure getint; getint := if not ok_int(current_text) then 0 else current_text.getint; % key_sensitize; LeftJustify; Setlimits(minint//4, maxint); end IntItemWindow; ItemWindow class RealItemWindow; begin Boolean procedure char_ok(key); character key; char_ok := digit(key) or key = '-' or key = '+' or key = '.'; integer procedure max_char_width; max_char_width := width_of_char('0'); integer procedure max_item_width; max_item_width := (2 + max_item_length)*width_of_char('0'); ref(RealItemWindow) procedure putreal(r, decimals); real r; integer decimals; begin current_text :- real_as_text(r, decimals); cursor_pos := current_text.length; Refresh; putreal :- this RealItemWindow; end; real procedure getreal; getreal := if not ok_real(current_text) then 0 else current_text.getreal; % key_sensitize; max_item_length := 12; Resize; end RealItemWindow; ItemWindow class CharItemWindow; begin integer procedure max_item_width; max_item_width := max(3*max_char_width//2, 3*width_of_char('x')); procedure SetSizeSub; max_item_length := 1; ref(CharItemWindow) procedure putchar(char); character char; begin if 32 <= rank(char) and rank(char) <= maxrank and char ne ' ' then begin current_text :- char_as_text(char); cursor_pos := 1; Refresh; end else begin current_text :- notext; cursor_pos := 0; Refresh; end; putchar :- this CharItemWindow; end; character procedure getchar; if current_text == notext then getchar := char(0) else begin current_text.setpos(1); getchar := current_text.getchar; end; % key_sensitize; CenterJustify; no_cursor := true; max_item_length := 1; Resize; end CharItemWindow; ItemWindow class BoolItemWindow; begin Boolean current_value, value_set; text yes_text, no_text; integer procedure max_item_width; max_item_width := width_of_text(" ") + max(width_of_text(yes_text), width_of_text(no_text)); % integer procedure max_item_height; % max_item_height := 4*height_of_char(yes_char)//3; procedure show_current_text; begin integer hh; hh := if head_height = 0 then 0 else head_height + 2; ClearRectangle(DepthBorder, hh + DepthBorder, width - 2*DepthBorder, height - hh - 2*DepthBorder); % DrawCenterText(if current_value then yes_text else no_text); if value_set then DrawTextPos(width//2, height//2, if current_value then yes_text else no_text, CenterPos, CenterPos); end; procedure SetSizeSub; max_item_length := 3; ref(XWindow) procedure MakeEmpty; begin current_value := false; current_text :- notext; value_set := false; Refresh; MakeEmpty :- this BoolItemWindow end; procedure handle_button_click(button); integer button; placeinput(not current_value); % if input_allowed then % begin % putBool(not current_value); % parent.InputInSubwindow(this BoolItemWindow); % end; procedure placeinput(b); Boolean b; if input_allowed then begin putBool(b); parent.InputInSubwindow(this BoolItemWindow); end; procedure handle_key_down(key); character key; begin if key = 'y' or else key = 'j' or else key = 'Y' or else key = 'J' then placeinput(true) else if key = 'n' or else key = 'N' then placeinput(false) else if key = char(return_code) then handle_return; end; ref(BoolItemWindow) procedure putBool(bool); Boolean bool; begin current_value := bool; value_set := true; if current_value then current_text :- yes_text else current_text :- notext; Refresh; putBool :- this BoolItemWindow; end; Boolean procedure getBool; getBool := if value_set then current_value else false; SetSymbolFont("itc zapf dingbats", 18); if FontExists then begin yes_text :- "3"; no_text :- "!109!" end else begin SetTypeFace("helvetica", 12, true, false); if NorskTekst then yes_text :- "Ja" else yes_text :- "Yes"; if NorskTekst then no_text :- "Nei" else no_text :- "No"; end; no_cursor := true; value_set := false; CenterJustify; max_item_length := 3; Resize; end BoolItemWindow; ItemWindow class TextItemWindow; begin integer procedure max_item_width; max_item_width := text_border + max_item_length*max_char_width; ref(TextItemWindow) procedure puttext(t); text t; begin current_text :- t; max_item_length := max(max_item_length, t.length); if current_text == notext or else current_text.strip == notext then cursor_pos := 0 else cursor_pos := current_text.strip.length; Refresh; puttext :- this TextItemWindow; end; text procedure gettext; if current_text.strip == notext then gettext :- notext else begin current_text.setpos(1); while current_text.getchar = ' ' do; gettext :- copy(current_text.sub(current_text.pos - 1, current_text.length - current_text.pos + 2).strip); end; % key_sensitize; LeftJustify; max_item_length := 0; Resize; end TextItemWindow; SubWindow class PromptWindow; begin procedure Refresh; if fancy then DownBorder; % if fancy then DownBorder(DepthBorder); ref(XWindow) procedure SetFancy; begin SetDepthBorder(3); SetSubWindowSpacing(font_height//2); if OK_button =/= none then OK_Button :- new FancyButton(this PromptWindow, "OK"); if cancel_button =/= none then cancel_Button :- new FancyButton(this PromptWindow, if Norsktekst then "Bryt" else "Cancel"); if clear_button =/= none then clear_Button :- new FancyButton(this PromptWindow, if Norsktekst then "Tom" else "Clear"); fancy := true; SetBackGround("gray25"); Resize; SetFancy :- this PromptWindow; end; ref(PromptWindow) procedure MakeOKButton; begin OK_button :- if fancy then new FancyButton(this PromptWindow, "OK") else new Button(this PromptWindow, "OK"); MakeOKButton :- this PromptWindow; end; ref(PromptWindow) procedure MakeCancelButton; begin text bt; if Norsktekst then bt :- "Bryt" else bt :- "Cancel"; cancel_button :- if fancy then new FancyButton(this PromptWindow, bt) else new Button(this PromptWindow, bt); MakeCancelButton :- this PromptWindow; end; ref(PromptWindow) procedure MakeClearButton; begin text bt; if Norsktekst then bt :- "Tom" else bt :- "Clear"; clear_button :- if fancy then new FancyButton(this PromptWindow, bt) else new Button(this PromptWindow, bt); MakeClearButton :- this PromptWindow; end; ref(PromptWindow) procedure MakeHideButton; begin text bt; if Norsktekst then bt :- "Skjul" else bt :- "Hide"; hide_button :- if fancy then new FancyButton(this PromptWindow, bt) else new Button(this PromptWindow, bt); hide_button.Show; MakeHideButton :- this PromptWindow; end; Boolean accept, cancel, bool_answer, width_increased; Boolean procedure cancelled; cancelled := cancel; Boolean procedure accepted; accepted := accept; text current_prompt; integer initial_text_length = 12, prevwidth; ref(Button) OK_button, cancel_button, clear_button, hide_button, yes_button, no_button; ref(ItemWindow) answer_window; text procedure ask_for(answer_wnd, prompt); ref(ItemWindow) answer_wnd; text prompt; begin Boolean is_mapped, inside_top_window; integer pointer_x, pointer_y; text ct; Clear; answer_window :- answer_wnd; answer_window.LeftJustify; answer_wnd.SetLabel(prompt) .PlaceUpLeft; if fancy then answer_wnd.SetHeight(2*font_height); width_increased := false; PlaceSubwindows; is_mapped := mapped; if not is_mapped then Show; Raise; answer_wnd.AllowInput; inside_top_window := TopWindow.FindPointerPos(pointer_x, pointer_y); % owner.FindPointerPos(pointer_x, pointer_y); % PlaceAt(pointer_x, pointer_y); answer_wnd.PlacePointerRight; accept := false; cancel := false; while not (accept or cancel) do handle_event; % if inside_top_window then TopWindow.PlacePointer(pointer_x, pointer_y); ct :- answer_wnd.current_text; answer_wnd.SetLabel(notext).Hide; Clear; answer_wnd.current_text :- ct; answer_wnd.DisallowInput; if OK_Button =/= none then OK_button.Hide; if Cancel_Button =/= none then Cancel_button.Hide; if Clear_Button =/= none then Clear_button.Hide; if not is_mapped then Hide; current_prompt :- notext; if width_increased then SetWidth(prevwidth); end; Boolean procedure ask_for_Bool(prompt); text prompt; begin text yes_text, no_text; integer pointer_x, pointer_y, hh, neww; Boolean is_mapped; hh := head_height; width_increased := false; if Norsktekst then yes_text :- "Ja" else yes_text :- "Yes"; if Norsktekst then no_text :- "Nei" else no_text :- "No"; yes_button :- (if fancy then MakeFancyButton(yes_text) else MakeButton(yes_text)) .PlaceUpleft .SetLabel(prompt) .Show; no_button :- (if fancy then MakeFancyButton(no_text) else MakeButton(no_text)) .PlaceRightof(yes_button) .Show; if hide_button =/= none then hide_button.PlaceRightof(no_button); neww := (if hide_button =/= none then hide_button else no_button).max_x + subwindow_spacing; if neww > width then begin prevwidth := width; width_increased := true; SetWidth(neww); end; is_mapped := mapped; if not is_mapped then Show; Raise; TopWindow.FindPointerPos(pointer_x, pointer_y); PlacePointer((yes_button.max_x + no_button.min_x)//2, hh + height//2); accept := false; cancel := false; key_sensitize; while not (accept or cancel) do handle_event; key_desensitize; % TopWindow.PlacePointer(pointer_x, pointer_y); yes_button.SetLabel(notext).Hide; no_button.Hide; Clear; if width_increased then SetWidth(prevwidth); if not is_mapped then Hide; ask_for_Bool := bool_answer; end; Boolean procedure be_om_Bool(prompt); text prompt; be_om_Bool := ask_for_Bool(prompt); procedure handle_key_down(key); character key; if key = 'n' then begin accept := true; bool_answer := false end else if key = 'y' or key = 'j' then begin accept := true; bool_answer := true end; procedure SizeChange_in_SubWindow(wnd); ref(SubWindow) wnd; if wnd == answer_window then PlaceSubwindows; procedure PlaceSubwindows; begin integer newwidth; if clear_Button =/= none then clear_button.PlaceRightof(answer_window) .Show; if OK_Button =/= none then OK_button.PlaceRightof(if clear_Button =/= none then clear_Button else answer_window) .Show; if Cancel_Button =/= none then Cancel_button.PlaceRightof(if OK_Button =/= none then OK_Button else if clear_Button =/= none then clear_Button else answer_window) .Show; if Hide_Button =/= none then Hide_button.PlaceRightof(if Cancel_Button =/= none then cancel_Button else if OK_Button =/= none then OK_Button else if clear_Button =/= none then clear_Button else answer_window) .Show; newwidth := (if Hide_Button =/= none then Hide_Button else if Cancel_Button =/= none then Cancel_Button else if OK_Button =/= none then OK_Button else if clear_Button =/= none then clear_Button else % if answer_window =/= none then answer_window else answer_window).max_x + subwindow_spacing + BorderWidth; if width < newwidth then begin if not width_increased then prevwidth := width; width_increased := true; SetWidth(newwidth); if max_x + parent.SubWindowSpacing > parent.width then parent.SetWidth(max_x + parent.SubWindowSpacing); end; end; text procedure ask_for_text(prompt); text prompt; begin ref(TextItemWindow) answer_wnd; answer_wnd :- new TextItemWindow(this PromptWindow) .SetMaxChars(initial_text_length) .Show; answer_wnd.incrementable := true; ask_for(answer_wnd, prompt); if accepted then ask_for_text :- answer_wnd.gettext else ask_for_text :- notext; answer_wnd.Hide; end; text procedure be_om_text(prompt); text prompt; be_om_text :- ask_for_text(prompt); text procedure ask_for_text_def(prompt, default); text prompt, default; begin ref(TextItemWindow) answer_wnd; answer_wnd :- new TextItemWindow(this PromptWindow) .SetMaxChars(max(initial_text_length, default.length)) .Show; answer_wnd.incrementable := true; answer_wnd.puttext(default); ask_for(answer_wnd, prompt); if accepted then ask_for_text_def :- answer_wnd.gettext else ask_for_text_def :- notext; answer_wnd.Hide; end; text procedure ask_for_text_lim(prompt, max_length); text prompt; integer max_length; begin ref(TextItemWindow) answer_wnd; answer_wnd :- new TextItemWindow(this PromptWindow) .SetMaxChars(max(1, max_length)) % .SetMaxChars(6) .Show; answer_wnd.incrementable := false; ask_for(answer_wnd, prompt); if accepted then ask_for_text_lim :- answer_wnd.gettext else ask_for_text_lim :- notext; answer_wnd.Hide; end; text procedure ask_for_text_def_lim(prompt, default, max_length); text prompt, default; integer max_length; begin ref(TextItemWindow) answer_wnd; answer_wnd :- new TextItemWindow(this PromptWindow) .SetMaxChars(max_length) .Show; answer_wnd.incrementable := false; answer_wnd.puttext(default); ask_for(answer_wnd, prompt); if accepted then ask_for_text_def_lim :- answer_wnd.gettext else ask_for_text_def_lim :- notext; answer_wnd.Hide; end; integer procedure ask_for_int(prompt); text prompt; begin ref(IntItemWindow) answer_wnd; answer_wnd :- new IntItemWindow(this PromptWindow) .SetMaxChars(10) .Show; answer_wnd.incrementable := true; ask_for(answer_wnd, prompt); ask_for_int := if accepted then answer_wnd.getint else 0; answer_wnd.Hide; end; integer procedure be_om_int(prompt); text prompt; be_om_int := ask_for_int(prompt); integer procedure ask_for_int_def(prompt, default); text prompt; integer default; begin ref(IntItemWindow) answer_wnd; answer_wnd :- new IntItemWindow(this PromptWindow) .SetMaxChars(10) .Show; answer_wnd.incrementable := true; answer_wnd.putint(default); ask_for(answer_wnd, prompt); ask_for_int_def := if accepted then answer_wnd.getint else 0; answer_wnd.Hide; end; real procedure ask_for_real(prompt); text prompt; begin ref(RealItemWindow) answer_wnd; answer_wnd :- new RealItemWindow(this PromptWindow) .SetMaxChars(11) .Show; answer_wnd.incrementable := true; ask_for(answer_wnd, prompt); ask_for_real := if accepted then answer_wnd.getreal else 0; answer_wnd.Hide; end; real procedure be_om_real(prompt); text prompt; be_om_real := ask_for_real(prompt); real procedure ask_for_real_def(prompt, default); text prompt; real default; begin ref(RealItemWindow) answer_wnd; answer_wnd :- new RealItemWindow(this PromptWindow) .SetMaxChars(11) .Show; answer_wnd.incrementable := true; answer_wnd.putreal(default, 3); ask_for(answer_wnd, prompt); ask_for_real_def := if accepted then answer_wnd.getreal else 0; answer_wnd.Hide; end; character procedure ask_for_char(prompt); text prompt; begin ref(CharItemWindow) answer_wnd; answer_wnd :- new CharItemWindow(this PromptWindow) .Show; ask_for(answer_wnd, prompt); ask_for_char := if accepted then answer_wnd.getchar else char(0); answer_wnd.Hide; end; character procedure be_om_char(prompt); text prompt; be_om_char := ask_for_char(prompt); character procedure ask_for_char_def(prompt, default); text prompt; character default; begin ref(CharItemWindow) answer_wnd; answer_wnd :- new CharItemWindow(this PromptWindow) .Show; answer_wnd.putchar(default); ask_for(answer_wnd, prompt); ask_for_char_def := if accepted then answer_wnd.getchar else char(0); answer_wnd.Hide; end; procedure ClickInButton(b); ref(Button) b; if b == OK_button then accept := true else if b == cancel_button then cancel := true else if b == hide_button then Hide else if b == clear_button then begin if answer_window =/= none then answer_window.MakeEmpty end else if b == yes_button then begin accept := true; bool_answer := true end else if b == no_button then begin accept := true; bool_answer := false end; procedure ReturnKey; accept := true; procedure Resize; SetSize(width_of_text(" (Prompt) "), max(height, head_height + 2*(DepthBorder + subwindow_spacing + BorderWidth) + (if fancy then 2*font_height else 4*font_height//3))); ref(XWindow) procedure SetFont(font_name); text font_name; begin SetXFont(new XFont(font_name)); Resize; Refresh; SetFont :- this XWindow; end; Resize; SaveUnder; PlaceAt(10*SubWindowSpacing, 10*SubWindowSpacing); end PromptWindow; SubWindow class MessageWindow; begin procedure Refresh; begin if message_in_window =/= notext then DrawTextPos(DepthBorder + 2*space_width, head_height + height//2, message_in_window, LeftPos, CenterPos); if fancy then DownBorder; % if fancy then DownBorder(DepthBorder); end; text message_in_window; integer space_width; ref(XWindow) procedure SetFancy; begin fancy := true; SetBackGround("gray25"); SetDepthBorder(3); setfancy :- this MessageWindow; end; ref(Button) OK_button; ref(MessageWindow) procedure MessageWait(mess, time); text mess; integer time; TimedMessage(mess, time); ref(MessageWindow) procedure TimedMessage(mess, time); text mess; integer time; begin Message(mess); SetAlarm(time); TimedMessage :- this MessageWindow; end; ref(MessageWindow) procedure Message(mess); text mess; begin SetSize(2*DepthBorder + 5*space_width + width_of_text(mess) + OK_button.width, max(height, 2*DepthBorder + head_height + max(2*font_height, OK_button.max_y + font_height//4))); OK_button.PlaceWithCenterIn(width - OK_button.width//2 - 2*space_width - DepthBorder, head_height + height//2); OK_button.Show; Clear; message_in_window :- mess; Raise; Show; Message :- this MessageWindow; end; procedure handle_alarm; Hide; procedure Perform(heading); text heading; if heading = "OK" then Hide; procedure Resize; SetHeight(max(height, head_height + 2*(DepthBorder + sw_gap) + OK_button.height)); ref(XWindow) procedure SetFont(font_name); text font_name; begin SetXFont(new XFont(font_name)); space_width := width_of_char(' '); Resize; Refresh; SetFont :- this XWindow; end; if parent.fancy then SetFancy; space_width := width_of_char(' '); OK_button :- new Button(this MessageWindow, "OK").Show; SaveUnder; Resize; PlaceAt(10*subwindowspacing, 10*subwindowspacing); end MessageWindow; SubWindow class ScrollBar; begin integer box_bot, box_height, prev_box_bot, prev_box_height; procedure Mark(wnd_bot, wnd_top, info_top); integer wnd_bot, wnd_top, info_top; begin integer top, h; prev_box_bot := box_bot; prev_box_height := box_height; h := height - 1; top := max(1, max(wnd_top, info_top)); box_bot := max(1, (wnd_bot-1)*h//top); box_height := max(1, wnd_top*h//top - box_bot); if box_bot > prev_box_bot then ClearRectangle(1, prev_box_bot, width - 2, box_bot - prev_box_bot); if box_bot + box_height < prev_box_bot + prev_box_height then ClearRectangle(1, box_bot + box_height + 1, width - 2, prev_box_bot + prev_box_height - (box_bot + box_height)); Refresh; end; procedure Refresh; FillRectangle(1, box_bot, width-2, box_height); procedure NewHeight(h); integer h; begin SetHeight(h); box_height := height end; procedure handle_button_click(button); integer button; if button = CenterButton then parent qua ScrollWindow.ScrollTo(y_of_event/height) else parent qua ScrollWindow.ScrollPage(y_of_event > box_bot); button_sensitize; SetFill("gray75"); box_bot := 1; box_height := height - 4; end ScrollBar; SubWindow class ScrollBox(up); Boolean up; begin procedure refresh; begin integer w; integer array x, y(1 : 3); w := width//3; if up then begin x(1) := width//2; y(1) := 2; x(2) := x(1) - w; y(2) := height - 3; x(3) := x(1) + w; y(3) := height - 3; end else begin x(1) := width//2; y(1) := height - 2; x(2) := x(1) - w; y(2) := 3; x(3) := x(1) + w; y(3) := 3; end; FillPolygon(x, y, 3); DrawLine(x(1), y(1), x(2), y(2)); DrawLine(x(2), y(2), x(3), y(3)); DrawLine(x(3), y(3), x(1), y(1)); end; procedure handle_button_down(button); integer button; inspect parent when ScrollWindow do StartScroll(button, up) when MultipleChoiceWindow do if up then PreviousChoice else NextChoice; procedure handle_button_up(button); integer button; inspect parent when ScrollWindow do StopScroll(up); button_sensitize; end ScrollBox; SubWindow class ScrollWindow(lines_in_history); integer lines_in_history; % % ref(ScrollWindow) procedure MakeEmpty; % ref(ScrollWindow) procedure MakeWaitButton(heading); text heading; % Boolean procedure IsEmpty; % procedure Wait; % ref(ScrollWindow) procedure AllowChoice; % ref(ScrollWindow) procedure DisallowChoice; % procedure LineChoice(line); text line; % procedure PutLine(line); text line; % procedure PutText(t); text t; % begin text procedure window_kind; window_kind :- "Scrollwindow"; ref(ListWindow) list_wnd; ref(HeadWindow) head_wnd; ref(MenuWindow) the_menu; ref(Button) ok_button, hide_button; ref(ScrollBar) scroll_bar; ref(ScrollBox) up_box, down_box; integer scroll_box_width = 15, scroll_box_height = 15; procedure Perform(heading); text heading; if hide_button =/= none and then hide_button.heading = heading then Hide; ref(XWindow) procedure MakeEmpty; begin list_wnd.MakeEmpty; unchoose; MakeEmpty :- this ScrollWindow; end; ref(Button) procedure MakeButton(heading); text heading; begin if the_menu == none then the_menu :- new MenuWindow(this ScrollWindow).Show; if horizontal then the_menu.SetHorizontal else the_menu.SetVertical; Resize; MakeButton :- the_menu.MakeButton(heading); end; Boolean horizontal; ref(ScrollWindow) procedure SetHorizontal; begin horizontal := true; SetHorizontal :- this ScrollWindow end; ref(ScrollWindow) procedure SetVertical; begin horizontal := false; SetVertical :- this ScrollWindow end; ref(ScrollWindow) procedure MakeWaitButton(heading); text heading; begin ok_button :- new Button(this ScrollWindow, heading) .Show; Resize; MakeWaitButton :- this ScrollWindow; end; ref(ScrollWindow) procedure MakeHideButton; begin hide_button :- new Button(this ScrollWindow, (if Norsktekst then "Skjul" else "Hide")) .Show; Resize; MakeHideButton :- this ScrollWindow; end; ref(XWindow) procedure MakeHeadWindow(heading); text heading; begin head_wnd :- new HeadWindow(this XWindow); head_wnd.SetHeading(heading); Resize; MakeHeadWindow :- this XWindow; end; ref(XWindow) procedure SetHeading(heading); text heading; begin if head_wnd == none then MakeHeadWindow(heading) else head_wnd.SetHeading(heading); Resize; SetHeading :- this XWindow; end; Boolean procedure IsEmpty; IsEmpty := list_wnd.IsEmpty; ref(XWindow) procedure Wait; begin if ok_button =/= none then ok_button.Wait; Wait :- this XWindow; end; Boolean line_chosen; procedure unchoose; line_chosen := false; ref(ScrollWindow) procedure SetBlockCursor; begin list_wnd.SetBlockCursor; SetBlockCursor :- this ScrollWindow; end; ref(ScrollWindow) procedure SetLineCursor; begin list_wnd.SetLineCursor; SetLineCursor :- this ScrollWindow; end; ref(XWindow) procedure AllowInput; begin list_wnd.AllowInput; AllowInput :- this ScrollWindow; end; ref(XWindow) procedure DisallowInput; begin list_wnd.DisallowInput; DisallowInput :- this ScrollWindow; end; ref(XWindow) procedure AllowChoice; begin list_wnd.AllowChoice; AllowChoice :- this ScrollWindow; end; ref(XWindow) procedure DisallowChoice; begin list_wnd.DisallowChoice; DisallowChoice :- this ScrollWindow; end; procedure LineChoice(line); text line; begin line_chosen := true; parent.LineChoice(line); end; procedure LineChoiceIn(line, line_number, wnd); text line; integer line_number; ref(SubWindow) wnd; begin line_chosen := true; parent.LineChoiceIn(line, line_number, this ScrollWindow); end; ref(ScrollWindow) procedure GrayLine(lnr); integer lnr; begin list_wnd.GrayLine(lnr); GrayLine :- this ScrollWindow; end; ref(ScrollWindow) procedure BlackLine(lnr); integer lnr; begin list_wnd.BlackLine(lnr); BlackLine :- this ScrollWindow; end; ref(ScrollWindow) procedure PutLine(line); text line; begin list_wnd.putline(line); PutLine :- this ScrollWindow; end; ref(ScrollWindow) procedure PutLineNr(lnr, line); integer lnr; text line; begin list_wnd.putlineNr(lnr, line); PutLineNr :- this ScrollWindow; end; ref(ScrollWindow) procedure PutVisibleLineNr(lnr, line); integer lnr; text line; begin list_wnd.putVisiblelineNr(lnr, line); PutVisibleLineNr :- this ScrollWindow; end; ref(ScrollWindow) procedure outline(line); text line; outline :- PutLine(line); ref(ScrollWindow) procedure outtext(t); text t; begin list_wnd.puttext(t); outtext :- this ScrollWindow; end; ref(ScrollWindow) procedure outchar(c); character c; outchar :- outtext(char_as_text(c)); ref(ScrollWindow) procedure outint(i, w); integer i, w; begin text t; if w <= 0 then t :- int_as_text(i) else begin t :- blanks(w); t.putint(i) end; outint :- outtext(t); end; ref(ScrollWindow) procedure outfix(r, d, w); real r; integer d, w; begin text t; if w <= 0 then t :- real_as_text(r, d) else begin t :- blanks(w); t.putfix(r, d) end; outfix :- outtext(t); end; ref(ScrollWindow) procedure PutText(t); text t; begin list_wnd.puttext(t); PutText :- this ScrollWindow; end; ref(ScrollWindow) procedure setpos(pos); integer pos; begin list_wnd.setpos(pos); setpos :- this ScrollWindow; end; ref(ScrollWindow) procedure outimage; begin list_wnd.PutImage; outimage :- this ScrollWindow; end; ref(ScrollWindow) procedure PutImage; begin list_wnd.PutImage; PutImage :- this ScrollWindow; end; text procedure GetLine(lnr); integer lnr; GetLine :- list_wnd.GetLine(lnr); text procedure GetVisibleLine(lnr); integer lnr; GetVisibleLine :- list_wnd.GetVisibleLine(lnr); ref(ScrollWindow) procedure ScrollLineUp; begin list_wnd.ScrollLineUp; ScrollLineUp :- this ScrollWindow; end; ref(ScrollWindow) procedure ScrollLineDown; begin list_wnd.ScrollLineDown; ScrollLineDown :- this ScrollWindow; end; ref(ScrollWindow) procedure ScrollToTop; begin list_wnd.ScrollToTop; ScrollToTop :- this ScrollWindow; end; ref(ScrollWindow) procedure ScrollToBottom; begin list_wnd.ScrollToBottom; ScrollToBottom :- this ScrollWindow; end; ref(ScrollWindow) procedure ScrollToLine(line_number); integer line_number; begin list_wnd.ScrollToLine(line_number); ScrollToLine :- this ScrollWindow; end; ref(ScrollWindow) procedure ScrollPage(forward); Boolean forward; begin list_wnd.ScrollPage(forward); ScrollPage:- this ScrollWindow; end; procedure ScrollTo(q); real q; list_wnd.ScrollTo(q); procedure MarkScrollbar(wnd_bot, wnd_top, info_top); integer wnd_bot, wnd_top, info_top; scroll_bar.Mark(wnd_bot, wnd_top, info_top); procedure StartScroll(speed, up); integer speed; Boolean up; list_wnd.StartScroll(speed, up); procedure StopScroll(up); Boolean up; list_wnd.StopScroll(up); ref(XWindow) procedure SetLines(lines); integer lines; begin max_lines := lines; max_lines_set := true; list_wnd.SetLines(lines); SetLines :- SetHeight(list_wnd.max_y + (if the_menu =/= none and horizontal then the_menu.height + subwindow_spacing else 0) + subwindow_spacing + 1); end; ref(XWindow) procedure SetColumns(columns); integer columns; begin list_wnd.SetColumns(columns); SetColumns :- SetWidth(list_wnd.max_x + (if the_menu =/= none and not horizontal then the_menu.width + subwindow_spacing else 0) + subwindow_spacing); end; procedure PlaceMenu; if the_menu =/= none and not horizontal then the_menu.PlaceAt(list_wnd.max_x + subwindow_spacing, 0) else if the_menu =/= none and horizontal then the_menu.PlaceAt(0, list_wnd.max_y + subwindow_spacing); procedure SetSizeSub; Resize; integer procedure chars_in_line; chars_in_line := list_wnd.chars_in_line; integer procedure top_height; top_height := 2*list_wnd.BorderWidth + (if head_wnd == none then 2*subwindow_spacing else head_wnd.height + 3*subwindow_spacing + 2*head_wnd.BorderWidth); procedure Resize; begin list_wnd.SetSize(width - scroll_box_width - 3*subwindow_spacing - 2*scroll_bar.BorderWidth - 2*list_wnd.BorderWidth, height - top_height); if head_wnd =/= none then begin head_wnd .PlaceUpLeft; up_box .PlaceLeftBelow(head_wnd) .SetSize(scroll_box_width, scroll_box_height); scroll_bar.PlaceLeftBelow(up_box) .SetWidth(scroll_box_width); list_wnd .PlaceRightof(up_box); head_wnd .SetWidth(list_wnd.max_x - head_wnd.min_x - 2*head_wnd.BorderWidth - (if ok_button == none and hide_button == none then 0 else (subwindow_spacing + 2*head_wnd.BorderWidth + (if OK_button =/= none then OK_button.width else hide_button.width)))); if ok_button =/= none then OK_button .SetHeight(head_wnd.height) .PlaceRightof(head_wnd); if hide_button =/= none then hide_button .SetHeight(head_wnd.height) .PlaceRightof(head_wnd); end else begin up_box .PlaceUpLeft .SetSize(scroll_box_width, scroll_box_height); scroll_bar.PlaceLeftBelow(up_box) .SetWidth(scroll_box_width); list_wnd .PlaceRightof(up_box); if ok_button =/= none then OK_button.PlaceUpRight; if hide_button =/= none then Hide_button.PlaceUpRight; end; scroll_bar.NewHeight(list_wnd.height - 2*scroll_box_height -2*subwindow_spacing - 4*BorderWidth); down_box .PlaceLeftBelow(scroll_bar) .SetSize(scroll_box_width, scroll_box_height); end; ref(XWindow) procedure SetFont(font_name); text font_name; begin if list_wnd =/= none then list_wnd.SetFont(font_name); SetXFont(new XFont(font_name)); Resize; Refresh; SetFont :- this XWindow; end; ref(ScrollWindow) procedure SetTypeFace(typeface, size, bold, slanted); text typeface; integer size; Boolean bold, slanted; begin SetHeadFont(FontName("helvetica", size, bold, slanted)); SetTypeFace :- SetFont(FontName(typeface, size, bold, slanted)); if FontExists then begin % current_typeface :- typeface; % current_font_size := size; % current_bold_font := bold; % current_slanted_font := slanted; end; end; ref(ScrollWindow) procedure SetHeadTypeface(typeface, size, bold, slanted); text typeface; integer size; Boolean bold, slanted; SetHeadTypeface :- SetHeadFont(FontName(typeface, size, bold, slanted)); ref(XWindow) procedure SetHeadFont(font_name); text font_name; begin if head_wnd =/= none then head_wnd.SetFont(font_name); if ok_button =/= none then OK_button.SetFont(font_name); if hide_button =/= none then hide_button.SetFont(font_name); Resize; Refresh; SetHeadFont :- this XWindow; end; SetSubwindowSpacing(5); scroll_bar :- new ScrollBar(this ScrollWindow) .Show; down_box :- new ScrollBox(this ScrollWindow, false) .Show; up_box :- new ScrollBox(this ScrollWindow, true) .Show; list_wnd :- new ListWindow(this ScrollWindow, lines_in_history) .Show; Resize; SetBackground("gray50"); SetBackingStore; end ScrollWindow; InputWindow class ListWindow(lines_in_history); integer lines_in_history; % % Messages accepted: % MakeEmpty; % PutLine(line); text line; % % Messages sent: % parent.LineChoice(line) % % hidden protected begin text array window_lines(1 : lines_in_history); Boolean array gray(1 : lines_in_history); text current_line; integer current_line_nr, invert_line_nr, pointer_line, pointer_col; integer max_lines_in_window, wnd_bot, wnd_top, info_top; procedure TtyWrite; inspect sysout do begin integer l; outtext("Wnd-bot: " & int_as_text(wnd_bot) & ", Wnd-top: " & int_as_text(wnd_top) & ", info-top: " & int_as_text(info_top) & ", : " & int_as_text(info_top)); outimage; outtext(" Current-line: " & (current_line) & ", current-text: " & (current_text) & ", curr-lnr: " & int_as_text(current_line_nr) & ", inv-lnr: " & int_as_text(invert_line_nr)); outimage; end; integer procedure text_left; text_left := text_border; Boolean choice_allowed; ref(XWindow) procedure AllowChoice; begin choice_allowed := true; AllowChoice :- this ListWindow; end; ref(XWindow) procedure DisallowChoice; begin choice_allowed := false; DisallowChoice :- this ListWindow; end; ref(ListWindow) procedure GrayLine(lnr); integer lnr; begin if 1 <= lnr and lnr <= lines_in_history then begin gray(lnr) := true; if wnd_bot <= lnr and lnr <= wnd_top then PutLineNr(lnr, window_lines(lnr)); end; GrayLine :- this ListWindow; end; ref(ListWindow) procedure BlackLine(lnr); integer lnr; begin if 1 <= lnr and lnr <= lines_in_history then begin gray(lnr) := false; if wnd_bot <= lnr and lnr <= wnd_top then PutLineNr(lnr, window_lines(lnr)); end; BlackLine :- this ListWindow; end; ref(ListWindow) procedure outtext(t); text t; outtext :- PutText(t); ref(ListWindow) procedure PutText(t); text t; begin if current_line =/= notext and then width < 2*text_left + width_of_text(current_line & t) then PutImage; current_line :- current_line & t; PutText :- this ListWindow; end; ref(ListWindow) procedure setpos(pos); integer pos; begin current_line :- if pos <= 1 then notext else if current_line == notext then blanks(pos - 1) else if current_line.length + 1 < pos then current_line & blanks(pos - current_line.length - 1) else if current_line.length >= pos then current_line.sub(1, pos - 1) else current_line; setpos :- this ListWindow; end; integer procedure chars_in_line; chars_in_line := width//max_char_width; ref(ListWindow) procedure outimage; outimage :- PutImage; ref(ListWindow) procedure PutImage; begin PutLine(current_line); current_line :- notext; PutImage :- this ListWindow; end; ref(ListWindow) procedure PutLine(line); value line; text line; begin if info_top > wnd_top then Scroll(info_top - wnd_top + 1) else if info_top = wnd_top then ScrollLineDown; info_top := info_top + 1; window_lines(info_top) :- line; ClearLine(info_top - wnd_bot + 1); DrawTextLine(info_top, line_bottom(info_top - wnd_bot + 1)); PutLine :- this ListWindow; end; ref(ListWindow) procedure PutLineNr(lnr, line); value line; integer lnr; text line; if 1 <= lnr and lnr <= lines_in_history then begin if lnr > wnd_top then Scroll(lnr - wnd_top); window_lines(lnr) :- line; info_top := max(info_top, lnr); ClearLine(lnr - wnd_bot + 1); DrawTextLine(lnr, line_bottom(lnr - wnd_bot + 1)); PutLineNr :- this ListWindow; end; ref(ListWindow) procedure PutVisibleLineNr(lnr, line); value line; integer lnr; text line; if 1 <= lnr and lnr <= max_lines_in_window then begin integer nr; nr := wnd_bot + lnr - 1; window_lines(nr) :- line; info_top := max(info_top, nr); ClearLine(nr); DrawTextLine(nr, line_bottom(nr)); PutVisibleLineNr :- this ListWindow; end; text procedure GetLine(lnr); integer lnr; if 1 <= lnr and lnr <= lines_in_history then GetLine :- window_lines(lnr) else GetLine :- notext; text procedure GetVisibleLine(lnr); integer lnr; if 1 <= lnr and lnr <= max_lines_in_window then GetVisibleLine :- window_lines(wnd_bot + lnr - 1); ref(XWindow) procedure MakeEmpty; begin integer lnr; wnd_bot := 1; wnd_top := wnd_bot + max_lines_in_window -1; info_top := 0; current_line :- notext; current_text :- notext; for lnr := 1 step 1 until lines_in_history do begin window_lines(lnr) :- notext; gray(lnr) := false; end; cursor_pos_set := false; current_line_nr := 0; invert_line_nr := 0; cursor_pos := 0; SClear; MarkScrollBar; MakeEmpty :- this ListWindow; end; Boolean procedure IsEmpty; IsEmpty := info_top = 0; procedure Refresh; begin integer line_nr; for line_nr := wnd_bot step 1 until min(wnd_top, info_top) do DrawTextLine(line_nr, line_bottom(line_nr - wnd_bot + 1)); end; procedure DrawTextLine(lnr, y); integer lnr, y; begin if gray(lnr) then SetDrawStipple("gray50"); DrawText(text_left, y, window_lines(lnr)); if gray(lnr) then SetDrawStipple("black"); end; Boolean scrolling; procedure StartScroll(speed, up); integer speed; Boolean up; begin integer microsecs; microsecs := if speed = 1 then 1000 else if speed = 2 then 30000 else 100000; scrolling := true; while scrolling do begin if up then ScrollLineUp else ScrollLineDown; PassiveWait(microsecs); handle_pending_events; end; end; procedure StopScroll(up); Boolean up; scrolling := false; ref(ListWindow) procedure ScrollLineUp; begin if wnd_bot > 1 then begin InvertLine(invert_line_nr); CopyRectangle(text_left, line_bottom(0) + font_descent, width - text_left - 2*DepthBorder, (max_lines_in_window - 1)*font_height - 1, text_left, line_bottom(1) + font_descent); ClearLine(1); wnd_top := wnd_top - 1; wnd_bot := wnd_bot - 1; MarkScrollbar; if wnd_top <= info_top then DrawTextLine(wnd_bot, line_bottom(1)); InvertLine(invert_line_nr); end; ScrollLineUp :- this ListWindow; end; ref(ListWindow) procedure ScrollLineDown; begin if wnd_top <= info_top then begin InvertLine(invert_line_nr); CopyRectangle(text_left, line_bottom(1) + font_descent, width - text_left - 2*DepthBorder, (max_lines_in_window - 1)*font_height - 1, text_left, head_height + font_descent); ClearLine(max_lines_in_window); if info_top = lines_in_history then begin integer i; for i := 2 step 1 until lines_in_history do window_lines(i-1) :- window_lines(i); window_lines(lines_in_history) :- notext; info_top := info_top - 1; end else begin wnd_top := wnd_top + 1; wnd_bot := wnd_bot + 1; end; MarkScrollbar; if wnd_top <= info_top then DrawTextLine(wnd_top, line_bottom(wnd_top - wnd_bot + 1)); InvertLine(invert_line_nr); end; ScrollLineDown :- this ListWindow; end; ref(ListWindow) procedure Scroll(n); integer n; begin integer l; if n > 0 then begin for l := 1 step 1 until n do ScrollLineDown; end else if n < 0 then begin for l := 1 step -1 until n do ScrollLineUp; end; Scroll :- this ListWindow; end; ref(ListWindow) procedure ScrollPage(forward); Boolean forward; ScrollPage :- Scroll((if forward then +1 else -1)*(max_lines_in_window-1)); ref(ListWindow) procedure ScrollToBottom; begin SClear; wnd_bot := 1; wnd_top := wnd_bot + max_lines_in_window - 1; Refresh; MarkScrollbar; ScrollToBottom :- this ListWindow; end; ref(ListWindow) procedure ScrollToTop; ScrollToTop :- ScrollTo(1); procedure SClear; begin external C procedure xclearwindow is procedure XClearWindow(WindowID); integer WindowID;; XClearWindow(windowID); end; ref(ListWindow) procedure ScrollToLine(line_number); integer line_number; begin integer n; SClear; n := max(1, min(info_top - max_lines_in_window + 2, line_number - max_lines_in_window//2)); wnd_bot := max(1, n); wnd_top := wnd_bot + max_lines_in_window - 1; Refresh; MarkScrollbar; ScrollToLine :- this ListWindow; end; ref(ListWindow) procedure ScrollTo(q); real q; begin integer n; SClear; n := max(1, min(info_top - max_lines_in_window + 2, q*info_top)); wnd_bot := max(1, n); wnd_top := wnd_bot + max_lines_in_window - 1; Refresh; MarkScrollbar; ScrollTo :- this ListWindow; end; integer procedure cursor_top; cursor_top := head_height + (current_line_nr - wnd_bot)*font_height + font_descent; integer procedure cursor_height; cursor_height := font_height + (if block_cursor then 2 else 0); procedure show_current_text; begin integer ty; if not cursor_pos_set then begin current_line_nr := 1; info_top := max(1, info_top); cursor_pos := 1; cursor_pos_set := true; end; ty := line_bottom(current_line_nr - wnd_bot + 1) - font_ascent; ClearRectangle(text_left - 1, ty, width - 2*(text_left - 1), font_height); window_lines(current_line_nr) :- current_text; DrawTextLine(current_line_nr, ty + font_ascent); end; procedure set_current_line(lnr, col); integer lnr, col; begin current_line_nr := lnr; info_top := max(lnr, info_top); current_text :- window_lines(current_line_nr); current_line :- window_lines(current_line_nr); cursor_pos := min(pointer_col, current_text.length); PlaceCursor; end; procedure handle_down_arrow; if input_allowed and current_line_nr < lines_in_history then begin RemoveCursor; if current_line_nr = wnd_top then ScrollLineDown; set_current_line(current_line_nr + 1, cursor_pos); end; procedure handle_up_arrow; if input_allowed and current_line_nr > 1 then begin RemoveCursor; if current_line_nr = wnd_bot then ScrollLineUp; set_current_line(current_line_nr - 1, cursor_pos); end; procedure handle_return; handle_down_arrow; procedure handle_button_down(button); integer button; if input_allowed and button = CenterButton then begin cursor_pos_set := true; RemoveCursor; set_current_line(pointer_line + wnd_bot - 1, pointer_col); end else if choice_allowed then begin integer ind; ind := invert_line_nr + wnd_bot - 1; if 1 <= ind and ind <= info_top and then not gray(ind) then begin parent.LineChoice(window_lines(ind)); parent.LineChoiceIn(window_lines(ind), ind, this ListWindow); end; end; procedure handle_pointer_motion(x, y); integer x, y; begin integer line_nr; line_nr := min((y - head_height)//font_height + 1, max_lines_in_window); if input_allowed then begin pointer_col := (x-text_left)//width_of_text("x"); pointer_line := line_nr; end; if choice_allowed then begin if invert_line_nr <> line_nr then begin InvertLine(invert_line_nr); invert_line_nr := line_nr; InvertLine(invert_line_nr); end; end; end; procedure handle_leave_window; begin if input_allowed then begin RemoveCursor; WhiteBorder end; % begin RemoveCursor; WhiteBorder(DepthBorder) end; if choice_allowed then begin InvertLine(invert_line_nr); invert_line_nr := 0; end; end; ref(ListWindow) procedure InvertLine(line_nr); integer line_nr; begin if choice_allowed and 1 <= line_nr and line_nr <= max_lines_in_window and then not gray(line_nr) then % InvertRectangle(width - font_height, % line_bottom(line_nr-1) + font_descent - 1, % font_height//2, % font_height); InvertRectangle(DepthBorder, line_bottom(line_nr), width - 2*DepthBorder, 1); InvertLine :- this ListWindow; end; ref(ListWindow) procedure ClearLine(line_nr); integer line_nr; begin if 1 <= line_nr and line_nr <= max_lines_in_window then ClearRectangle(DepthBorder, line_bottom(line_nr-1) + font_descent + 1, width, font_height + 1); ClearLine :- this ListWindow; end; procedure MarkScrollbar; if parent in ScrollWindow then parent qua ScrollWindow.MarkScrollbar(wnd_bot, wnd_top, info_top); integer procedure line_bottom(line); integer line; line_bottom := head_height + line*font_height; ref(ListWindow) procedure SetTextSize(ncolumns, nrows); integer ncolumns, nrows; SetTextSize :- SetColumns(ncolumns).SetLines(nrows); ref(XWindow) procedure SetColumns(ncolumns); integer ncolumns; SetColumns :- SetWidth(ncolumns*max_char_width + 2*text_border); procedure SetSizeSub; begin max_lines_in_window := max(1, min(lines_in_history, (height - head_height - font_descent - 1)//font_height)); max_item_length := max(1, (width - 2*text_border)//max_char_width); wnd_top := wnd_bot + max_lines_in_window -1; end; ref(XWindow) procedure SetFont(font_name); text font_name; begin SetXFont(new XFont(font_name)); max_lines_in_window := min(lines_in_history, (height - head_height)//font_height); max_item_length := min(max_item_length, max(1, (width - 2*text_border)//max_char_width)); wnd_top := wnd_bot + max_lines_in_window -1; Refresh; SetFont :- this XWindow; end; MakeEmpty; button_sensitize; pointer_motion_sensitize; LeftJustify; SetBackingStore; SetTypeFace("courier", default_font_points, true, false); end ListWindow; SubWindow class DrawWindow; begin ref(XWindow) procedure SetScales(xmn, ymn, xmx, ymx, imn, jmn, imx, jmx); real xmn, ymn, xmx, ymx; integer imn, jmn, imx, jmx; begin scxi := (imx - imn)/(xmx - xmn); ioff := imn - scxi*xmn; scyj := (jmx - jmn)/(ymx - ymn); joff := jmn - scyj*ymn; scix := 1/scxi; xoff := xmn - scix*imn; scjy := 1/scyj; yoff := ymn - scjy*jmn; SetScales :- this XWindow; end; ref(XWindow) procedure DrawLineScaled(x1, y1, x2, y2); real x1, y1, x2, y2; DrawLineScaled :- DrawLine(hor_scale(x1), ver_scale(y1), hor_scale(x2), ver_scale(y2)); ref(XWindow) procedure DrawPointScaled(x, y); real x, y; DrawPointScaled :- DrawPoint(hor_scale(x), ver_scale(y)); ref(XWindow) procedure DrawCircleScaled(cx, cy, r); real cx, cy, r; DrawCircleScaled :- DrawCircle(hor_scale(cx), ver_scale(cy), hor_relscale(r)); ref(XWindow) procedure DrawArcScaled(x1, y1, x2, y2, ang1, ang2); real x1, y1, x2, y2, ang1, ang2; begin integer sx1, sy1, sx2, sy2; sx1 := hor_scale(x1); sy1 := ver_scale(y1); sx2 := hor_scale(x2); sy2 := ver_scale(y2); DrawArcScaled :- DrawArc(min(sx1, sx2), min(sy1, sy2), max(sx1, sx2), max(sy1, sy2), ang1, ang2); end; ref(XWindow) procedure DrawTextScaled(x, y, t, hpos, vpos); real x, y; text t; integer hpos, vpos; DrawTextScaled :- DrawTextPos(hor_scale(x), ver_scale(y), t, hpos, vpos); real scxi, scyj, ioff, joff, scix, scjy, xoff, yoff; integer procedure hor_scale(x); real x; hor_scale := scxi*x + ioff; integer procedure ver_scale(y); real y; ver_scale := scyj*y + joff; integer procedure hor_relscale(x); real x; hor_relscale := scxi*x; integer procedure ver_relscale(y); real y; ver_relscale := scyj*y; real procedure hor_invscale(i); integer i; hor_invscale := scix*i + xoff; real procedure ver_invscale(j); integer j; ver_invscale := scjy*j + yoff; end DrawWindow; DrawWindow class GraphWindow; begin real minx, maxx, miny, maxy; Boolean cornersdefined, coordinatesdefined; integer ndiv = 10; procedure handle_configure; if cornersdefined then DefineCorners(minx, miny, maxx, maxy) else if coordinatesdefined then DefineCoordinates(minx, miny, maxx, maxy); procedure DefineCorners(mnx, mny, mxx, mxy); real mnx, mny, mxx, mxy; begin Clear; SetScales(mnx, mny, mxx, mxy, 0, height, width, 0); minx := mnx; maxx := mxx; miny := mny; maxy := mxy; cornersdefined := true; coordinatesdefined := false; end; procedure DefineCoordinates(mnx, mny, mxx, mxy); real mnx, mny, mxx, mxy; begin integer left, right_gap, bottom_gap, top, sifw, pointw, nmarksv, nmarksh, mk, dd = 5, xw, yw, xdig, ydig; real x, y, xdd, ydd, xx, yy; integer procedure right; right := width - right_gap; integer procedure bottom; bottom := height - bottom_gap; integer procedure qdig(a); real a; if a >= 10 then qdig := 0 else if a >= 1 then qdig := 1 else if a >= 0.1 then qdig := 2 else if a >= 0.01 then qdig := 3 else if a >= 0.001 then qdig := 4 else if a >= 0.0001 then qdig := 5 else qdig := 6; integer procedure dig(i); integer i; dig := int_as_text(i).length; procedure BottomMark(x); real x; begin DrawLineScaled(x, mny, x, mny - ydd); DrawTextScaled(x, mny - ydd, real_as_text(x, xdig), CenterPos, TopPos); end; procedure LeftMark(y); real y; begin DrawLineScaled(mnx, y, mnx - xdd, y); DrawTextScaled(mnx - xdd, y, real_as_text(y, ydig), RightPos, CenterPos); end; Clear; minx := mnx; maxx := mxx; miny := mny; maxy := mxy; cornersdefined := false; coordinatesdefined := true; sifw := width_of_text("1"); pointw := width_of_text(". "); xx := max(abs(mxx), abs(mnx)); yy := max(abs(mxy), abs(mny)); xdig := qdig(xx) + 1; ydig := qdig(yy) + 1; right_gap := (dd + (xdig + max(dig(mxx), dig(mnx)))*sifw + pointw)/2; left := max(dd + (ydig + max(dig(mxy), dig(mny)))*sifw + pointw, right_gap); top := font_height/2 + 2; bottom_gap := dd + font_height + 2; SetScales(mnx, mny, mxx, mxy, left, bottom, right, top); ydd := scjy*(-dd); xdd := scix*dd; nmarksv := 10; nmarksh := 10; for mk := 0 step 1 until nmarksh do BottomMark(mnx + mk*((mxx - mnx)/nmarksh)); for mk := 0 step 1 until nmarksv do LeftMark(mny + mk*((mxy - mny)/nmarksv)); DrawRectangle(left, top, right - left, bottom - top); end; SetBackingStore; end GraphWindow; SideWindow class GraphPage; begin ref(GraphWindow) graph_wnd; procedure DefineCorners(mnx, mny, mxx, mxy); real mnx, mny, mxx, mxy; graph_wnd.DefineCorners(mnx, mny, mxx, mxy); procedure DefineCoordinates(mnx, mny, mxx, mxy); real mnx, mny, mxx, mxy; graph_wnd.DefineCoordinates(mnx, mny, mxx, mxy); ref(XWindow) procedure DrawLineScaled(x1, y1, x2, y2); real x1, y1, x2, y2; begin graph_wnd.DrawLineScaled(x1, y1, x2, y2); DrawLineScaled :- this XWindow; end; ref(XWindow) procedure DrawPointScaled(x, y); real x, y; begin graph_wnd.DrawPointScaled(x, y); DrawPointScaled :- this XWindow; end; ref(XWindow) procedure MakeEmpty; begin graph_wnd.Clear; MakeEmpty :- this XWindow; end; procedure Handle_configure; if graph_wnd =/= none then graph_wnd.SetSize(width, height); graph_wnd :- new GraphWindow(this GraphPage).Show; end; SubWindow class MultipleChoiceWindow; begin ref(sequence) table; ref(ScrollBox) next_box, prev_box; integer current, min_width, max_choice_width; procedure handle_button_click(button); integer button; if button = LeftButton then PreviousChoice else if button = CenterButton then FirstChoice else if button = RightButton then NextChoice; procedure Refresh; begin Clear; DrawCenterText(CurrentChoice) end; procedure PreviousChoice; begin current := current - 1; Refresh end; procedure FirstChoice; begin current := 1; Refresh end; procedure NextChoice; begin current := current + 1; Refresh end; text procedure CurrentChoice; begin if current > table.size then current := 1; if current < 1 then current := table.size; CurrentChoice :- table.element_number(current) qua text_element.stored_text; end; ref(MultipleChoiceWindow) procedure AddChoice(t); text t; begin table :- table.append(new text_element(t)); max_choice_width := max(max_choice_width, width_of_text(t)); if max_choice_width + min_width > width then begin SetWidth(max_choice_width + min_width); if next_box =/= none then next_box.PlaceUpRight; if prev_box =/= none then prev_box.PlaceUpLeft; end; AddChoice :- this MultipleChoiceWindow; end; ref(MultipleChoiceWindow) procedure SetChoice(t); text t; begin Boolean found; current := 1; while current <= table.size and not found do if t = table.element_number(current) qua text_element.stored_text then found := true else current := current + 1; Refresh; SetChoice :- this MultipleChoiceWindow; end; ref(MultipleChoiceWindow) procedure MakeStepBoxes; begin integer box_size; box_size := max(height - 2*(SubwindowSpacing + BorderWidth), 5); min_width := 2*(box_size + 2*(SubwindowSpacing + BorderWidth) + width_of_text("x")); SetWidth(min_width + max_choice_width); next_box :- new ScrollBox(this MultipleChoiceWindow, false) .SetSize(box_size, box_size) .PlaceUpRight .Show; prev_box :- new ScrollBox(this MultipleChoiceWindow, true) .SetSize(box_size, box_size) .PlaceUpLeft .Show; MakeStepBoxes :- this MultipleChoiceWindow; end; table :- new sequence; current := 1; button_sensitize; SetHeight(4*font_height//3); SetSubWindowSpacing(3); max_choice_width := width_of_text("W"); min_width := 2*subwindow_spacing + max_choice_width; SetWidth(min_width); end MultipleChoiceWindow; element class text_element(stored_text); text stored_text;; SubWindow class MenuWindow; begin ref(sequence) table; Boolean horizontal; ref(MenuWindow) procedure SetHorizontal; begin horizontal := true; SetHorizontal :- this MenuWindow end; ref(MenuWindow) procedure SetVertical; begin horizontal := false; SetVertical :- this MenuWindow end; text procedure window_kind; window_kind :- "MenuWindow"; procedure ClickinButton(b); ref(Button) b; parent.ClickinButton(b); procedure Perform(heading); text heading; parent.Perform(heading); ref(Button) procedure MakeButton(heading); text heading; begin ref(Button) b; b :- if parent.fancy then new FancyButton(this XWindow, heading) else new Button(this XWindow, heading); if table.is_empty then b.PlaceUpLeft else if horizontal then b.PlaceRightof(table.element_number(table.size) qua Button) else b.PlaceBelow( table.element_number(table.size) qua Button); table :- table.append(b); if not horizontal then begin integer maxw; procedure fmw(ob); ref(element) ob; maxw := max(maxw, ob qua button.width); procedure smw(ob); ref(element) ob; ob qua button.setwidth(maxw); maxw := head_width; table.for_each_element(fmw); table.for_each_element(smw); end; SetSizeToSubwindowSize; b.Show; MakeButton :- b; end; SetHeading("Actions:"); table :- new sequence; SetBackground("gray25"); SetSubWindowSpacing(3); Show; end MenuWindow; SubWindow class ParameterWindow(para_label); text para_label; virtual: procedure make_item_wnd is ref(ItemWindow) procedure make_item_wnd;; procedure get_current_value is procedure get_current_value;; procedure cancel_input is procedure cancel_input;; begin ref(ItemWindow) item_wnd; ref(Button) ok_button, cancel_button, clear_button; procedure InputInSubWindow(wnd); ref(SubWindow) wnd; begin if ok_button =/= none then ok_button.Allow; if cancel_button =/= none then cancel_button.Allow; if clear_button =/= none then clear_button.Allow; end; procedure ClickInButton(b); ref(Button) b; begin if b == OK_button then get_current_value else if b == cancel_button then get_current_value else if b == clear_button then item_wnd.Clear; if ok_button =/= none then ok_button.DisAllow; if cancel_button =/= none then cancel_button.DisAllow; if clear_button =/= none then clear_button.DisAllow; end; procedure PlaceItemwnd(cx); integer cx; begin item_wnd.PlaceAt(cx, subwindowspacing); SetSizeToSubWindowSize; end; procedure PlaceOKButton(w); integer w; begin SetWidth(w); OK_Button.PlaceUpRight; end; SetBackground("gray25"); item_wnd :- make_item_wnd .LeftJustify .AllowInput .SetLabel(para_label) .PlaceUpleft; ok_button :- MakeButton("OK") .DisAllow .PlaceRightof(item_wnd); SetSizeToSubWindowSize; Show; end; ParameterWindow class IntParameter(nc); integer nc; begin ref(ItemWindow) procedure make_item_wnd; make_item_wnd :- MakeIntItemWindow.SetMaxChars(nc); integer current_value_vv; integer procedure current_value; current_value := current_value_vv; procedure get_current_value; current_value_vv := item_wnd qua IntItemWindow.getint; procedure set_current_value(v); integer v; begin current_value_vv := v; item_wnd qua IntItemWindow.putint(v); end; end IntParameter; ParameterWindow class BoolParameter; begin ref(ItemWindow) procedure make_item_wnd; make_item_wnd :- MakeBoolItemWindow; Boolean current_value_vv; Boolean procedure current_value; current_value := current_value_vv; procedure get_current_value; current_value_vv := item_wnd qua BoolItemWindow.getBool; procedure set_current_value(v); Boolean v; begin current_value_vv := v; item_wnd qua BoolItemWindow.putBool(v); end; end BoolParameter; ParameterWindow class CharParameter; begin ref(ItemWindow) procedure make_item_wnd; make_item_wnd :- MakeCharItemWindow; character current_value_vv; character procedure current_value; current_value := current_value_vv; procedure get_current_value; current_value_vv := item_wnd qua CharItemWindow.getchar; procedure set_current_value(v); character v; begin current_value_vv := v; item_wnd qua CharItemWindow.putChar(v); end; end CharParameter; ParameterWindow class RealParameter(nc); integer nc; begin ref(ItemWindow) procedure make_item_wnd; make_item_wnd :- MakeRealItemWindow.SetMaxChars(nc); real current_value_vv; real procedure current_value; current_value := current_value_vv; procedure get_current_value; current_value_vv := item_wnd qua RealItemWindow.getreal; procedure set_current_value(v, ndec); real v; integer ndec; begin current_value_vv := v; item_wnd qua RealItemWindow.putreal(v, ndec); end; end RealParameter; ParameterWindow class TextParameter(nc); integer nc; begin ref(ItemWindow) procedure make_item_wnd; make_item_wnd :- MakeTextItemWindow.SetMaxChars(nc); text current_value_vv; text procedure current_value; current_value :- current_value_vv; procedure get_current_value; current_value_vv :- item_wnd qua TextItemWindow.gettext; procedure set_current_value(v); text v; begin current_value_vv :- copy(v); item_wnd qua TextItemWindow.puttext(v); end; end TextParameter; SubWindow class ParameterMenu; begin ref(ParameterWindow) last_para_window; ref(Sequence) para_windows; ref(ParameterWindow) procedure PlaceParameterWindow(para); ref(ParameterWindow) para; begin integer mw, cx; procedure fs(p); ref(element) p; cx := max(cx, p qua ParameterWindow.item_wnd.min_x); procedure fm(p); ref(element) p; mw := max(mw, p qua ParameterWindow.width); procedure ss(p); ref(element) p; p qua ParameterWindow.PlaceItemwnd(cx); procedure sw(p); ref(element) p; p qua ParameterWindow.PlaceOKButton(mw); if last_para_window == none then para.PlaceUpleft else para.PlaceLeftBelow(last_para_window); last_para_window :- para; para_windows.append(para); mw := head_width; cx := 0; para_windows.for_each_element(fs); para_windows.for_each_element(ss); para_windows.for_each_element(fm); para_windows.for_each_element(sw); SetSizeToSubwindowSize; PlaceParameterWindow :- para; end; ref(IntParameter) procedure MakeIntPara(lb, nc); text lb; integer nc; MakeIntPara :- PlaceParameterWindow( new IntParameter(this ParameterMenu, lb, nc)); ref(BoolParameter) procedure MakeBoolPara(lb); text lb; MakeBoolPara :- PlaceParameterWindow( new BoolParameter(this ParameterMenu, lb)); ref(CharParameter) procedure MakeCharPara(lb); text lb; MakeCharPara :- PlaceParameterWindow( new CharParameter(this ParameterMenu, lb)); ref(RealParameter) procedure MakeRealPara(lb, nc); text lb; integer nc; MakeRealPara :- PlaceParameterWindow( new RealParameter(this ParameterMenu, lb, nc)); ref(TextParameter) procedure MakeTextPara(lb, nc); text lb; integer nc; MakeTextPara :- PlaceParameterWindow( new TextParameter(this ParameterMenu, lb, nc)); SetHeading("Parameters:"); SetBackGround("gray25"); SetSubWindowSpacing(0); para_windows :- new Sequence; Show; end ParameterMenu; SubWindow class ParameterList; begin ref(ItemWindow) last_para_window; ref(Sequence) para_windows; ref(ItemWindow) procedure PlaceParameterWindow(para, lb); ref(ItemWindow) para; text lb; begin integer cx, wx; procedure fs(p); ref(element) p; inspect p when ItemWindow do begin cx := max(cx, min_x); wx := max(wx, width) end; procedure fm(p); ref(element) p; inspect p when ItemWindow do begin PlaceAt(cx, max(3, min_y)); SetWidth(wx) end; para.AllowInput; para.SetLabel(lb); para.LeftJustify; SetSubWindowSpacing(0); if last_para_window == none then para.PlaceUpleft else para.PlaceLeftBelow(last_para_window); last_para_window :- para; para_windows.append(para); cx := 0; wx := 0; para_windows.for_each_element(fs); para_windows.for_each_element(fm); SetSubWindowSpacing(3); SetSizeToSubwindowSize; PlaceParameterWindow :- para; end; ref(IntItemWindow) procedure MakeIntPara(lb, init, nc); text lb; integer init, nc; MakeIntPara :- PlaceParameterWindow( MakeIntItemWindow.putint(init).SetMaxchars(nc), lb); ref(BoolItemWindow) procedure MakeBoolPara(lb, init); text lb; Boolean init; MakeBoolPara :- PlaceParameterWindow( MakeBoolItemWindow.putBool(init), lb); ref(RealItemWindow) procedure MakeRealPara(lb, init, nd, nc); text lb; real init; integer nd, nc; MakeRealPara :- PlaceParameterWindow( MakeRealItemWindow.putreal(init, nd).SetMaxchars(nc), lb); ref(TextItemWindow) procedure MakeTextPara(lb, init, nc); text lb, init; integer nc; MakeTextPara :- PlaceParameterWindow( MakeTextItemWindow.puttext(init).SetMaxchars(nc), lb); SetSubWindowSpacing(3); para_windows :- new Sequence; Show; end ParameterList; SubWindow class RadioPanel; begin ref(sequence) table; integer current; Boolean horizontal; ref(RadioPanel) procedure SetHorizontal; begin horizontal := true; SetHorizontal :- this RadioPanel end; ref(RadioPanel) procedure SetVertical; begin horizontal := false; SetVertical :- this RadioPanel end; text procedure window_kind; window_kind :- "RadioPanel"; text procedure CurrentChoice; begin if current > table.size then current := 1; if current < 1 then current := table.size; CurrentChoice :- table.element_number(current) qua RadioButton.heading; end; ref(RadioPanel) procedure AddButton(t); text t; begin ref(RadioButton) rb; rb :- new RadioButton(this RadioPanel, t, horizontal); if table.is_empty then rb.PlaceUpLeft else if horizontal then rb.PlaceRightof(table.element_number(table.size) qua RadioButton) else rb.PlaceBelow( table.element_number(table.size) qua RadioButton); table :- table.append(rb); SetSize(max( width, rb.max_x + SubwindowSpacing + DepthBorder), max(height, rb.max_y + SubwindowSpacing + DepthBorder)); AddButton :- this RadioPanel; end; ref(RadioPanel) procedure ClickInRadiobutton(t); text t; begin ClickInRadiobutton :- SetButton(t); parent.ClickInRadioPanel(this RadioPanel); end; ref(RadioPanel) procedure SetButton(t); text t; begin Boolean found; integer n; current := 1; while current <= table.size and not found do if t = table.element_number(current) qua RadioButton.heading then found := true else current := current + 1; if found then begin integer n; for n := 1 step 1 until table.size do table.element_number(n) qua RadioButton.Choose(n = current); end; SetButton :- this RadioPanel; end; ref(RadioPanel) procedure AddSetButton(t); text t; AddSetButton :- AddButton(t).SetButton(t); table :- new sequence; current := 1; SetSubWindowSpacing(3); end RadioPanel; SubWindow class RadioButton(heading, horizontal); text heading; Boolean horizontal; begin Boolean chosen; text procedure window_kind; window_kind :- "RadioButton-element " & heading; procedure Choose(c); Boolean c; begin chosen := c; Refresh end; integer head_bot, head_left, center_x, center_y, radius; procedure Refresh; begin Clear; if horizontal then begin DrawTextPos(width//2, center_y + radius + 2, heading, CenterPos, TopPos); DrawCircle(width//2, center_y, radius); if chosen then FillCircle(width//2, center_y, radius - 2); end else begin DrawTextPos(head_left, height//2, heading, LeftPos, CenterPos); DrawCircle(center_x, height//2, radius); if chosen then FillCircle(center_x, height//2, radius - 2); end end; procedure handle_button_click(button); integer button; parent qua RadioPanel.ClickInRadiobutton(heading); button_sensitize; SetFill("black"); SetBorderWidth(0); head_left := 3*font_height//2; if horizontal then SetSize(max(width_of_text(heading & " "), 3*radius), 2*font_height + font_descent) else SetSize(head_left + width_of_text(heading) + SubwindowSpacing, font_height); center_x := font_height//2 + 3; center_y := font_height//2 + 3; radius := font_height//2 - 1; head_bot := height - (font_descent); Show; end RadioButton; class TextTable(count); integer count; begin text array text_table(1 : max(1, count)); ref(TextTable) procedure addtext(t); text t; begin ref(TextTable) tt; integer ind; tt :- new TextTable(count + 1); for ind := 1 step 1 until count do tt.text_table(ind) :- text_table(ind); tt.text_table(count + 1) :- t; addtext :- tt; end; text procedure get(ind); integer ind; if 1 <= ind and ind <= count then get :- text_table(ind) else get :- notext; end TextTable; procedure PassiveWait(microseconds); integer microseconds; begin external c procedure sleepus is procedure sleepus(microseconds); integer microseconds;; sleepus(microseconds); end; procedure WaitPassive(seconds); real seconds; PassiveWait(seconds*1000000); integer procedure minint0; minint0 := -1;