home *** CD-ROM | disk | FTP | other *** search
/ Falcon 030 Power 2 / F030_POWER2.iso / ST_STE / MAGS / ICTARI09.ARJ / ictari.09 / PASCAL / ADDBOOK / ADDBOOK.PAS next >
Pascal/Delphi Source File  |  1994-02-16  |  13KB  |  538 lines
  1. PROGRAM windowdemo6;
  2. USES gemaes, gemdecl, gemvdi, {gem, util, ppal,} dos, printer;
  3. CONST
  4.   fname = 'ADDFILE.DJG';
  5.   maxe  = 80;
  6.   drive = '';
  7.  
  8. TYPE 
  9.   ob_Type         = g_box..g_title;
  10.   object          = packed record
  11.     ob_next       : integer;
  12.     ob_head       : integer;
  13.     ob_tail       : integer;
  14.     ob_type       : integer;   
  15.     ob_flags      : integer;
  16.     ob_state      : integer;
  17.     ob_spec       : pointer;
  18.     ob_x          : integer;
  19.     ob_y          : integer;
  20.     ob_w          : integer;
  21.     ob_h          : integer;
  22.   END;
  23.   tree            = packed array[0..199] OF object;
  24.   tree_ptr        = ^tree;
  25.   string10              = packed string [10];
  26.   string30              = packed string [30];
  27.   ms                    = packed array [0..10] OF string30;
  28.  
  29. VAR
  30.   nameline, infoline    : string30;
  31.   x, y, w, h, p, acchan : integer;
  32.   tstring               : packed array [0..10] OF string10;
  33.   mestring, f2          : ms;
  34.   ontop                 : boolean;
  35.   myfile                : packed file OF ms;
  36.   main                  : tree_ptr;
  37.   hello                 : tree_ptr;
  38.   pipe                  : array_8;
  39.   vdihan, wh, aeshan,
  40.   charh, charw, 
  41.   minx, miny, maxw, maxh      : integer;
  42.   s : string30;
  43.  
  44. PROCEDURE upper (VAR me     : string30);
  45. VAR
  46.   n                         : byte;
  47. BEGIN
  48.   FOR n:=1 TO LENGTH (me) DO
  49.     me[n]:=UPCASE (me[n]);
  50. END;
  51.  
  52. PROCEDURE openfile;
  53. VAR
  54.   ok                    : searchrec;
  55. BEGIN
  56.   ASSIGN (myfile, drive+fname);
  57.   FINDFIRST (drive+fname, $27, ok);
  58.   IF DOSERROR=0 THEN RESET (myfile)
  59.     ELSE REWRITE (myfile);
  60. END;
  61.  
  62. PROCEDURE setlen (VAR mstring  : ms);
  63. VAR
  64.   x, y                  : integer;
  65. BEGIN
  66.   FOR x:=0 TO 10 DO
  67.   BEGIN
  68.     y:=1;
  69.     WHILE (mstring[x][y]<>#0) AND (y<=30) DO
  70.     BEGIN
  71.       mstring[x][0]:=CHAR(y);
  72.       INC (y);
  73.     END;
  74.     FILLCHAR (mstring[x][y], 30-y, #0);
  75.   END;
  76. END;
  77.  
  78. PROCEDURE readinfo;
  79. BEGIN
  80.   IF FILESIZE (myfile)>0 THEN 
  81.   BEGIN
  82.     SEEK (myfile, p);
  83.     READ (myfile, mestring);
  84.     setlen (mestring);
  85.   END;
  86. END;
  87.  
  88. PROCEDURE setts;
  89. VAR
  90.   n                     : integer;
  91. BEGIN
  92.   tstring[0]:='Name      :';
  93.   tstring[1]:='Company   :';
  94.   tstring[2]:='Street    :';
  95.   tstring[3]:='Town      :';
  96.   tstring[4]:='City      :';
  97.   tstring[5]:='Other     :';
  98.   tstring[6]:='Post Code :';
  99.   tstring[7]:='Tel       :';
  100.   tstring[8]:='Fax       :';
  101.   tstring[9]:='Comment   :';
  102.   FOR n:=0 TO 10 DO
  103.     mestring[n][1]:=#00;
  104. END;
  105.  
  106. PROCEDURE rscload(rscname : string);
  107. BEGIN
  108.   rscname:=rscname+#00;
  109.   rsrc_load (rscname[1]);
  110.   IF GemError = 0 THEN
  111.   BEGIN
  112.     Writeln(rscname,' could not be found');
  113.     appl_exit;
  114.     EXIT;
  115.   END;
  116. END;
  117.  
  118. PROCEDURE openrsc;
  119. BEGIN
  120.   rscload (drive+'ADDBOOK.RSC');
  121.   RSRC_GADDR (R_TREE, 0, hello);
  122.   RSRC_GADDR (R_TREE, 1, main);
  123. END;
  124.  
  125. PROCEDURE movestpos;
  126. VAR
  127.   n                   : integer;
  128.   f                   : ^longint;
  129. BEGIN
  130.   FOR n:=6 TO 15 DO
  131.   BEGIN
  132.     f:=main^[n].ob_spec;
  133.     f^:=ORD (ADDR (mestring[n-6][1]));
  134.   END;
  135. END;
  136.  
  137. PROCEDURE puttextline;
  138. VAR
  139.   i, d                  : integer;
  140. BEGIN
  141.   setlen (mestring);
  142.   WIND_GET (pipe[3], WF_WORKXYWH, x, y, w, h);
  143.   i:=charh;
  144.   d:=0;
  145.   WHILE (i<=y+h-1+charh) AND (d<10) DO
  146.   BEGIN
  147.     V_GTEXT (vdihan, x+5, y+i, tstring[d]+' '+mestring[d]);
  148.     INC (i, charh);
  149.     INC (d);
  150.   END;
  151. END;
  152.  
  153. PROCEDURE redrawwindow;
  154. VAR
  155.   r1, r2              : grect;
  156.   a                   : array_4;
  157. BEGIN
  158.   IF wh<0 THEN EXIT;
  159.   WIND_GET (wh, WF_CURRXYWH, r1.x, r1.y, r1.w, r1.h);
  160.   WIND_UPDATE (BEG_UPDATE);
  161.   GRAF_MOUSE (M_OFF, NIL);
  162.   VSF_COLOR (vdihan, WHITE);
  163.   VSF_STYLE (vdihan, SOLID);
  164.   WIND_GET (pipe[3], WF_FIRSTXYWH, r2.x, r2.y, r2.w, r2.h);
  165.   WHILE ((r2.w<>0) AND (r2.h<>0)) DO
  166.   BEGIN
  167.     IF INTERSECT (r1, r2) THEN
  168.     BEGIN
  169.       a[0]:=r2.x;                 a[1]:=r2.y;
  170.       a[2]:=r2.x+r2.w-1;          a[3]:=r2.y+r2.h-1;
  171.       VS_CLIP (vdihan, 1, a);
  172.       V_BAR (vdihan, a);
  173.       puttextline;
  174.     END;  
  175.     WIND_GET (pipe[3], WF_NEXTXYWH, r2.x, r2.y, r2.w, r2.h);
  176.   END;
  177.   VS_CLIP (vdihan, 0, a);
  178.   GRAF_MOUSE (M_ON, NIL);
  179.   WIND_UPDATE (END_UPDATE);
  180. END;
  181.  
  182. PROCEDURE findad;
  183. VAR
  184.   n                     : integer;
  185.   byebye, go            : boolean;
  186. BEGIN
  187.   openfile;
  188.   setlen (f2);
  189.   FOR n:=0 TO 9 DO
  190.     upper (f2[n]);
  191.   n:=0;
  192.   go:=FALSE;
  193.   WHILE (NOT (EOF (myfile))) AND (NOT (go)) DO
  194.   BEGIN
  195.     n:=0;
  196.     byebye:=TRUE;
  197.     readinfo;
  198.     setlen (mestring);
  199.     IF POS ('DELETED', mestring[0])=1 THEN byebye:=FALSE;
  200.     REPEAT
  201.       upper (mestring[n]);
  202.       IF f2[n][1]<>#0 THEN 
  203.         IF (POS (f2[n], mestring[n])=0) THEN byebye:=FALSE;
  204.       INC (n);
  205.     UNTIL (byebye=FALSE) OR (n=9);
  206.     IF (n=9) AND (byebye=TRUE) THEN go:=TRUE;
  207.     INC (p);
  208.   END;
  209.   IF (go) AND (FILESIZE (myfile)>0) THEN 
  210.   BEGIN
  211.     p:=FILEPOS (myfile)-1;
  212.     SEEK (myfile, p);
  213.     READ (myfile, mestring);
  214.     setlen (mestring);
  215.     CLOSE (myfile);
  216.   END;
  217.   redrawwindow;
  218. END;
  219.  
  220. PROCEDURE find;
  221. BEGIN
  222.   p:=0;
  223.   f2:=mestring;
  224.   findad;
  225. END;
  226.  
  227. PROCEDURE setupwindow;
  228. VAR
  229.   oldwh                 : integer;
  230. BEGIN
  231.   oldwh:=wh;
  232.   IF wh<0 THEN
  233.   BEGIN
  234.     nameline:='Another Address Book'+#0+#0;
  235.     wh:=WIND_CREATE (223-info, minx, miny, 365, 15+(10*charh));
  236.   END;
  237.   WIND_SET (wh, WF_NAME, HIPTR (nameline[1]), LOPTR (nameline[1]), 0, 0);
  238.   WIND_SET (wh, WF_INFO, HIPTR (infoline[1]), LOPTR (infoline[1]), 0, 0);
  239.   IF (oldwh<0) AND (wh>=0) THEN
  240.   BEGIN
  241.     WIND_GET (wh, WF_FULLXYWH, x, y, w, h);
  242.     WIND_OPEN (wh, x, y, w, h);
  243.   END ELSE IF wh>=0 THEN WIND_SET (wh, WF_TOP, 0, 0, 0, 0);
  244.   pipe[3]:=wh;  pipe[4]:=x;   pipe[5]:=y;
  245.   pipe[6]:=w;   pipe[7]:=h;
  246.   redrawwindow;
  247.   ontop:=TRUE;
  248. END;
  249.  
  250. PROCEDURE addaddress;
  251. BEGIN
  252.   openfile;
  253.   SEEK (myfile, FILESIZE (myfile));
  254.   WRITE (myfile, mestring);
  255.   CLOSE (myfile);
  256. END;
  257.  
  258. PROCEDURE moveadd;
  259. VAR
  260.   spare                       : integer;
  261. BEGIN
  262.   spare:=0;
  263.   openfile;
  264.   IF (pipe[4]=3) AND (p<FILESIZE (myfile)-1) THEN INC (p)
  265.     ELSE IF (p>0) AND (pipe[4]=2) THEN DEC (p);
  266.   readinfo;
  267.   setlen (mestring);
  268.   WHILE (mestring[0]='DELETED') AND (spare<10) DO
  269.   BEGIN
  270.     INC (spare);
  271.     readinfo;
  272.     INC (p);
  273.     p:=p MOD FILESIZE (myfile);
  274.   END;
  275.   IF spare=10 THEN p:=0;
  276.   CLOSE (myfile);
  277.   redrawwindow;
  278. END;
  279.  
  280. PROCEDURE print;
  281. VAR
  282.   n                     : integer;
  283. BEGIN
  284.   openfile;
  285.   readinfo;
  286.   setlen (mestring);
  287.   FOR n:=0 TO 8 DO
  288.     WRITELN (lst, '         ', mestring[n]);
  289.   CLOSE (myfile);
  290. END;
  291.  
  292. PROCEDURE clipboard;
  293. VAR
  294.   tfile                 : text;
  295.   ok                    : searchrec;
  296.   path                  : string30;
  297.   olddrive, n           : byte;
  298.   olddir                : dirstr;
  299. BEGIN
  300.   openfile;
  301.   readinfo;
  302.   CLOSE (myfile);
  303.   SCRP_READ (olddir[1]);
  304.   IF olddir='' THEN
  305.   BEGIN
  306.     FINDFIRST ('C:\', anyfile, ok);
  307.     IF DOSERROR <>0 THEN path:='C:\' ELSE path:='A:\';
  308.     FINDFIRST (path+'CLIPBRD\', directory, ok);
  309.     IF DOSERROR<>0 THEN MKDIR (path+'CLIPBRD\');
  310.     olddir:=path+'CLIPBRD\';
  311.   END;
  312.   FINDFIRST (olddir+'scrap.*',$27, ok);
  313.   WHILE DOSERROR=0 DO
  314.   BEGIN
  315.     ERASE (olddir+ok.name);
  316.     FINDNEXT (ok);
  317.   END;
  318.   setlen (mestring);
  319.   ASSIGN (tfile, olddir+'SCRAP.TXT');
  320.   REWRITE (tfile);
  321.   FOR n:=0 TO 9 DO
  322.     Writeln (tfile, mestring[n]);
  323.   CLOSE (tfile);
  324.   olddir:=olddir+#0;
  325.   scrp_write (olddir[1]);
  326. END;
  327.  
  328. PROCEDURE edit;
  329. BEGIN
  330.   openfile;
  331.   SEEK (myfile, p);
  332.   setlen (mestring);
  333.   WRITE (myfile, mestring);
  334.   CLOSE (myfile);
  335.   redrawwindow;
  336. END;
  337.  
  338. PROCEDURE delete;
  339. BEGIN
  340.   openfile;
  341.   IF FILESIZE (myfile)>0 THEN
  342.   BEGIN
  343.     readinfo;
  344.     mestring[0]:='DELETED'+#0;
  345.     setlen (mestring);
  346.     SEEK (myfile, p);
  347.     WRITE (myfile, mestring);
  348.     IF (p>0) THEN DEC (p) ELSE 
  349.       IF p<FILESIZE (myfile) THEN INC (p)
  350.         ELSE p:=0;
  351.   END;
  352.   CLOSE (myfile);
  353.   moveadd;
  354. END;
  355.  
  356. PROCEDURE setobjectstatus (t  : tree_ptr; index, stat  : integer);
  357. BEGIN
  358.   t^[index].ob_state:=stat;
  359. END;
  360.  
  361. FUNCTION drawform (thistree : tree_ptr;n  : integer) : integer;
  362. VAR
  363.   d                          : integer;
  364. BEGIN
  365.   WITH thistree^[0] DO
  366.   BEGIN
  367.     d:=ob_x;
  368.     form_center (thistree, minx, miny, maxw, maxh);
  369.     form_dial (fmd_start, 0, 0, 0, 0, minx, miny, maxw, maxh);
  370.     form_dial (fmd_grow , d, d, d, d, d, d, d, d);
  371.     objc_draw (thistree,  0, $7fff, minx, miny, maxw, maxh);
  372.     IF n>=0 THEN n:=form_do (thistree, n);
  373.     form_dial (fmd_shrink, d, d, d, d, d, d, d, d);
  374.     form_dial (fmd_finish, 0, 0, 0, 0, minx, miny, maxw, maxh);
  375.     setobjectstatus (thistree, n, thistree^[n].ob_state-1);
  376.   END;
  377.   drawform:=n;
  378. END;
  379.  
  380. PROCEDURE sayhello;
  381. VAR
  382.   n                     : integer;
  383. BEGIN
  384.   n:=drawform (hello, 0);
  385.   setobjectstatus (hello, 9, 48);
  386. END;
  387.  
  388. PROCEDURE fullwindow;
  389. VAR
  390.   sx, sy, sw, sh        : integer;
  391. BEGIN
  392.   setts;
  393.   sx:=drawform (main, 6);
  394.   setobjectstatus (main, sx, 48);
  395.   CASE sx OF
  396.     3   : addaddress; {accept}
  397.     4   : setts; {cancel}
  398.     16  : find; {find}
  399.     17  : sayhello; {hello}
  400.     18  : print; {print}
  401.     19  : clipboard; {to clip board}
  402.     20  : delete; {delete}
  403.     25  : edit; {edit}
  404.   END;
  405. END;
  406.  
  407. PROCEDURE sendmessage;
  408. VAR
  409.   n                     : integer;
  410. BEGIN
  411.   n:=pipe[1];
  412.   pipe[0]:=69;
  413.   pipe[1]:=aeshan;
  414.   pipe[2]:=1;
  415.   openfile;
  416.   SEEK (myfile, p);
  417.   READ (myfile, mestring);
  418.   setlen (mestring);
  419.   CLOSE (myfile);
  420.   pipe[3]:=HIPTR (mestring);
  421.   pipe[4]:=LOPTR (mestring);
  422.   pipe[5]:=p;
  423.   APPL_WRITE (n, SIZEOF(pipe), pipe[0]);
  424. END;
  425.  
  426. PROCEDURE closedownwindow;
  427. BEGIN
  428.   IF wh>=0 THEN 
  429.   BEGIN
  430.     WIND_CLOSE (wh);
  431.     WIND_DELETE (wh);
  432.     wh:=-1;
  433.   END;
  434.   ontop:=FALSE;
  435. END;
  436.  
  437. PROCEDURE shutdown;
  438. BEGIN
  439.   graf_shrinkbox (0, 0, 0, 0, minx, miny, maxw, maxh);
  440.   rsrc_free;
  441.   v_clsvwk (vdihan);
  442.   appl_exit;
  443. END;
  444.  
  445. PROCEDURE windowbits;
  446. BEGIN
  447.   CASE pipe[0] OF
  448.     41  : wh:=-1; 
  449.     22  : IF APPFLAG THEN BEGIN
  450.             wh:=-1;                        { Accessory closed }
  451.             closedownwindow;
  452.             shutdown;
  453.             HALT;
  454.           END ELSE closedownwindow;
  455.     20  : redrawwindow;                           { Window redraw requested }
  456.     21  : setupwindow;                            { Window topped }
  457.     23  : fullwindow;                             { Window full "button" was hit }
  458.     24  : moveadd;                                { One of the slider bar arrows was hit }
  459.     28  : WIND_SET (pipe[3], WF_CURRXYWH,
  460.             pipe[4], pipe[5], MAX (70,pipe[6]), MAX (50,pipe[7]));
  461.                                                   { Window moved }
  462.     29  : ontop:=FALSE;
  463.     40  : setupwindow;                            { Accessory opened }
  464.     69  : sendmessage;
  465.   END;
  466. END;
  467.  
  468. PROCEDURE handlesearch (mx, my, mb  : integer);
  469. BEGIN
  470.   IF FILEPOS (myfile)=0 THEN EXIT;
  471.   WIND_GET (wh, WF_TOP, x, y, w, h);
  472.   IF (x=wh) AND (mb=1) THEN
  473.   BEGIN
  474.     WIND_GET (wh, WF_WORKXYWH, x, y, w, h);
  475.     IF (mx>x) AND (mx<(x+w)) AND (my>y) AND (my<(y+h)) THEN
  476.     BEGIN
  477.       openfile;
  478.       IF FILESIZE (myfile)>p+1 THEN INC (p)
  479.         ELSE p:=0;
  480.       CLOSE (myfile);
  481.       findad;
  482.     END;
  483.   END;
  484. END;
  485.  
  486. PROCEDURE mainloop;
  487. VAR
  488.   mx, my, mb, u,  
  489.   rt, k, dummy, t1, t2  : integer;
  490.   byebye                : boolean;
  491. BEGIN
  492.   byebye:=FALSE;
  493.   WHILE (NOT (byebye)) OR (NOT (APPFLAG)) DO
  494.   BEGIN
  495.     IF ontop THEN u:=19 ELSE u:=17;
  496.     rt:=evnt_multi (u, 1, 2, 1, 0, 0, 0, 
  497.                     0, 0, 0, 0, 0, 0, 0, pipe[0], 0, 0,
  498.                     mx, my, mb, dummy, k, dummy);
  499.     IF (rt AND 1) = 1 THEN IF (k=$11b) AND (APPFLAG) THEN byebye:=TRUE;
  500.     IF ((rt AND 2) = 2) AND (ontop) THEN handlesearch (mx, my, mb);
  501.     IF (rt AND 16)=16 THEN windowbits;
  502.   END;
  503. END;
  504.  
  505. FUNCTION setupgem : boolean;
  506. VAR
  507.   n               : integer;
  508.   income          : intin_array;
  509.   outward         : workout_array;
  510. BEGIN
  511.   n:=0;
  512.   aeshan:=appl_init;
  513.   vdihan:=graf_handle (charw, charh, n, n);
  514.   IF (vdihan<0) OR (aeshan<0) THEN setupgem:=FALSE
  515.     ELSE setupgem:=TRUE;
  516.   FOR n:=0 TO 9 DO
  517.     income[n]:=1;
  518.   income[10]:=2;
  519.   v_opnvwk (income, vdihan, outward);
  520.   wind_get (0, 7, minx, miny, maxw, maxh );
  521. END;
  522.  
  523. BEGIN
  524.   ontop:=FALSE;
  525.   s:='  Address Book'+#0;
  526.   openrsc;
  527.   p:=0;
  528.   wh:=-1;
  529.   setts;
  530.   movestpos;
  531.   moveadd;
  532.   IF setupgem THEN GRAF_MOUSE (arrow, NIL);
  533.   IF APPFLAG THEN setupwindow
  534.     ELSE acchan:=menu_register (aeshan, s[1]);
  535.   mainloop;
  536.   closedownwindow;
  537.   shutdown ;
  538. END.