home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 13 / CDA13.ISO / cdactual / demobin / share / program / Pascal / APITOOLS.ZIP / WASHER.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-10-03  |  11.8 KB  |  446 lines
  1. (****************************************************************
  2. *
  3. *  Name:          WASHER
  4. *
  5. *  Function:      Emulate a washing machine control panel.
  6. *
  7. *  Shows how to:  1. construct complex menus (dialogues) including
  8. *                    select, input, output, and inactive fields.
  9. *                 2. change field types dynamically.
  10. *                 3. implement "radio button" select fields.
  11. *                 4. use a timer object to measure time intervals.
  12. *                 5. use an objectq to wait for multiple events.
  13. *
  14. ****************************************************************)
  15.  
  16. program Washer;
  17.  
  18. uses DVAPI;
  19.  
  20. const
  21.  
  22.   (* minimum API version required *)
  23.   REQUIRED = $201;
  24.  
  25.   (* possible values of the "temperature" variable *)
  26.   HOT  = 0;
  27.   WARM = 1;
  28.   COLD = 2;
  29.  
  30.   (* possible values of the "state" variable *)
  31.   IDLE        = 0;
  32.   WASHING     = 1;
  33.   FIRST_RINSE = 2;
  34.   FIRST_SPIN  = 3;
  35.   FINAL_RINSE = 4;
  36.   FINAL_SPIN  = 5;
  37.  
  38.   (* panel library filename in ASCIIZ string format *)
  39.   lib : string = 'examples.plb'#$00;
  40.  
  41.   (* name of panel within panel library *)
  42.   name : string = 'washer';
  43.  
  44. var
  45.  
  46.   (* actual API version number *)
  47.   version : integer;
  48.  
  49.   (* object handles *)
  50.   winme,pan,win,kbd,tim,obj : ULONG;
  51.  
  52. type
  53.  
  54.   (* keyboard buffer definition *)
  55.   KEYBUF = array [0..4] of byte;
  56.  
  57. var
  58.  
  59.   (* variables used when reading from the menu *)
  60.   kptr,kend : pointer;
  61.   kbufptr : ^KEYBUF;
  62.   field,kstatus : byte;
  63.   klng,fsize,err : integer;
  64.   field1 : string[2];
  65.  
  66.   (* variables set according to menu input *)
  67.   wash_time,temperature : integer;
  68.   second_rinse,bell : boolean;
  69.  
  70.   (* state related variables *)
  71.   state,indicator : integer;
  72.   done : boolean;
  73.  
  74.   (* variables for saving the cursor position *)
  75.   row,col : integer;
  76.  
  77.   (* unused function results *)
  78.   status : integer;
  79.  
  80.   (* TFDD text files *)
  81.   tfdme,tfd : text;
  82.  
  83. const
  84.  
  85.   (* boolean values *)
  86.   ON  = True;
  87.   OFF = False;
  88.  
  89.  
  90. (**********************************************************************
  91. *  stop_cycle  -  stops the current timer, if any.  Changes field 1 back
  92. *                 to an input field, enables the start button, and
  93. *                 disables the stop button.
  94. ***********************************************************************)
  95.  
  96. procedure stop_cycle;
  97. begin
  98.  
  99.   tim_erase (tim);
  100.   fld_type (win,1,FLT_INPUT);
  101.   fld_type (win,7,FLT_DESELECT);
  102.   fld_type (win,8,FLT_INACTIVE);
  103.  
  104. end;
  105.  
  106.  
  107. (**********************************************************************
  108. *  change_state  -  changes the current state of the wash cycle and
  109. *                   lights the specified indicator.  The previously
  110. *                   lighted indicator, if any, is turned off.
  111. ***********************************************************************)
  112.  
  113. procedure change_state (newstate, field : integer);
  114. begin
  115.  
  116.   (* log new state *)
  117.   state := newstate;
  118.  
  119.   (* if an indicator is ON, turn it OFF *)
  120.   if (indicator <> 0) then
  121.     fld_attr (win,indicator,1);
  122.  
  123.   (* turn ON the requested indicator and remember it *)
  124.   if (field <> 0) then
  125.     fld_attr (win,field,5);
  126.   indicator := field;
  127.  
  128. end;
  129.  
  130.  
  131. (**********************************************************************
  132. *  radio_button  -  select a specified field and deselect all others in
  133. *                   the given range.
  134. ***********************************************************************)
  135.  
  136. procedure radio_button (win : ULONG; first,last,chosen : integer);
  137. var
  138.   i : integer;
  139.  
  140. begin
  141.  
  142.   (* loop for each field in range "first" through "last" *)
  143.   for i := first to last do
  144.  
  145.     (* change "chosen" field type to SELECTed, others to DESELECTed *)
  146.     if (i = chosen) then
  147.       fld_type (win,i,FLT_SELECT)
  148.     else
  149.       fld_type (win,i,FLT_DESELECT);
  150.  
  151.   end;
  152.  
  153.  
  154. (**********************************************************************
  155. *  process_timer_event  -  process timer expiration
  156. ***********************************************************************)
  157.  
  158. procedure process_timer_event;
  159. var
  160.   time : longint;
  161.  
  162. begin
  163.  
  164.   (* read the timer object to clear the event *)
  165.   time := tim_read(tim);
  166.  
  167.   (* save cursor position.  Decrement time remaining and display. *)
  168.   wash_time := wash_time - 1;
  169.   qry_cursor (win,row,col);
  170.   fld_cursor (win,1);
  171.   write (tfd,wash_time:2);
  172.  
  173.   (* if the clock has expired, dispatch based on current state.       *)
  174.   (* In each case, switch to the next state and light the appropriate *)
  175.   (* indicator.                                                       *)
  176.   if (wash_time = 0) then
  177.   begin
  178.     case (state) of
  179.       WASHING :
  180.         if (second_rinse) then
  181.           change_state (FIRST_RINSE,11)
  182.         else
  183.           change_state (FINAL_RINSE,11);
  184.       FIRST_RINSE :
  185.         change_state (FIRST_SPIN,12);
  186.       FIRST_SPIN :
  187.         change_state (FINAL_RINSE,11);
  188.       FINAL_RINSE :
  189.         change_state (FINAL_SPIN,12);
  190.       FINAL_SPIN : (* Cycle complete - switch to IDLE state, beep if
  191.                           requested.  Restore original field types. *)
  192.       begin
  193.         change_state (IDLE,0);
  194.         if (bell) then
  195.           api_sound (2000,18);
  196.         stop_cycle;
  197.       end;
  198.     end;
  199.  
  200.     (* unless we are now IDLE, we need to start a rinse or spin cycle.  *)
  201.     (* do so by setting the clock to 3 seconds and setting the timer to *)
  202.     (* expire in 1 second.                                              *)
  203.     if (state <> IDLE) then
  204.     begin
  205.       wash_time := 3;
  206.       tim_addto (tim,100)
  207.     end
  208.   end
  209.  
  210.   (* if clock is still counting, simply set timer for another second *)
  211.   else
  212.     tim_addto (tim,100);
  213.  
  214.   (* restore cursor to its original position *)
  215.   win_cursor (win,row,col);
  216.  
  217. end;
  218.  
  219.  
  220.  
  221. (**********************************************************************
  222. *  process_menu_event  -  process data returned from the menu.
  223. ***********************************************************************)
  224.  
  225. procedure process_menu_event;
  226. begin
  227.  
  228.   (* get menu data and determine what event caused data to be returned *)
  229.   key_read (kbd,kptr,klng);
  230.   kbufptr := kptr;
  231.   kstatus := key_status (kbd);
  232.  
  233.   (* beep and return if anything but a field selection *)
  234.   if (kstatus <> 1) then
  235.   begin
  236.     api_sound (1000,5);
  237.     exit;
  238.   end;
  239.  
  240.   (* point just past returned data.  Save current cursor position. *)
  241.   kend := @kbufptr^[klng];
  242.   qry_cursor (win,row,col);
  243.  
  244.   (* loop once for each field returned *)
  245.   while (kbufptr <> kend) do
  246.   begin
  247.  
  248.     (* get field # and length.  Log field info to task window. *)
  249.     field := kbufptr^[0];
  250.     fsize := kbufptr^[1] + (kbufptr^[2] * 256);
  251.     write (tfdme,'field = ',field,'   length = ',fsize,'   contents = ');
  252.     win_write (winme,@kbufptr^[3],fsize);
  253.     writeln (tfdme);
  254.  
  255.     (* dispatch based on field number *)
  256.     case (field) of
  257.  
  258.       1 : (* wash time changed *)
  259.       begin
  260.  
  261.         (* copy returned data to two character string variable *)
  262.         field1 := '  ';
  263.         move (kbufptr^[3],field1[1],2);
  264.  
  265.         (* convert to integer, clip at zero, and set state to IDLE *)
  266.         val (field1,wash_time,err);
  267.         if (wash_time < 0) then
  268.           wash_time := 0;
  269.         change_state (IDLE,0);
  270.  
  271.       end;
  272.  
  273.       2 : (* Hot water selected -  Select field 2.  Deselect fields
  274.                  3 and 4.  Log temperature. *)
  275.       begin
  276.         radio_button (win,2,4,2);
  277.         temperature := HOT;
  278.       end;
  279.  
  280.       3 : (* Warm water selected - Select field 3.  Deselect fields
  281.                  2 and 4.  Log temperature. *)
  282.       begin
  283.         radio_button (win,2,4,3);
  284.         temperature := WARM;
  285.       end;
  286.  
  287.       4 : (* Cold water selected - Select field 4.  Deselect fields
  288.                  2 and 3.  Log temperature. *)
  289.       begin
  290.         radio_button (win,2,4,4);
  291.         temperature := COLD;
  292.       end;
  293.  
  294.       5 : (* Second rinse - if the field data is "Y", the field is
  295.                  selected.  Otherwise, the data will be "N". *)
  296.         second_rinse := (chr(kbufptr^[3]) = 'Y');
  297.  
  298.       6 : (* Beep when done - if the field data is "Y", the field is
  299.                  selected.  Otherwise, the data will be "N". *)
  300.         bell := (chr(kbufptr^[3]) = 'Y');
  301.  
  302.       7 : (* Start button *)
  303.       begin
  304.  
  305.         (* deselect field so it does not remain highlighted *)
  306.         fld_type (win,7,FLT_DESELECT);
  307.  
  308.         (* ignore if no wash time has been selected.  Otherwise ... *)
  309.         if (wash_time <> 0) then
  310.         begin
  311.  
  312.           (* convert field 1 to an output field.  Disable the start button
  313.              and enable the stop button *)
  314.           fld_type (win,1,FLT_OUTPUT);
  315.           fld_type (win,7,FLT_INACTIVE);
  316.           fld_type (win,8,FLT_DESELECT);
  317.  
  318.           (* set timer to run 1 second.  If IDLE, set state to WASHING. *)
  319.           tim_addto (tim,100);
  320.           if (state = IDLE) then
  321.             change_state (WASHING,10);
  322.         end;
  323.       end;
  324.  
  325.       8 : (* Stop button - stop cycle and reset field types. *)
  326.         stop_cycle;
  327.  
  328.       9 : (* Exit button - stop cycle, reset fields, and set "done". *)
  329.       begin
  330.         stop_cycle;
  331.         done := True;
  332.       end;
  333.  
  334.       else  (* unknown field number - should never happen. *)
  335.       begin
  336.         writeln (tfdme,'impossible!');
  337.       end;
  338.  
  339.     end;
  340.  
  341.     (* bump pointer to next field and loop *)
  342.     kbufptr := @kbufptr^[fsize + 3];
  343.  
  344.   end;
  345.  
  346.   (* restore original cursor position *)
  347.   win_cursor (win,row,col);
  348.  
  349. end;
  350.  
  351.  
  352. (**********************************************************************
  353. *  program_body  -  initialize application and loop processing events.
  354. ***********************************************************************)
  355.  
  356. procedure program_body;
  357. begin
  358.  
  359.   (* get task window handle and open objectq *)
  360.   winme := win_me;
  361.   obq_open;
  362.  
  363.   (* create timer object *)
  364.   tim := tim_new;
  365.  
  366.   (* create and open panel object, and associate it with panel library *)
  367.   pan := pan_new;
  368.   status := pan_sopen (pan,lib);
  369.  
  370.   (* apply named panel, and return window & keyboard handles *)
  371.   status := pan_sapply (pan,winme,name,win,kbd);
  372.  
  373.   (* open TFDDs and assign to windows *)
  374.   tfd_open (tfdme,winme);
  375.   tfd_open (tfd,win);
  376.  
  377.   (* preselect "hot water".  Jump cursor to field 1.  Set "state" to idle *)
  378.   radio_button (win,2,4,2);
  379.   fld_cursor (win,1);
  380.   change_state (IDLE,0);
  381.   done := False;
  382.  
  383.   (* initialize to default variables set according to menu input *)
  384.   wash_time := 0;
  385.   temperature := HOT;
  386.   second_rinse := False;
  387.   bell := False;
  388.  
  389.   (* show panel window *)
  390.   win_top (win);
  391.  
  392.   (* loop until "done" becomes TRUE *)
  393.   while (not done) do
  394.   begin
  395.  
  396.     (* wait for input from any open object and return its handle *)
  397.     obj := obq_read;
  398.  
  399.     (* determine which object it is and process accordingly *)
  400.     if (obj = kbd) then
  401.       process_menu_event
  402.     else
  403.       if (obj = tim) then
  404.         process_timer_event;
  405.  
  406.   end;
  407.  
  408.   (* close TFDDs *)
  409.   tfd_close (tfd);
  410.   tfd_close (tfdme);
  411.  
  412.   (* free all allocated objects and return *)
  413.   key_free (kbd);
  414.   win_free (win);
  415.   pan_free (pan);
  416.   tim_free (tim);
  417.  
  418. end;
  419.  
  420.  
  421. (**********************************************************************
  422. *  main  -  check for DESQview present and enable required extensions.
  423. ***********************************************************************)
  424.  
  425. begin
  426.  
  427.   (* initialize Pascal interfaces and get API version number *)
  428.   version := api_init;
  429.  
  430.   (* if DESQview is not running or version is too low, display a message *)
  431.   if (version < REQUIRED) then
  432.     writeln ('This program requires DESQview version ',REQUIRED div 256,
  433.        '.',(REQUIRED mod 256) div 16,(REQUIRED mod 256) mod 16,' or later.')
  434.  
  435.   (* tell DESQview what extensions to enable and start application *)
  436.   else
  437.   begin
  438.     api_level (REQUIRED);
  439.     program_body;
  440.   end;
  441.  
  442.   (* disable Pascal interfaces and return from program *)
  443.   api_exit;
  444.  
  445. end.
  446.