home *** CD-ROM | disk | FTP | other *** search
/ PC Underground / UNDERGROUND.ISO / speaker / design.pas next >
Encoding:
Pascal/Delphi Source File  |  1995-07-28  |  7.8 KB  |  303 lines
  1. unit design;
  2.  
  3. interface
  4. uses crt,windos;
  5.  
  6. procedure writexy(x,y : integer;s : string);
  7. procedure frame(rt: byte;startx,starty,dx,dy : integer);
  8. function select_file(dir : string;mask : pchar;mtext,comment: string) : string;
  9. function wrhexb(b : byte) : string;
  10. function wrhexw(w : word) : string;
  11. procedure save_screen;
  12. procedure restore_screen;
  13. procedure window(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
  14. procedure cursor_on;
  15. procedure cursor_off;
  16.  
  17. implementation
  18.  
  19. var filenames : array[1..512] of string[12];
  20. const      Screen_Cur   : byte = 1;
  21.  
  22. procedure writexy(x,y : integer;s : string);
  23. begin;
  24.  gotoxy(x,y);
  25.  write(s);
  26. end;
  27.  
  28. procedure save_screen;
  29. var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
  30. begin;
  31.   if Screen_Cur <= 4 then begin;
  32.     inc(Screen_Cur);
  33.     move(screen[1],screen[Screen_Cur],8000);
  34.   end;
  35. end;
  36.  
  37. procedure restore_screen;
  38. var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
  39. begin;
  40.   if Screen_Cur >= 2 then begin;
  41.     move(screen[Screen_Cur],screen[1],8000);
  42.     dec(Screen_Cur);
  43.   end;
  44. end;
  45.  
  46. procedure frame(rt: byte;startx,starty,dx,dy : integer);
  47. const frames : array[1..2,1..6] of char =
  48.  (('┌','┐','┘','└','─','│'),
  49.   ('╔','╗','╝','╚','═','║'));
  50. var lx,ly : integer;
  51.     s : string;
  52. begin;
  53.   { top row }
  54.   s := frames[rt,1];
  55.   for lx := 1 to dx-2 do s := s + frames[rt,5];
  56.   s := s + frames[rt,2];
  57.   gotoxy(startx,starty);
  58.   write(s);
  59.   { middle rows }
  60.   for ly := 1 to dy-2 do begin;
  61.     s := frames[rt,6];
  62.     for lx := 1 to dx-2 do s := s + ' ';
  63.     s := s + frames[rt,6];
  64.     gotoxy(startx,starty+ly);
  65.     write(s);
  66.   end;
  67.   { bottom row }
  68.   s := frames[rt,4];
  69.   for lx := 1 to dx-2 do s := s + frames[rt,5];
  70.   s := s + frames[rt,3];
  71.   gotoxy(startx,starty+dy-1);
  72.   write(s);
  73. end;
  74.  
  75. Procedure Window(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
  76. var tleng : byte;
  77.     deltx,tstartpos : byte;
  78. begin;
  79.   tleng := length(s);
  80.   tstartpos := x + ((dx-Tleng) SHR 1);
  81.   textcolor(rcol);
  82.   textbackground(bcol);
  83.   frame(1,x,y,dx,dy);
  84.   writexy(tstartpos,y,s);
  85. end;
  86.  
  87. procedure sort_filenames(start,end1 : integer);
  88. {
  89.  Quick-Sort should be built in here for larger directories !
  90. }
  91. var help : string;
  92.     l1,l2 : integer;
  93. begin;
  94.   for l1 := start to end1-1 do begin;
  95.     for l2 := start to end1-1 do begin;
  96.       if filenames[l2] > filenames[l2+1] then begin;
  97.         help := filenames[l2];
  98.         filenames[l2] := filenames[l2+1];
  99.         filenames[l2+1] := help;
  100.       end;
  101.     end;
  102.   end;
  103. end;
  104.  
  105. function select_file(dir : string;mask : pchar;mtext,comment: string) : string;
  106. const  row : byte = 1;
  107.   column : byte = 0;
  108.   Start_fndisp : word = 0;
  109. var
  110.   DirInfo: TSearchRec;
  111.   count : integer;
  112.   Nullpos : byte;
  113. var li,lj : integer;
  114.     inp : char;
  115.     retval : string;
  116.     box_found : boolean;
  117.     select : byte;
  118.     changed : boolean;
  119.     End_fndisp : word;
  120. begin
  121.   {$I+}
  122.   for li := 1 to 512 do filenames[li] := ' - - -';
  123.   count := 1;
  124.   FindFirst(mask, faArchive, DirInfo);
  125.   while DosError = 0 do
  126.   begin
  127.     filenames[count] := (DirInfo.Name);
  128.     Nullpos := pos(#0,filenames[count]);
  129.     if Nullpos <> 0 then
  130.       filenames[count] := copy(filenames[count],0,Nullpos-1);
  131.     inc(count);
  132.     FindNext(DirInfo);
  133.   end;
  134.   {$I-}
  135.  
  136.   sort_filenames(1,count-1);
  137.   save_screen;
  138.   Window(5,4,72,16,comment,black,7);
  139.   textcolor(1);
  140.   writexy(21,5,'         Please select file');
  141.   textcolor(black);
  142.   inp := #255;
  143.   changed := true;
  144.   repeat
  145.     textcolor(black);
  146.     if changed then begin;
  147.       changed := false;
  148.       for lj := 0 to 4 do begin;
  149.         for li := 1 to 12 do begin;
  150.           writexy(7+lj*14,5+li,'            ');
  151.           writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
  152.         end;
  153.       end;
  154.       textcolor(14);
  155.       writexy(7+Column*14,5+Row,filenames[Column*12+Row+Start_fndisp]);
  156.     end;
  157.     if keypressed then inp := readkey;
  158.     if ord(inp) = 0 then inp := readkey;
  159.     case ord(inp) of
  160.       32,
  161.       13: begin;
  162.             inp := #13;
  163.             changed := true;
  164.             if (pos('- - -',filenames[Column*12+Row+Start_fndisp]) = 0) then
  165.               retval := filenames[Column*12+Row+Start_fndisp]
  166.             else
  167.               retval := 'xxxx';
  168.           end;
  169.       27: begin;
  170.             inp := #27;
  171.             changed := true;
  172.             retval := 'xxxx';
  173.           end;
  174.       71: begin; { Home }
  175.             inp := #255;
  176.             Row  := 1;
  177.             Column := 0;
  178.             changed := true;
  179.           end;
  180.       72: begin; { Arrow up }
  181.             inp := #255;
  182.             changed := true;
  183.             if not ((Row = 1) and (Column = 0)) then
  184.               dec(Row);
  185.             if Row = 0 then begin;
  186.               dec(Column);
  187.               Row := 12;
  188.             end;
  189.           end;
  190.       73: begin; { Page UP }
  191.             if Start_fndisp >= 12 then
  192.               dec(Start_fndisp,12)
  193.             else begin;
  194.               Start_fndisp := 0;
  195.               Row := 1;
  196.             end;
  197.             inp := #255;
  198.             changed := true;
  199.           end;
  200.       81: begin; { Page Down }
  201.             if ((Column+1)*12+Start_fndisp < count) and
  202.             (Start_fndisp < 500) then
  203.               inc(Start_fndisp,12)
  204.             else
  205.               Start_fndisp := count-11;
  206.             inp := #255;
  207.             changed := true;
  208.           end;
  209.       75: begin; { Arrow left }
  210.             inp := #255;
  211.             changed := true;
  212.             if Column = 0 then begin;
  213.               if Start_fndisp >= 12 then dec(Start_fndisp,12);
  214.             end else begin;
  215.               if Column > 0 then dec(Column);
  216.             end;
  217.           end;
  218.       77: begin; { Arrow right }
  219.             inp := #255;
  220.             changed := true;
  221.             if Column = 4 then begin;
  222.               if ((Column+1)*12+Start_fndisp < count) and
  223.               (Start_fndisp < 500) then inc(Start_fndisp,12);
  224.             end else begin;
  225.             if (Column < 4) and
  226.               (Row+(Column+1)*12+Start_fndisp < count) then
  227.                 inc(Column);
  228.             end;
  229.           end;
  230.       79: begin; { End }
  231.             inp := #255;
  232.             changed := true;
  233.             Column := (count-Start_fndisp-12) div 12;
  234.             Row := (count-Start_fndisp) - Column*12 -1;
  235.           end;
  236.       80: begin; { Arrow down }
  237.             inp := #255;
  238.             changed := true;
  239.             if ((Row = 12) and (Column = 4)) then begin;
  240.               if (Start_fndisp+Row+Column*12 < count-1) then begin;
  241.                 inc(Start_fndisp,1);
  242.               end;
  243.             end else begin;
  244.               if (Start_fndisp+Row+Column*12 < count-1) then
  245.                 inc(Row);
  246.              end;
  247.             if Row > 12 then begin;
  248.               inc(Column);
  249.               Row := 1;
  250.             end;
  251.           end;
  252.       82 : begin;
  253.             changed := true;
  254.              save_screen;
  255.              textcolor(black);
  256.              frame(2,16,9,45,5);
  257.              writexy(20,10,' Enter filename ('+mtext+')');
  258.              writexy(20,12,'Name: ');
  259.              readln(retval);
  260.              if retval = '' then retval := 'xxxx';
  261.              restore_screen;
  262.            end;
  263.      end;
  264.   until (inp = #13) or (inp = #27) or (inp = #32)
  265.      or (inp = #82);
  266.   restore_screen;
  267.   textbackground(black);
  268.   textcolor(7);
  269.   select_file := retval;
  270. end;
  271.  
  272. function wrhexb(b : byte) : string;
  273. const hexcar : array[0..15] of char =
  274.  ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
  275. begin;
  276.   wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
  277. end;
  278.  
  279. function wrhexw(w : word) : string;
  280. begin;
  281.   wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
  282. end;
  283.  
  284. procedure cursor_off; assembler;
  285. asm
  286.   xor ax,ax
  287.   mov ah,01h
  288.   mov cx,2020h
  289.   int 10h
  290. end;
  291.  
  292. procedure cursor_on; assembler;
  293. asm
  294.  mov ah,01h
  295.  mov cx,0607h
  296.  int 10h
  297. end;
  298.  
  299.  
  300.  
  301. begin;
  302. end.
  303.