home *** CD-ROM | disk | FTP | other *** search
/ Falcon 030 Power 2 / F030_POWER2.iso / ST_STE / MAGS / ICTARI08.ARJ / ictari.08 / PASCAL / SHOW_DIR.PAS next >
Pascal/Delphi Source File  |  1994-01-16  |  12KB  |  477 lines
  1. {compile with all checks off and linker 4 11 11 10}
  2.  
  3. PROGRAM davids_window_thing;
  4. USES gemaes, gemdecl, gemvdi, printer, bios, dos;
  5. TYPE
  6.   pipearray                   = array [0..7] OF integer;
  7.  
  8. CONST
  9.   elements                    = 4095;
  10.   strnlen                     = 50;
  11.   max_elements  : byte        = 127;
  12.   real_max                    = 127;
  13.   dir           : dirstr      = 'c:\*.*'#0'                           ';
  14.   wh            : integer     = -1;
  15.   acchandle     : integer     = -1;
  16.   aeshandle     : integer     = -1;
  17.   vdihandle     : integer     = -1;
  18.   charw         : integer     = 0;
  19.   charh         : integer     = 0;
  20.   charbw        : integer     = 0;
  21.   charbh        : integer     = 0;
  22.   minx          : integer     = 0;
  23.   miny          : integer     = 0;
  24.   maxw          : integer     = 0;
  25.   maxh          : integer     = 0;
  26.   atpos         : integer     = 0;
  27.   atelement     : integer     = 0;
  28.   winx          : integer     = 50;
  29.   winy          : integer     = 50;
  30.   winw          : integer     = 150;
  31.   winh          : integer     = 100;
  32.   accname       : string[17]  = '  Show Directory'#00#00;
  33.   winname       : string[15]  = 'Directory'#00#00;
  34.   wininfo       : string[150] = '  By David Gunby | '#00#00;
  35.  
  36. VAR
  37.   big_array     : packed array [0..real_max] OF string [strnlen];
  38.   pipe          : pipearray;
  39.  
  40. PROCEDURE alert (s  : string);
  41. BEGIN
  42.   s:='[3]['+s+'][  OK  ]';
  43.   IF FORM_ALERT (1, s[1])=3 THEN ;
  44. END;
  45.  
  46. FUNCTION strf (l  : longint;n : byte)  : string;
  47. VAR
  48.   s               : string[10];
  49. BEGIN
  50.   IF (l=0) AND (n=6) THEN s:='      ' 
  51.   ELSE
  52.     STR (l:n, s);
  53.   strf:=s;
  54. END;
  55.  
  56. PROCEDURE tidyup;
  57. BEGIN
  58.   IF wh>=0 THEN
  59.   BEGIN
  60.     WIND_CLOSE (wh);
  61.     WIND_DELETE (wh);
  62.   END;
  63.   wh:=-1;
  64. END;
  65.  
  66. PROCEDURE termchain;
  67. BEGIN
  68.   tidyup;
  69.   V_CLSVWK (vdihandle);
  70.   APPL_EXIT;
  71. END;
  72.  
  73. PROCEDURE sort_bigarray;
  74. VAR
  75.   n, m                    : byte;
  76.   s                       : string;
  77.   doneone                 : boolean;
  78. BEGIN
  79.   IF max_elements=0 THEN EXIT;
  80.   FOR m:=1 TO max_elements-1 DO
  81.     FOR n:=1 TO (max_elements-1)-m DO
  82.       IF big_array [n]>big_array [n+1] THEN
  83.       BEGIN
  84.         s:=big_array [n];
  85.         big_array[n]:=big_array[n+1];
  86.         big_array [n+1]:=s;
  87.         doneone:=TRUE;
  88.       END;
  89. END;
  90.  
  91. FUNCTION prepname (s  : string) : string;
  92. BEGIN
  93.   WHILE (POS ('.', s)<9) AND (POS ('.', s)>0) DO
  94.     INSERT (' ', s, POS ('.', s));
  95.   WHILE (LENGTH (s)<13) DO
  96.     s:=s+' ';
  97.   prepname:=s;
  98. END;
  99.  
  100. FUNCTION otherstuff (ok : searchrec)  : string;
  101. VAR
  102.   s             : string;
  103.   d             : datetime;
  104. BEGIN
  105.   s:='';
  106.   UNPACKTIME (ok.time, d);
  107.   s:=s+'  '+strf (d.hour, 2)+':'+strf (d.min, 2);
  108.   s:=s+'  '+strf (d.day, 2)+'/'+strf (d.month, 2)+'/'+strf (d.year, 4)+'  ';
  109.   IF (ok.attr AND  1)= 1 THEN s:=s+'R' ELSE s:=s+'-';
  110.   IF (ok.attr AND  2)= 2 THEN s:=s+'S' ELSE s:=s+'-';
  111.   IF (ok.attr AND  4)= 4 THEN s:=s+'H' ELSE s:=s+'-';
  112.   IF (ok.attr AND  8)= 8 THEN s:=s+'V' ELSE s:=s+'-';
  113.   IF (ok.attr AND 16)=16 THEN s:=s+'D' ELSE s:=s+'-';
  114.   IF (ok.attr AND 32)=32 THEN s:=s+'A' ELSE s:=s+'-';
  115.   otherstuff:=s;
  116. END;
  117.  
  118. PROCEDURE readin;
  119. VAR
  120.   size              : longint;
  121.   n                 : byte;
  122.   ok                : searchrec;
  123. BEGIN
  124.   size:=0;
  125.   n:=1;
  126.   FINDFIRST (dir, $3f, ok);
  127.   WHILE (DOSERROR=0) AND (n<real_max) DO
  128.   BEGIN
  129.     size:=size+ok.size;
  130.     big_array [n]:='  '+prepname (ok.name)+'  '+strf (ok.size, 6);
  131.     big_array [n]:=big_array [n]+otherstuff (ok);
  132.     IF (ok.attr AND $10)=$10 THEN big_array[n][1]:=#7;
  133.     INC (n);
  134.     FINDNEXT (ok);
  135.   END;
  136.   DEC (n);
  137.   max_elements:=n;
  138.   n:=LENGTH (wininfo);
  139.   WHILE (wininfo[n]<>'|')  AND (n>0) DO
  140.     DEC (n);
  141.   DELETE (wininfo, n, LENGTH (wininfo));
  142.   wininfo:=wininfo+'| '+dir+#00+#00;
  143.   sort_bigarray;
  144.   big_array [0]:=strf (max_elements-1, 0)+' items in '+strf (size, 0)+' bytes ('+strf (size DIV 1024, 0)+'K)';
  145. END;
  146.  
  147. PROCEDURE setup;
  148. VAR
  149.   n               : byte;
  150.   workin          : intin_array;
  151.   workout         : workout_array;
  152. BEGIN
  153.   readin;
  154.   aeshandle:=APPL_INIT;
  155.   vdihandle:=graf_handle (charw, charh, charbw, charbh);
  156.   FOR n:=0 TO 9 DO
  157.     workin[n]:=1;
  158.   workin[10]:=2;
  159.   V_OPNVWK (workin, vdihandle, workout);
  160.   WIND_GET (0, WF_FULLXYWH, minx, miny, maxw, maxh);
  161. END;
  162.  
  163. PROCEDURE setslidersize;
  164. VAR
  165.   hsize, hat, wsize, wat,
  166.   x, y, w, h        : integer;
  167. BEGIN
  168.   WIND_CALC (1, elements, winx, winy, winw, winh, x, y, w, h);
  169.   hsize:=MIN (1000, ROUND (1000*(w / charw) / strnlen));
  170.   IF max_elements=0 THEN wsize:=1000
  171.     ELSE wsize:=MIN (1000, ROUND (1000*(h / charh) / max_elements));
  172.   WIND_SET (wh, WF_HSLSIZE, hsize, 0, 0, 0);
  173.   WIND_SET (wh, WF_VSLSIZE, wsize, 0, 0, 0);
  174.   IF atpos<>0 THEN
  175.     wat:=ROUND (1000*((atpos)/(strnlen-(w DIV charw))))
  176.   ELSE
  177.     wat:=0;
  178.   IF atelement<>0 THEN
  179.     hat:=ROUND (1000*((atelement)/(max_elements-(h DIV charh))))
  180.   ELSE
  181.     hat:=0;
  182.   WIND_SET (wh, WF_HSLIDE, wat, 0, 0, 0);
  183.   WIND_SET (wh, WF_VSLIDE, hat, 0, 0, 0);
  184. END;
  185.  
  186. FUNCTION getline (atline : integer)  : string;
  187. VAR
  188.   m                   : integer;
  189.   linestr             : string;
  190. BEGIN
  191.   linestr:='   '+big_array[atline];
  192.   linestr:=linestr+#0+#0;
  193.   getline:=linestr;
  194. END;
  195.  
  196. PROCEDURE doredraw;
  197. VAR
  198.   b1, b2        : grect;
  199.   a             : array_4;
  200.   atline,
  201.   n             : integer;
  202.   linestr       : string;
  203. BEGIN
  204.   WIND_UPDATE (BEG_UPDATE);
  205.   GRAF_MOUSE (M_OFF, NIL);
  206.   b1.x:=pipe[4];
  207.   b1.y:=pipe[5];
  208.   b1.w:=pipe[6];
  209.   b1.h:=pipe[7];
  210.   VSF_COLOR (vdihandle, WHITE);
  211.   VSF_STYLE (vdihandle, SOLID);
  212.   WIND_GET (wh, WF_FIRSTXYWH, b2.x, b2.y, b2.w, b2.h);
  213.   WHILE (b2.w<>0) AND (b2.h<>0) DO
  214.   BEGIN
  215.     IF intersect (b1, b2) THEN
  216.     BEGIN
  217.       a[0]:=b2.x;
  218.       a[1]:=b2.y;
  219.       a[2]:=b2.x+b2.w-1;
  220.       a[3]:=b2.y+b2.h-1;
  221.       VS_CLIP (vdihandle, 1, a);
  222.       V_BAR (vdihandle, a); 
  223.       n:=b2.y+charbh;
  224.       atline:=ROUND (atelement +((b2.y-(winy+(2*charh))) / charh))-1;
  225.       INC (b2.h, charh);
  226.       REPEAT
  227.         IF atline<=max_elements THEN
  228.         BEGIN 
  229.           linestr:=getline (atline);
  230.           V_GTEXT (vdihandle, (b2.x DIV charw)*charw, ((n-1) DIV charh)*charh , 
  231.             COPY (linestr, (atpos+((b1.x-winx) DIV charw))+1, (b2.w DIV charw)+1));
  232.         END;
  233.         INC (atline);
  234.         INC (n, charh);
  235.       UNTIL n>b2.y+b2.h;
  236.     END;
  237.     WIND_GET (wh, WF_NEXTXYWH, b2.x, b2.y, b2.w, b2.h);
  238.   END;  
  239.   GRAF_MOUSE (M_ON, NIL);
  240.   WIND_UPDATE (END_UPDATE);
  241. END;
  242.  
  243. PROCEDURE send_redraw;
  244. BEGIN
  245.   pipe[0]:=WM_REDRAW;
  246.   pipe[3]:=wh;
  247.   pipe[4]:=winx;
  248.   pipe[5]:=winy;
  249.   pipe[6]:=winw;
  250.   pipe[7]:=winh;
  251.   APPL_WRITE (aeshandle, SIZEOF (pipe), pipe);
  252. END;
  253.  
  254. PROCEDURE openwindow;
  255. BEGIN
  256.   IF wh<0 THEN
  257.   BEGIN
  258.     wh:=WIND_CREATE (elements, minx, miny, maxw, maxh);
  259.     IF wh>=0 THEN
  260.     BEGIN
  261.       WIND_SET (wh, WF_NAME, HIPTR (winname[1]), LOPTR (winname[1]), 0, 0);
  262.       WIND_SET (wh, WF_INFO, HIPTR (wininfo[1]), LOPTR (wininfo[1]), 0, 0);
  263.       setslidersize;
  264.       WIND_OPEN (wh, winx, winy, winw, winh);
  265.       WIND_SET (wh, WF_PREVXYWH, minx, miny, maxw, maxh);
  266.     END ELSE alert ('||Window Creation error');
  267.   END ELSE   
  268.     send_redraw;
  269. END;
  270.  
  271. PROCEDURE window (x, y, w, h  : integer);
  272. BEGIN
  273.   winx:=((x DIV charw) *charw)+2;
  274.   winy:=((y DIV charh) *charh)+2;
  275.   winw:=w;
  276.   winh:=h;
  277.   WIND_SET (wh, WF_CURRXYWH, winx, winy, w, h);
  278.   setslidersize;
  279. END;
  280.  
  281. PROCEDURE full_window;
  282. VAR
  283.   x, y, w, h            : integer;
  284. BEGIN
  285.   WIND_GET (wh, WF_PREVXYWH, x, y, w, h);
  286.   window (x, y, w, h);
  287. END;
  288.  
  289. PROCEDURE hslidtopos;
  290. VAR
  291.   x, y, w, h        : integer;
  292. BEGIN
  293.   WIND_CALC (1, elements, winx, winy, winw, winh, x, y, w, h);
  294.   atpos:=ROUND ((pipe[4] / 1000)*(strnlen-(w DIV charw)));
  295.   WIND_SET (wh, WF_HSLIDE, pipe[4], 0, 0, 0);
  296.   send_redraw;
  297. END;
  298.  
  299. PROCEDURE vslidtopos;
  300. VAR
  301.   x, y, w, h        : integer;
  302. BEGIN
  303.   WIND_CALC (1, elements, winx, winy, winw, winh, x, y, w, h);
  304.   atelement:=ROUND ((pipe[4] / 1000)*(max_elements-(h DIV charh)+1));
  305.   WIND_SET (wh, WF_VSLIDE, pipe[4], 0, 0, 0);
  306.   send_redraw;
  307. END;
  308.  
  309. PROCEDURE doarrows;
  310. VAR
  311.   ph, pw          : integer;
  312. BEGIN
  313.   ph:=((winh-(3*charbh)) DIV charh);
  314.   pw:=(winw-(2*charbw)) DIV charw;
  315.   CASE pipe[4] OF
  316.     1 : atelement:=MIN (atelement+ph, max_elements-ph+1);
  317.     0 : atelement:=MAX (0, atelement-ph);
  318.     3 : atelement:=MIN (atelement+1, max_elements-ph+1);
  319.     2 : atelement:=MAX (0, atelement-1);
  320.     5 : atpos:=MIN (atpos+pw, strnlen-pw);
  321.     4 : atpos:=MAX (atpos-pw, 0);
  322.     7 : atpos:=MIN (atpos+1, strnlen-pw);
  323.     6 : atpos:=MAX (atpos-1, 0);
  324.   END;
  325.   setslidersize;
  326.   send_redraw;
  327. END;
  328.  
  329. PROCEDURE topwindow;
  330. VAR
  331.   n, m              : integer;
  332. BEGIN
  333.   WIND_SET (wh, WF_TOP, winx, winy, winw, winh);
  334. END;
  335.  
  336. PROCEDURE doclipboard;
  337. VAR
  338.   myfile            : text;
  339.   s                 : string;
  340.   m                 : integer;
  341.   ok                : searchrec;
  342. BEGIN
  343.   SCRP_READ (s[1]);
  344.   m:=1;
  345.   REPEAT
  346.     s[0]:=CHAR (m);
  347.     INC (m);
  348.   UNTIL s[m]=#0;
  349.   IF s='' THEN s:='A:\SCRAP'+#0;
  350.   IF (DRVMAP AND 4)=4 THEN s[1]:='C';
  351.   SCRP_WRITE (s[1]);
  352.   FINDFIRST (s, $10, ok);
  353.   IF DOSERROR<>0 THEN MKDIR (s);
  354.   IF s[LENGTH (s)]<>'\' THEN s:=s+'\';
  355.   FINDFIRST (s+'SCRAP.*', $27, ok);
  356.   WHILE DOSERROR=0 DO
  357.   BEGIN
  358.     ERASE (s+ok.name);
  359.     FINDNEXT (ok);
  360.   END;
  361.   ASSIGN (myfile, s+'SCRAP.TXT');
  362.   REWRITE (myfile);
  363.   FOR m:=0 TO max_elements DO
  364.   BEGIN
  365.     s:=getline (m);
  366.     WHILE (POS (#0, s)<>0) DO
  367.       DELETE (s, POS (#0, s), 1);
  368.     WRITELN (myfile, s);
  369.   END;
  370.   CLOSE (myfile);
  371. END;
  372.  
  373. PROCEDURE getnewpath;
  374. VAR
  375.   dir2        : dirstr;
  376.   name        : string[20];
  377.   n           : integer;
  378. BEGIN
  379.   name:=#0;
  380.   dir:=dir+#0;
  381.   dir2:=dir;
  382.   FSEL_INPUT (dir[1], name[1], n);
  383.   IF n=1 THEN
  384.     readin
  385.   ELSE
  386.     dir:=dir2;
  387.   WIND_SET (wh, WF_INFO, HIPTR (wininfo), LOPTR (wininfo), 0, 0);
  388. END;
  389.  
  390. PROCEDURE acopen;
  391. VAR
  392.   s           : string;
  393.   n, m        : integer;
  394. BEGIN
  395.   openwindow;
  396.   s:='[1][    Pipe Monitor|   By David Gunby|(in HighSpeed Pascal)][  OK  | MORE | DIR ]'#0#0;
  397.   n:=FORM_ALERT (3, s[1]);
  398.   IF n=3 THEN 
  399.   BEGIN
  400.     getnewpath;
  401.     EXIT;
  402.   END;
  403.   IF n=1 THEN EXIT;
  404.   alert ('|David Gunby, 12 Windrush Drive|Oadby, Leicester,LE2 4GH');
  405.   s:='[2][||Output To Which Device][ Printer | ClipBoard | Non ]'+#0+#0;
  406.   n:=FORM_ALERT (1, s[1]);
  407.   IF (n=1) THEN FOR m:=0 TO max_elements DO
  408.                   WRITELN (lst, getline (m));
  409.   IF (n=2) THEN doclipboard;     
  410. END;
  411.  
  412. PROCEDURE evnt_mesag (VAR pipe : pipearray);
  413. VAR
  414.   k, rt, d            : integer;
  415. BEGIN
  416.   REPEAT
  417.     pipe[0]:=32123;
  418.     pipe[4]:=32123;
  419.     WIND_GET (0, WF_TOP, k, rt, rt, rt);
  420.     IF k=wh THEN d:=17 ELSE d:=16;
  421.     rt:=EVNT_MULTI (d, 0, 0, 0, 0, 0, 0, 0, 0, 
  422.                     0, 0, 0, 0, 0, pipe, 0, 0, 
  423.                     d, d, d, d, k, d);
  424.     IF (rt=1) THEN
  425.     BEGIN
  426.       CASE k OF
  427.         $6200 : pipe[0]:=AC_OPEN;
  428.         24832 : pipe[0]:=AC_CLOSE;
  429.         $4800 : pipe[4]:=2;
  430.         $5000 : pipe[4]:=3;
  431.         $4b00 : pipe[4]:=6;
  432.         $4d00 : pipe[4]:=7;
  433.       END;
  434.       IF pipe[4]<>32123 THEN pipe[0]:=WM_ARROWED;
  435.     END;
  436.   UNTIL pipe[0]<>32123;
  437. END;
  438.  
  439. PROCEDURE domainloop;
  440. VAR
  441.   n              : byte;
  442.   byebye          : boolean;
  443. BEGIN
  444.   REPEAT
  445.     byebye:=FALSE;
  446.     evnt_mesag (pipe);
  447.     CASE pipe[0] OF
  448.       MN_SELECTED : ;
  449.       WM_FULLED   : full_window;
  450.       WM_REDRAW   : doredraw;
  451.       WM_ARROWED  : IF max_elements>0 THEN doarrows;
  452.       WM_HSLID    : hslidtopos;
  453.       WM_VSLID    : IF max_elements>0 THEN vslidtopos;
  454.       WM_MOVED,
  455.       WM_SIZED    : window (pipe[4], pipe[5], pipe[6], pipe[7]);
  456.       WM_TOPPED   : topwindow;
  457.       AC_OPEN     : acopen;
  458.       30,
  459.       33          : WIND_SET (wh, 25, winx, winy, winw, winh);
  460.       WM_CLOSED,
  461.       AC_CLOSE    : IF APPFLAG THEN byebye:=TRUE ELSE tidyup;
  462.     END;
  463.   UNTIL byebye=TRUE;
  464. END;
  465.  
  466. BEGIN
  467.   GRAF_MOUSE (2, NIL);
  468.   setup;
  469.   IF APPFLAG THEN 
  470.   BEGIN
  471.     wininfo:=' Press HELP | '+wininfo;
  472.     openwindow
  473.   END ELSE acchandle:=menu_register (aeshandle, accname[1]);
  474.   GRAF_MOUSE (0, NIL);
  475.   domainloop;
  476.   termchain;
  477. END.