home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 September / Chip_1999-09_cd.bin / internet / Jeremy / tp / downloads / vstupy.pas < prev   
Pascal/Delphi Source File  |  1999-08-03  |  16KB  |  483 lines
  1. Unit Vstupy;
  2. Interface
  3.  
  4. uses dos, crt, savewind;
  5.  
  6. const
  7.    Null    =   #0;
  8.    BS      =   #8;
  9.    TAB     =   #9;
  10.    CR      =  #13;
  11.    Esc     =  #27;
  12.    Space   =  #32;
  13.    F1      = #187;
  14.    F2      = #188;
  15.    F3      = #189;
  16.    F4      = #190;
  17.    F5      = #191;
  18.    F6      = #192;
  19.    F7      = #193;
  20.    F8      = #194;
  21.    F9      = #195;
  22.    F10     = #196;
  23.    Home    = #199;
  24.    EndK    = #207;
  25.    Ins     = #210;
  26.    Del     = #211;
  27.    Up      = #200;
  28.    Down    = #208;
  29.    Left    = #203;
  30.    Right   = #205;
  31.    PgUp    = #201;
  32.    PgDn    = #209;
  33.  
  34. type
  35.     CharSet = set of char;
  36.     Retezec = string[80];
  37.  
  38. var TimeOut:longint; {Round(sekundy * 18.18)}
  39.     JeSaver: boolean;
  40.     KursType: word;
  41.  
  42. procedure KbdClear;
  43.          { maºe vyrovnávací pam╪£ klávesnice }
  44. procedure WaitTo;            { ƒeká na stisk klávesy }
  45. procedure Saver;
  46. function GetKey : char;      { vrací znak z klávesnice }
  47.      {!! Základní funkce pro vstup, náhrada fce Readkey z unitu Crt !!}
  48. function GetLegalKey(LegalSet : CharSet) : char;
  49.          { ¼eká na stisk klávesy, která pat²í do mnoºiny LegalSet
  50.            (nan jiné klávesy nereaguje }
  51. function GetString(X,Y,Delka : byte) : Retezec;
  52.          { Naƒte ²et╪zec o zadané délce z pozice (X,Y) }
  53.          { Delka : délka pole, do kterého se má ²et╪zec vkládat }
  54. function GetChar(Sl, Row : byte) : char;
  55.          { Vrací znak p²eƒten∞ z dané pozice (Sl,Row) }
  56.          { Sl  - ƒíslo sloupce vstupního pole;
  57.            Row - ƒíslo ²ádku vstupního pole }
  58. function GetInteger(Sl,Row,Len : byte;Low,High : integer):integer;
  59.          { Sl     - ƒíslo sloupce, na kterém má vstup zaƒínat;
  60.            Row    - ƒíslo ²ádku, na kterém má vstup zaƒínat;
  61.            Len    - poƒet ƒíslic, které budou zadávány;
  62.            Low    - nejmenτí ƒíslo, které màºe b∞t zadáno;
  63.            High   - nejv╪tτí ƒíslo, které màºe b∞t zadáno:
  64.           Funkce vrací ƒíslo typu integer; }
  65. function GetReal(Sl,Row,Len : byte;Low,High : real):real;
  66.          { Sl     - ƒíslo sloupce, na kterém má vstup zaƒínat;
  67.            Row    - ƒíslo ²ádku, na kterém má vstup zaƒínat;
  68.            Len    - poƒet ƒíslic, které budou zadávány;
  69.            Low    - nejmenτí ƒíslo, které màºe b∞t zadáno;
  70.            High   - nejv╪tτí ƒíslo, které màºe b∞t zadáno:
  71.           Funkce vrací ƒíslo typu real; }
  72. procedure EditString(X,Y,Delka : byte; var st:string);
  73.          { Slouºí k editaci ²et╪zce dané délky na pozici (X,Y)
  74.            P²i stisku klávesy ESC vrací prázdn∞ ²et╪zec  }
  75. procedure EditWord(Sl,Row,Len: byte;Low,High,Def: word;var w:word);
  76.          { Slouºí k editaci ƒísla typu word na dané pozici;
  77.            Len - délka pole pro editaci ƒísla (=poƒet ƒíslic)
  78.            Low, High - nejmenτí a nejv╪tτí p²ípustné ƒíslo
  79.            Def - implicitní hodnota p²i prázdném vstupu }
  80. function  Real2Str(x: real):string;
  81. procedure EditReal(Sl,Row,Len: byte;Low,High,def: real;var w:real);
  82.          { Slouºí k editaci ƒísla typu real na dané pozici;
  83.            Len - délka pole pro editaci ƒísla (=poƒet ƒíslic)
  84.            Low, High - nejmenτí a nejv╪tτí p²ípustné ƒíslo
  85.            Def - implicitní hodnota p²i prázdném vstupu }
  86.  
  87. procedure skryjkursor;
  88. procedure obnovkursor;
  89.  
  90. implementation
  91. var screen: pbuf;
  92.  
  93. procedure skryjkursor; assembler;
  94. asm
  95.    push AX;
  96.    push BX;
  97.    push CX;
  98.    push DX;
  99.    mov BH,0;
  100.    mov AH,03h;
  101.    int 10h;
  102.    mov KursType,CX;
  103.    or CH,20h;
  104.    mov AH,01h;
  105.    int 10h;
  106.    pop DX;
  107.    pop CX;
  108.    pop BX;
  109.    pop AX;
  110. end;
  111.  
  112. procedure ObnovKursor; assembler;
  113. asm
  114.    push AX;
  115.    push BX;
  116.    push CX;
  117.    mov CX,KursType;
  118.    mov AH,01h;
  119.    int 10h;
  120.    pop CX;
  121.    pop BX;
  122.    pop AX;
  123. end;
  124.  
  125.  
  126. Procedure KbdClear;assembler;
  127.    asm
  128.     @@1: mov AH,11h
  129.          int 16h
  130.          jz  @@2
  131.          mov AH,10h
  132.          int 16h
  133.          jmp @@1
  134.     @@2:
  135.    end;
  136.  
  137. procedure WaitTo;
  138.     begin
  139.        KbdClear;
  140.        repeat until KeyPressed;
  141.     end;
  142.  
  143. {------------SETRIC-------------}
  144. procedure Saver;
  145. const
  146.   Flakes = 80;
  147.  
  148.  Procedure vidMode(mode : byte);assembler;
  149.   asm
  150.      mov ah,$00;
  151.      mov al,mode;
  152.      int 10h;
  153.   end;
  154.  
  155.  Procedure setPixel(pixPos : word; color : byte);
  156.  begin
  157.     mem[$A000:pixPos] := color;
  158.  end;
  159.  
  160. var
  161.   CurFlake : integer;
  162.   i : longint;
  163.   x,y, newPos: array[0..Flakes] of word;
  164.   b: byte absolute $0000:$0449;
  165.   ax, ay: byte;
  166.  
  167. BEGIN
  168.   if (JeSaver=false) or (b=7) then exit;
  169.   ax:=wherex;
  170.   ay:=wherey;
  171.   savewin(1,1,80,25,screen);
  172.  
  173.   randomize;
  174.   for curFlake:=0 to Flakes do        { set up snow lookup table }
  175.   begin
  176.     x[curFlake]:=random(319);
  177.     y[curFlake]:=random(199);
  178.   end;
  179.   vidMode($13);                       { 320x200x256 graphics mode }
  180.   i := 0; { change to 100 or higher to get rid of start explosion }
  181.   repeat
  182.     inc(i);
  183.     for curFlake:=0 to Flakes do
  184.       begin
  185.         setPixel(newPos[curFlake], 0);     { erase old snowflake }
  186.         newPos[curFlake] :=      { set up and draw new snowflake }
  187.           round(x[curFlake]*(i*0.01)) +                  { new X }
  188.           round(y[curFlake]*(i*0.01)) * 320;             { new Y }
  189.         setPixel(newPos[curFlake], 16-(curflake mod 8));
  190.       end;                         {(curFlake mod 13) + 19}
  191.     while (port[$3da] and $08) = $08 do;  { wait for vRetrace to }
  192.     while (port[$3da] and $08) = $00 do;  { start and end        }
  193.   until keypressed;
  194.   vidMode($03);                       { return to 80x25 textmode }
  195.   restorewin(1,1,80,25,screen);
  196.   gotoxy(ax,ay);
  197. end;
  198.  
  199. Function GetKey : char;
  200.     var
  201.        Key : char; t:longint;
  202.     begin
  203.        KbdClear;               { vyprázdni buffer klávesnice}
  204.        t:=MemL[Seg0040:$006c]; { poƒet tikà hodin}
  205.        repeat
  206.            if (MemL[Seg0040:$006C]-t > TimeOut) then
  207.             begin
  208.                  Saver;
  209.                  t:=MemL[Seg0040:$006C];
  210.                  KbdClear;
  211.             end;
  212.        until KeyPressed; { ƒekej na stisk libovolné klávesy }
  213.  
  214.        Key := ReadKey;   { p²eƒti znak z klávesnice }
  215.        if (Key = Null) and KeyPressed then
  216.        begin             { jestliºe se jedná o rozτí²enou
  217.                            klávesu }
  218.           Key := ReadKey;{ p²eƒti druh∞ byte kódu klávesy }
  219.           key:= Chr(Ord(Key)+128);
  220.        end;
  221.        GetKey := Key;
  222.     end;
  223.  
  224. Function GetLegalKey(LegalSet : CharSet) : char;
  225.     var
  226.        Key : char;
  227.     begin
  228.        repeat
  229.           Key := GetKey;     { ƒekej na vstup z klávesnice}
  230.        until Key in LegalSet;{ pat²í znak do mnoºiny ? }
  231.        GetLegalKey := Key;
  232.     end;
  233.  
  234. function GetString(X,Y,Delka : byte) : Retezec;
  235.     { Delka : délka pole, do kterého se má ²et╪zec vkládat }
  236.  
  237.     function Input(Max : byte;
  238.                   Sl,R : word;
  239.                  var S : Retezec) : char;
  240.     { Funkce  ƒeká  na  vstup  z  klávesnice  a  vrací  znakovou
  241.       reprezentaci stisknuté klávesy. }
  242.     var
  243.        Inp : char;           { vkládan∞ znak }
  244.        Len : byte absolute S;{ aktuální délka vkládaného ²et╪zce}
  245.     begin
  246.        Inp := GetLegalKey([#32..#169, BS, CR]);
  247.        case Inp of
  248.        { jestliºe se stiskne zobraziteln∞ znak ze  spodní  poloviny
  249.          tabulky ASCII a aktuální délka ²et╪zce je menτí neº povolené
  250.          maximum, znak se p²idá do ²et╪zce  a  zobrazí  za  posledním
  251.          znakem ²et╪zce }
  252.          #32..#169 : if Len < Max then
  253.                      begin
  254.                         S := S + Inp;
  255.                         GotoXY(WhereX,WhereY);
  256.                         Write(Inp);
  257.                     end;
  258.          { jestliºe se stiskne klávesa  BackSpace,  poslední  vloºen∞
  259.            znak se vymaºe }
  260.          BS       : if Len>0 then
  261.                     begin
  262.                        Write(Bs+' '+Bs);
  263.                        Delete(S,Len,1);
  264.                     end;
  265.         ESC       : S := ESC;
  266.       end;
  267.       Input := Inp;
  268.     end;
  269.  
  270.     var
  271.        S : Retezec;
  272.        Ch : char;
  273.  
  274.     begin
  275.        S := ''; gotoxy(X,Y);
  276.        repeat
  277.            Ch := Input(Delka,X, Y, S);
  278.        until Ch in [ESC, CR];
  279.        if S <> ESC then
  280.            GetString := S
  281.        else
  282.            GetString := '';
  283.     end;
  284.  
  285.  
  286. function GetChar(Sl, Row : byte) : char;
  287.     { Sl  - ƒíslo sloupce vstupního pole;
  288.       Row - ƒíslo ²ádku vstupního pole }
  289.     var
  290.        S : Retezec;
  291.     begin
  292.        S := GetString(Sl, Row, 1);
  293.        If S[0] <> #0 then
  294.           GetChar := S[1];
  295.     end;
  296.  
  297.  
  298. function GetInteger(Sl,Row,Len : byte;Low,High : integer):integer;
  299.       var
  300.          S : Retezec;         { vstupní ²et╪zec ƒíslic }
  301.          N, R : integer;      { N - v∞sledek zp╪tného p²evodu }
  302.                               { R - kontrolní kód zp╪tného p²evodu }
  303.          Good : boolean;      { pomocná prom╪nná }
  304.       begin
  305.          Good := False;
  306.          repeat
  307.              GotoXY(Sl,Row);Write(' ':Len);
  308.              S := GetString(Sl, Row, Len);  { vstup ƒíslic do ²et╪zce }
  309.              Val(S, N, R);  { p²evod ²et╪zce na ƒíslo typu integer }
  310.              Good := ((N >= Low) and (N <= High) and (R = 0) and
  311.                   (S <> '')); { test správnosti ƒísla }
  312.          until Good;      { opakování vstupu je-li zadání τpatné }
  313.          GetInteger := N;
  314.      end;
  315.  
  316. function GetReal(Sl,Row,Len : byte;Low,High : real):real;
  317.         { Sl     - ƒíslo sloupce, na kterém má vstup zaƒínat;
  318.       Row    - ƒíslo ²ádku, na kterém má vstup zaƒínat;
  319.       Len    - poƒet ƒíslic, které budou zadávány;
  320.       Low    - nejmenτí ƒíslo, které màºe b∞t zadáno;
  321.       High   - nejv╪tτí ƒíslo, které màºe b∞t zadáno:
  322.                Funkce vrací ƒíslo typu real; }
  323.       var
  324.          S : Retezec;         { vstupní ²et╪zec ƒíslic }
  325.          N : real;            { N - v∞sledek zp╪tného p²evodu }
  326.          R : integer;         { R - kontrolní kód zp╪tného p²evodu }
  327.          Good : boolean;      { pomocná prom╪nná }
  328.       begin
  329.          Good := False;
  330.          repeat
  331.              GotoXY(Sl,Row);Write(' ':Len);
  332.              S := GetString(Sl, Row, Len);  { vstup ƒíslic do ²et╪zce }
  333.              Val(S, N, R);  { p²evod ²et╪zce na ƒíslo typu integer }
  334.              Good := ((N >= Low) and (N <= High) and (R = 0) and
  335.                   (S <> '')); { test správnosti ƒísla }
  336.          until Good;      { opakování vstupu je-li zadání τpatné }
  337.          GetReal := N;
  338.      end;
  339.  
  340. Procedure EditString(X,Y,Delka : byte; var st:string);
  341.     { Delka : délka pole, do kterého se má ²et╪zec vkládat }
  342.  
  343.     function Input(Max : byte;
  344.                   Sl,R : word;
  345.                  var S : string) : char;
  346.     { Funkce  ƒeká  na  vstup  z  klávesnice  a  vrací  znakovou
  347.       reprezentaci stisknuté klávesy. }
  348.     var
  349.        Inp : char;           { vkládan∞ znak }
  350.        Len : byte absolute S;{ aktuální délka vkládaného ²et╪zce}
  351.        pos : byte;
  352.     begin
  353.        pos:=whereX-Sl;  {na zaƒátku nula}
  354.        Inp := GetLegalKey([#32..#169, BS, CR, Right, Left, Del]);
  355.        case Inp of
  356.          #32..#169 : if Len < Max then
  357.                      if Pos=Len then
  358.                      begin
  359.                         S := S + Inp;
  360.                         GotoXY(WhereX,WhereY); Write(Inp);
  361.                         inc(pos)
  362.                      end
  363.                      else
  364.                      begin
  365.                        Inc(pos);Insert(Inp,S,Pos);
  366.                        Gotoxy(X,Y);write(S);
  367.                        GotoXY(X+Pos,Y);
  368.                      end;
  369.          BS       : if pos>0 then
  370.                     begin
  371.                        Delete(S,Pos,1);Dec(pos);
  372.                        Gotoxy(X,Y);write(S,' ':max-len);
  373.                        GotoXY(X+Pos,Y)
  374.                     end;
  375.          Del      : if pos<len then
  376.                     begin
  377.                        Delete(S,Pos+1,1);
  378.                        Gotoxy(X,Y);write(S,' ':max-len);
  379.                        GotoXY(X+Pos,Y)
  380.                     end;
  381.          Right    :if pos<Len then begin
  382.                                    Inc(pos);gotoxy(X+pos,Y)
  383.                                    end;
  384.          Left     : if pos>0 then begin
  385.                                    Dec(pos);gotoxy(x+pos,Y)
  386.                                   end;
  387.          ESC       : begin gotoxy(x,y);write(' ':delka);S := ESC;
  388.                      end;
  389.       end;
  390.       Input := Inp;
  391.     end;
  392.  
  393.     var
  394.        S : string;
  395.        Ch : char;
  396.  
  397.     begin
  398.        S := St; gotoxy(X,Y);write(St);gotoxy(X,Y);
  399.        repeat
  400.            Ch := Input(Delka,X, Y, S);
  401.        until Ch in [ESC, CR];
  402.        if S <> ESC then
  403.            St := S
  404.        else
  405.            St := '';
  406.     end;
  407.  
  408. Procedure EditWord(Sl,Row,Len: byte;Low,High,def: word;var w:word);
  409.           {Def - p²eddefinovaná hodnota p²i prázdném vstupu}
  410. var
  411.      S : string;         { vstupní ²et╪zec ƒíslic }
  412.      l :byte absolute S;
  413.      N, R : word;
  414.      Good : boolean;      { pomocná prom╪nná }
  415.   begin
  416.          Good := False;
  417.          if (w<Low) or (w>High) then S:='' else Str(w, S);
  418.          repeat
  419.              GotoXY(Sl,Row);Write(S,' ':len-l);
  420.              EditString(Sl, Row, Len,S);  { vstup ƒíslic do ²et╪zce }
  421.              Val(S, N, R);               { p²evod ²et╪zce na ƒíslo typu word }
  422.              if (r=0) and ((n<Low) or (n>high)) then s:='';    {ƒíslo mimo rozsah}
  423.              Good := ((N >= Low) and (N <= High) and (R = 0))
  424.                      or ((s='') and (r<>0));
  425.              if not good then s:=''
  426.          until Good ;      { opakování vstupu je-li zadání τpatné }
  427.          if S='' then begin N:=def;
  428.                             gotoxy(Sl, Row); write(' ':Len);
  429.                             gotoxy(Sl, Row); write(N);
  430.                       end;
  431.  
  432.          w:=N;
  433.   end;
  434.  
  435. Function  Real2Str(x: real):string;
  436. var s:string;
  437.     i,j:byte;
  438.     nula:boolean;
  439.     len:byte absolute s;        {aktuální délka ²et╪zce S}
  440. begin
  441.      Str(x:1:12,S);
  442.      j:=len+1; nula:=true;
  443.      for i:=len downto 1 do     {najde 1. nev∞znamnou nulu}
  444.          if nula and (s[i]='0') then j:=i else nula:=false;
  445.      Delete(s, j, 20);      {odstraní nev∞znamné nuly na konci}
  446.      if s[len]='.' then Delete(s, j-1, 1);
  447.      Real2Str:=S;
  448. end;
  449.  
  450. Procedure EditReal(Sl,Row,Len: byte;Low,High,def: real;var w:real);
  451.           {Def - p²eddefinovaná hodnota p²i prázdném vstupu}
  452. var
  453.      S : string;         { vstupní ²et╪zec ƒíslic }
  454.      l : byte absolute S;
  455.      N : real;
  456.      R : word;
  457.      Good : boolean;      { pomocná prom╪nná }
  458.   begin
  459.          Good := False;
  460.          if (w<Low) or (w>High) then S:='' else S:=Real2Str(w);
  461.          repeat
  462.              GotoXY(Sl,Row);Write(S,' ':len-l);
  463.              EditString(Sl, Row, Len,S);  { vstup ƒíslic do ²et╪zce }
  464.              R:=Pos(',', S);              {nahrazeni carky teckou}
  465.              if R<>0 then S[R]:='.';
  466.              Val(S, N, R);               { p²evod ²et╪zce na ƒíslo typu real }
  467.              if (r=0) and ((n<Low) or (n>high)) then s:='';    {ƒíslo mimo rozsah}
  468.              Good := ((N >= Low) and (N <= High) and (R = 0))
  469.                      or ((s='') and (r<>0));
  470.              if not good then s:=''
  471.          until Good ;      { opakování vstupu je-li zadání τpatné }
  472.          if S='' then begin N:=def;
  473.                             gotoxy(Sl, Row); write(' ':Len);
  474.                             gotoxy(Sl, Row); write(real2str(N));
  475.                       end;
  476.  
  477.          w:=N;
  478.   end;
  479.  
  480. BEGIN
  481.      JeSaver:=false;
  482.      Timeout:=(Round(55*18.18));
  483. END.