home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / msdos / pascal / ifp1s158 / ifpcomon.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-08-15  |  12.3 KB  |  636 lines

  1. unit ifpcomon;
  2.  
  3. interface
  4.  
  5. uses Crt, Dos, ifpglobl, ifpextrn;
  6.  
  7. function getkey2: char2;
  8. function getnum: word;
  9. procedure caption1(a: string);
  10. procedure caption2(a: string);
  11. procedure caption3(a : string);
  12. function nocarry(regs: registers) : boolean;
  13. function hex(a : word; b : byte) : string;
  14. procedure unknown(a: string; b: word; c: byte);
  15. procedure yesorno(a : boolean);
  16. procedure yesorno2(a: boolean);
  17. procedure yesorno3(a: boolean);
  18. procedure dontknow;
  19. procedure dontknow2;
  20. procedure segofs(a, b : word);
  21. function showchar(a : char) : char;
  22. function power2(y: word): longint;
  23. procedure pause1;
  24. procedure pause2;
  25. procedure pause3(extra: integer);
  26. procedure pause4(direc: directions; var ch2: char2);
  27. procedure pause5(direc: directions; var ch2: char2);
  28. function bin4(a: byte) : string;
  29. procedure offoron(a: string; b: boolean);
  30. procedure zeropad(a: word);
  31. procedure zeropad3(a: word);
  32. procedure showvers;
  33. function cbw(a, b: byte) : word;
  34. function bin16(a: word) : string;
  35. procedure drvname(a: byte);
  36. procedure media(a, b: byte);
  37. procedure pagenameclr;
  38. procedure Intr(intno: byte; var regs: registers);
  39. procedure MsDos(var regs: registers);
  40. procedure TextColor(color: byte);
  41. procedure TextBackground(color: byte);
  42. function unBCD(b: byte): byte;
  43. function addzero(b: byte): string;
  44. procedure modeinfo(var vidmode, vidlen, vidpg: byte; var vidwid: word);
  45. procedure box;
  46. procedure center(s: string);
  47. function EMSOK: boolean;
  48.  
  49. implementation
  50.  
  51. uses ifpscrpt, ifphelp;
  52.  
  53. function getkey2: char2;
  54.   var
  55.     c: char;
  56.     c2: char2;
  57.  
  58.   begin
  59.   c:=ReadKey;
  60.   if c = #0 then
  61.     getkey2:=c + ReadKey
  62.   else
  63.     getkey2:=c;
  64.   end; {getkey2}
  65.  
  66. {^Make sure number entered, not any letters}
  67. function getnum: word;
  68.   var
  69.     inpchar: char;
  70.     number_string: string[2];
  71.     temp, position, code: word;
  72.     row, col: byte;
  73.     finish: boolean;
  74.  
  75.   begin
  76.   row:=WhereY;
  77.   col:=WhereX;
  78.   Write(' ':3);
  79.   GotoXY(col, row);
  80.   temp:=99;
  81.   finish:=false;
  82.   position:=0;
  83.   number_string:='';
  84.   TextColor(LightGray);
  85.   repeat
  86.     inpchar:=ReadKey;
  87.     case inpchar of
  88.       '0'..'9':if position < 2 then
  89.         begin
  90.         Inc(position);
  91.         Inc(number_string[0]);
  92.         number_string[position]:=inpchar;
  93.         Write(inpchar)
  94.         end;
  95.       #8: if position > 0 then
  96.         begin
  97.         Dec(position);
  98.         Dec(number_string[0]);
  99.         Write(^H' '^H)
  100.         end;
  101.       #27: if number_string = '' then
  102.           finish:=true
  103.         else
  104.           begin
  105.           number_string:='';
  106.           GotoXY(col, row);
  107.           ClrEol;
  108.           position:=0
  109.           end;
  110.       #13: finish:=true
  111.     end {case}
  112.   until finish;
  113.   if number_string <> '' then
  114.     Val(number_string, temp, code)
  115.   else
  116.     temp:=999;
  117.   getnum:=temp
  118.   end; {getnum}
  119.  
  120. procedure caption1(a: string);
  121.   begin
  122.   textcolor(LightGray);
  123.   Write(a);
  124.   textcolor(LightCyan)
  125.   end; {caption1}
  126.  
  127. procedure caption2(a: string);
  128.   const
  129.     capterm = ': ';
  130.  
  131.   var
  132.     i: byte;
  133.     xbool: boolean;
  134.  
  135.   begin
  136.   i:=length(a);
  137.   while (i > 0) and (a[i] = ' ') do
  138.     dec(i);
  139.   insert(capterm, a, i + 1);
  140.   caption1(a)
  141.   end; {caption2}
  142.  
  143. procedure caption3(a : string);
  144.   begin
  145.   caption2('  ' + a)
  146.   end; {caption3}
  147.  
  148. function nocarry(regs: registers) : boolean;
  149.   begin
  150.   nocarry:=regs.flags and fcarry = $0000
  151.   end; {nocarry}
  152.  
  153. function hex(a : word; b : byte) : string;
  154.   const
  155.     digit : array[$0..$F] of char = '0123456789ABCDEF';
  156.  
  157.   var
  158.     i : byte;
  159.     xstring : string;
  160.  
  161.   begin
  162.   xstring:='';
  163.   for i:=1 to b do
  164.     begin
  165.     insert(digit[a and $000F], xstring, 1);
  166.     a:=a shr 4
  167.     end;
  168.   hex:=xstring
  169.   end; {hex}
  170.  
  171. procedure unknown(a: string; b: word; c: byte);
  172.   begin
  173.   Writeln('(unknown', ' ', a, ' ', hex(b, c), ')')
  174.   end; {unknown}
  175.  
  176. procedure yesorno(a : boolean);
  177.   begin
  178.   if a then
  179.     Writeln('yes')
  180.   else
  181.     Writeln('no')
  182.   end; {yesorno}
  183.  
  184. procedure yesorno2(a: boolean);
  185.   begin
  186.   if a then
  187.     Write('yes')
  188.   else
  189.     Write('no')
  190.   end; {yesorno2}
  191.  
  192. procedure YesOrNo3(a: boolean);
  193.   begin
  194.   YesOrNo2(a);
  195.   if not a then
  196.     Write(' ');
  197.   end;
  198.  
  199. procedure dontknow;
  200.   begin
  201.   Writeln('(unknown)')
  202.   end; {dontknow}
  203.  
  204. procedure dontknow2;
  205.   begin
  206.   Write('(unknown)')
  207.   end; {dontknow2}
  208.  
  209. procedure segofs(a, b : word);
  210.   begin
  211.   Write(hex(a, 4), ':', hex(b, 4))
  212.   end; {segofs}
  213.  
  214. function showchar(a : char) : char;
  215.   begin
  216.   if a in pchar then
  217.     showchar:=a
  218.   else
  219.     showchar:='.'
  220.   end; {showchar}
  221.  
  222. function power2(y: word): longint;
  223.   begin
  224.   power2:=Trunc(exp((y * 1.0) * ln(2.0)))
  225.   end;
  226.  
  227. procedure pause1;
  228.   var
  229.     xbyte : byte;
  230.     xchar : char2;
  231.     SaveX, SaveY: byte;
  232.  
  233.   begin
  234.   xbyte:=TextAttr;
  235.   endit:=false;
  236.   TextColor(Cyan);
  237.   SaveX:=WhereX;
  238.   SaveY:=WhereY;
  239.   Write('( for more)');
  240.   if PrinterRec.Mode = 'A' then
  241.     ScreenPrint(Pg, PgNames[Pg], VerNum)
  242.   else
  243.     begin
  244.     repeat
  245.       xchar:=getkey2;
  246.       if xchar = #0#25 then
  247.         begin
  248.         ScreenPrint(Pg, PgNames[Pg], VerNum);
  249.         xchar:=#0#0
  250.         end;
  251.       if xchar = #0#$3B then
  252.         begin
  253.         HelpScreen(Pg, HelpVersion);
  254.         xchar:=#0#0
  255.         end;
  256.     until xchar <> #0#0;
  257.     if xchar <> #0#80 then
  258.       begin
  259.       endit:=true;
  260.       c2:=xchar
  261.       end;
  262.     end;
  263.   TextAttr:=xbyte;
  264.   GotoXY(SaveX, SaveY);
  265.   Write('            ')
  266.   end; {pause1}
  267.  
  268. procedure pause2;
  269.   var
  270.     xbyte : byte;
  271.  
  272.   begin
  273.   if WhereY + hi(WindMin) > hi(WindMax) then
  274.     begin
  275.     xbyte:=TextAttr;
  276.     TextColor(Cyan);
  277.     pause1;
  278.     if not endit then
  279.       begin
  280.       Clrscr;
  281.       Writeln('(continued)');
  282.       end;
  283.     TextAttr:=xbyte
  284.     end
  285.   end; {pause2}
  286.  
  287. procedure pause3(extra: integer);
  288.   var
  289.     xbyte: byte;
  290.   begin
  291.   endit:=false;
  292.   if WhereY + Hi(WindMin) + Abs(extra) > Hi(WindMax) then
  293.     begin
  294.     xbyte:=TextAttr;
  295.     TextColor(Cyan);
  296.     pause1;
  297.     if not endit then
  298.       begin
  299.       ClrScr;
  300.       if extra < 0 then
  301.         Writeln('(continued)');
  302.       end;
  303.     TextAttr:=xbyte
  304.     end
  305.   end; {pause3}
  306.  
  307. procedure pause4(Direc: Directions; var ch2: char2);
  308.   var
  309.     xbyte : byte;
  310.     xchar : char2;
  311.     SaveX, SaveY: byte;
  312.  
  313.   begin
  314.   xbyte:=TextAttr;
  315.   endit:=false;
  316.   TextColor(Cyan);
  317.   SaveX:=WhereX;
  318.   SaveY:=WhereY;
  319.   case Direc of
  320.     none:   Write('(any key)');
  321.     up:     Write('( for more)');
  322.     down:   Write('( for more)');
  323.     updown: Write('( or  for more)')
  324.   end;
  325.   repeat
  326.     if PrinterRec.Mode = 'A' then
  327.       if Direc = up then
  328.         xchar:=#0#81
  329.       else
  330.         begin
  331.         ScreenPrint(Pg, PgNames[Pg], VerNum);
  332.         xchar:=#0#80;
  333.         end
  334.     else
  335.       begin
  336.       xchar:=getkey2;
  337.       if xchar = #0#25 then
  338.         begin
  339.         ScreenPrint(Pg, Pgnames[Pg], VerNum);
  340.         xchar:=#0#0
  341.         end;
  342.       if xchar = #0#$3B then
  343.         begin
  344.         HelpScreen(Pg, HelpVersion);
  345.         xchar:=#0#0
  346.         end;
  347.       end;
  348.   until xchar <> #0#0;
  349.   if (xchar[1] <> #0) or
  350.     ((xchar[1] = #0) and (not (xchar[2] in [#80, #72]))) then
  351.     begin
  352.     endit:=true;
  353.     c2:=xchar;
  354.     end;
  355.   TextAttr:=xbyte;
  356.   GotoXY(SaveX, SaveY);
  357.   Write('                 ');
  358.   ch2:=xchar;
  359.   end; {pause4}
  360.  
  361. procedure pause5(direc: directions; var ch2: char2);
  362.   var
  363.     xbyte : byte;
  364.  
  365.   begin
  366.   ch2:=#0#0;
  367.   if WhereY + Hi(WindMin) > Hi(WindMax) then
  368.     begin
  369.     xbyte:=TextAttr;
  370.     TextColor(Cyan);
  371.     Pause4(direc, ch2);
  372.     if not endit then
  373.       Clrscr;
  374.     TextAttr:=xbyte
  375.     end
  376.   end; {pause5}
  377.  
  378. function bin4(a : byte) : string;
  379.   const
  380.     digit : array[0..1] of char = '01';
  381.  
  382.   var
  383.     xstring : string;
  384.     i : byte;
  385.  
  386.   begin
  387.   xstring:='';
  388.   for i:=3 downto 0 do
  389.     begin
  390.     insert(digit[a mod 2], xstring, 1);
  391.     a:=a shr 1
  392.     end;
  393.   bin4:=xstring
  394.   end; {bin4}
  395.  
  396. procedure offoron(a : string; b : boolean);
  397.   begin
  398.   caption3(a);
  399.   if b then
  400.     Write('on')
  401.   else
  402.     Write('off')
  403.   end; {offoron}
  404.  
  405. procedure zeropad(a : word);
  406.   begin
  407.   if a < 10 then
  408.     Write('0');
  409.   Write(a)
  410.   end; {zeropad}
  411.  
  412.  procedure zeropad3(a: word);
  413.    begin
  414.    if a < 10 then
  415.      Write('00')
  416.    else
  417.      if a < 100 then
  418.        Write('0');
  419.    Write(a)
  420.    end; {zeropad3}
  421.  
  422. procedure showvers;
  423.   begin
  424.   if osmajor > 0 then
  425.     Writeln(osmajor, decimal, addzero(osminor))
  426.   else
  427.     Writeln('1', decimal, 'x')
  428.   end; {showvers}
  429.  
  430. function cbw(a, b : byte) : word;
  431.   begin
  432.   cbw:=word(b) shl 8 + a
  433.   end; {cbw}
  434.  
  435. function bin16(a : word) : string;
  436.   function bin8(a : byte) : string;
  437.     begin
  438.     bin8:=bin4(a shr 4) + '_' + bin4(a and $0F)
  439.     end; {bin8}
  440.  
  441.   begin {bin16}
  442.   bin16:=bin8(hi(a)) + '_' + bin8(lo(a))
  443.   end; {bin16}
  444.  
  445. procedure drvname(a : byte);
  446.   begin
  447.   Write(chr(ord('A') + a), ': ')
  448.   end; {drvname}
  449.  
  450. procedure media(a, b : byte);
  451.   procedure diskette(a, b, c : byte);
  452.     begin
  453.     Writeln('floppy ', a, ' side, ', b, ' sctr, ', c, ' trk')
  454.     end; {diskette}
  455.  
  456.   begin {media}
  457.   caption3('Media');
  458.   case a of
  459.     $FF : diskette(2, 8, 40);
  460.     $FE : diskette(1, 8, 40);
  461.     $FD : diskette(2, 9, 40);
  462.     $FC : diskette(1, 9, 40);
  463.     $F9 : if b = 1 then
  464.       diskette(2, 15, 80)
  465.     else
  466.       diskette(2, 9, 80);
  467.     $F8 : Writeln('fixed disk');
  468.     $F0 : diskette(2, 18, 80)
  469.     else
  470.       unknown('media', a, 2)
  471.   end
  472.   end; {media}
  473.  
  474. procedure pagenameclr;
  475.   var
  476.     xbyte: byte;
  477.  
  478.   begin
  479.   xbyte:=TextAttr;
  480.   Window(x1, tlength, x2 - 1, tlength);
  481.   TextColor((TextAttr and $70) shr 4);
  482.   ClrScr;
  483.   TextAttr:=xbyte;
  484.   Window(1, 1, twidth, tlength)
  485.   end; {pagenameclr}
  486.  
  487. procedure Intr(intno: byte; var regs: registers);
  488.   begin
  489.   AltIntr(intno, regs)
  490.   end;
  491.  
  492. procedure MsDos(var regs: registers);
  493.   begin
  494.   AltMsDos(regs)
  495.   end;
  496.  
  497. {These first two procedures filter the color commands to allow Black&White}
  498. procedure TextColor(color: byte);
  499.   var
  500.     temp: byte;
  501.   begin
  502.   if mono then
  503.     begin
  504.     case (color and $0F) of
  505.       0: temp:=0;
  506.       1..7: temp:=7;
  507.       8..15: temp:=15
  508.       end;
  509.     if color > 15 then
  510.       temp:=temp + Blink;
  511.     end
  512.   else
  513.     temp:=color;
  514.   Crt.TextColor(temp)
  515.   end; {TextColor}
  516.  
  517. procedure TextBackground(color: byte);
  518.   var
  519.     temp: byte;
  520.   begin
  521.   temp:=color;
  522.   if mono and (color < 7) then
  523.     temp:=0;
  524.   Crt.TextBackground(temp);
  525.   end; {TextBackground}
  526.  
  527. function unBCD(b: byte): byte;
  528.   begin
  529.   unBCD:=(b and $0F) + ((b shr 4) * 10)
  530.   end; {unBCD}
  531.  
  532. function addzero(b: byte): string;
  533.   var
  534.     c2: string[2];
  535.   begin
  536.   Str(b:0, c2);
  537.   if b < 10 then
  538.     c2:='0' + c2;
  539.   addzero:=c2
  540.   end; {addzero}
  541.  
  542. procedure modeinfo(var vidmode, vidlen, vidpg: byte; var vidwid: word);
  543.   var
  544.     regs: registers;
  545.  
  546.   begin
  547.   with regs do
  548.     begin
  549.     AH:=$0F;
  550.     Intr($10, regs);
  551.     vidmode:=AL;
  552.     vidwid:=AH;
  553.     vidpg:=BH;
  554.     AX:=$1200;
  555.     BL:=$10;
  556.     Intr($10, regs);
  557.     if BL = $10 then
  558.       vidlen:=25
  559.     else
  560.       vidlen:=Mem[$40:$84] + 1;
  561.     end
  562.   end; {modeinfo}
  563.  
  564. procedure box;
  565.   const
  566.     frame: array[1..8] of char = '╔═╗║║╚═╝';
  567.   var
  568.     h, w, x, y: word;
  569.  
  570.   begin
  571.   w:=Lo(WindMax) - Lo(WindMin) + 1;
  572.   h:=Hi(WindMax) - Hi(WindMin) + 1;
  573.   Inc(WindMax, $0101);
  574.   GotoXY(1, 1);
  575.   Write(frame[1]);
  576.   for x:=2 to w - 1 do
  577.     Write(frame[2]);
  578.   GotoXY(w, 1);
  579.   Write(frame[3]);
  580.   for y:=2 to h - 1 do
  581.     begin
  582.     GotoXY(1, y);
  583.     Write(frame[4]);
  584.     GotoXY(w, y);
  585.     Write(frame[5]);
  586.     end;
  587.   GotoXY(1, h);
  588.   Write(frame[6]);
  589.   GotoXY(2, h);
  590.   for x:=2 to w-1 do
  591.     Write(frame[7]);
  592.   GotoXY(w, h);
  593.   Write(frame[8]);
  594.   Dec(WindMax, $0202);
  595.   Inc(WindMin, $0101);
  596.   end;
  597.  
  598. procedure center(s: string);
  599.   var
  600.     x, halfwidth, halfstr: integer;
  601.  
  602.   begin
  603.   halfwidth:=(Lo(WindMax) - Lo(WindMin)) div 2;
  604.   halfstr:=Length(s) div 2;
  605.   if (halfwidth - halfstr) > 0 then
  606.     for x:=1 to (halfwidth - halfstr) do
  607.       Write(' ');
  608.   Write(s);
  609.   end;
  610.  
  611. function EMSOK: boolean;
  612.   var
  613.     S: string;
  614.     EMSSeg, Address: word;
  615.     Regs: Registers;
  616.  
  617.   begin
  618.   EMSOK:=false;
  619.   if longint(IntVec[$67]) <> 0 then
  620.     begin
  621.     EMSSeg:=longint(IntVec[$67]) shr 16;
  622.     S:='';
  623.     for Address:=$A to $11 do
  624.       S:=S + Chr(Mem[EMSSeg:Address]);
  625.     if S = 'EMMXXXX0' then
  626.       with Regs do
  627.         begin
  628.         AH:=$40;
  629.         Intr($67, regs);
  630.         if AH = 0 then
  631.           EMSOK:=true;
  632.         end;
  633.     end;
  634.   end;
  635.  
  636. end.