PC Interdit/pc-interdit.iso/sound/gusmod/design.pas

Pascal/Delphi Source File | 1994-10-19 | 7.9 KB | 303 lines

unit design;

interface
uses crt,windos;

procedure writexy(x,y : integer;s : string);
procedure Cadre(rt: byte;startx,starty,dx,dy : integer);
function select_fichier(dir : string;mask : pchar;mtext,comment: string) : string;
function wrhexb(b : byte) : string;
function wrhexw(w : word) : string;
procedure save_screen;
procedure restore_screen;
Procedure Fenetre(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
procedure cursor_On;
procedure cursor_Off;

implementation

var filenames : array[1..512] of string[12];
const      Ecran   : byte = 1;

procedure writexy(x,y : integer;s : string);
begin;
 gotoxy(x,y);
 write(s);
end;

procedure save_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Ecran <= 4 then begin;
    inc(Ecran);
    move(screen[1],screen[Ecran],8000);
  end;
end;

procedure restore_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Ecran >= 2 then begin;
    move(screen[Ecran],screen[1],8000);
    dec(Ecran);
  end;
end;

procedure Cadre(rt: byte;startx,starty,dx,dy : integer);
const frames : array[1..2,1..6] of char =
 (('┌','┐','┘','└','─','│'),
  ('╔','╗','╝','╚','═','║'));
var lx,ly : integer;
    s : string;
begin;
  { Ligne supérieure }
  s := frames[rt,1];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,2];
  gotoxy(startx,starty);
  write(s);
  { Lignes du milieu }
  for ly := 1 to dy-2 do begin;
    s := frames[rt,6];
    for lx := 1 to dx-2 do s := s + ' ';
    s := s + frames[rt,6];
    gotoxy(startx,starty+ly);
    write(s);
  end;
  { Dernière ligne }
  s := frames[rt,4];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,3];
  gotoxy(startx,starty+dy-1);
  write(s);
end;

Procedure Fenetre(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
var Tlong : byte;
    deltx,tstartpos : byte;
begin;
  Tlong := length(s);
  tstartpos := x + ((dx-Tlong) SHR 1);
  textcolor(rcol);
  textbackground(bcol);
  Cadre(1,x,y,dx,dy);
  writexy(tstartpos,y,s);
end;

procedure sort_filenames(start,Fin : integer);
{
 Pour un fichier plus grand, il faut utiliser Quick-Sort !
}
var Aide : string;
    l1,l2 : integer;
begin;
  for l1 := start to Fin-1 do begin;
    for l2 := start to Fin-1 do begin;
      if filenames[l2] > filenames[l2+1] then begin;
        Aide := filenames[l2];
        filenames[l2] := filenames[l2+1];
        filenames[l2+1] := Aide;
      end;
    end;
  end;
end;

function select_fichier(dir : string;mask : pchar;mtext,comment: string) : string;
const  Ligne : byte = 1;
  Creux : byte = 0;
  Start_fndisp : word = 0;
var
  DirInfo: TSearchRec;
  count : integer;
  Nullpos : byte;
var li,lj : integer;
    inp : char;
    retval : string;
    Boite_trouve : boolean;
    select : byte;
    changed : boolean;
    End_fndisp : word;
begin
  {$I+}
  for li := 1 to 512 do filenames[li] := ' - - -';
  count := 1;
  FindFirst(mask, faArchive, DirInfo);
  while DosError = 0 do
  begin
    filenames[count] := (DirInfo.Name);
    Nullpos := pos(#0,filenames[count]);
    if Nullpos <> 0 then
      filenames[count] := copy(filenames[count],0,Nullpos-1);
    inc(count);
    FindNext(DirInfo);
  end;
  {$I-}

  sort_filenames(1,count-1);
  save_screen;
  Fenetre(5,4,72,16,comment,black,7);
  textcolor(1);
  writexy(21,5,'         Sélectionnez un fichier');
  textcolor(black);
  inp := #255;
  changed := true;
  repeat
    textcolor(black);
    if changed then begin;
      changed := false;
      for lj := 0 to 4 do begin;
        for li := 1 to 12 do begin;
          writexy(7+lj*14,5+li,'            ');
          writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
        end;
      end;
      textcolor(14);
      writexy(7+Creux*14,5+Ligne,filenames[Creux*12+Ligne+Start_fndisp]);
    end;
    if keypressed then inp := readkey;
    if ord(inp) = 0 then inp := readkey;
    case ord(inp) of
      32,
      13: begin;
            inp := #13;
            changed := true;
            if (pos('- - -',filenames[Creux*12+Ligne+Start_fndisp]) = 0) then
              retval := filenames[Creux*12+Ligne+Start_fndisp]
            else
              retval := 'xxxx';
          end;
      27: begin;
            inp := #27;
            changed := true;
            retval := 'xxxx';
          end;
      71: begin; { Pos 1 }
            inp := #255;
            Ligne  := 1;
            Creux := 0;
            changed := true;
          end;
      72: begin; { Flêche haut }
            inp := #255;
            changed := true;
            if not ((Ligne = 1) and (Creux = 0)) then
              dec(Ligne);
            if Ligne = 0 then begin;
              dec(Creux);
              Ligne := 12;
            end;
          end;
      73: begin; { Page UP }
            if Start_fndisp >= 12 then
              dec(Start_fndisp,12)
            else begin;
              Start_fndisp := 0;
              Ligne := 1;
            end;
            inp := #255;
            changed := true;
          end;
      81: begin; { Page Down }
            if ((Creux+1)*12+Start_fndisp < count) and
            (Start_fndisp < 500) then
              inc(Start_fndisp,12)
            else
              Start_fndisp := count-11;
            inp := #255;
            changed := true;
          end;
      75: begin; { Flêche gauche }
            inp := #255;
            changed := true;
            if Creux = 0 then begin;
              if Start_fndisp >= 12 then dec(Start_fndisp,12);
            end else begin;
              if Creux > 0 then dec(Creux);
            end;
          end;
      77: begin; { Flêche droite }
            inp := #255;
            changed := true;
            if Creux = 4 then begin;
              if ((Creux+1)*12+Start_fndisp < count) and
              (Start_fndisp < 500) then inc(Start_fndisp,12);
            end else begin;
            if (Creux < 4) and
              (Ligne+(Creux+1)*12+Start_fndisp < count) then
                inc(Creux);
            end;
          end;
      79: begin; { Fin }
            inp := #255;
            changed := true;
            Creux := (count-Start_fndisp-12) div 12;
            Ligne := (count-Start_fndisp) - Creux*12 -1;
          end;
      80: begin; { Flêche bas }
            inp := #255;
            changed := true;
            if ((Ligne = 12) and (Creux = 4)) then begin;
              if (Start_fndisp+Ligne+Creux*12 < count-1) then begin;
                inc(Start_fndisp,1);
              end;
            end else begin;
              if (Start_fndisp+Ligne+Creux*12 < count-1) then
                inc(Ligne);
             end;
            if Ligne > 12 then begin;
              inc(Creux);
              Ligne := 1;
            end;
          end;
      82 : begin;
            changed := true;
             save_screen;
             textcolor(black);
             Cadre(2,16,9,45,5);
             writexy(20,10,' Entrez les noms de fichier ('+mtext+')');
             writexy(20,12,'Nom : ');
             readln(retval);
             if retval = '' then retval := 'xxxx';
             restore_screen;
           end;
     end;
  until (inp = #13) or (inp = #27) or (inp = #32)
     or (inp = #82);
  restore_screen;
  textbackground(black);
  textcolor(7);
  select_fichier := retval;
end;

function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure cursor_Off; assembler;
asm
  xor ax,ax
  mov ah,01h
  mov cx,2020h
  int 10h
end;

procedure cursor_on; assembler;
asm
 mov ah,01h
 mov cx,0607h
 int 10h
end;



begin;
end.