home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / HSPASCAL.LZH / HSPASCAL / MYCALC / MYCALC.PAS < prev    next >
Pascal/Delphi Source File  |  1992-05-01  |  21KB  |  533 lines
  1. {-------------------------------------------------------------------------
  2.                     HighSpeed Pascal GEM accessory demo
  3.  
  4.                          MyCalc RPN CALCULATOR DEMO
  5.  
  6.                       Copyright (c) 1990 by D-House I
  7.                             All rights reserved
  8.  
  9.                       Programmed by Martin Eskildsen
  10. -------------------------------------------------------------------------}
  11. {$R-,S-,D+,F-,M 4,1,1,20}
  12.  
  13. program MyCalc;
  14.  
  15. uses GemDecl, GemAES, GemVDI, RPN;
  16.  
  17. CONST
  18.   {$I MyCalc.I}         { get resource file constants }
  19.  
  20. type
  21.   C_String       = packed array [0..255] of char;
  22.   String_Ptr     = ^C_string;
  23.   Ob_Type        = G_BOX..G_TITLE;
  24.   Spec_Info      = RECORD
  25.                      CASE Ob_Type OF
  26.                        G_Box,
  27.                        G_IBox,
  28.                        G_BoxChar,
  29.                        G_Text,
  30.                        G_BoxText,       { these fields should    }
  31.                        G_FText,         { of course be extended  }
  32.                        G_FBoxText,      { but as the only field  }
  33.                        G_Image,         { needed is G_String,    }
  34.                        G_UserDef,       { this structure is per- }
  35.                        G_Button,        { fectly suitable        }
  36.                        G_Icon,
  37.                        G_String,
  38.                        G_Title          : (str : String_Ptr)
  39.                    END;
  40.  
  41.   Object         = RECORD
  42.                      ob_next  : Integer;        { next object in tree   }
  43.                      ob_head  : Integer;        { parent object         }
  44.                      ob_tail  : Integer;        { next parent on level  }
  45.                      ob_type  : integer;        { object type           }
  46.                      ob_flags : integer;        { flags                 }
  47.                      ob_state : integer;        { state                 }
  48.                      ob_spec  : Spec_Info;      { color/pointer etc.    }
  49.                      ob_x     : integer;        { obj. rectangle size   }
  50.                      ob_y     : integer;        { and position relative }
  51.                      ob_w     : integer;        { to parent object      }
  52.                      ob_h     : integer
  53.                    END;
  54.  
  55.   Tree           = ARRAY [ 0..199 ] OF Object;  { the object tree       }
  56.   Tree_Ptr       = ^Tree;                       { pointer to the tree   }
  57.  
  58. var
  59.   VDI_handle    : Integer;              { GEM VDI handle (graf_handle)  }
  60.   AES_handle    : Integer;              { GEM AES handle (appl_init)    }
  61.   ACC_handle    : Integer;              { GEM acc. id (menu_tregister)  }
  62.   Title         : string[14];           { '  MyCalc  '#0#0              }
  63.   Window        : Integer;              { window handle                 }
  64.   Quit          : Boolean;              { TRUE = exit application       }
  65.   noRSC         : Boolean;              { TRUE = no resource file       }
  66.   Dialog        : Tree_Ptr;             { the calculator dialog tree    }
  67.   LastSelected  : Integer;              { index of last selected button }
  68.  
  69.                                         { event manager variables :     }
  70.   x, y          : Integer;              { mouse x,y coordinate          }
  71.   key           : Integer;              { keyboard key scan code        }
  72.   button        : Integer;              { mouse button state            }
  73.   clicks        : Integer;              { mouse button clicks           }
  74.   kbdstate      : Integer;              { keyboard state (CTRL, ALT etc)}
  75.   pipe          : array_16;             { GEM message pipe              }
  76.   Xres          : Integer;              { screen x resolution (pixels)  }
  77.   eventflags    : Integer;              { flags for evnt_multi          }
  78.   evnt_flag     : record                { different evnt_multi flag ... }
  79.                     wait        : Integer;      { ... setups            }
  80.                     active      : Integer
  81.                   end;
  82.  
  83. { Initialize GEM (application and workstation. Accessory detection not until
  84.   later }
  85. procedure Init;
  86. var
  87.   workIn        : intin_Array;
  88.   workOut       : workout_Array;
  89.   i             : integer;
  90. begin
  91.   AES_handle := appl_init;
  92.   if AES_handle <> -1 then begin                { -1 = error }
  93.     VDI_handle := graf_handle(i, i, i, i);
  94.     for i := 0 to 9 do workIn[i] := 1;  workIn[10] := 2;
  95.     v_opnvwk(workIn, VDI_handle, workOut);
  96.     Xres := workOut[0]
  97.   end
  98.   else begin
  99.     writeln('MyCalc could not be installed');
  100.     Halt(0)
  101.   end
  102. end;
  103.  
  104. procedure DeInit;
  105. begin
  106.   rsrc_free;                    { remove RSC file                         }
  107.   v_clsvwk(VDI_handle);         { close workstation                       }
  108.   appl_exit                     { exit application (no AES usage allowed) }
  109. end;
  110.  
  111. { Try to load the resource file. If unsuccessful, then write error message }
  112. procedure LoadRSC;
  113. var
  114.   title : string;               { name of RSC file }
  115.   i     : integer;              { dummy            }
  116. begin
  117.   title := 'MYCALC.RSC'#0;
  118.   rsrc_load(title[1]);
  119.   noRSC := GemError <= 0;
  120.   if noRSC then 
  121.     begin
  122.       Insert('MYCALC\',title,1);
  123.       rsrc_load(title[1]);
  124.       noRSC := GemError <= 0;    
  125.       if noRSC then
  126.         begin
  127.           title := '[3][MYCALC.RSC could not be found |and MyCalc can hence '
  128.                  + 'not be |activated unless you copy the |RSC file into the'
  129.                  + ' currently |active directory.][  Too bad!  ]'#0;
  130.           i := form_alert(1, title[1]);
  131.           if AppFlag then 
  132.             begin               { terminate if application }
  133.               v_clsvwk(VDI_handle);
  134.               appl_exit;
  135.               halt(0)
  136.             end
  137.         end
  138.     end;    
  139.    rsrc_gaddr(R_TREE, CALCULAT, Dialog)     { get Dialog's address }
  140. end;
  141.  
  142.  
  143. { Open calculator window }
  144. procedure OpenWindow;
  145. var
  146.   s             : String;       { alert message string  }
  147.   i             : Integer;      { dummy                 }
  148.   elements      : Integer;      { window elements       }
  149.   x, y, w, h    : Integer;      { window bordr x,y,w,h  }
  150. begin
  151.   if noRSC then LoadRSC;  { try to load resource file again }
  152.   if not noRSC then begin
  153.     elements := NAME or MOVER or CLOSER;        { window elements }
  154.  
  155. { the below is a tricky thing : All objects in an object tree are located
  156.   relative to their parent object, i.e. the calculator dialog box (CALCULAT).
  157.   Now, the window is ment to show itself at the middle of the screen, so we
  158.   make a form_center to place the dialog box there, and then use wind_calc
  159.   with the CALCULAT objects size parameters as work area input to calculate
  160.   the window's border dimensions which we require in order to do a nice
  161.   wind_create
  162. }
  163.     form_center(dialog, i, i, i, i);
  164.     with Dialog^[CALCULAT] do wind_calc(WC_BORDER, elements, ob_x, ob_y, ob_w, ob_h, x, y, w, h);
  165.  
  166.     window := wind_create(elements, x, y, w, h);
  167.     if window < 0 then begin    { if the AES has no more windows : }
  168.       s := '[3][|No window for MyCalc |Close one and retry ][  Ok  ]'#0;
  169.       i := form_alert(1, s[1])
  170.     end
  171.     else begin                  { a window was created successfully }
  172.       eventflags := evnt_flag.active;
  173.  
  174.       { set window title }
  175.       wind_set(window, WF_NAME, HiPtr(Title[1]), LoPtr(Title[1]), 0, 0);
  176.       graf_growbox(0,0,0,0, x,y,w,h);
  177.       wind_open(window, x, y, w, h)
  178.     end
  179.   end
  180. end;
  181.  
  182. { Redraw our window. The procedure is : If our window is not open, then exit
  183.   otherwise get the total work area into MyArea. After this, get the first
  184.   rectangle from the rectangle list and see if it intersects with our window.
  185.   If it does then redraw the CALCULAT dialog with the intersecting rectangle
  186.   as active (non-clipped) area
  187. }
  188. Procedure RedrawWindow;
  189. var
  190.   WindowRect, MyArea    : GRect;        { Using x,y,w,h system          }
  191.   Clip                  : Array_4;      { Using x1,y1,x2,y2 system      }
  192. begin
  193.   if Window = -1 then exit;     { can't redraw if no window! }
  194.   with MyArea do wind_get(Window, WF_WORKXYWH, x, y, w, h);
  195.   with WindowRect do wind_get(Window, WF_FIRSTXYWH, x, y, w, h);
  196.   while not EmptyRect(WindowRect) do
  197.   begin
  198.     if intersect(MyArea, WindowRect) then with WindowRect do
  199.       objc_draw(Dialog, CALCULAT, $7FFF, x, y, w, h);
  200.     with WindowRect do wind_get(Window, WF_NEXTXYWH, x, y, w, h)
  201.   end
  202. end;
  203.  
  204. { Close our window }
  205. procedure CloseWindow;
  206. var x, y, w, h : Integer;
  207. begin
  208.   eventflags := evnt_flag.wait;                 { go into "wait-state"  }
  209.   wind_get(window, WF_CURRXYWH, x, y, w, h);    { get current position  }
  210.   graf_shrinkbox(0,0,0,0, x,y,w,h);             { shrink a box          }
  211.   wind_close(window);                           { remove from screen    }
  212.   wind_delete(window);                          { and RAM               }
  213.   window := -1                                  { and indicate as closed}
  214. end;
  215.  
  216. { Top our window }
  217. procedure TopWindow;
  218. begin
  219.   wind_set(window, WF_TOP, 0, 0, 0, 0);
  220.   eventflags := evnt_flag.active
  221. end;
  222.  
  223. { Put something in the display. If in an error condition, then write the
  224.   error message, else if inputting (Result = FALSE) then write input string
  225.   unformatted, else write the top-of-stack value formatted }
  226. procedure WriteDisplay(Result : boolean);
  227. var
  228.   s : string;
  229. begin
  230.   if Error <> -1 then s := ' Error ' + chr(Error + ord('0')) + #0
  231.   else
  232.     if result then begin
  233.       str(TopOfStack:width:digits, s);
  234.       s := copy(s, 1, width) + #0
  235.     end
  236.     else s := InputString + #0;
  237.   move(s[1], Dialog^[SEGMENTS].ob_spec.str^, length(s));
  238.   objc_draw(Dialog, DISPLAY, $7FFF, 0, 0, 0, 0)
  239. end;
  240.  
  241. { Show the help screens }
  242. procedure ShowHelp;
  243. var
  244.   ScreenIndex   : 1..2;         { screen 1 or 2 is being shown          }
  245.   Choice        : Integer;      { OK, MORE or BACK selected             }
  246.   Dialog        : Tree_Ptr;     { the current help screen dialog tree   }
  247.   x, y, w, h    : Integer;      { its x,y,w,h                           }
  248.  
  249.   function TestWidth : boolean;         { can't show help in low res. }
  250.   var
  251.     w1, w2 : integer;
  252.     a      : Tree_Ptr;
  253.     s      : string;
  254.   begin
  255.     rsrc_gaddr(R_TREE, HELPSCR1, a);    { get screen 1's width }
  256.     w1 := a^[0].ob_w;
  257.     rsrc_gaddr(R_TREE, HELPSCR2, a);    { and screen 2's width }
  258.     w2 := a^[0].ob_w;
  259.     if (w1 >= Xres) or (w2 >= Xres) then begin  { if larger than screen : }
  260.       TestWidth := FALSE;
  261.       s := '[3][|MyCalc can''t show any help |information in this reso- |lution. Try a higher.][ Sorry ]'#0;
  262.       w1 := form_alert(1, s[1])
  263.     end
  264.     else TestWidth := TRUE
  265.   end;
  266.  
  267. begin { ShowHelp }
  268.   if TestWidth then begin               { only exec. if screen wide enough }
  269.     ScreenIndex := 1;                   { first screen first            }
  270.     repeat
  271.       if ScreenIndex = 1                { get proper dialog address     }
  272.         then rsrc_gaddr(R_TREE, HELPSCR1, Dialog)
  273.         else rsrc_gaddr(R_TREE, HELPSCR2, Dialog);
  274.       form_center(Dialog, x, y, w, h);  { center on screen              }
  275.       with Dialog^[0] do begin
  276.         form_dial(FMD_START, 0, 0, 0, 0, x, y, w, h);
  277.         form_dial(FMD_GROW, 0, 0, 0, 0, x, y, w, h);
  278.         objc_draw(Dialog, 0, $7FFF, 0, 0, 0, 0);
  279.         Choice := form_do(Dialog, 0);
  280.         form_dial(FMD_SHRINK, 0, 0, 0, 0, x, y, w, h);
  281.         form_dial(FMD_FINISH, 0, 0, 0, 0, x, y, w, h)
  282.       end;
  283.       { deselect the button : }
  284.       with Dialog^[Choice] do ob_state := ob_state - SELECTED;
  285.       if ScreenIndex = 1 then ScreenIndex := 2 else ScreenIndex := 1
  286.           { MORE and BACK are not needed and hence not used }
  287.     until ( (ScreenIndex = 1) and (Choice = HELPOK1) ) or ( (ScreenIndex = 2) and (Choice = HELPOK2) )
  288.   end
  289. end;
  290.  
  291. { Convert from a GEM resource tree index to a char value usable by the RPN
  292.   unit }
  293. function FormChar(index : Integer) : Char;
  294. begin
  295.   case index of
  296.     ZERO        : FormChar := '0';
  297.     ONE         : FormChar := '1';
  298.     TWO         : FormChar := '2';
  299.     THREE       : FormChar := '3';
  300.     FOUR        : FormChar := '4';
  301.     FIVE        : FormChar := '5';
  302.     SIX         : FormChar := '6';
  303.     SEVEN       : FormChar := '7';
  304.     EIGHT       : FormChar := '8';
  305.     NINE        : FormChar := '9';
  306.     RADIX       : FormChar := '.';
  307.     ENTERKEY    : FormChar := CR;
  308.     DELKEY      : FormChar := BS;
  309.     ADDKEY      : FormChar := '+';
  310.     SUBKEY      : FormChar := '-';
  311.     MULTKEY     : FormChar := '*';
  312.     DIVKEY      : FormChar := '/';
  313.     SWAPKEY     : FormChar := ')';
  314.     SIGNKEY     : FormChar := '('
  315.   else
  316.     FormChar := #0      { bad value }
  317.   end
  318. end;
  319.  
  320. { This is exactly the reverse to FormChar above : Convert from a character
  321.   to a GEM resource index value }
  322. function FormIndex(ch : Char) : Integer;
  323. begin
  324.   case ch of
  325.     '0' : FormIndex := ZERO;
  326.     '1' : FormIndex := ONE;
  327.     '2' : FormIndex := TWO;
  328.     '3' : FormIndex := THREE;
  329.     '4' : FormIndex := FOUR;
  330.     '5' : FormIndex := FIVE;
  331.     '6' : FormIndex := SIX;
  332.     '7' : FormIndex := SEVEN;
  333.     '8' : FormIndex := EIGHT;
  334.     '9' : FormIndex := NINE;
  335.     '.' : FormIndex := RADIX;
  336.     '+' : FormIndex := ADDKEY;
  337.     '-' : FormIndex := SUBKEY;
  338.     '*' : FormIndex := MULTKEY;
  339.     '/' : FormIndex := DIVKEY;
  340.     '(' : FormIndex := SIGNKEY;
  341.     ')' : FormIndex := SWAPKEY;
  342.     CR  : FormIndex := ENTERKEY;
  343.     BS  : FormIndex := DELKEY
  344.   else
  345.     FormIndex := -1     { bad value }
  346.   end
  347. end;
  348.  
  349. procedure Handle(KBDevent : boolean);
  350. var
  351.   index         : Integer;      { GEM object index                      }
  352.   dummy         : Integer;
  353.   topwindow     : Integer;      { currently topped window's handle      }
  354.   SetButton     : boolean;      { TRUE = a mouse button is pressed      }
  355. begin
  356.   SetButton := button = 1;      { determine if button was pressed       }
  357.   if SetButton then             { if so, then wait until it's released  }
  358.     repeat
  359.       graf_mkstate(x, y, button, kbdstate)
  360.     until button = 0;
  361.  
  362.   { see if it's our window that's on the top : }
  363.   wind_get(0, WF_TOP, topwindow, dummy, dummy, dummy);
  364.  
  365.   { if it isn't then go into wait-state and exit }
  366.   if (window = -1) or (window <> topwindow) then eventflags := evnt_flag.wait
  367.   else begin
  368.  
  369.     { if a key was pressed then make a GEM object index from it, otherwise
  370.       determine (via objc_find) at which object the mouse is currently
  371.       pointing
  372.     }
  373.     if KbdEvent
  374.       then index := FormIndex(chr(lo(key)))
  375.       else index := objc_find(Dialog, KEYBOARD, $7FFF, x, y);
  376.  
  377.     { if the mouse points at the box containing the buttons, then ignore!
  378.       (if you don't understand why, then try to put a comment around the
  379.        following line and move the mouse past a button)
  380.     }
  381.     if index = KEYBOARD then index := -1;
  382.  
  383.     { if the mouse has changed its position : }
  384.     if (index <> LastSelected) then begin
  385.  
  386.       { deselect previously selected object }
  387.       if LastSelected <> -1 then objc_change(Dialog, LastSelected, 0, 0, 0, 0, 0, NORMAL or SHADOWED, 1);
  388.  
  389.       { select the object at which the mouse is pointing }
  390.       if index        <> -1 then objc_change(Dialog, index, 0, 0, 0, 0, 0, SELECTED or SHADOWED, 1);
  391.  
  392.       LastSelected := index
  393.     end;
  394.  
  395.     { if, after all the preceeding actions, the we have a legal index and
  396.       either a pressed key or a pressed mouse button, then see if the choice
  397.       was the HELP soft-button. If so then show the help screen, else try
  398.       to make a nice input to the RPN unit (FormChar) and update the display
  399.     }
  400.     if (index <> -1) and (SetButton or KBDevent) then begin
  401.       if index = HELPKEY then ShowHelp
  402.       else begin
  403.         CharInput(FormChar(index));
  404.         WriteDisplay(InputString = '')
  405.       end
  406.     end
  407.   end
  408. end;
  409.  
  410. { This is the GEM pipe message handler. It takes appropriate action when the
  411.   AES has placed a message in our pipe
  412. }
  413. Procedure HandleMsg;
  414. var x, y, w, h : Integer;       { temporary coordinates         }
  415. begin
  416.   case Pipe[0] of
  417.     AC_OPEN   : if Pipe[4] = ACC_handle then
  418.                   if window = -1 then OpenWindow else TopWindow;
  419.     AC_CLOSE  : if Pipe[3] = ACC_handle then Window := -1;
  420.     WM_REDRAW : RedrawWindow;
  421.     WM_TOPPED : TopWindow;
  422.     WM_CLOSED : begin
  423.                   if Pipe[3] = Window then CloseWindow;
  424.                   Quit := AppFlag       { don't quit if an accessory }
  425.                 end;
  426.     WM_MOVED  : if Pipe[3] = Window then begin
  427.                   wind_get(window, WF_CURRXYWH, x, y, w, h);
  428.                   graf_movebox(w, h, x, y, Pipe[4], Pipe[5]);
  429.                   wind_set(Window, WF_CURRXYWH,
  430.                            Pipe[4], Pipe[5], Pipe[6], Pipe[7]);
  431.                   { update the dialog box' position in accordance with the
  432.                     window's new position
  433.                   }
  434.                   with Dialog^[CALCULAT]
  435.                     do wind_get(window, WF_WORKXYWH, ob_x, ob_y, ob_w, ob_h)
  436.                 end
  437.     end
  438. end;
  439.  
  440. { This is the main loop, where MyCalc waits for something to happen.
  441.   evnt_multi looks for two different sets of events, depending on the current
  442.   state of the program. If it is in "wait-state" it only waits for a message
  443.   via the pipe. In its second, active, state it waits for message events,
  444.   mouse events and keyboard events. The below defines the state depending on
  445.   the environment :
  446.  
  447.   GEM environment                       state
  448.   -------------------------------------------
  449.   MyCalc window closed                  wait
  450.   window opened and on top              active
  451.   window open, but not on top           wait
  452.   window topped                         active
  453.  
  454.   This scheme is implemented to minimize MyCalc's request for CPU time. If
  455.   it wasn't you would experience "slow" - sometimes none at all - response
  456.   to mouse button activations
  457. }
  458. Procedure EventLoop;
  459. var event : Integer;    { Coded value containing event flags    }
  460. begin
  461.   event := evnt_multi(eventflags,
  462.                     0, 0, 0,
  463.                     0, 0, 0, 0, 0,
  464.                     0, 0, 0, 0, 0,
  465.                     Pipe,
  466.                     0, 0,
  467.                     x, y, button, kbdstate, key, clicks);
  468.  
  469.   { at this point, something has happened, so we tell GEM that we're updating
  470.     the screen (disregarding the fact that we just might not after all) }
  471.   wind_update(BEG_UPDATE);
  472.  
  473.   { determine which events had happned. By using an if...then...else if...
  474.     structure like the below, only one type of (perhaps concurrent) events
  475.     are allowed to influence MyCalc. Furthermore, this implements a priority
  476.     scheme in which ordinary messages (MU_MESAG) are at the highest level,
  477.     after which we look at the keyboard (MU_KEYBD) and finally at the mouse
  478.     (MU_BUTTON)
  479.   }
  480.   if (event and MU_MESAG) <> 0 then HandleMsg
  481.   else if (event and MU_KEYBD) <> 0
  482.        then if key = Esc then begin
  483.               Quit := AppFlag;
  484.               CloseWindow
  485.             end
  486.             else Handle(TRUE)   { TRUE = keyboard event }
  487.        else if (event and MU_BUTTON) <> 0 then Handle(FALSE);
  488.   wind_update(END_UPDATE)       { done updating }
  489. end;
  490.  
  491. { And then to the main program! It inits the some of the global variables
  492.   and - if the program was started as ACC - tries to install MyCalc.
  493.   Otherwise the program runs as application, i.e. opens the window, waits
  494.   for the user to operate, and upon ESC, closes the window and exits
  495. }
  496. begin { main }
  497.   Title            := '  MyCalc  '#0#0;
  498.   Quit             := FALSE;
  499.   noRSC            := FALSE;
  500.   LastSelected     := -1;
  501.   window           := -1;
  502.   evnt_flag.wait   := MU_MESAG;
  503.   evnt_flag.active := MU_MESAG or MU_KEYBD or MU_BUTTON;
  504.   Init;
  505.   if AppFlag then begin                 { application (.PRG) }
  506.     LoadRSC;
  507.     wind_update(BEG_UPDATE);
  508.     graf_mouse(ARROW, NIL);
  509.     OpenWindow;
  510.     wind_update(END_UPDATE);
  511.     eventflags := evnt_flag.active;
  512.     repeat
  513.       EventLoop
  514.     until Quit;
  515.     DeInit
  516.   end
  517.   else begin                            { accessory (.ACC) }
  518.     ACC_handle := menu_register(AES_handle, Title[1]);
  519.     if ACC_handle > -1 then begin
  520.       LoadRSC;
  521.       eventflags := evnt_flag.wait;
  522.       repeat
  523.         EventLoop
  524.       until false
  525.     end
  526.     else begin
  527.       writeln('No accessory slot for MyCalc');
  528.       v_clsvwk(VDI_handle);
  529.       appl_exit
  530.     end
  531.   end
  532. end.
  533.