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