home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / HSPASCAL.LZH / HSPASCAL / GEMDEMO / GEMINTER.PAS < prev    next >
Pascal/Delphi Source File  |  1992-05-01  |  13KB  |  380 lines
  1. {-------------------------------------------------------------------------
  2.                 HighSpeed Pascal GEM-interface demo program
  3.  
  4.                               INTERFACE UNIT
  5.  
  6.                       Copyright (c) 1990 by D-House I
  7.                             All rights reserved
  8.  
  9.                       Programmed by Martin Eskildsen
  10. -------------------------------------------------------------------------}
  11. {$R-,S-,D+}
  12. unit GemInterface;
  13.  
  14. INTERFACE
  15.  
  16. uses GemDecl, GemVDI, GemAES, Bios;
  17.  
  18. const                   { object tree indices for message box   }
  19.   FRAMEBOX      = 0;    { white, framing rectangle              }
  20.   MSGBOX        = 1;    { white box containing message          }
  21.   MSGSTR        = 2;    { the message string (C format)         }
  22.   OKBUTTON      = 3;    { the "Ok" button                       }
  23.  
  24. type
  25.   C_String       = packed array [0..255] of char;
  26.   String_Ptr     = ^C_string;
  27.   Ob_Type        = G_BOX..G_TITLE;
  28.   Spec_Info      = RECORD
  29.                      CASE Ob_Type OF
  30.                        G_Box,
  31.                        G_IBox,
  32.                        G_BoxChar  : (thick : integer;
  33.                                      color : integer);
  34.                        G_Text,
  35.                        G_BoxText,       { these fields should    }
  36.                        G_FText,         { of course be extended  }
  37.                        G_FBoxText,      { but as the only fields }
  38.                        G_Image,         { needed are those above }
  39.                        G_UserDef,       { and G_string, this     }
  40.                        G_Button,        { structure is perfectly }
  41.                        G_Icon,          { suitable               }
  42.                        G_String,
  43.                        G_Title    : (str : String_Ptr)
  44.                    END;
  45.  
  46.   Object         = RECORD
  47.                      ob_next  : Integer;        { next object in tree   }
  48.                      ob_head  : Integer;        { parent object         }
  49.                      ob_tail  : Integer;        { next parent on level  }
  50.                      ob_type  : integer;        { object type           }
  51.                      ob_flags : integer;        { flags                 }
  52.                      ob_state : integer;        { state                 }
  53.                      ob_spec  : Spec_Info;      { color/pointer etc.    }
  54.                      ob_x     : integer;        { obj. rectangle size   }
  55.                      ob_y     : integer;        { and position relative }
  56.                      ob_w     : integer;        { to parent object      }
  57.                      ob_h     : integer
  58.                    END;
  59.  
  60.   Tree           = ARRAY [ 0..199 ] OF Object;  { the object tree       }
  61.   Tree_Ptr       = ^Tree;                       { pointer to the tree   }
  62.  
  63. var
  64.   workIn        : IntIn_Array;          { v_opnvwk input parameters     }
  65.   workOut       : WorkOut_Array;        { v_opnvwk output parameters    }
  66.   AES_handle    : Integer;              { application id                }
  67.   VDI_handle    : Integer;              { graphics/VDI handle           }
  68.   CharDefs      : record                { default character definitions }
  69.                     h_char, w_char, h_box, w_box : integer
  70.                   end;
  71.   MinX          : integer;              { desktop area                  }
  72.   MinY          : integer;
  73.   MaxX          : integer;
  74.   MaxY          : integer;
  75.   MaxColors     : integer;
  76.   OutputWindow  : record
  77.                     handle         : integer;   { wind_create return    }
  78.                     bX, bY, bW, bH : integer;   { border area           }
  79.                     wX, wY, wW, wH : integer;   { work area             }
  80.                     midX, midY     : integer    { work area middle      }
  81.                   end;
  82.   MessageBox    : Tree_Ptr;             { the message box               }
  83.  
  84. function Init_Gem : boolean;    { set up GEM (appl, workstation etc.)   }
  85.  
  86. procedure Exit_Gem;             { complete GEM usage                    }
  87.  
  88. procedure Message(s : string);  { write message, wait for Ok            }
  89.  
  90. procedure Inform(s : string);   { write message, don't wait for Ok      }
  91.  
  92. procedure ErrorCloseDown(s : string);   { fatal error, abort program    }
  93.  
  94. function MaxW : integer;        { max. width of desktop area            }
  95.  
  96. function MaxH : integer;        { max. height of desktop area           }
  97.  
  98. function Binary(s : string) : integer;  { convert s into a binary value }
  99.  
  100. procedure OpenOutputWindow;     { open predefined output window         }
  101.  
  102. procedure CloseOutputWindow;    { close output window                   }
  103.  
  104. procedure ClearOutputWindow;    { clear output window                   }
  105.  
  106. IMPLEMENTATION
  107.  
  108. var
  109.   WindowName : string;          { name of output window (must be global)}
  110.  
  111. { The below proc sets up the message box shown on top of the screen by
  112.   creating an object tree with the following objects :
  113.  
  114.         FRAMEBOX        - the white box containing the message and the
  115.                           Ok button
  116.         MSGBOX          - a white box containing the message to output
  117.         MSGSTR          - the message string to output (C format)
  118.         OKBUTTON        - the Ok button
  119.  
  120.   The above fields construct a level-tree as shown below :
  121.  
  122.  
  123.         FRAMEBOX
  124.            |
  125.            |
  126.            v
  127.         MSGBOX ----------> OKBUTTON
  128.            |
  129.            |
  130.            v
  131.         MSGSTR
  132.  
  133.   We havn't shown all pointers involved, but only the ones relevant for
  134.   clarifying the tree structure.
  135. }
  136. procedure SetUpMessageBox;
  137. begin
  138.   getmem(MessageBox, 4 * SizeOf(Object));       { get memory for 4 objects }
  139.  
  140.   with MessageBox^[FRAMEBOX] do begin  { box }
  141.     ob_w     := 50 * CharDefs.w_char;           { 50 * 4.5 chars wide box }
  142.     ob_h     :=  4 * CharDefs.h_char + CharDefs.h_char DIV 2;
  143.     ob_x     := (MaxX - MinX - ob_w) div 2;     { center on X axis }
  144.     ob_y     := MinY + CharDefs.h_char div 2;   { a bit down on the Y axis }
  145.     ob_next  := -1;     { these three fields must be set to -1, as the }
  146.     ob_head  := -1;     { objc_add procedure used later will get con-  }
  147.     ob_tail  := -1;     { fused otherwise! }
  148.     ob_type  := G_BOX;  { this object is a box }
  149.     ob_flags := NONE;           { no flags are set }
  150.     ob_state := OUTLINED;       { it's outlined }
  151.     ob_spec.color := WHITE;     { white background }
  152.     MinY := ob_y + ob_h + 4     { protect message box }
  153.   end;
  154.  
  155.   with MessageBox^[MSGBOX] do begin  { white box containing message string }
  156.     ob_x     := 0;      { rel. position to parent (FRAMEBOX) = upper }
  157.     ob_y     := 0;      { left corner                                }
  158.     ob_w     := 50 * CharDefs.w_char;   { 50 * 2 chars wide }
  159.     ob_h     :=  2 * CharDefs.h_char;
  160.     ob_next  := -1;
  161.     ob_head  := -1;
  162.     ob_tail  := -1;
  163.     ob_type  := G_BOX;
  164.     ob_flags := NONE;
  165.     ob_state := NORMAL;
  166.     ob_spec.color := WHITE
  167.   end;
  168.   objc_add(MessageBox, FRAMEBOX, MSGBOX);
  169.  
  170.         { the objc_add makes the MSGBOX a child of the FRAMEBOX }
  171.  
  172.   with MessageBox^[MSGSTR] do begin  { message string }
  173.     ob_x     := CharDefs.w_char div 2;
  174.     ob_y     := 0;
  175.     ob_w     := 50 * CharDefs.w_char;
  176.     ob_h     :=  2 * CharDefs.h_char;
  177.     ob_next  := -1;
  178.     ob_head  := -1;
  179.     ob_tail  := -1;
  180.     ob_type  := G_STRING;
  181.     ob_flags := NONE;
  182.     ob_state := NORMAL;
  183.     getmem(ob_spec.str, 50);
  184.     ob_spec.str^[0] := #0
  185.   end;
  186.   objc_add(MessageBox, MSGBOX, MSGSTR);
  187.  
  188.         { objc_add makes the MSGSTR a child of MSGBOX, which is again }
  189.         { a child of the FRAMEBOX }
  190.  
  191.   with MessageBox^[OKBUTTON] do begin  { OK button }
  192.     ob_x     := 40 * CharDefs.w_char;
  193.     ob_y     :=  3 * CharDefs.h_char;
  194.     ob_w     :=  8 * CharDefs.w_char;
  195.     ob_h     := CharDefs.h_char;
  196.     ob_next  := -1;
  197.     ob_head  := -1;
  198.     ob_tail  := -1;
  199.     ob_type  := G_BUTTON;
  200.     ob_flags := SELECTABLE + DEFAULT + F_EXIT + LASTOB;
  201.     ob_state := NORMAL;
  202.     getmem(ob_spec.str, 2 + 1);         { reserve space for the string }
  203.     ob_spec.str^[0] := 'O';             { make the string }
  204.     ob_spec.str^[1] := 'k';
  205.     ob_spec.str^[2] := #0
  206.   end;
  207.   objc_add(MessageBox, FRAMEBOX, OKBUTTON);
  208.  
  209.         { objc_add makes the OKBUTTON a child of the FRAMEBOX }
  210.  
  211.   objc_draw(MessageBox, FRAMEBOX, $7FFF, 0, 0, 0, 0)
  212.  
  213.         { objc_draw draws the FRAMEBOX with all levels ($7FFF = more
  214.           levels than a 520 ST would have room for in its memory -
  215.           when using a such big number, we make 101% sure that all
  216.           of the object tree really IS drawn). The four 0's tell that
  217.           no clipping should be used
  218.         }
  219.  
  220. end;
  221.  
  222. function Init_Gem : boolean;
  223. var
  224.   i : integer;
  225.   s : string;
  226. begin
  227.   AES_handle := appl_init;      { get AES id }
  228.  
  229.   if AES_handle >= 0 then begin
  230.     for i := 0 to 9 do WorkIn[i] := 1;  { set some defaults }
  231.     WorkIn[10] := 2;                    { use Raster Coordinates (RC) }
  232.  
  233.     with CharDefs do    { get a VDI handle and font information }
  234.       VDI_handle := graf_handle(w_char, h_char, w_box, h_box);
  235.  
  236.     v_opnvwk(WorkIn, VDI_handle, WorkOut);      { open virtual workstation }
  237.  
  238.     graf_mouse(ARROW, NIL);             { make mouse cursor an arrow }
  239.  
  240.     { now we determine the available desktop area at our disposal }
  241.     wind_get(0, WF_FULLXYWH, MinX, MinY, MaxX, MaxY);
  242.     { the 0 makes wind_get return FULLXYWH information about the desktop }
  243.  
  244.     inc(MaxX, MinX);  inc(MaxY, MinY);  { adjust MaxX and MaxY }
  245.  
  246.     if MaxX - MinX < 51 * CharDefs.w_char then begin
  247.       s := '[3][ | The demo won''t run on screens | with less than 51 characters | per line ][  Sorry  ]'#00;
  248.       i := form_alert(1, s[1]);
  249.       Exit_Gem;
  250.       halt(0)
  251.     end;
  252.  
  253.     if GetRez < 2 then begin
  254.       s := '[1][|The demo looks best in |high resolution, but can |run in medium too][   Ok   ]'#00;
  255.       i := form_alert(1, s[1])
  256.     end;
  257.  
  258.     MaxColors := WorkOut[39];
  259.     graf_mouse(M_OFF, NIL);
  260.     Init_Gem := TRUE
  261.   end
  262.   else Init_Gem := FALSE
  263. end;
  264.  
  265. procedure Exit_Gem;
  266. begin
  267.   if MessageBox <> NIL          { remove the message box }
  268.     then FreeMem(MessageBox, 4 * SizeOf(Object));
  269.   graf_mouse(M_ON, NIL);
  270.   v_clsvwk(VDI_handle);         { close virtual workstation }
  271.   appl_exit                     { end AES usage }
  272. end;
  273.  
  274. procedure Message(s : string);
  275. var
  276.   SelectedItem : Integer;       { the item that the user selected  }
  277. begin                           { (here, it equals OKBUTTON)       }
  278.   if MessageBox = NIL then SetUpMessageBox;
  279.   MessageBox^[OKBUTTON].ob_state := NORMAL;      { deselect button }
  280.   objc_draw(MessageBox, OKBUTTON, $7FFF, 0, 0, 0, 0); { redraw button }
  281.   s := copy(s, 1, 49);                           { truncate string }
  282.   s := s + #0;                                   { make "C" string }
  283.   move(s[1], MessageBox^[MSGSTR].ob_spec.str^, length(s));  { move it   }
  284.   objc_draw(MessageBox, MSGBOX, $7FFF, 0, 0, 0, 0); { draw message }
  285.   graf_mouse(M_ON, NIL);
  286.   SelectedItem := form_do(MessageBox, 0);        { wait for "Ok"   }
  287.   graf_mouse(M_OFF, NIL)
  288. end;
  289.  
  290. procedure Inform(s : string);
  291. var
  292.   SelectedItem : integer;
  293. begin
  294.   if MessageBox = NIL then SetUpMessageBox;
  295.   objc_draw(MessageBox, FRAMEBOX, 0, 0, 0, 0, 0);      { draw white box   }
  296.   s := copy(s, 1, 49) + #0;
  297.   move(s[1], MessageBox^[MSGSTR].ob_spec.str^, length(s));
  298.   objc_draw(MessageBox, MSGBOX, $7FFF, 0, 0, 0, 0)     { draw all of message (box and str) }
  299. end;
  300.  
  301. procedure ErrorCloseDown(s : string);
  302. var i : integer;
  303. begin
  304.   s := '[3][ ' + s + '][ Abort ]'#00;
  305.   graf_mouse(M_OFF, NIL);
  306.   i := form_alert(1, s[1]);
  307.   graf_mouse(M_ON, NIL);
  308.   Exit_Gem;
  309.   halt(0)
  310. end;
  311.  
  312. function MaxW : integer;
  313. begin
  314.   MaxW := MaxX - MinX
  315. end;
  316.  
  317. function MaxH : integer;
  318. begin
  319.   MaxH := MaxY - MinY
  320. end;
  321.  
  322. function Binary(s : string) : integer;
  323. var
  324.   n, i : integer;
  325. begin
  326.   n := 0;
  327.   for i := 1 to length(s) do
  328.     if s[i] in ['0', '1'] then n := n*2 + ord(s[i]) - ord('0');
  329.   Binary := n
  330. end;
  331.  
  332. procedure OpenOutputWindow;
  333. var p : Array_4;
  334. begin
  335.   with OutputWindow do begin
  336.     bX := MinX + 10;  bY := MinY + 10;
  337.     bW := MaxW - 20;  bH := MaxH - 20;
  338.     handle := wind_create(NAME, bX, bY, bW, bH);
  339.     wind_set(handle, WF_NAME, HiPtr(WindowName[1]), LoPtr(WindowName[1]), 0, 0);
  340.     wind_open(handle, bX, bY, bW, bH);
  341.     wind_calc(WC_WORK, NAME, bX, bY, bW, bH, wX, wY, wW, wH);
  342.     midX := wX + wW div 2;
  343.     midY := wY + wH div 2
  344.   end;
  345.   ClearOutputWindow
  346. end;
  347.  
  348. procedure CloseOutputWindow;
  349. begin
  350.   with OutputWindow do begin
  351.     wind_close(handle);
  352.     wind_delete(handle)
  353.   end
  354. end;
  355.  
  356. procedure ClearOutputWindow;
  357. var
  358.   p : Array_4;
  359.   a : Array_5;
  360. begin
  361.   vqf_attributes(VDI_handle, a);
  362.   with OutputWindow do begin
  363.     p[0] := wX;
  364.     p[1] := wY;
  365.     p[2] := wX + wW - 1;
  366.     p[3] := wY + wH - 1;
  367.     vs_clip(VDI_handle, 1, p);
  368.     vsf_color(VDI_handle, White);
  369.     vsf_interior(VDI_handle, Solid);
  370.     vr_recfl(VDI_handle, p)
  371.   end;
  372.   vsf_color(VDI_handle, a[1]);
  373.   vsf_interior(VDI_handle, a[0])
  374. end;
  375.  
  376. begin { of unit }
  377.   MessageBox := NIL;            { no message box made yet }
  378.   WindowName := ' Output '#00#00
  379. end.
  380.