home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / PASCAL / DUMPING / ALTCRT2.PAS < prev    next >
Pascal/Delphi Source File  |  1995-03-24  |  67KB  |  2,228 lines
  1. Unit  AltCrt2 ;
  2.  
  3. {
  4.    Copyright (c) 1991-1995 by Oliver Fromme <fromme@rz.tu-clausthal.de>.
  5.    Freely usable, freely distributable.
  6.  
  7.    Last edit:  3-Feb-1995  Oliver Fromme
  8.  
  9.    This unit is intended to be used for Borland/Turbo Pascal 7.0.
  10.    It provides a lot of utility routines which are very useful in the
  11.    everyday life of every Pascal programmer.  Once you get used to it,
  12.    you'll never want to miss it.
  13.    Sorry, all comments are currently in German, but you should be able
  14.    to figure out what each of the procs/funcs is good for.  If you really
  15.    need a translation, ask me and I'll probably translate it.
  16.  
  17.    Important:  Do not use both Crt and AltCrt2 at the same time!
  18. }
  19.  
  20. {$A+,B-,D+,E-,F-,G+,I-,L+,N-,O-,P+,Q-,R-,S-,T-,V+,X+,Y+}
  21.  
  22. {---------------------------------------------------------------------------}
  23.  
  24. Interface
  25.  
  26. Uses  Dos,Strings ;
  27.  
  28. Const  EarthExists   = True ;  {z.B. für `While EarthExists Do' :-)  }
  29.        EndOfUniverse = False ; {z.B. für `Repeat Until EndOfUniverse' :-)  }
  30.        EmptyString   = '' ;
  31.        CrLf          = #13#10 ; {Carriage Return + Line Feed}
  32.  
  33. Type  ExText  = File ;   {Für ExWriteLn/ExReadLn, siehe unten.}
  34.       Str2    = String[2] ;   {Für die Byte-Hex-Funktionen.}
  35.       Str4    = String[4] ;   {Für die Word-Hex-Funktionen.}
  36.       Str8    = String[8] ;   {Für die LongInt-Hex-Funktionen.}
  37.       Str10   = String[10] ;  {Für die Lead-Funktionen.}
  38.       NExtStr = String[12] ;  {Für Dateinamen mit Extension.}
  39.  
  40. Var  TextAttr  : Byte ;   {Wird bei Read/Write ignoriert.}
  41. Var  MaxX,MaxY : Word ;   {Werden beim Start initialisiert, Zählung
  42.                            beginnt bei 0. Werden auch bei speziellen
  43.                            SVGA-Modi richtig gesetzt (z.B. 99/39 im
  44.                            Modus 100x40 des Tseng-ET4000).}
  45. Var  mx,my : Word ;   {Enthält die Mauskoordinaten des letzten Aufrufes
  46.                        von GetMouse, siehe unten.}
  47.  
  48. {Die folgenden Prozeduren/Funktionen sind funktionell mit denen von
  49.  Crt identisch. Man beachte die folgenden Punkte:
  50.     - TextAttr wird bei Read/Write ignoriert.
  51.     - Aktuelles Window ist stets der ganze Bildschirm.
  52.     - Read/Write erfolgt über DOS, d.h. Umleitungen und Pipes sind möglich.
  53.     - Alle anderen Bildschirm-Funktionen erfolgen über das BIOS,
  54.       d.h. sie funktionieren auch in SVGA-Modi, die das jeweilige VGA-BIOS
  55.       unterstützt. TextAttr wird berücksichtigt.
  56.     - KeyPressed und ReadKey verwenden Int16, d.h. sie sind systemkonform.
  57.     - Delay ist unabhängig von Rechnertyp und Takfrequenz, die Abweichung
  58.       beträgt nur wenige Taktzyklen.}
  59.  
  60. Procedure  ClrScr ;
  61. Procedure  GotoXY (x,y : Byte) ;
  62. Function   WhereX : Byte ;
  63. Function   WhereY : Byte ;
  64. Procedure  InsLine ;
  65. Procedure  DelLine ;
  66. Function   KeyPressed : Boolean ;
  67. Function   ReadKey : Char ;
  68. Procedure  Sound (Hz : Word) ;
  69. Procedure  NoSound ;
  70. Procedure  Delay (w : Word) ;
  71.  
  72. {Die folgenden Prozeduren/Funktionen sind im Standard-Crt nicht
  73.  implementiert, sind aber ganz brauchbar und gehören thematisch
  74.  hierher. TextAttr wird, wo sinnvoll, beachtet.}
  75.  
  76. Procedure  FeedKey (k : Char) ;
  77.    {Täuscht den Tastendruck 'k' (ASCII) vor.  KeyPressed liefert dann
  78.     solange True, bis man den Tastendruck mit ReadKey abgeholt hat.}
  79. Procedure  ClrLine ;
  80.    {Löscht die Zeile, in der der Cursor steht. Kein Scrolling.
  81.     Cursorposition bleibt unverändert.}
  82. Procedure  ClrLines (yy1,yy2 : Integer) ;
  83.    {Löscht die Zeilen yy1 bis yy2, Zählung beginnt bei 0. Kein Scrolling.
  84.     Cursorposition wird an den Anfang der ersten gelöschten Zeile gesetzt.}
  85. Procedure  Center (s : String) ;
  86. Procedure  LeftAlign (s : String) ;
  87. Procedure  RightAlign (s : String) ;
  88.    {Diese drei Prozeduren schreiben den angegebenen String zentriert, links-
  89.     bzw. rechtsbündig in die aktuelle Bildschirmzeile. Direktzugriff auf
  90.     Bildschrimspeicher, funktioniert nur bei Farb-Karten!
  91.     TextAttr wird beachtet. Cursorposition bleibt unverändert.}
  92. Procedure  ClrKeyBuf ;
  93.    {Der Tastaturpuffer wird geleert.}
  94. Function   Counter : Word ;
  95.    {Für sehr feine Zeitmessungen: Liefert den momentanen Zählerstand
  96.     von Timer 0, wird 1.193.180 mal pro Sekunde dekrementiert. Ein
  97.     Unterlauf tritt 18,2 mal pro Sekunde auf.
  98.     Benötigt nur 29 Taktzyklen (80386, ohne call/ret).}
  99. Function   LCounter : LongInt ;
  100.    {Dito, für längere, aber genauso feine Zeitmessungen. Ein Unterlauf
  101.     tritt genau 1 mal pro Stunde auf. Auch negative Werte möglich.
  102.     Benötigt 51 Taktzyklen (80386, ohne call/ret).}
  103. Procedure  Beep ;
  104.    {Gibt einen Ton von 1000 Hz für 100 ms aus.}
  105. Procedure  Buup ;
  106.    {Gibt einen Ton von 450-250 Hz für 200 ms aus (z.B. bei Fehler).}
  107. Procedure  WaitVerticalRetrace ;
  108.    {Wartet darauf, daß der Elektronenstrahl am unteren Bildrand angekommen
  109.     ist und zum Bildanfang zurückkehrt. Befindet sich der Elektronenstrahl
  110.     bereits auf der Rückkehr, wird bis zum nächsten Bildende gewartet.
  111.     Funktioniert sowohl im Text- als auch im Grafikmodus.
  112.     Kann z.B. verwendet werden, um Bildschirmaktionen flackerfrei zu
  113.     gestalten, oder um die Videofrequenz zu messen.}
  114. Procedure  WriteStdErr (Const s : String) ;
  115.    {Schreibt s direkt auf den Bildschirm, eine eventuelle Umleitung der
  116.     Ausgabe via DOS wird ignoriert.}
  117.  
  118. {---------------------------------------------------------------------------}
  119.  
  120. {Die folgenden Prozeduren/Funktionen stammen ursprünglich aus der Unit
  121.  AllgUtil. Sie implementieren alle möglichen nützlichen Sachen.}
  122.  
  123. {Allgemeine/Sonstiges}
  124.  
  125. Procedure Nothing ; Inline ($90) ; {"Fast" nichts (2 Taktzyklen).}
  126.    {Nützlich für Konstrukte wie "While ... Do Nothing".}
  127. Procedure  Move (Var Source,Dest ; Count : Word) ;
  128.    {Schneller als das Original, da 16-Bit-Transfer verwendet wird.}
  129. Procedure  FillByte (Var X ; Count : Word ; Value : Byte) ;
  130.    {Entspricht FillChar, ist aber schneller (16-Bit-Transfer).
  131.     Value darf nur ein Byte-Typ sein, bei Char-Typen muß man ein
  132.     Typecasting Char(...) verwenden.}
  133. Procedure  FillWord (Var X ; Count : Word ; Value : Word) ;
  134. Procedure  Fill3Byt (Var X ; Count : Word ; Value : LongInt) ;
  135. Procedure  FillLong (Var X ; Count : Word ; Value : LongInt) ;
  136.    {Dito für 2-, 3- und 4-Byte-Variablen.}
  137. Procedure  FillGen (Var X ; Count : Word ; Value : LongInt ; size : Byte) ;
  138.    {Dito, allgemeine Version (size = Größe der Variablen in Byte).}
  139. Function  Quest (Cond : Boolean ; a,b : LongInt) : LongInt ;
  140.    {Entspricht dem "?:"-Operator in C: liefert a, wenn Cond=True, sonst b.}
  141. Function  CQuest (Cond : Boolean ; a,b : Char) : Char ;
  142.    {Dito für Char-Typen.}
  143. Function  SQuest (Cond : Boolean ; Const a,b : String) : String ;
  144.    {Dito für String-Typen.}
  145. Function  Quest2 (Cond1,Cond0 : Boolean ; a00,a01,a10,a11 : LongInt) : LongInt ;
  146.    {Entsprechend für zwei Bedingungen.}
  147. Function  LoCase (c : Char) : Char ;
  148.    {Wandelt Groß- in Kleinbuchstaben, analog zu UpCase.}
  149. Function  UpperCase (Const s : String) : String ;
  150.    {Liefert den String in Großbuchstaben.}
  151. Function  LowerCase (Const s : String) : String ;
  152.    {Liefert den String in Kleinbuchstaben.}
  153. Function  IDist (i1,i2,x : LongInt) : LongInt ;
  154.    {Abstand von x vom Intervall [i1,i2] (mit i1<=i2).
  155.     Es gilt:  Diff (a,x) = IDist (a,a,x).}
  156. Function  Bound (x,min,max : LongInt) : LongInt ;
  157. Function  Max (w1,w2 : LongInt) : LongInt ;
  158. Function  Min (w1,w2 : LongInt) : LongInt ;
  159. Function  Even (x : LongInt) : Boolean ;
  160. Function  ggT (a,b : LongInt) : LongInt ;
  161. Function  kgV (a,b : LongInt) : LongInt ;
  162. Function  Sgn (x : LongInt) : ShortInt ; {-1, 0, 1}
  163. Function  Diff (a,b : LongInt) : LongInt ; {a-b bzw. b-a}
  164.    {-Ohne Worte-}
  165.  
  166. {Utilities für DOS}
  167.  
  168. Function  GetPDir  (Const n : String) : DirStr ;
  169.    {Liefert Laufwerk+Verzeichnis einer Pfadangabe (incl. "\").}
  170. Function  GetRawDir  (Const n : String) : DirStr ;
  171.    {Liefert  das Verzeichnis (ohne Laufwerk und ohne "\").}
  172. Function  GetName  (Const n : String) : NameStr ;
  173.    {Liefert den Namen einer Pfadangabe (ohne Suffix, max. 8 Zeichen).}
  174. Function  GetExt   (Const n : String) : ExtStr ;
  175.    {Liefert den Suffix einer Pfadangabe (incl. ".", max. 4 Zeichen).}
  176. Function  GetXt   (Const n : String) : ExtStr ;
  177.    {Liefert den Suffix einer Pfadangabe (ohne ".", max. 3 Zeichen).}
  178. Function  GetNExt  (Const n : String) : NExtStr ;
  179.    {Liefert Namen+Suffix einer Pfadangabe (max 12 Zeichen).}
  180. Function  GetDName (Const n : String) : PathStr ;
  181.    {Liefert Verzeichnis+Name einer Pfadangabe (ohne Suffix).}
  182. Function  GetDrive (Const n : String) : Str2 ;
  183.    {Liefert das Laufwerk einer Pfadangabe, z.B. 'C:'.}
  184. Function  ExtPath  (Const n,e : String) : PathStr ;
  185.    {Liefert n, falls n ein Suffix enthält (auch leer, d.h. "XXX."),
  186.     ansonsten n+'.'+e.}
  187. Function  NormName (n : NExtStr) : NExtStr ;
  188.    {Fügt in einen Dateinamen Leerzeichen (und eventuell einen Punkt) ein,
  189.     um ihn auf eine Länge von 12 Zeichen zu bringen.}
  190. Function  NormDirn (Const n : NExtStr) : NExtStr ;
  191.    {Dito, ersetzt den Punkt aber durch ein Leerzeichen, falls kein Suffix
  192.     vorhanden ist, außerdem Sonderbehandlung für '.' und '..'.}
  193. Procedure  NormDir (Var d : DirStr) ;
  194. Function   fNormDir (Const d : DirStr) : DirStr ;
  195.    {Hängt an d nötigenfalls ein '\' an.}
  196. Function  NormChDir (d : DirStr) : DirStr ;
  197.    {Entfernt ein angehängtes '\', falls nicht das Wurzelverzeichnis gemeint
  198.     ist. Dos.ChDir und Exists benötigen diese Form.}
  199. Function  WildExpand (n : NExtStr) : NExtStr ;
  200.    {Normalisiert (siehe NormName) und expandiert '*' zu '?'.}
  201. Function  Matches (n : NExtStr ; Const mask : NExtStr) : Boolean ;
  202.    {Liefert True, wenn n der Maske mask entspricht, letztere darf '?',
  203.     aber nicht '*' enthalten, und muß die Länge 12 haben (siehe WildExpand).}
  204. Function  TempDir : PathStr ;
  205.    {Liefert Namen eines Temp-Dirs incl. '\'.}
  206. Type  PathProc = Procedure (Dir : DirStr ; Fil : SearchRec) ;
  207. Const  Recursive    = 1 ;
  208. Function  ProcessFiles (Const mask : PathStr ; opt : Word ; job : PathProc)
  209.           : LongInt ;
  210.    {Führt die Prozedur job für jede Datei aus, die zum Muster mask paßt
  211.     (kann '?' und/oder '*' enthalten).  Für opt können eine oder mehrere der
  212.     folgenden Optionen verwendet werden:
  213.      - Recursive: es werden ebenfalls die Inhalte aller Unterverzeichnisse
  214.                   rekursiv bearbeitet.
  215.     Funktionsergebnis ist die Anzahl der bearbeiteten Dateien (= Anzahl
  216.     der Aufrufe von job), was natürlich auch 0 sein kann (wenn keine
  217.     passenden Dateien gefunden wurden).
  218.     Das an die job-Prozedur übergebene Dir endet immer mit einem '\'.}
  219. Function  PathEq   (n : String) : PathStr ;
  220.    {Hängt an n soviele Leerzeichen an, daß es lang ist wie bei
  221.     maximaler Ausnutzung der Dateinamenlänge.}
  222. Procedure  ChangeDir (d : String) ;
  223.    {Wechselt das aktuelle Verzeichnis. Im Gegensatz zu System.ChDir wird aber
  224.     nicht das aktuelle Laufwerk gewechselt, falls d eine Laufwerksangabe
  225.     enthält, sondern nur das aktuelle Verzeichnis auf dem angegebenen
  226.     Laufwerk. Trailing '\' ist egal.}
  227. Function  QuietFileSize (Const n : PathStr) : LongInt ;
  228.    {Liefert die Größe der Datei in Bytes, ohne daß die Datei geöffnet wird.
  229.     Ergebnis ist -1 bei einem Verzeichnis oder Volume Label, -2 bei einem
  230.     Fehler (siehe Dos.DosError).}
  231. Function  Exists   (Const n : String) : Boolean ;
  232.    {Liefert True, falls n existiert (File, Verzeichnis, Volume Label).}
  233. Function  IsDir    (Const n : String) : Boolean ;
  234.    {Liefert True, falls n existiert und ein Verzeichnis ist.}
  235. Function  IsFile   (Const n : String) : Boolean ;
  236.    {Liefert True, falls n existiert und eine Datei ist.}
  237. Function  IsEmpty  (n : DirStr) : Boolean ;
  238.    {Liefert True, falls das Verzeichnis n (mit oder ohne abschließenden
  239.     "\") leer ist (bis auf "." und "..").}
  240. Function  Writeable (d : Char) : Boolean ;
  241.    {Liefert True, falls man auf das Laufwerk d schreibend zugreifen kann.
  242.     Liefert False, wenn das Laufwerk nicht existiert oder schreibgeschützt
  243.     ist (z.B. CD-ROMs).}
  244. Function  IsOpenFile (Var f : File) : Boolean ;
  245.    {Liefert True, falls die Datei noch offen ist.
  246.     Achtung: Assign (f,...) muß ausgeführt sein!}
  247. Function  IsOpenText (Var f : Text) : Boolean ;
  248.    {Dito für Textfiles.}
  249.  
  250. {Weitere Utilities zur Ein-/Ausgabe}
  251.  
  252. Procedure ExWriteLn (Var f : ExText ; s : String) ;
  253.    {WriteLn für eine untypisierte Datei (File).
  254.     Muß mit Reset/ReWrite (f,1) geöffnet worden sein.}
  255. Procedure ExReadLn  (Var f : ExText ; Var s : String) ;
  256.    {ReadLn für eine untypisierte Datei (File).
  257.     Muß mit Reset/ReWrite (f,1) geöffnet worden sein.}
  258. Function  TextFilePos (Var t : Text) : LongInt ;
  259.    {FilePos für Text-Dateien.}
  260. Function  TextFileSize (Var t : Text) : LongInt ;
  261.    {FileSize für Text-Dateien.}
  262. Procedure  TextSeek (Var t : Text ; Pos : LongInt) ;
  263.    {Seek für Text-Dateien. Diese Prozedur und die vorhergehenden beiden
  264.     Funktionen können genauso angewendet werden wie ihre entsprechenden
  265.     Gegenstücke für nicht-Text-Dateien (aus der Unit DOS); Fehler können
  266.     wie gewohnt mit IOResult abgefragt werden.}
  267. Procedure WaitKey ;
  268.    {Wartet auf einen beliebigen Tastendruck.
  269.     Der Tastaturpuffer wird vorher und hinterher gelöscht.}
  270. Function  GetOption (s : String) : Char ;
  271.    {Wartet auf ein Taste, deren ASCII-Code in s enthalten ist.
  272.     Das Zeichen wird zurückgegeben und außerdem auf dem Bildschirm
  273.     ausgegeben. Kleinbuchstaben werden in Großbuchstaben gewandelt.
  274.     Der Tastaturpuffer wird vorher und hinterher gelöscht.}
  275. Function  GetQuietOption (s : String) : Char ;
  276.    {Dito, ohne Bildschirmausgabe.}
  277. Function  GetJaNein : Boolean ;
  278.    {Spezialfall: "GetJaNein := GetOption('JN')='J'"}
  279. Function  GetYesNo : Boolean ;
  280.    {Spezialfall: "GetYesNo := GetOption('YN')='Y'"}
  281.  
  282. {Noch mehr Utilities für den Bildschirm}
  283.  
  284. Procedure ScrollUp (x1,y1,x2,y2,nr,at : Byte) ;
  285.    {Scrollt das angegebene Rechteck um nr Zeilen nach oben, freiwerdende
  286.     Zeile werden mit dem Attribut at gefüllt. Zählung beginnt bei 0.}
  287. Procedure ScrollDown (x1,y1,x2,y2,nr,at : Byte) ;
  288.    {Dito, scrollt nach unten.}
  289. Procedure PrintAt (x,y : Integer ; Const s : String ; at : Byte) ;
  290.    {Gibt den String s mit dem Attribut at an der Position x/y aus, die
  291.     Zählung beginnt bei 1. Verwendet die aktuelle Cursorposition, wenn
  292.     x=0 und/oder y=0. Führt auch nötigenfalls ein Scrolling durch.}
  293. Function  Tab (n : Integer) : String ;
  294.    {Am besten ein Beispiel: "WriteLn ('abc',Tab(20),'xyz')". Die
  295.     Zählung beginnt bei 1. Ist die betreffende Position bereits
  296.     überschritten, ändert sich nichts (man bekommt einen Leerstring).}
  297. Function  LeftEq (Const s : String ; n : Integer) : String ;
  298.    {Das Gegenstück zu "WriteLn ('Test':15)": "WriteLn (LeftEq('Test',15))".
  299.    Ist der String zu lang, wird rechts abgeschnitten.}
  300. Procedure  StringOf (Var s : String ; c : Char ; b : Byte) ;
  301.    {Erzeugt einen String, der das Zeichen c b-mal enthält.}
  302. Function  fStringOf (c : Char ; b : Byte) : String ;
  303.    {Dito, als Funktion.}
  304. Function  WordStr (w : Word) : String ;
  305. Function  IntStr (i : Integer) : String ;
  306. Function  LongStr (l : LongInt) : String ;
  307.    {Entsprechen Str als Funktionen, z.B. "WriteLn (LeftEq(WordStr(w),12))".}
  308. Procedure PingCursor ;
  309.    {Merkt sich die aktuelle Cursorposition.}
  310. Procedure PongCursor ;
  311.    {Setzt den Cursor auf die zuletzt gemerkte Position.}
  312. Function  Clock : LongInt ;
  313.    {Liefert die Systemzeit (ab Mitternacht) in 1/100 Sekunden, die
  314.     Genauigkeit ist aber nur 1/18.2 Sekunden.}
  315. Function  TimeIdent : LongInt ;
  316.    {Liefert Datum und Uhrzeit DOS-kodiert.}
  317. Function  lShl (l : LongInt ; c : Byte) : LongInt ;
  318. Function  lShr (l : LongInt ; c : Byte) : LongInt ;
  319.    {Shl and Shr fuer LongInts.}
  320. Function  MulDiv (m1,m2,d : Word) : Word ;
  321.    {(LongInt(m1)*LongInt(m2)) Div d}
  322. Function  LongHi (x : LongInt) : Word ;
  323. Function  LongLo (x : LongInt) : Word ;
  324.    {Liefern Hi- bzw. Lo-Word eines 32-Bit-Wertes.}
  325. Function  Hex (l : LongInt) : Str8 ;
  326.    {Liefert l als Hexzahl (soviele Stellen wie nötig).}
  327. Function  Hex2 (b : Byte) : Str2 ;
  328.    {Liefert b als 2stellige Hexzahl.}
  329. Function  Hex4 (w : Word) : Str4 ;
  330.    {Liefert w als 4stellige Hexzahl.}
  331. Function  Hex8 (l : LongInt) : Str8 ;
  332.    {Liefert l als 8stellige Hexzahl.}
  333. Function  Hex2Dec (Const h : Str8 ; Var l : LongInt) : Boolean ;
  334.    {Wandelt eine 0- bis 8-stellige Hexzahl in einen Dezimalwert um.
  335.     Ergebnis ist True bei Erfolg, False bei ungültigen Zeichen
  336.     (nicht in [0..9,a..f,A..F]).  Bei False oder h='' ist l=0.}
  337. Function  Lead0 (l : LongInt ; f : Byte) : Str10 ;
  338.    {Liefert l mit führenden Nullen, mind. f Stellen.}
  339. Function  LeadSpc (l : LongInt ; f : Byte) : Str10 ;
  340.    {Liefert l mit führenden Leerzeichen, mind. f Stellen.}
  341. Function  Subst (s : String ; Const old,new : String) : String ;
  342.    {Ersetzt in s alle Vorkommen von 'old' durch 'new';
  343.     'old' und 'new' müssen nicht gleich lang sein.
  344.     ACHTUNG: 'new' darf nicht 'old' enthalten! In diesem Fall wird ein
  345.     Leerstring geliefert, um eine Endlosrekursion zu vermeiden.}
  346. Procedure  DeComment (Const com : String ; Var s : String) ;
  347.    {Löscht alles, was nach Kommentarzeichen (einschließlich) in s
  348.     folgt, Beispiel: DeComment ('#;%',inputline).}
  349. Procedure  Justify (Var s : String) ;
  350.    {Entfernt führende und abschließende Spaces, wandelt Tabs in Spaces
  351.     um, und komprimiert aufeinanderfolgende Spaces zu einem einzelnen
  352.     Space.}
  353. Procedure  DeSpace (Var s : String) ;
  354.    {Entfernt alle Spaces und Tabs.}
  355.  
  356. Function  PartStr (Const s : String ; c : Char ; x : Integer) : String ;
  357.    {Liefert den x-ten Teilstring. Die einzelnen Teilstrings werden durch
  358.     'c' getrennt, die Zählung beginnt bei Null. Beipiel:
  359.        PartStr('ABC*123*XYZ','*',1) = '123'
  360.     Wenn s[1]=c gilt, beginnt die Zählung entsprechend bei 1.
  361.     Bei x<0 wird von rechts nach links gezaehlt:
  362.        PartStr('ABC*123*XYZ','*',-1) = 'XYZ'}
  363. Function  PartCount (Const s : String ; c : Char) : Word ;
  364.    {Ermittelt, wieviele Teilstrings s enthält. Mit anderen Worten, das
  365.     Ergebnis gibt an, wie oft c in s vorkommt, plus eins; Ausnahme:
  366.     bei einem Leerstring (s='') ist das Ergebnis Null.}
  367. Function  PartWidth (Const s : String ; c : Char) : Word ;
  368.    {Ermittelt die Länge des längsten Teilstrings in s.
  369.     Die einzelnen Teilstrings werden durch c getrennt.}
  370.  
  371. Function  PPartStr (s : PChar ; c : Char ; x : Integer ; Dest : PChar) : PChar ;
  372. Function  PPartCount (s : PChar ; c : Char) : Word ;
  373. Function  PPartWidth (s : PChar ; c : Char) : Word ;
  374.     {Dito für Nullterminierte Strings bis 65535 Zeichen Länge.}
  375. Function  PPartStart (s : PChar ; c : Char ; x : Integer) : PChar ;
  376.     {Ähnlich PPartStr, liefert aber nur Zeiger auf den Anfang des
  377.      entsprechenden Teilstrings in `s'.  Liefert NIL, wenn Teilstring
  378.      nicht enthalten ist oder Länge Null hat.}
  379.  
  380. Function  StrGetMem (Var p : PChar ; Len : Word) : PChar ;
  381.     {Belegt Speicher für einen Z-String mit maximaler Länge `Len'
  382.      (d.h. Len+1 Bytes) und liefert einen Zeiger darauf in `p' und
  383.      als Funktionsergebnis.  Im Fehlerfalle (nicht genug Speicher)
  384.      NIL.}
  385. Procedure  StrFreeMem (Var p : PChar ; Len : Word) ;
  386.     {Gibt den Speicher wieder frei und setzt `p' auf NIL.}
  387.  
  388. Function  UpdateCRC32 (InitCRC : LongInt ; Var InBuf ; InLen : Word) : LongInt ;
  389.    {Berechnet einen CRC32 von `InLen' Bytes ab `InBuf', basierend auf
  390.     `InitCRC'.  Der anfängliche CRC32 sollte -1 ($ffffffff) sein, und
  391.     der abschließende sollte invertiert werden (Not).
  392.     Kompatibel mit ZIP und Zmodem.}
  393.  
  394. Type  PCProc = Procedure (p : Word ; c : Char ; Cursor : Boolean) ;
  395.    {Schreibt Zeichen c an Position p (Basis 1), mit Cursor wenn
  396.     `Cursor' = True (z.B. invertiert).}
  397. Function  EnterString (s : pChar ; maxlen : Word ; PrintChar : PCProc) : Boolean ;
  398.    {Eingabe eines Strings (mit Vorgabe) s^ mit maximaler Länge `maxlen',
  399.     zum Schreiben wird die Prozedur `PrintChar' benutzt.
  400.     Ergebnis is True, wenn Eingabe mit Enter-Taste bestätigt wurde, bzw.
  401.     False, wenn mit Esc abgebrochen wurde (s^ unverändert).}
  402.  
  403. {------ Maus-Funktionen ------}
  404.  
  405. Function  InitMouse : Boolean ;
  406.    {Initialisiert den Maustreiber und liefert True, wenn einer
  407.     installiert ist. Der Mauszeiger ist noch nicht sichtbar.}
  408. Procedure  ResetMouse ;
  409.    {Nur Software-Reset.}
  410. Procedure  HideMouse ;
  411.    {Macht den Mauszeiger unsichtbar.}
  412. Procedure  ShowMouse ;
  413.    {Macht den Mauszeiger sichtbar.}
  414. Procedure  SetFrame (x1,y1,x2,y2 : Word) ;
  415.    {Legt den Bereich fest, in dem sich der Mauszeiger bewegen darf.
  416.     Zählung beginnt bei 0.}
  417. Function  GetMouse : Word ;
  418.    {Liefert Tastenstatus: Bit 0 = linke Taste, Bit 1 = rechte Taste,
  419.     Bit 2 = mittlere Taste (falls vorhanden).
  420.     Ein Aufruf dieser Funktion aktualisiert außerdem die Mauskoordinaten
  421.     in mx und my.}
  422. Procedure  SetMouse (x,y : Word) ;
  423.    {Setzt den Mauszeiger auf die angegeben Position.}
  424. Procedure  DefineMickey (Horiz,Vertic : Word) ;
  425.    {Hiermit kann man die Auflösung der Maus einstellen, und damit
  426.     die Geschwindigkeit des Mauszeigers.}
  427. Procedure  GetMickey (Var Horiz,Vertic : Integer) ;
  428.    {Liefert den Stand des Bewegungszählers der Maus.}
  429. Procedure  WaitButton ;
  430.    {Wartet auf das Betätigen einer Maustaste oder einer Taste auf der
  431.     Tastatur. Sollte beim Aufruf bereits eine Maustaste gedrückt sein,
  432.     wird erst gewartet, bis sie losgelassen wird.
  433.     Der Tastaturpuffer wird vorher und hinterher gelöscht.}
  434. Procedure  SetMouseCursor (sm,cm : Word) ;
  435.    {Schaltet auf Software-Mauscursor um und definiert sein Aussehen:
  436.     Der Bildschirm-Wert wird zuerst mit sm AND-verknüpft und dann mit
  437.     cm XOR-verknüpft. Das Low-Byte ist jeweils für den Zeichencode
  438.     zuständig, das High-Byte für das Attribut.}
  439. Procedure  SetMousePointer (Var scm ; hotx,hoty : Integer) ;
  440.    {Definiert das Aussehen das Mauspointers im Grafikmodus. scm ist ein
  441.     Feld von 16 Screenmask(sm)-Worten und 16 Cursormask(cm)-Worten:
  442.        sm=0: cm=0: Schwarz (Farbe 0), cm=1: Weiss (Farbe 15),
  443.        sm=1: cm=0: Transparent,       cm=1: Invertierend,
  444.     hotx und hoty geben die Position des "Hot Spot" an, bezogen auf die
  445.     linke obere Ecke des Pointers, sie können Wert von -16 bis 16
  446.     annehmen.}
  447. Procedure  SetUpdateFrame (x1,y1,x2,y2 : Word) ;
  448.    {Definiert einen rechteckigen Bereich, innerhalb dessen ein Update
  449.     (oder irgendeine Grafikaktion) stattfindet. Wenn der Mauspointer diesen
  450.     Bereich berührt, wird ein HideMouse durchgeführt.
  451.     Ein Aufruf von ShowMouse macht diese Prozedur wieder rückgängig (egal,
  452.     ob HideMouse durchgeführt wurde oder nicht).
  453.     Diese Funktion benötigt unbedingt einen Microsoft-kompatiblen Maustreiber,
  454.     bei Genius-Mäusen mindestens Treiberversion 9.06.}
  455.  
  456. {===========================================================================}
  457.  
  458.  
  459.  
  460. Implementation
  461.  
  462. Const  HexDig : Array [0..15] Of Char = '0123456789abcdef' ;
  463.  
  464. Var  r : Registers ;
  465.  
  466. Var  x1,y1,x2,y2 : Word ;
  467.  
  468. Var  KeyPends : Boolean ;
  469.      key      : Char ;
  470.  
  471. Var  PingX,PingY : Integer ;
  472.  
  473. Procedure  Video (a,b,c,d : Word) ; Assembler ;
  474.    Asm
  475.         mov     ax,a
  476.         mov     bx,b
  477.         mov     cx,c
  478.         mov     dx,d
  479.         push    bp
  480.         int     10h
  481.         pop     bp
  482.    End {Video} ;
  483.  
  484. Procedure  ClrScr ;
  485.    Begin
  486.       Video ($0600,TextAttr Shl 8,y1 Shl 8+x1,y2 Shl 8+x2) ;
  487.       GotoXY (1,1)
  488.    End {ClrScr} ;
  489.  
  490. Procedure  GotoXY (x,y : Byte) ;
  491.    Begin
  492.       Video ($0200,0,0,Word(Pred(y))Shl 8+Pred(x))
  493.    End {GotoXY} ;
  494.  
  495. Function   WhereX : Byte ; Assembler ;
  496.    Asm
  497.                 mov     ax,0300h
  498.                 push    bp
  499.                 int     10h
  500.                 pop     bp
  501.                 mov     al,dl
  502.                 inc     al
  503.    End {WhereX} ;
  504.  
  505. Function   WhereY : Byte ; Assembler ;
  506.    Asm
  507.                 mov     ax,0300h
  508.                 push    bp
  509.                 int     10h
  510.                 pop     bp
  511.                 mov     al,dh
  512.                 inc     al
  513.    End {WhereY} ;
  514.  
  515. Function  KeyPressed : Boolean ;
  516.    Begin
  517.       If KeyPends Then Begin
  518.          KeyPressed := True ;
  519.          Exit
  520.       End ;
  521.       r.ah := $01 ;
  522.       Intr ($16,r) ;
  523.       KeyPressed := r.flags And $40=0
  524.    End {KeyPressed} ;
  525.  
  526. Function  ReadKey : Char ;
  527.    Begin
  528.       If KeyPends Then Begin
  529.          KeyPends := False ;
  530.          ReadKey := Key
  531.       End
  532.       Else Begin
  533.          r.ah := 0 ;
  534.          Intr ($16,r) ;
  535.          ReadKey := Char(r.al) ;
  536.          If r.al=0 Then Begin
  537.             KeyPends := True ;
  538.             Key := Char(r.ah)
  539.          End
  540.       End
  541.    End {ReadKey} ;
  542.  
  543. Procedure  FeedKey (k : Char) ;
  544.    Begin
  545.       KeyPends := True ;
  546.       Key := k
  547.    End {FeedKey} ;
  548.  
  549. Procedure  InsLine ; Assembler ;
  550.    Asm
  551.                 mov     ax,0300h
  552.                 push    bp
  553.                 int     10h
  554.                 mov     ax,0701h
  555.                 mov     bh,TextAttr
  556.                 xor     bl,bl
  557.                 mov     ch,dh
  558.                 mov     cl,Byte Ptr x1
  559.                 mov     dh,Byte Ptr y2
  560.                 mov     dl,Byte Ptr x2
  561.                 int     10h
  562.                 pop     bp
  563.    End {InsLine} ;
  564.  
  565. Procedure  DelLine ; Assembler ;
  566.    Asm
  567.                 mov     ax,0300h
  568.                 push    bp
  569.                 int     10h
  570.                 mov     ax,0601h
  571.                 mov     bh,TextAttr
  572.                 xor     bl,bl
  573.                 mov     ch,dh
  574.                 mov     cl,Byte Ptr x1
  575.                 mov     dh,Byte Ptr y2
  576.                 mov     dl,Byte Ptr x2
  577.                 int     10h
  578.                 pop     bp
  579.    End {DelLine} ;
  580.  
  581. Procedure  ClrLine ; Assembler ;
  582.    Asm
  583.                 mov     ax,0300h
  584.                 push    bp
  585.                 int     10h
  586.                 mov     ax,0600h
  587.                 mov     bh,TextAttr
  588.                 xor     bl,bl
  589.                 mov     ch,dh
  590.                 mov     cl,Byte Ptr x1
  591.                 mov     dl,Byte Ptr x2
  592.                 int     10h
  593.                 pop     bp
  594.    End {DelLine} ;
  595.  
  596. Procedure  ClrLines (yy1,yy2 : Integer) ;
  597.    Begin
  598.       If yy1=-1 Then
  599.          yy1 := y1 ;
  600.       If yy2=-1 Then
  601.          yy2 := y2 ;
  602.       Video ($0600,TextAttr Shl 8,yy1 Shl 8+x1,yy2 Shl 8+x2) ;
  603.       GotoXY (1,Succ(yy1))
  604.    End {ClrScr} ;
  605.  
  606. Procedure  Center (s : String) ;
  607.    Var  i,a : Word ;
  608.    Begin
  609.       a := Succ(MaxX)*Pred(WhereY) Shl 1-2 ;
  610.       i := Succ(MaxX-Length(s))Shr 1 ;
  611.       Move (s[1],s[Succ(i)],Length(s)) ;
  612.       FillChar (s[1],i,32) ;
  613.       FillChar (s[Succ(length(s)+i)],Succ(MaxX)-Length(s)-i,32) ;
  614.       For i:=1 To Succ(MaxX) Do
  615.          MemW[Segb800:a+i Shl 1] := TextAttr Shl 8+Byte(s[i])
  616.    End {Center} ;
  617.  
  618. Procedure  LeftAlign (s : String) ;
  619.    Var  i,a : Word ;
  620.    Begin
  621.       a := Succ(MaxX)*Pred(WhereY) Shl 1-2 ;
  622.       FillChar (s[Succ(length(s))],Succ(MaxX)-Length(s),32) ;
  623.       For i:=1 To Succ(MaxX) Do
  624.          MemW[Segb800:a+i Shl 1] := TextAttr Shl 8+Byte(s[i])
  625.    End {LeftAlign} ;
  626.  
  627. Procedure  RightAlign (s : String) ;
  628.    Var  i,a : Word ;
  629.    Begin
  630.       a := Succ(MaxX)*Pred(WhereY) Shl 1-2 ;
  631.       i := Succ(MaxX-Length(s)) ;
  632.       Move (s[1],s[Succ(i)],Length(s)) ;
  633.       FillChar (s[1],i,32) ;
  634.       For i:=1 To Succ(MaxX) Do
  635.          MemW[Segb800:a+i Shl 1] := TextAttr Shl 8+Byte(s[i])
  636.    End {RightAlign} ;
  637.  
  638. Procedure  ClrKeyBuf ;
  639.    Begin
  640.       While KeyPressed Do
  641.          If ReadKey=#0 Then
  642.             If ReadKey=#0 Then
  643.    End {ClrKeyBuf} ;
  644.  
  645. Procedure  Beep ;
  646.    Begin
  647.       Sound (1000) ;
  648.       Delay (100) ;
  649.       NoSound
  650.    End {Beep} ;
  651.  
  652. Procedure  Buup ;
  653.    Var  w : Word ;
  654.    Begin
  655.       For w := 450 DownTo 250 Do Begin
  656.          Sound (w) ;
  657.          Delay (1)
  658.       End ;
  659.       NoSound
  660.    End {Buup} ;
  661.  
  662. Procedure  WaitVerticalRetrace ; Assembler ;
  663.    Asm
  664.            mov     dx,03dah
  665.      @vr:  in      al,dx
  666.            test    al,08h
  667.            jnz     @vr
  668.      @nvr: in      al,dx
  669.            test    al,08h
  670.            jz      @nvr
  671.    End {WaitVerticalRetrace} ;
  672.  
  673. Procedure  WriteStdErr (Const s : String) ;
  674.    Var  w : Word ;
  675.         c : Char ;
  676.    Begin
  677.       For w:=1 To Length(s) Do Begin
  678.          c := s[w] ;
  679.          Asm
  680.             mov     ah,0eh
  681.             mov     al,c
  682.             xor     bx,bx
  683.             push    bp
  684.             int     10h
  685.             pop     bp
  686.          End
  687.       End
  688.    End {WriteStdErr} ;
  689.  
  690. Procedure  Sound (Hz : Word) ;
  691.    Var  bbb : Byte ;
  692.    Begin
  693.       If Hz<=18 Then
  694.          Exit ;
  695.       Hz := $1234dd Div Hz ;
  696.       bbb := Port[$61] ;
  697.       If bbb And $03=0 Then Begin
  698.          Port[$61] := bbb Or $03 ;
  699.          Port[$43] := $b6 {Binaer, Modus 3, Lo/Hi-Byte, Counter 2}
  700.       End ;
  701.       Port[$42] := Lo(Hz) ;
  702.       Port[$42] := Hi(Hz)
  703.    End {Sound} ;
  704.  
  705. Procedure  NoSound ;
  706.    Begin
  707.       Port[$61] := Port[$61] And $fc
  708.    End {NoSound} ;
  709.  
  710. Function  Counter : Word ; Assembler ;
  711.    Asm
  712.       in      al,$40
  713.       mov     ah,al
  714.       in      al,$40
  715.       xchg    ah,al
  716.    End {Counter} ;
  717.  
  718. Function  LCounter : LongInt ; Assembler ;
  719.    Asm
  720.       pushf
  721.       cli
  722.       in      al,$40
  723.       mov     ah,al
  724.       in      al,$40
  725.       xchg    ah,al
  726.       mov     dx,Seg0040
  727.       mov     es,dx
  728.       mov     dx,Word Ptr es:$006c
  729.       not     dx
  730.       popf
  731.    End {Counter} ;
  732.  
  733. Procedure  WaitApprox (w : Word) ;
  734.    Begin
  735.       While Counter-w<49152 Do
  736.    End {WaitApprox} ;
  737.  
  738. Procedure  Delay (w : Word) ;
  739.    Var  wll : LongInt ;
  740.         tm  : Word ;
  741.    Begin
  742.       tm := Counter ;
  743.       wll := LongInt(w)*1193 ;
  744.       While wll>65535 Do Begin
  745.          WaitApprox (tm XOr $8000) ;
  746.          WaitApprox (tm) ;
  747.          Dec (wll,65536)
  748.       End ;
  749.       If wll>32767 Then
  750.          WaitApprox (tm XOr $8000) ;
  751.       WaitApprox (tm-Word(wll))
  752.    End {Delay} ;
  753.  
  754. Procedure  Move (Var Source,Dest ; Count : Word) ; Assembler ;
  755.    Asm
  756.           push    ds
  757.           mov     cx,Count
  758.           jcxz    @1
  759.           lds     si,[Source]
  760.           les     di,[Dest]
  761.           cld
  762.           test    di,1
  763.           jz      @0
  764.              movsb
  765.              dec     cx
  766.       @0: shr     cx,1
  767.           rep     movsw
  768.           jnc     @1
  769.              movsb
  770.       @1: pop     ds
  771.    End {Move} ;
  772.  
  773. Procedure  FillByte (Var X ; Count : Word ; Value : Byte) ; Assembler ;
  774.    Asm
  775.           mov     cx,Count
  776.           jcxz    @1
  777.           mov     al,Value
  778.           mov     ah,al
  779.           les     di,[X]
  780.           cld
  781.           test    di,1
  782.           jz      @0
  783.              stosb
  784.              dec     cx
  785.       @0: shr     cx,1
  786.           rep     stosw
  787.           jnc     @1
  788.              stosb
  789.       @1:
  790.    End {FillByte} ;
  791.  
  792. Procedure  FillWord (Var X ; Count : Word ; Value : Word) ; Assembler ;
  793.    Asm
  794.           mov     cx,Count
  795.           jcxz    @1
  796.           mov     ax,Value
  797.           les     di,[X]
  798.           cld
  799.           test    di,1
  800.           jz      @0
  801.              stosb
  802.              xchg    al,ah
  803.              dec     cx
  804.              jz      @2
  805.              rep     stosw
  806.          @2: stosb
  807.              jmp     @1
  808.       @0: rep     stosw
  809.       @1:
  810.    End {FillWord} ;
  811.  
  812. Procedure  Fill3Byt (Var X ; Count : Word ; Value : LongInt) ; Assembler ;
  813.    Asm
  814.           mov     cx,Count
  815.           jcxz    @1
  816.           mov     ax,Word Ptr Value
  817.           mov     bl,Byte Ptr Value+2
  818.           les     di,[X]
  819.           cld
  820.       @0: stosw
  821.           mov     es:[di],bl
  822.           inc     di
  823.           loop    @0
  824.       @1:
  825.    End {Fill3Byt} ;
  826.  
  827. Procedure  FillLong (Var X ; Count : Word ; Value : LongInt) ; Assembler ;
  828.    Asm
  829.           mov     cx,Count
  830.           jcxz    @1
  831.           mov     ax,Word Ptr Value
  832.           mov     bx,Word Ptr Value+2
  833.           mov     dx,2
  834.           les     di,[X]
  835.           cld
  836.       @0: stosw
  837.           mov     es:[di],bx
  838.           add     di,dx
  839.           loop    @0
  840.       @1:
  841.    End {FillLong} ;
  842.  
  843. Procedure  FillGen (Var X ; Count : Word ; Value : LongInt ; size : Byte) ;
  844.    Begin
  845.       Case size Of
  846.          1 : FillByte (X,Count,Value) ;
  847.          2 : FillWord (X,Count,Value) ;
  848.          3 : Fill3Byt (X,Count,Value) ;
  849.          4 : FillLong (X,Count,Value)
  850.       End
  851.    End {FillGen} ;
  852.  
  853. Function  Quest (Cond : Boolean ; a,b : LongInt) : LongInt ;
  854.    Begin
  855.       If Cond Then
  856.          Quest := a
  857.       Else
  858.          Quest := b
  859.    End {Quest} ;
  860.  
  861. Function  CQuest (Cond : Boolean ; a,b : Char) : Char ;
  862.    Begin
  863.       If Cond Then
  864.          CQuest := a
  865.       Else
  866.          CQuest := b
  867.    End {CQuest} ;
  868.  
  869. Function  SQuest (Cond : Boolean ; Const a,b : String) : String ;
  870.    Begin
  871.       If Cond Then
  872.          SQuest := a
  873.       Else
  874.          SQuest := b
  875.    End {SQuest} ;
  876.  
  877. Function  Quest2 (Cond1,Cond0 : Boolean ; a00,a01,a10,a11 : LongInt) : LongInt ;
  878.    Begin
  879.       If Cond1 Then
  880.          If Cond0 Then
  881.             Quest2 := a11
  882.          Else
  883.             Quest2 := a10
  884.       Else
  885.          If Cond0 Then
  886.             Quest2 := a01
  887.          Else
  888.             Quest2 := a00
  889.    End {Quest2} ;
  890.  
  891. Function  LoCase (c : Char) : Char ;
  892.    Begin
  893.       If c In ['A'..'Z'] Then Asm
  894.          mov     al,c
  895.          add     al,20h
  896.          mov     @result,al
  897.       End
  898.       Else
  899.          LoCase := c
  900.    End {LoCase} ;
  901.  
  902. Function  UpperCase (Const s : String) : String ;
  903.    Var  i : Integer ;
  904.    Begin
  905.       UpperCase[0] := s[0] ;
  906.       For i:=1 To Length(s) Do
  907.          UpperCase[i] := UpCase(s[i])
  908.    End {UpperCase} ;
  909.  
  910. Function  LowerCase (Const s : String) : String ;
  911.    Var  i : Integer ;
  912.    Begin
  913.       LowerCase[0] := s[0] ;
  914.       For i:=1 To Length(s) Do
  915.          LowerCase[i] := LoCase(s[i])
  916.    End {LowerCase} ;
  917.  
  918. Function  IDist (i1,i2,x : LongInt) : LongInt ;
  919.    Begin
  920.       If x<i1 Then
  921.          IDist := i1-x
  922.       Else
  923.          If x>i2 Then
  924.             IDist := x-i2
  925.          Else
  926.             IDist := 0
  927.    End {IDist} ;
  928.  
  929. Function  Bound (x,min,max : LongInt) : LongInt ;
  930.    Begin
  931.       If x<min Then
  932.          Bound := min
  933.       Else If x>max Then
  934.          Bound := max
  935.       Else
  936.          Bound := x
  937.    End {Bound} ;
  938.  
  939. Function  Max (w1,w2 : LongInt) : LongInt ;
  940.    Begin
  941.       if w1>w2 Then
  942.          Max := w1
  943.       Else
  944.          Max := w2
  945.    End {Max} ;
  946.  
  947. Function  Min (w1,w2 : LongInt) : LongInt ;
  948.    Begin
  949.       if w1<w2 Then
  950.          Min := w1
  951.       Else
  952.          Min := w2
  953.    End {Min} ;
  954.  
  955. Function  Even (x : LongInt) : Boolean ;
  956.    Begin
  957.       Even := Not Odd(x)
  958.    End {Even} ;
  959.  
  960. Function  ggT (a,b : LongInt) : LongInt ;
  961.    Var  c,d : LongInt ;
  962.    Begin
  963.       d := a Mod b ;
  964.       While d<>0 Do Begin
  965.          c := b ;
  966.          b := d ;
  967.          a := c ;
  968.          d := a Mod b
  969.       End ;
  970.       ggT := b
  971.    End {ggT} ;
  972.  
  973. Function  kgV (a,b : LongInt) : LongInt ;
  974.    Var  c : LongInt ;
  975.    Begin
  976.       c := ggT(a,b) ;
  977.       If c<>0 Then
  978.          kgV := (a Div c)*b
  979.       Else
  980.          kgV := 0
  981.    End {kgV} ;
  982.  
  983. Function  Sgn (x : LongInt) : ShortInt ; Assembler ;
  984.    Asm
  985.                 xor     ax,ax
  986.                 mov     bx,word ptr x+2
  987.                 test    bh,80h
  988.                 jnz     @neg
  989.                 or      bx,word ptr x
  990.                 jz      @z
  991.                 mov     ax,1
  992.                 jmp     @z
  993.         @neg:   not     ax
  994.         @z:
  995.    End {Sgn} ;
  996.  
  997. Function  Diff (a,b : LongInt) : LongInt ;
  998.    Begin
  999.       If a<b Then
  1000.          Diff := b-a
  1001.       Else
  1002.          Diff := a-b
  1003.    End {Diff} ;
  1004.  
  1005. Function GetPDir (Const n : String) : DirStr ;
  1006.    Var Dir  : DirStr ;
  1007.        Name : NameStr ;
  1008.        Ext  : ExtStr ;
  1009.    Begin
  1010.       FSplit (n,Dir,Name,Ext) ;
  1011.       GetPDir := Dir
  1012.    End {GetPDir} ;
  1013.  
  1014. Function  GetRawDir  (Const n : String) : DirStr ;
  1015.    Var Dir  : DirStr ;
  1016.        Name : NameStr ;
  1017.        Ext  : ExtStr ;
  1018.    Begin
  1019.       FSplit (n,Dir,Name,Ext) ;
  1020.       GetRawDir := Copy(Dir,3,Length(Dir)-3)
  1021.    End {GetRawDir} ;
  1022.  
  1023. Function GetName (Const n : String) : NameStr ;
  1024.    Var Dir  : DirStr ;
  1025.        Name : NameStr ;
  1026.        Ext  : ExtStr ;
  1027.    Begin
  1028.       FSplit (n,Dir,Name,Ext) ;
  1029.       GetName := Name
  1030.    End {GetName} ;
  1031.  
  1032. Function GetExt  (Const n : String) : ExtStr ;
  1033.    Var Dir  : DirStr ;
  1034.        Name : NameStr ;
  1035.        Ext  : ExtStr ;
  1036.    Begin
  1037.       FSplit (n,Dir,Name,Ext) ;
  1038.       GetExt := Ext
  1039.    End {GetExt} ;
  1040.  
  1041. Function  GetXt   (Const n : String) : ExtStr ;
  1042.    Var Dir  : DirStr ;
  1043.        Name : NameStr ;
  1044.        Ext  : ExtStr ;
  1045.    Begin
  1046.       FSplit (n,Dir,Name,Ext) ;
  1047.       GetXt := Copy(Ext,2,3)
  1048.    End {GetXt} ;
  1049.  
  1050. Function GetNExt (Const n : String) : NExtStr ;
  1051.    Var Dir  : DirStr ;
  1052.        Name : NameStr ;
  1053.        Ext  : ExtStr ;
  1054.    Begin
  1055.       FSplit (n,Dir,Name,Ext) ;
  1056.       GetNExt := Name+Ext
  1057.    End {GetNExt} ;
  1058.  
  1059. Function GetDName (Const n : String) : PathStr ;
  1060.    Var Dir  : DirStr ;
  1061.        Name : NameStr ;
  1062.        Ext  : ExtStr ;
  1063.    Begin
  1064.       FSplit (n,Dir,Name,Ext) ;
  1065.       GetDName := Dir+Name
  1066.    End {GetDName} ;
  1067.  
  1068. Function  GetDrive (Const n : String) : Str2 ;
  1069.    Begin
  1070.       GetDrive := UpperCase(Copy(n,1,2))
  1071.    End {GetDrive} ;
  1072.  
  1073. Function ExtPath (Const n,e : String) : PathStr ;
  1074.    Var i : Integer ;
  1075.    Begin
  1076.       i:=Length(n) ;
  1077.       While (i>0)And(n[i]<>'.')And(n[i]<>'\') Do
  1078.          Dec(i) ;
  1079.       If (i=0)Or(n[i]='\') Then
  1080.          ExtPath:=n+'.'+e
  1081.       Else
  1082.          ExtPath:=n
  1083.    End {ExtPath} ;
  1084.  
  1085. Function  NormName (n : NExtStr) : NExtStr ;
  1086.    Var  nam : NameStr ;
  1087.         ext : ExtStr ;
  1088.         p   : Word ;
  1089.    Begin
  1090.       p := Pos('.',n) ;
  1091.       If p=0 Then Begin
  1092.          n := n+'.' ;
  1093.          p := Succ(Length(n))
  1094.       End ;
  1095.       FillByte (nam[1],8,32) ;
  1096.       FillByte (ext[1],3,32) ;
  1097.       nam := Copy(n,1,Pred(p)) ;
  1098.       ext := Copy(n,Succ(p),3) ;
  1099.       nam[0] := #8 ;
  1100.       ext[0] := #3 ;
  1101.       NormName := nam+'.'+ext
  1102.    End {NormName} ;
  1103.  
  1104. Function  NormDirn (Const n : NExtStr) : NExtStr ;
  1105.    Var  nam : NameStr ;
  1106.         ext : ExtStr ;
  1107.         p   : Word ;
  1108.    Begin
  1109.       If n[1]='.' Then
  1110.          p := Succ(Length(n))
  1111.       Else Begin
  1112.          p := Pos('.',n) ;
  1113.          If p=0 Then
  1114.             p := Succ(Length(n))
  1115.       End ;
  1116.       FillByte (nam[1],8,32) ;
  1117.       FillByte (ext[1],3,32) ;
  1118.       nam := Copy(n,1,Pred(p)) ;
  1119.       ext := Copy(n,Succ(p),3) ;
  1120.       nam[0] := #8 ;
  1121.       ext[0] := #3 ;
  1122.       If ext='   ' Then
  1123.          NormDirn := nam+#32+ext
  1124.       Else
  1125.          NormDirn := nam+'.'+ext
  1126.    End {NormDirn} ;
  1127.  
  1128. Procedure  NormDir (Var d : DirStr) ;
  1129.    Begin
  1130.       If d[Length(d)]<>'\' Then
  1131.          d := d+'\'
  1132.    End {NormDir} ;
  1133.  
  1134. Function  fNormDir (Const d : DirStr) : DirStr ;
  1135.    Begin
  1136.       If d[Length(d)]<>'\' Then
  1137.          fNormDir := d+'\'
  1138.       Else
  1139.          fNormDir := d
  1140.    End {fNormDir} ;
  1141.  
  1142. Function  NormChDir (d : DirStr) : DirStr ;
  1143.    Begin
  1144.       If (d[Length(d)]='\') And ((Length(d)<>3) Or (d[2]<>':')) Then
  1145.          Dec (d[0]) ;
  1146.       NormChDir := d
  1147.    End {NormChDir} ;
  1148.  
  1149. Function  WildExpand (n : NExtStr) : NExtStr ;
  1150.    Var  p : Word ;
  1151.    Begin {WildExpand}
  1152.       n := NormName(n) ;
  1153.       p := Pos('*',n) ;
  1154.       If (p<>0) And (p<9) Then Begin
  1155.          For p:=p To 8 Do
  1156.             n[p] := '?' ;
  1157.          p := Pos('*',n)
  1158.       End ;
  1159.       If p<>0 Then
  1160.          For p:=p To 12 Do
  1161.             n[p] := '?' ;
  1162.       WildExpand := n
  1163.    End {WildExpand} ;
  1164.  
  1165. Function  Matches (n : NExtStr ; Const mask : NExtStr) : Boolean ;
  1166.    Var  i : Word ;
  1167.    Begin
  1168.       n := NormName(n) ;
  1169.       Matches := False ;
  1170.       For i:=1 To 12 Do
  1171.          If mask[i]<>'?' Then
  1172.             If mask[i]<>n[i] Then
  1173.                Exit ;
  1174.       Matches := True
  1175.    End {Matches} ;
  1176.  
  1177. Function  TempDir : PathStr ;
  1178.    Var  t : PathStr ;
  1179.    Begin
  1180.       t := GetEnv('TEMP') ;
  1181.       If t[0]=#0 Then Begin
  1182.          t := GetEnv('TMP') ;
  1183.          If t[0]=#0 Then
  1184.             t := 'C:\'
  1185.       End ;
  1186.       If t[Length(t)]<>'\' Then
  1187.          t := t+'\' ;
  1188.       TempDir := t
  1189.    End {TempDir} ;
  1190.  
  1191. Function  ProcessFiles (Const mask : PathStr ; opt : Word ; job : PathProc) : LongInt ;
  1192.    Var  Search : SearchRec ;
  1193.         Dir    : DirStr ;
  1194.         NExt   : NExtStr ;
  1195.         Count  : LongInt ;
  1196.    Begin
  1197.       Count := 0 ;
  1198.       Dir := GetPDir(mask) ;
  1199.       NExt := GetNExt(mask) ;
  1200.       Search.Name := NExt ;
  1201.       FindFirst (mask,$3f,Search) ;
  1202.       While DosError=0 Do Begin
  1203.          job (Dir,Search) ;
  1204.          Inc (Count) ;
  1205.          FindNext (Search)
  1206.       End ;
  1207.       If opt And Recursive<>0 Then Begin
  1208.          Search.Name := '*.*' ;
  1209.          FindFirst (Dir+'*.*',$33,Search) ;
  1210.          While DosError=0 Do Begin
  1211.             If (Search.Attr And $10)=$10 Then
  1212.                If (Search.Name<>'.') And (Search.Name<>'..') Then
  1213.                   Inc (Count,ProcessFiles(Dir+Search.Name+'\'+NExt,opt,job)) ;
  1214.             FindNext (Search)
  1215.          End
  1216.       End ;
  1217.       ProcessFiles := Count
  1218.    End {ProcessFiles} ;
  1219.  
  1220. Function  PathEq   (n : String) : PathStr ;
  1221.    Var  slash,i : Integer ;
  1222.    Begin
  1223.       slash := 0 ;
  1224.       For i:=Length(n) DownTo 1 Do
  1225.          If (n[i]='\') Or (n[i]='\') Then Begin
  1226.             slash := i ;
  1227.             Break
  1228.          End ;
  1229.       While Length(n)<slash+12 Do
  1230.          n := n+#32 ;
  1231.       PathEq := n
  1232.    End {PathEq} ;
  1233.  
  1234. Procedure  ChangeDir (d : String) ;
  1235.    Begin
  1236.       d := NormChDir(d)+#0 ;
  1237.       r.ah := $3b ;
  1238.       r.dx := Ofs(d[1]) ;
  1239.       r.ds := Seg(d[1]) ;
  1240.       Intr ($21,r) ;
  1241.       If r.flags And fcarry <>0 Then
  1242.          InOutRes := 3
  1243.    End {ChangeDir} ;
  1244.  
  1245. Function  QuietFileSize (Const n : PathStr) : LongInt ;
  1246.    Var  s : SearchRec ;
  1247.    Begin
  1248.       s.Name := GetNExt(n) ;
  1249.       FindFirst (n,$3f,s) ;
  1250.       If DosError<>0 Then
  1251.          QuietFileSize := -2
  1252.       Else If s.Attr And $18 <>0 Then
  1253.          QuietFileSize := -1
  1254.       Else
  1255.          QuietFileSize := s.Size
  1256.    End {QuietFileSize} ;
  1257.  
  1258. Function  Exists   (Const n : String) : Boolean ;
  1259.    Var  f : File ;
  1260.         a : Word ;
  1261.    Begin
  1262.       Assign (f,n) ;
  1263.       GetFAttr (f,a) ;
  1264.       Exists := DosError=0
  1265.    End {Exists} ;
  1266.  
  1267. Function  IsDir    (Const n : String) : Boolean ;
  1268.    Var  f : File ;
  1269.         a : Word ;
  1270.    Begin
  1271.       If n[Length(n)]='\' Then
  1272.          IsDir := True
  1273.       Else Begin
  1274.          Assign (f,n) ;
  1275.          GetFAttr (f,a) ;
  1276.          IsDir := (a And $10=$10) And (DosError=0)
  1277.       End
  1278.    End {IsDir} ;
  1279.  
  1280. Function  IsFile   (Const n : String) : Boolean ;
  1281.    Var  f : File ;
  1282.         a : Word ;
  1283.    Begin
  1284.       Assign (f,n) ;
  1285.       GetFAttr (f,a) ;
  1286.       IsFile := (a And $18=0) And (DosError=0)
  1287.    End {IsFile} ;
  1288.  
  1289. Function  IsEmpty (n : DirStr) : Boolean ;
  1290.    Var  s : SearchRec ;
  1291.    Begin
  1292.       NormDir (n) ;
  1293.       s.Name := '*.*' ;
  1294.       FindFirst (n+'*.*',$3f,s) ;
  1295.       While (DosError=0)
  1296.             And ((s.Name='.') Or (s.Name='..') Or (s.Attr And $08=$08)) Do
  1297.          FindNext (s) ;
  1298.       IsEmpty := DosError=18
  1299.    End {IsEmpty} ;
  1300.  
  1301. Function  Writeable (d : Char) : Boolean ;
  1302.    Var  f : File ;
  1303.    Begin
  1304.       Assign (f,d+':\awritest.$$$') ;
  1305.       ReWrite (f,1) ;
  1306.       If IOResult<>0 Then
  1307.          Writeable := False
  1308.       Else Begin
  1309.          Close (f) ;
  1310.          Erase (f) ;
  1311.          Writeable := IOResult=0
  1312.       End
  1313.    End {Writeable} ;
  1314.  
  1315. Function  IsOpenFile (Var f : File) : Boolean ;
  1316.    Begin
  1317.       IsOpenFile := FileRec(f).Mode <> fmClosed
  1318.    End {IsOpenFile} ;
  1319.  
  1320. Function  IsOpenText (Var f : Text) : Boolean ;
  1321.    Begin
  1322.       IsOpenText := TextRec(f).Mode <> fmClosed
  1323.    End {IsOpenText} ;
  1324.  
  1325. Procedure  ExWriteLn (Var f : ExText ; s : String) ;
  1326.    Begin
  1327.       s := s+CrLf ;
  1328.       BlockWrite (f,s[1],Length(s))
  1329.    End {ExWriteLn} ;
  1330.  
  1331. Procedure  ExReadLn  (Var f : ExText ; Var s : String) ;
  1332.    Var  t : String ;
  1333.         p : LongInt ;
  1334.         e : Integer ;
  1335.         r : Word ;
  1336.    Begin
  1337.       p := FilePos(f) ;
  1338.       BlockRead (f,t[1],255,r) ;
  1339.       t[0] := Char(r) ;
  1340.       e := Pos(CrLf,t) ;
  1341.       If e>0 Then
  1342.          t[0] := Char(Pred(e)) ;
  1343.       Seek (f,p+Byte(t[0])+2) ;
  1344.       s := t
  1345.    End {ExReadLn} ;
  1346.  
  1347. Function  TextFilePos (Var t : Text) : LongInt ;
  1348.    Begin
  1349.       r.ax := $4201 ;
  1350.       r.bx := TextRec(t).Handle ;
  1351.       r.cx := 0 ;
  1352.       r.dx := 0 ;
  1353.       Intr ($21,r) ;
  1354.       If r.flags And fcarry=0 Then
  1355.          TextFilePos := LongInt(r.dx)*65536+r.ax+TextRec(t).BufPos
  1356.                         -TextRec(t).BufEnd
  1357.       Else Begin
  1358.          InOutRes := r.ax ;
  1359.          TextFilePos := 0
  1360.       End
  1361.    End {TextFilePos} ;
  1362.  
  1363. Function  TextFileSize (Var t : Text) : LongInt ;
  1364.    Var  l : LongInt ;
  1365.    Begin
  1366.       If TextRec(t).Mode=fmInput Then Begin
  1367.          l := TextFilePos(t) ;
  1368.          r.ax := $4202 ;
  1369.          r.bx := TextRec(t).Handle ;
  1370.          r.cx := 0 ;
  1371.          r.dx := 0 ;
  1372.          Intr ($21,r) ;
  1373.          If r.flags And fcarry=0 Then
  1374.             TextFileSize := LongInt(r.dx)*65536+r.ax
  1375.          Else Begin
  1376.             InOutRes := r.ax ;
  1377.             TextFileSize := 0
  1378.          End ;
  1379.          TextSeek (t,l)
  1380.       End
  1381.       Else If TextRec(t).Mode=fmOutput Then
  1382.          TextFileSize := TextFilePos(t)
  1383.       Else Begin
  1384.          InOutRes := 1 ;
  1385.          TextFileSize := 0
  1386.       End
  1387.    End {TextFileSize} ;
  1388.  
  1389. Procedure  TextSeek (Var t : Text ; Pos : LongInt) ;
  1390.    Var  w : Record l,h : Word End Absolute Pos ;
  1391.    Begin
  1392.       If TextFilePos(t)=Pos Then
  1393.          Exit ;
  1394.       If TextRec(t).Mode=fmOutput Then
  1395.          Flush (t) ;
  1396.       TextRec(t).BufPos := 0 ;
  1397.       TextRec(t).BufEnd := 0 ;
  1398.       r.ax := $4200 ;
  1399.       r.bx := TextRec(t).Handle ;
  1400.       r.cx := w.h ;
  1401.       r.dx := w.l ;
  1402.       Intr ($21,r) ;
  1403.       If r.flags And fcarry<>0 Then
  1404.          InOutRes := r.ax
  1405.    End {TextSeek} ;
  1406.  
  1407. Procedure WaitKey ;
  1408.    Begin
  1409.       ClrKeyBuf ;
  1410.       While Not KeyPressed Do Nothing ;
  1411.       ClrKeyBuf
  1412.    End {WaitKey} ;
  1413.  
  1414. Function GetJaNein : Boolean ;
  1415.    Begin
  1416.       GetJaNein := GetOption('JN')='J'
  1417.    End {GetJaNein} ;
  1418.  
  1419. Function GetYesNo : Boolean ;
  1420.    Begin
  1421.       GetYesNo := GetOption('YN')='Y'
  1422.    End {GetYesNo} ;
  1423.  
  1424. Function  GetOption (s : String) : Char ;
  1425.    Var c : Char ;
  1426.    Begin
  1427.       s := UpperCase(s) ;
  1428.       ClrKeyBuf ;
  1429.       Repeat
  1430.          c := ReadKey ;
  1431.          If c=#0 Then
  1432.             c := Chr(0*Ord(ReadKey)) ;
  1433.          c := UpCase(c)
  1434.       Until Pos(c,s)<>0 ;
  1435.       WriteLn (c) ;
  1436.       GetOption := c ;
  1437.       ClrKeyBuf
  1438.    End {GetOption} ;
  1439.  
  1440. Function  GetQuietOption (s : String) : Char ;
  1441.    Var c : Char ;
  1442.    Begin
  1443.       s := UpperCase(s) ;
  1444.       ClrKeyBuf ;
  1445.       Repeat
  1446.          c := ReadKey ;
  1447.          If c=#0 Then
  1448.             c := Chr(0*Ord(ReadKey)) ;
  1449.          c := UpCase(c)
  1450.       Until Pos(c,s)<>0 ;
  1451.       GetQuietOption := c ;
  1452.       ClrKeyBuf
  1453.    End {GetQuietOption} ;
  1454.  
  1455. Procedure ScrollUp(x1,y1,x2,y2,nr,at : Byte) ;
  1456.    Begin
  1457.       r.al := nr ;
  1458.       r.ch := y1 ;
  1459.       r.cl := x1 ;
  1460.       r.dh := y2 ;
  1461.       r.dl := x2 ;
  1462.       r.bh := at ;
  1463.       r.ah := 6 ;
  1464.       Intr ($10,r)
  1465.    End {ScrollUp} ;
  1466.  
  1467. Procedure ScrollDown(x1,y1,x2,y2,nr,at : Byte) ;
  1468.    Begin
  1469.       r.al := nr ;
  1470.       r.ch := y1 ;
  1471.       r.cl := x1 ;
  1472.       r.dh := y2 ;
  1473.       r.dl := x2 ;
  1474.       r.bh := at ;
  1475.       r.ah := 7 ;
  1476.       Intr ($10,r)
  1477.    End {ScrollDown} ;
  1478.  
  1479. Procedure PrintAt(x,y : Integer ; Const s : String ; at : Byte) ;
  1480.    Var  i : Integer ;
  1481.    Begin
  1482.       If x<=0 Then x := WhereX ;
  1483.       If y<=0 Then y := WhereY ;
  1484.       For i:=1 To Length(s) Do Begin
  1485.          GotoXY (x,y) ;
  1486.          r.al := Byte(s[i]) ;
  1487.          r.bl := at ;
  1488.          r.bh := 0 ;
  1489.          r.ah := $09 ;
  1490.          r.cx := 1 ;
  1491.          Intr ($10,r) ;
  1492.          Inc (x)
  1493.       End
  1494.    End {PrintAt} ;
  1495.  
  1496. {
  1497. ************
  1498. *  Anwendungsbeispiel:
  1499. *  WriteLn ('abc',Tab(20),'xyz') ;
  1500. *  Offset ist 1. Hat der Cursor die angegebene Spalte schon überschritten,
  1501. *  wird ein Leerstring übergeben.
  1502. ************}
  1503.  
  1504. Function  Tab (n : Integer) : String ;
  1505.   Var  h : String ;
  1506.        z : Integer ;
  1507.   Begin
  1508.      z := n-WhereX ;
  1509.      If z<1 Then
  1510.         Tab := ''
  1511.      Else Begin
  1512.         FillChar (h[1],z,32) ;
  1513.         h[0] := Chr(z) ;
  1514.         Tab := h
  1515.      End ;
  1516.   End {Tab} ;
  1517.  
  1518. {
  1519. **********
  1520. *  Anwendungsbeispiel:
  1521. *  WriteLn (LeftEq('abc',20),'xyz') ;
  1522. *  Im Ergebnisstring ist s linksbündig enthalten. Ist er kürzer als n, so
  1523. *  wird er mit Spaces aufgefüllt; ist er länger, wird rechts abgeschnit-
  1524. *  ten. Eine rechtsbündige Ausgabe ist mit der normalen Write-Formatierung
  1525. *  (per Doppelpunkt) zu erreichen.
  1526. **********}
  1527.  
  1528. Function  LeftEq (Const s : String ; n : Integer) : String ;
  1529.    Var  h : String ;
  1530.    Begin
  1531.       If Length(s)=n Then
  1532.          LeftEq := s
  1533.       Else
  1534.          If Length(s)>n Then
  1535.             LeftEq := Copy(s,1,n)
  1536.          Else Begin
  1537.             FillChar (h[1],n,32) ;
  1538.             h := s ;
  1539.             h[0] := Chr(n) ;
  1540.             LeftEq := h
  1541.          End
  1542.    End {LeftEq} ;
  1543.  
  1544. {StringOf() schreibt in den String s das Zeichen c b-mal.}
  1545. Procedure  StringOf (Var s : String ; c : Char ; b : Byte) ;
  1546.    Begin
  1547.       FillChar (s[1],b,c) ;
  1548.       s[0] := Char(b)
  1549.    End {StringOf} ;
  1550.  
  1551. Function  fStringOf (c : Char ; b : Byte) : String ;
  1552.    Var  s : String ;
  1553.    Begin
  1554.       FillChar (s[1],b,c) ;
  1555.       s[0] := Char(b) ;
  1556.       fStringOf := s
  1557.    End {fStringOf} ;
  1558.  
  1559. Function  WordStr (w : Word) : String ;
  1560.    Var  s : String[5] ;
  1561.    Begin
  1562.       Str (w,s) ;
  1563.       WordStr := s
  1564.    End {WordStr} ;
  1565.  
  1566. Function  IntStr (i : Integer) : String ;
  1567.    Var  s : String[6] ;
  1568.    Begin
  1569.       Str (i,s) ;
  1570.       IntStr := s
  1571.    End {IntStr} ;
  1572.  
  1573. Function  LongStr (l : LongInt) : String ;
  1574.    Var  s : String[11] ;
  1575.    Begin
  1576.       Str (l,s) ;
  1577.       LongStr := s
  1578.    End {LongStr} ;
  1579.  
  1580. Procedure PingCursor ;
  1581.    Begin
  1582.       PingX := WhereX ;
  1583.       PingY := WhereY
  1584.    End {PingCursor} ;
  1585.  
  1586. Procedure PongCursor ;
  1587.    Begin
  1588.       GotoXY (PingX,PingY)
  1589.    End {PongCursor} ;
  1590.  
  1591. Function  Clock : LongInt ;
  1592.    Var  h,m,s,s100 : Word ;
  1593.    Begin
  1594.       GetTime (h,m,s,s100) ;
  1595.       Clock := 360000*h+6000*LongInt(m)+100*s+s100
  1596.    End {Clock} ;
  1597.  
  1598. Function  TimeIdent : LongInt ;
  1599.    Var  dt    : DateTime ;
  1600.         id    : LongInt ;
  1601.         dummy : Word ;
  1602.    Begin
  1603.       GetTime (dt.hour,dt.min,dt.sec,dummy) ;
  1604.       GetDate (dt.year,dt.month,dt.day,dummy) ;
  1605.       PackTime (dt,id) ;
  1606.       TimeIdent := id
  1607.    End {TimeIdent} ;
  1608.  
  1609.  
  1610. Function  Hex2 (b : Byte) : Str2 ;
  1611.    Begin
  1612.       Hex2[0] := #2 ;
  1613.       Hex2[1] := HexDig[b Shr 4] ;
  1614.       Hex2[2] := HexDig[b And 15]
  1615.    End {Hex2} ;
  1616.  
  1617. Function  Hex4 (w : Word) : Str4 ;
  1618.    Begin
  1619.       Hex4[0] := #4 ;
  1620.       Hex4[1] := HexDig[Hi(w) Shr 4] ;
  1621.       Hex4[2] := HexDig[Hi(w) And 15] ;
  1622.       Hex4[3] := HexDig[Lo(w) Shr 4] ;
  1623.       Hex4[4] := HexDig[w And 15]
  1624.    End {Hex4} ;
  1625.  
  1626. Function  Hex8 (l : LongInt) : Str8 ;
  1627.    Var  w : Record l,h : Word End Absolute l ;
  1628.    Begin
  1629.       Hex8[0] := #8 ;
  1630.       Hex8[1] := HexDig[Hi(w.h) Shr 4] ;
  1631.       Hex8[2] := HexDig[Hi(w.h) And 15] ;
  1632.       Hex8[3] := HexDig[Lo(w.h) Shr 4] ;
  1633.       Hex8[4] := HexDig[w.h And 15] ;
  1634.       Hex8[5] := HexDig[Hi(w.l) Shr 4] ;
  1635.       Hex8[6] := HexDig[Hi(w.l) And 15] ;
  1636.       Hex8[7] := HexDig[Lo(w.l) Shr 4] ;
  1637.       Hex8[8] := HexDig[w.l And 15]
  1638.    End {Hex8} ;
  1639.  
  1640. Function  lShl (l : LongInt ; c : Byte) : LongInt ; Assembler ;
  1641.    Asm
  1642.                 mov     cl,c
  1643.                 cmp     cl,16
  1644.                 je      @e16
  1645.                 ja      @a16
  1646.                 mov     ax,Word Ptr l
  1647.                 mov     dx,Word Ptr l+2
  1648.                 mov     bx,ax
  1649.                 shl     ax,cl
  1650.                 shl     dx,cl
  1651.                 sub     cl,16
  1652.                 neg     cl
  1653.                 shr     bx,cl
  1654.                 or      dx,bx
  1655.                 jmp     @z
  1656.         @e16:   mov     dx,Word Ptr l
  1657.                 xor     ax,ax
  1658.                 jmp     @z
  1659.         @a16:   mov     dx,Word Ptr l
  1660.                 xor     ax,ax
  1661.                 sub     cl,16
  1662.                 shl     dx,cl
  1663.         @z:
  1664.    End {lShl} ;
  1665.  
  1666. Function  lShr (l : LongInt ; c : Byte) : LongInt ; Assembler ;
  1667.    Asm
  1668.                 mov     cl,c
  1669.                 cmp     cl,16
  1670.                 je      @e16
  1671.                 ja      @a16
  1672.                 mov     ax,Word Ptr l
  1673.                 mov     dx,Word Ptr l+2
  1674.                 mov     bx,dx
  1675.                 shr     ax,cl
  1676.                 shr     dx,cl
  1677.                 sub     cl,16
  1678.                 neg     cl
  1679.                 shl     bx,cl
  1680.                 or      ax,bx
  1681.                 jmp     @z
  1682.         @e16:   mov     ax,Word Ptr l+2
  1683.                 xor     dx,dx
  1684.                 jmp     @z
  1685.         @a16:   mov     ax,Word Ptr l+2
  1686.                 xor     dx,dx
  1687.                 sub     cl,16
  1688.                 shr     ax,cl
  1689.         @z:
  1690.    End {lShr} ;
  1691.  
  1692. Function  MulDiv (m1,m2,d : Word) : Word ; Assembler ;
  1693.    Asm
  1694.                 mov     ax,m1
  1695.                 mul     m2
  1696.                 div     d
  1697.    End {MulDiv} ;
  1698.  
  1699. Function  LongHi (x : LongInt) : Word ; Assembler ;
  1700.    Asm
  1701.         mov     ax,Word Ptr x+2
  1702.    End {LongHi} ;
  1703.  
  1704. Function  LongLo (x : LongInt) : Word ; Assembler ;
  1705.    Asm
  1706.         mov     ax,Word Ptr x
  1707.    End {LongLo} ;
  1708.  
  1709. Function  Hex2Dec (Const h : Str8 ; Var l : LongInt) : Boolean ;
  1710.    Var  tl : LongInt ;
  1711.         i  : Integer ;
  1712.    Begin
  1713.       Hex2Dec := False ;
  1714.       l := 0 ;
  1715.       tl := 0 ;
  1716.       For i:=1 To Length(h) Do
  1717.          Case UpCase(h[i]) Of
  1718.             '0'..'9' : tl := lShl(tl,4) Or (Byte(h[i])-Byte('0')) ;
  1719.             'A'..'F' : tl := lShl(tl,4) Or (Byte(UpCase(h[i]))-Byte('A')+10)
  1720.          Else
  1721.             Exit
  1722.          End ;
  1723.       Hex2Dec := True ;
  1724.       l := tl
  1725.    End {Hex2Dec} ;
  1726.  
  1727. Function  Hex (l : LongInt) : Str8 ;
  1728.    Var  t : Str8 ;
  1729.    Begin
  1730.       t := Hex8(l) ;
  1731.       While (t[0]>#1) And (t[1]='0') Do
  1732.          Delete (t,1,1) ;
  1733.       Hex := t
  1734.    End {Hex} ;
  1735.  
  1736. Function  Lead0 (l : LongInt ; f : Byte) : Str10 ;
  1737.    Var  ts : Str10 ;
  1738.    Begin
  1739.       Str (l:f,ts) ;
  1740.       f := 1 ;
  1741.       While ts[f]=#32 Do Begin
  1742.          ts[f] := '0' ;
  1743.          Inc (f)
  1744.       End ;
  1745.       Lead0 := ts
  1746.    End {Lead0} ;
  1747.  
  1748. Function  LeadSpc (l : LongInt ; f : Byte) : Str10 ;
  1749.    Var  ts : Str10 ;
  1750.    Begin
  1751.       Str (l:f,ts) ;
  1752.       LeadSpc := ts
  1753.    End {LeadSpc} ;
  1754.  
  1755. Function  Subst (s : String ; Const old,new : String) : String ;
  1756.    Var  p : Integer ;
  1757.    Begin
  1758.       If Pos(old,new)<>0 Then
  1759.          Subst := ''
  1760.       Else Begin
  1761.          p := Pos(old,s) ;
  1762.          While p<>0 Do Begin
  1763.             s := Copy(s,1,Pred(p))+new+Copy(s,p+Length(old),255) ;
  1764.             p := Pos(old,s)
  1765.          End ;
  1766.          Subst := s
  1767.       End
  1768.    End {Subst} ;
  1769.  
  1770. Procedure  DeComment (Const com : String ; Var s : String) ;
  1771.    Var  i,p : Integer ;
  1772.    Begin
  1773.       For i:=1 To Length(com) Do Begin
  1774.          p := Pos(com[i],s) ;
  1775.          If p<>0 Then
  1776.             Delete (s,p,255)
  1777.       End
  1778.    End {DeComment} ;
  1779.  
  1780. Procedure  Justify (Var s : String) ;
  1781.    Var  i : Integer ;
  1782.    Begin
  1783.       {Convert tabs to spaces:}
  1784.       For i:=1 To Length(s) Do
  1785.          If s[i]=#9 Then
  1786.             s[i] := #32 ;
  1787.       {Delete preceding spaces:}
  1788.       For i:=1 To Length(s) Do
  1789.          If s[i]<>#32 Then
  1790.             Break ;
  1791.       If i>Length(s) Then Begin
  1792.          s[0] := #0 ;
  1793.          Exit
  1794.       End ;
  1795.       If i>1 Then
  1796.          Delete (s,1,Pred(i)) ;
  1797.       {Delete trailing spaces:}
  1798.       For i:=Length(s) DownTo 1 Do
  1799.          If s[i]<>#32 Then
  1800.             Break ;
  1801.       If i<Length(s) Then
  1802.          Delete (s,Succ(i),255) ;
  1803.       {Compress spaces:}
  1804.       i:=2 ;
  1805.       While i<=Length(s)-2 Do Begin
  1806.          While (s[i]=#32) And (s[Succ(i)]=#32) Do
  1807.             Delete (s,i,1) ;
  1808.          Inc (i)
  1809.       End
  1810.    End {Justify} ;
  1811.  
  1812. Procedure  DeSpace (Var s : String) ;
  1813.    Var  p : Byte ;
  1814.    Begin
  1815.       p := Pos(#9,s) ;
  1816.       While p<>0 Do Begin
  1817.          Delete (s,p,1) ;
  1818.          p := Pos(#9,s)
  1819.       End ;
  1820.       p := Pos(#32,s) ;
  1821.       While p<>0 Do Begin
  1822.          Delete (s,p,1) ;
  1823.          p := Pos(#32,s)
  1824.       End
  1825.    End {DeSpace} ;
  1826.  
  1827. Function  PartStr (Const s : String ; c : Char ; x : Integer) : String ;
  1828.    Var  i,j,p : Word ;
  1829.    Begin
  1830.       If x<0 Then Begin
  1831.          j := 0 ;
  1832.          For i:=1 To Length(s) Do
  1833.             If s[i]=c Then
  1834.                Inc (j) ;
  1835.          Inc (x,Succ(j))
  1836.       End ;
  1837.       i := 1 ;
  1838.       p := 0 ;
  1839.       While (i<=Length(s)) And (p<x) Do Begin
  1840.          If s[i]=c Then
  1841.             Inc (p) ;
  1842.          Inc (i)
  1843.       End ;
  1844.       If i>Length(s) Then Begin
  1845.          PartStr := '' ;
  1846.          Exit
  1847.       End ;
  1848.       j := i ;
  1849.       While (j<=Length(s)) And (p=x) Do Begin
  1850.          If s[j]=c Then
  1851.             Inc (p) ;
  1852.          Inc (j)
  1853.       End ;
  1854.       If p>x Then
  1855.          Dec (j) ;
  1856.       PartStr := Copy(s,i,j-i)
  1857.    End {PartStr} ;
  1858.  
  1859. Function  PartCount (Const s : String ; c : Char) : Word ;
  1860.    Var  w,i : Word ;
  1861.    Begin
  1862.       If s[0]=#0 Then Begin
  1863.          PartCount := 0 ;
  1864.          Exit
  1865.       End ;
  1866.       w := 1 ;
  1867.       For i:=1 To Length(s) Do
  1868.          If s[i]=c Then
  1869.             Inc (w) ;
  1870.       PartCount := w
  1871.    End {PartCount} ;
  1872.  
  1873. Function  PartWidth (Const s : String ; c : Char) : Word ;
  1874.    Var  w,maxw,i : Word ;
  1875.    Begin
  1876.       w := 0 ;
  1877.       maxw := 0 ;
  1878.       For i:=1 To Length(s) Do
  1879.          If s[i]=c Then Begin
  1880.             If w>maxw Then
  1881.                maxw := w ;
  1882.             w := 0
  1883.          End
  1884.          Else
  1885.             Inc (w) ;
  1886.       If w>maxw Then
  1887.          PartWidth := w
  1888.       Else
  1889.          PartWidth := maxw
  1890.    End {PartWidth} ;
  1891.  
  1892. Function  PPartStart (s : PChar ; c : Char ; x : Integer) : PChar ;
  1893.    Var  p      : Word ;
  1894.         tp,tp2 : PChar ;
  1895.    Begin
  1896.       PPartStart := NIL ;
  1897.       If (s=NIL) Or (s[0]=#0) Then
  1898.          Exit ;
  1899.       If x<0 Then Begin {x in positiven Wert umwandeln}
  1900.          p := 0 ; {zählt die Parts}
  1901.          tp := s ;
  1902.          While True Do Begin
  1903.             tp := StrScan(tp,c) ;
  1904.             Inc (p) ;
  1905.             If tp=NIL Then
  1906.                Break
  1907.             Else
  1908.                Inc (tp)
  1909.          End ;
  1910.          Inc (x,p)
  1911.       End ;
  1912.       p := 0 ; {zählt die Parts}
  1913.       tp := s ;
  1914.       While (p<x) Do Begin
  1915.          tp := StrScan(tp,c) ;
  1916.          Inc (p) ;
  1917.          If tp=NIL Then
  1918.             Break
  1919.          Else
  1920.             Inc (tp)
  1921.       End ; {tp zeigt auf Trennzeichen+1, oder NIL}
  1922.       If (tp[0]=#0) Or (tp[0]=c) Then
  1923.          PPartStart := NIL
  1924.       Else
  1925.          PPartStart := tp
  1926.    End {PPartStart} ;
  1927.  
  1928. Function  PPartStr (s : PChar ; c : Char ; x : Integer ; Dest : PChar) : PChar ;
  1929.    Var  tp,tp2 : PChar ;
  1930.    Begin
  1931.       PPartStr := Dest ;
  1932.       If Dest=NIL Then
  1933.          Exit ;
  1934.       Dest[0] := #0 ;
  1935.       tp := PPartStart(s,c,x) ;
  1936.       If tp=NIL Then
  1937.          Exit ;
  1938.       tp2 := StrScan(tp,c) ;
  1939.       If tp2=NIL Then
  1940.          tp2 := StrEnd(tp) ;
  1941.       StrLCopy (Dest,tp,tp2-tp)
  1942.    End {PPartStr} ;
  1943.  
  1944. Function  PPartCount (s : PChar ; c : Char) : Word ;
  1945.    Var  p : Word ;
  1946.    Begin
  1947.       p := 0 ;
  1948.       If (s=NIL) Or (s[0]=#0) Then Begin
  1949.          PPartCount := 0 ;
  1950.          Exit
  1951.       End ;
  1952.       While True Do Begin
  1953.          s := StrScan(s,c) ;
  1954.          Inc (p) ;
  1955.          If s=NIL Then
  1956.             Break
  1957.          Else
  1958.             Inc (s)
  1959.       End ;
  1960.       PPartCount := p
  1961.    End {PPartCount} ;
  1962.  
  1963. Function  PPartWidth (s : PChar ; c : Char) : Word ;
  1964.    Var  w,maxw : Word ;
  1965.         l      : PChar ;
  1966.    Begin
  1967.       maxw := 0 ;
  1968.       If (s=NIL) Or (s[0]=#0) Then Begin
  1969.          PPartWidth := 0 ;
  1970.          Exit
  1971.       End ;
  1972.       While True Do Begin
  1973.          l := s ;
  1974.          s := StrScan(l,c) ;
  1975.          If s=NIL Then
  1976.             s := StrEnd(l) ;
  1977.          w := s-l ;
  1978.          If w>maxw Then
  1979.             maxw := w ;
  1980.          If s[0]=#0 Then
  1981.             Break
  1982.       End ;
  1983.       PPartWidth := maxw
  1984.    End {PPartWidth} ;
  1985.  
  1986. Function  StrGetMem (Var p : PChar ; Len : Word) : PChar ;
  1987.    Begin
  1988.       If MaxAvail<=Succ(Len) Then
  1989.          p := NIL
  1990.       Else
  1991.          GetMem (p,Succ(Len)) ;
  1992.       StrGetMem := p
  1993.    End {StrGetMem} ;
  1994.  
  1995. Procedure  StrFreeMem (Var p : PChar ; Len : Word) ;
  1996.    Begin
  1997.       If p<>NIL Then Begin
  1998.          FreeMem (p,Succ(Len)) ;
  1999.          p := NIL
  2000.       End
  2001.    End {StrFreeMem} ;
  2002.  
  2003. Function  UpdateCRC32 (InitCRC : LongInt ; Var InBuf ; InLen : Word) : LongInt ;
  2004.    External ; {$L CRC32.OBJ}
  2005.  
  2006. Function  EnterString (s : pChar ; maxlen : Word ; PrintChar : PCProc) : Boolean ;
  2007.    Const  CursorOff = False ;
  2008.           CursorOn  = True ;
  2009.    Var  w,actp : Word ;
  2010.         Ready,Cancel : Boolean ;
  2011.         st : String ;
  2012.         c  : Char ;
  2013.    Begin
  2014.       st := StrPas(s) ;
  2015.       For w:=1 To Length(st) Do
  2016.          PrintChar (w,st[w],CursorOff) ;
  2017.       actp := Succ(Length(st)) ;
  2018.       PrintChar (actp,#32,CursorOn) ;
  2019.       For w:=Succ(actp) To maxlen Do
  2020.          PrintChar (w,#32,CursorOff) ;
  2021.       Ready := False ;
  2022.       Cancel := False ;
  2023.       ClrKeyBuf ;
  2024.       Repeat
  2025.          c := ReadKey ;
  2026.          If actp>Length(st) Then
  2027.             PrintChar (actp,#32,CursorOff)
  2028.          Else
  2029.             PrintChar (actp,st[actp],CursorOff) ;
  2030.          Case c Of
  2031.             #0 : Case ReadKey Of
  2032.                     #75 : If actp>1 Then {left}
  2033.                              Dec (actp) ;
  2034.                     #77 : If actp<=Length(st) Then {right}
  2035.                              Inc (actp) ;
  2036.                     #71 : actp := 1 ; {home}
  2037.                     #79 : actp := Succ(Length(st)) ; {end}
  2038.                     #83 : If actp<=Length(st) Then Begin {delete}
  2039.                              Delete (st,actp,1) ;
  2040.                              For w:=Succ(actp) To Length(st) Do
  2041.                                 PrintChar (w,st[w],CursorOff) ;
  2042.                              PrintChar (Succ(Length(st)),#32,CursorOff)
  2043.                           End ;
  2044.                     #115 : If actp>1 Then
  2045.                               Repeat
  2046.                                  Dec (actp)
  2047.                               Until (actp=1) Or
  2048.                                     (st[actp]<>#32) And (st[actp-1]=#32) ;
  2049.                     #116 : If actp<=Length(st) Then
  2050.                               Repeat
  2051.                                  Inc (actp)
  2052.                               Until (actp>Length(st)) Or
  2053.                                     (st[actp]<>#32) And (st[actp-1]=#32) ;
  2054.                  Else
  2055.                     Beep ;
  2056.                     ClrKeyBuf
  2057.                  End ;
  2058.             #8 : If actp>1 Then Begin
  2059.                     Dec (actp) ;
  2060.                     Delete (st,actp,1) ;
  2061.                     For w:=actp To Length(st) Do
  2062.                        PrintChar (w,st[w],w=actp) ;
  2063.                     PrintChar (Succ(Length(st)),#32,CursorOff)
  2064.                  End ;
  2065.             #13 : Ready := True ;
  2066.             #27 : Cancel := True
  2067.          Else
  2068.             If Length(st)<maxlen Then Begin
  2069.                st := Copy(st,1,Pred(actp))+c+Copy(st,actp,Succ(Length(st)-actp)) ;
  2070.                Inc (actp) ;
  2071.                For w:=Pred(actp) To Length(st) Do
  2072.                   PrintChar (w,st[w],CursorOff)
  2073.             End
  2074.             Else Begin
  2075.                Beep ;
  2076.                ClrKeyBuf
  2077.             End
  2078.          End ;
  2079.          If actp>Length(st) Then
  2080.             PrintChar (actp,#32,CursorOn)
  2081.          Else
  2082.             PrintChar (actp,st[actp],CursorOn)
  2083.       Until Ready Or Cancel ;
  2084.       If Ready Then
  2085.          StrPCopy (s,st) ;
  2086.       EnterString := Ready
  2087.    End {EnterString} ;
  2088.  
  2089. {*************************
  2090.  ***  Maus-Funktionen  ***
  2091.  *************************}
  2092.  
  2093. Function  InitMouse : Boolean ; Assembler ;
  2094.    Asm
  2095.           mov     ax,3533h
  2096.           int     21h   {get int vector 33h}
  2097.           xor     ax,ax
  2098.           test    bx,bx
  2099.           jnz     @t
  2100.           mov     bx,es
  2101.           test    bx,bx
  2102.           jz      @f
  2103.  
  2104.       @t: int     33h   {ax still 0}
  2105.           test    ax,ax
  2106.           jz      @f    {0 = no mouse driver}
  2107.           mov     ax,0001h
  2108.       @f:
  2109.    End {InitMouse} ;
  2110.  
  2111. Procedure  ResetMouse ; Assembler ;
  2112.    Asm
  2113.       mov     ax,0021h
  2114.       int     33h
  2115.    End {ResetMouse} ;
  2116.  
  2117. Procedure  ShowMouse ; Assembler ;
  2118.    Asm
  2119.       mov     ax,0001h
  2120.       int     33h
  2121.    End {ShowMouse} ;
  2122.  
  2123. Procedure  HideMouse ; Assembler ;
  2124.    Asm
  2125.       mov     ax,0002h
  2126.       int     33h
  2127.    End {HideMouse} ;
  2128.  
  2129. Procedure  SetFrame (x1,y1,x2,y2 : Word) ; Assembler ;
  2130.    Asm
  2131.       mov     ax,0007h
  2132.       mov     cx,x1
  2133.       mov     dx,x2
  2134.       int     33h
  2135.       mov     ax,0008h
  2136.       mov     cx,y1
  2137.       mov     dx,y2
  2138.       int     33h
  2139.    End {SetFrame} ;
  2140.  
  2141. Function  GetMouse : Word ; Assembler ;
  2142.    Asm
  2143.       mov     ax,0003h
  2144.       xor     bx,bx
  2145.       int     33h
  2146.       mov     mx,cx
  2147.       mov     my,dx
  2148.       mov     ax,bx
  2149.    End {GetMouse} ;
  2150.  
  2151. Procedure  SetMouse (x,y : Word) ; Assembler ;
  2152.    Asm
  2153.       mov     ax,0004h
  2154.       mov     cx,x
  2155.       mov     dx,y
  2156.       int     33h
  2157.    End {SetMouse} ;
  2158.  
  2159. Procedure  DefineMickey (Horiz,Vertic : Word) ; Assembler ;
  2160.    Asm
  2161.       mov     ax,000fh
  2162.       mov     cx,Horiz
  2163.       mov     dx,Vertic
  2164.       int     33h
  2165.    End {DefineMickey} ;
  2166.  
  2167. Procedure GetMickey (Var Horiz,Vertic : Integer) ; Assembler ;
  2168.    Asm
  2169.       mov     ax,000bh
  2170.       int     33h
  2171.       les     di,Horiz
  2172.       mov     es:[di],cx
  2173.       les     di,Vertic
  2174.       mov     es:[di],dx
  2175.    End {GetMickey} ;
  2176.  
  2177. Procedure  WaitButton ;
  2178.    Begin
  2179.       While GetMouse<>0 Do Nothing ;
  2180.       ClrKeyBuf ;
  2181.       While Not KeyPressed And (GetMouse=0) Do Nothing ;
  2182.       ClrKeyBuf
  2183.    End {WaitButton} ;
  2184.  
  2185. Procedure SetMouseCursor (sm,cm : Word) ; Assembler ;
  2186.    Asm
  2187.       mov     ax,000ah
  2188.       xor     bx,bx
  2189.       mov     cx,sm
  2190.       mov     dx,cm
  2191.       int     33h
  2192.    End {SetMouseCursor} ;
  2193.  
  2194. Procedure SetMousePointer (Var scm ; hotx,hoty : Integer) ; Assembler ;
  2195.    Asm
  2196.       mov     ax,0009h
  2197.       mov     bx,hotx
  2198.       mov     cx,hoty
  2199.       les     dx,scm
  2200.       int     33h
  2201.    End {SetMousePointer} ;
  2202.  
  2203. Procedure  SetUpdateFrame (x1,y1,x2,y2 : Word) ; Assembler ;
  2204.    Asm
  2205.       mov     ax,0010h
  2206.       mov     cx,x1
  2207.       mov     dx,y1
  2208.       mov     si,x2
  2209.       mov     di,y2
  2210.       int     33h
  2211.    End {SetUpdateFrame} ;
  2212.  
  2213. Begin
  2214.    MaxX := Pred(Mem[Seg0040:$004a]) ;
  2215.    MaxY := Mem[Seg0040:$0084] ;
  2216.    If (MaxY<24) Or (MaxY>95) Then
  2217.       MaxY := 24 ;
  2218.    x1 := 0 ;
  2219.    y1 := 0 ;
  2220.    x2 := MaxX ;
  2221.    y2 := MaxY ;
  2222.    TextAttr := Mem[SegB800:Succ(MaxY*Succ(MaxX)Shl 1)] ;
  2223.    KeyPends := False ;
  2224.    Port[$43] := $34 ; {Binaer, Modus 2, Lo/Hi-Byte, Counter 0}
  2225.    Port[$40] := 0 ;
  2226.    Port[$40] := 0
  2227. End.
  2228.