Turbo Toolbox/Turbo_Toolbox.iso/1991/09_10/praxis/morsenpc.pas

Pascal/Delphi Source File | 1991-07-12 | 17.8 KB | 538 lines

(* ------------------------------------------------------ *)
(*                    MORSENPC.PAS                        *)
(*      Morsezeichen senden und mit einer parallelen      *)
(*         Schnittstelle oder Gamekarte empfangen         *)
(*          (c) 1991 Andreas Bartels & TOOLBOX            *)
(* ------------------------------------------------------ *)
{$A+,B-,D-,E-,F-,I-,L-,N-,O-,R+,S-,V-,X+}
PROGRAM MorsenMitPC;
USES
  Graph, Crt, Dos, Printer;
CONST
  PortNo = $379;                        { Portadresse LPT1 }
  BitNo  = 4;            { Position des "Datenbits" an LPT }
{ Das Interface läßt sich auf verschiedene Arten           }
{ anschließen. Die folgende Tabelle gibt Auskunft über     }
{ die Portadresse, die Position des Datenbits und die      }
{ Pin-Nr. des Anschluß. Bitte passen Sie die Konstanten    }
{ "PortNo" und "BitNo" auf den Anschluß an!                }
{╔═══════════════════╦═══════╤═════╤═════════════════╤════╗}
{║  Schnittstelle    ║ BitNo │ Pol │ Bedeutung       │Pin ║}
{╠═══════════════════╬═══════╪═════╪═════════════════╪════╣}
{║ ┌──────────Port─┐ ║   3   │  -  │ Error           │ 15 ║}
{║ │LPT1      0379h│ ║   4   │  +  │ Select          │ 13 ║}
{║ │LPT2      0279h│ ║   5   │  +  │ Paper Out       │ 12 ║}
{║ │LPT3      03BDh│ ║   6   │  +  │ Acknowledge     │ 10 ║}
{║ └───────────────┘ ║   7   │  -  │ Busy            │ 11 ║}
{╠═┌──────────Port─┐═╬═══════╪═════╪═════════════════╪════╣}
{║ │Gamekarte 0200h│ ║   4   │  +  │ Stick 1 Feuer 1 │ 2  ║}
{║ │Multi-IO: 0201h│ ║   5   │  +  │ Stick 1 Feuer 2 │ 7  ║}
{║ │      bis 0207h│ ║   6   │  +  │ Stick 2 Feuer 1 │ 14 ║}
{║ └───────────────┘ ║   7   │  +  │ Stick 2 Feuer 2 │ 10 ║}
{╚═══════════════════╩═══════╧═════╧═════════════════╧════╝}
  MaxLen = 6;                       { max. Länge Morsecode }
  ZSatz : STRING[126] =    { binär codiertes Morsealphabet }
{ Binärcode, letzte
   Dezimalstelle     :     010123012345670123456789012345
   Binärcode-Länge   :     112222333333334444444444444444
   Zulässige Zeichen : } 'ETIANMSURWDKGOHVF~L~PJBXCYZQ!~'
{                        01234567890123456789012345678901
                         55555555555555555555555555555555 }
                       +'54~3~~~2~~~~~~~16=/~~~(~7~~~8~90'
{                        01234567890123456789012345678901
                         66666666666666666666666666666666 }
                       +'~~~~~~~~~~~~?~~~~~~~~.~~~~~~~~'''
{                        23456789012345678901234567890123
                         66666666666666666666666666666666 }
                       +'~~-~~~~~~~~;~~)~~~~~,~~~~:~~~~~~';
  ZweiHoch : ARRAY[0..MaxLen] OF BYTE =
             (1, 2, 4, 8, 16, 32, 64);
  SoundOn  : BOOLEAN = TRUE;
  GameOver : BOOLEAN = FALSE;
VAR
  ZProMin, Vari, MFreq, MTime, Long, Short : WORD;
  EmpfProtFName, SendProtFName,
  MorseFName, Kennung                      : STRING[60];
  EmpfProtF, SendProtF                     : TEXT;
  MorseF                                   : FILE OF CHAR;

PROCEDURE Line(y : BYTE; s : STRING);
VAR n : BYTE;
BEGIN
  GotoXY(1, y); ClrEoL; GotoXY(10, y);
  FOR n := 1 TO Length(s) DO
    CASE s[n] OF
      '⌐' : HighVideo;
      '¬' : LowVideo;
    ELSE    Write(s[n]);
    END;
END;  { Line }

PROCEDURE KopfZeile;
BEGIN
  ClrScr;
  Line(1, '⌐Morsen mit PC¬   (c) 1991 Andreas'+
          ' Bartels & toolbox');
END;  { KopfZeile }

FUNCTION DateiExistiert(FileName : STRING) : BOOLEAN;
VAR Datei : FILE;
BEGIN
  Assign(Datei, FileName);
  {$I-} Reset( Datei ); Close( Datei ); {$I+};
  DateiExistiert := (FileName <> '') AND (IOResult = 0);
END;  { DateiExistiert }

PROCEDURE WaitOrKey(MS : LONGINT);
VAR Key : CHAR; Time : LONGINT;
BEGIN
  Time := 0;
  REPEAT
    IF KeyPressed THEN Time := MS;
    Delay(10); Inc(Time, 10);
  UNTIL Time >= MS;
  IF KeyPressed THEN Key := ReadKey;
END;  { WaitOrKey }

PROCEDURE AcceptStr(x, y : BYTE; VAR Str : STRING);
BEGIN
  GotoXY(x, y); ClrEoL; ReadLn(Str);
END;  { AcceptStr }

PROCEDURE AcceptNum(x, y : BYTE; VAR Num : WORD);
VAR Fehler : WORD;
BEGIN
  GotoXY(x, y); ClrEoL;
  REPEAT
    {$I-} ReadLn(Num); {$I+}
    Fehler := IOResult;
    IF Fehler <> 0 THEN GotoXY(x, y);
  UNTIL Fehler = 0;
END;  { AcceptNum }

PROCEDURE ZeichenMorsen(MChar : CHAR);
VAR Laenge, MCode, PosNr, n, m : BYTE;
BEGIN
  IF MChar IN [#97..#122] THEN    { Zeichen filtern und in }
    MChar := UpCase(MChar);       { Großbuchstaben wandeln }
  IF NOT(MChar IN [#32..#165]) THEN MChar := ' ';
  PosNr := Pos(MChar, ZSatz);
  IF PosNr = 0 THEN BEGIN    { kein entspr. Code vorhanden }
    Laenge := 0; MCode  := 0;
  END ELSE BEGIN
    n := PosNr + 1;       { Länge des Morsecodes berechnen }
    IF PosNr < 3 THEN Laenge := 1
    ELSE BEGIN
      Laenge := 0;
      REPEAT
        n := n SHR 1; Inc(Laenge);
      UNTIL n < 2;
    END;
    n := 2; MCode := PosNr;     { Morsecode im Binärformat }
    IF PosNr < 3 THEN MCode := PosNr
    ELSE BEGIN
      REPEAT
        MCode := MCode - n; n := n SHL 1;
      UNTIL n >= MCode;
    END;
    Dec(MCode, 1);
  END;
  IF Laenge = 0 THEN           { Ausgabe über Lautsprecher }
    Delay(3 * MTime)                   { Pause oder Fehler }
  ELSE
    FOR n := 1 TO Laenge DO BEGIN
      Sound(MFreq); Delay(MTime);
      IF MCode AND ZweiHoch[Laenge - n] =
         ZweiHoch[Laenge - n] THEN Delay(2 * MTime);
      NoSound; Delay(MTime);     { Pause innerhalb Zeichen }
    END;
  Delay(2 * MTime);        { Pause zw. Zeichen : 3 * MTime }
  Write(SendProtF, MChar);                { protokollieren }
  IF WhereX > 69 THEN BEGIN                { Zeilenumbruch }
    WriteLn(SendProtF); WriteLn;
  END;
END;  { ZeichenMorsen }

PROCEDURE SendeZeichenWeise;
VAR i, x, y : BYTE; ch : CHAR;
BEGIN
  y := 15;
  REPEAT
    x := 10; GotoXY(x, y);
    REPEAT
      ch := ReadKey; GotoXY(x,y); Write(ch);
      ZeichenMorsen(ch); Inc(x);
    UNTIL (ch = #27) OR (x > 70);
    IF x > 70 THEN Inc(y);
  UNTIL ch = #27;
  ch := 'x'; WriteLn(SendProtF);
END;  { SendeZeichenWeise }

PROCEDURE SendeKennung;
VAR i : BYTE; MorseCh : CHAR; MorseZeile : STRING[60];
BEGIN
  Line(14, 'Sende die Kennung: ' + Kennung); WriteLn;
  FOR i := 1 TO Length(Kennung) DO BEGIN
    Write(UpCase(Kennung[i]));
    ZeichenMorsen(Kennung[i]); Delay(2 * MTime);
    IF KeyPressed THEN
      IF UpCase(ReadKey) = #27 THEN
        i := Length(Kennung);
  END;
  WriteLn(' ... OK'); WaitOrKey(5000); WriteLn(SendProtF);
END;  { SendeKennung }

PROCEDURE SendeDatei;
VAR i : BYTE; MorseCh, ch : CHAR; MorseZeile : STRING[60];
BEGIN
  MorseFName := ' ';
  REPEAT
    Line(14, '⌐Zu sendende Datei:¬ ');
    AcceptStr(30, 14, MorseFName);
    IF MorseFName = ' .TXT' THEN Exit;    { ohä: vertippt! }
  UNTIL DateiExistiert(MorseFName);
  Assign(MorseF, MorseFName); Reset(MorseF);
  MorseZeile := '';
  FOR i := 1 TO 60 DO MorseZeile := MorseZeile + ' ';
  REPEAT
    IF NOT EoF(MorseF) THEN BEGIN
      Read(MorseF, MorseCh);
      CASE MorseCh OF
        #30..#154 : Write(MorseCh);
        #13 :       WriteLn;
      END;
      ZeichenMorsen(MorseCh);
      IF KeyPressed THEN ch := UpCase(ReadKey);
    END;
  UNTIL EoF(MorseF) OR (ch = #27);
  Close(MorseF); WriteLn(' ... OK');
  WaitOrKey(5000); WriteLn(SendProtF);
END;  { SendeDatei }

PROCEDURE SendeMenue;
VAR ch : CHAR;
BEGIN
  IF DateiExistiert(SendProtFName) THEN BEGIN
    Assign(SendProtF, SendProtFName);
    Append(SendProtF);
    WriteLn(SendProtF, #10#13, '  Nächster Eintrag: ');
  END
  ELSE BEGIN
    Assign(SendProtF, SendProtFName);
    ReWrite(SendProtF);
    WriteLn(SendProtF, '  Erster Eintrag: ');
  END;
  REPEAT
    KopfZeile;
    Line(3, '⌐S e n d e - M e n ü');
    Line(5, '⌐Sende:  ⌐K¬ennung  ⌐Z¬eichenweise  ⌐D¬atei');
    Line(9, '⌐Esc¬    Hauptmenü');
    ch := UpCase(ReadKey);
    CASE ch OF
      'K' : SendeKennung;
      'Z' : SendeZeichenWeise;
      'D' : SendeDatei;
    END;
  UNTIL ch = #27;
  WriteLn(SendProtF); Close(SendProtF);
END;  { SendeMenue }

FUNCTION DekodiereZeichen(SCode : STRING) : CHAR;
VAR PosNr, MCode, n : BYTE; ch : CHAR;
BEGIN
  MCode := 0;
  FOR n := 1 TO Length(SCode) DO
    IF SCode[n] = '-' THEN
      MCode := MCode OR ZweiHoch[Length(SCode) - n];
  IF (MCode > ZweiHoch[Length(SCode)] - 1) THEN ch := '≈'
  ELSE ch := ZSatz[ZweiHoch[Length(SCode)] - 1 + MCode];
  NoSound; DekodiereZeichen := ch;
END;  { DekodiereZeichen }

FUNCTION InputBit : BOOLEAN;           { Abfrage des Ports }
VAR BitAnd : BYTE; Bit : BOOLEAN;
BEGIN
  BitAnd := 1 SHL BitNo;
{ Auswertung für Polarisation - }
  Bit := (Port[PortNo] AND BitAnd > 0);
{ ...und für Polarisation + }
{ Bit := (Port[PortNo] AND BitAnd = 0); }
  InputBit := Bit;
  IF SoundOn THEN IF Bit THEN Sound(MFreq)
                         ELSE NoSound;
END;  { InputBit }

PROCEDURE Decode(VAR Zustand : BOOLEAN; VAR Count : WORD);
VAR Zust, ZustAlt : BOOLEAN;            { Signale erkennen }
    FehlerZaehl : WORD;
CONST MaxFehler = 5;
BEGIN
  ZustAlt := InputBit; FehlerZaehl := 0;
  REPEAT
    Inc(Count); Delay(1);
    IF InputBit <> ZustAlt THEN Inc(FehlerZaehl)
                           ELSE FehlerZaehl := 0;
  UNTIL (FehlerZaehl > MaxFehler) OR (Count = $FFFF)
                                  OR KeyPressed;
  Zustand := ZustAlt;
END;  { Decode }

PROCEDURE AdjustSpeed;         { Geschwindigkeitsanpassung }
CONST MaxCount = 10;                     { Anzahl Meßwerte }
VAR Help : LONGINT; Count, Count2 : WORD;
    Zustand, ZustandAlt : BOOLEAN; n, nn, Hi : BYTE;
    Vals : ARRAY[1..MaxCount] OF WORD;
BEGIN
  Line(14, 'Geschwindigkeitsabgleich - bitte warten...');
  WriteLn; Decode(Zustand, Count);   { Signalende abwarten }
  Short := $FFFF; Long := 1;
  Zustand := FALSE; ZustandAlt := TRUE;
  FOR n := 1 TO MaxCount DO BEGIN     { Meßwerte aufnehmen }
    Write(MaxCount - n, '...'); Count := 0;
    REPEAT Decode(Zustand, Count);
    UNTIL NOT Zustand;
    Count := 0;
    REPEAT Decode(Zustand, Count);
    UNTIL Zustand;
    Count2 := 0;
    REPEAT Decode(Zustand, Count2);
    UNTIL NOT Zustand;
    Vals[n] := Count;
  END;  { FOR }
  FOR n := 1 TO MaxCount - 1 DO       { Meßwerte sortieren }
    FOR nn := n TO MaxCount DO
      IF Vals[n] > Vals[nn] THEN BEGIN
        Count := Vals[n];
        Vals[n] := Vals[nn];
        Vals[nn] := Count;
      END;
  Help := Vals[MaxCount]; Hi := 1;   { Zeitermittlung lang }
  FOR n := MaxCount DOWNTO 1 DO
    IF Vals[n] > Vals[MaxCount] DIV 2 THEN BEGIN
      Inc(Help, Vals[n]); Inc(Hi);    { "Ausreißer" werden }
    END;                                      { eliminiert }
  Long := Help DIV Hi;
  Help := 0; Hi := 0;                { Zeitermittlung kurz }
  FOR n := 1 TO MaxCount DO
    IF Abs(Round(Vals[n] - Long DIV 3)) < Long DIV 4 THEN
    BEGIN
      Inc(Help, Vals[n]); Inc(Hi);
    END;
  IF Hi = 0 THEN Short := Long DIV 3
            ELSE Short := Help DIV Hi;
END;  { AdjustSpeed }

PROCEDURE AdjustLevel;           { grafische Abgleichhilfe }
VAR Gd, Gm, x, y : INTEGER; Abbruch : BOOLEAN;
BEGIN
  Abbruch := FALSE;
  DetectGraph(Gd, Gm); InitGraph(Gd, Gm, GetEnv('BGIPATH'));
  SetTextStyle(DefaultFont, HorizDir, 1);
  SetTextJustify(CenterText, TopText);
  OutTextXY(GetMaxX DIV 2, 0,
            'Pegelabgleich - Ende mit Tastendruck...');
  REPEAT
    y := TextHeight('X') * 2;
    REPEAT
      x := 0;
      REPEAT
        Abbruch := KeyPressed;
        IF InputBit THEN PutPixel(x, y, GetMaxColor)
                    ELSE PutPixel(x, y, 0);
        Delay(1); Inc(x);
      UNTIL (x > GetMaxX) OR Abbruch;
      Inc(y, GetMaxY DIV 50);
    UNTIL (y > GetMaxY) OR Abbruch;
  UNTIL Abbruch;
  WHILE KeyPressed DO ReadKey;
  NoSound; RestoreCrtMode;
END;  { AdjustLevel }

PROCEDURE Empfange(TextOnly : BOOLEAN);
TYPE MorseType =
     (NoSign, SLong, SShort, PCode, PLetter, PWord);
VAR Zustand, ZustandAlt : BOOLEAN; Queue : STRING[MaxLen];
    Count : WORD; Sign : MorseType; ch : CHAR;
BEGIN
  ClrScr;
  Line(1, '⌐Automatischer Empfang von Morsezeichen¬');
  Line(2, 'Ton ⌐u¬mschalten, ⌐ESC¬ Abbruch');
  WriteLn; WriteLn;
  ZustandAlt := TRUE; Zustand := FALSE;
  Queue := ''; Count := 0; ch := #0;
  REPEAT
    Decode(Zustand, Count);
    IF KeyPressed THEN BEGIN
      ch := UpCase(ReadKey);
      IF ch = 'U' THEN BEGIN
        SoundOn := NOT SoundOn; NoSound;
      END;
    END;
    IF Zustand <> ZustandAlt THEN
    BEGIN                   { anderer Impuls -> Auswertung }
      ZustandAlt := Zustand; Sign := PCode;
      CASE Zustand OF
        TRUE :                          { Signalauswertung }
          IF Count > 3 * Long DIV 5 THEN BEGIN   { Signal: }
            Sign := SLong;                          { lang }
            Long := (Vari*Count + (100-Vari)*Long) DIV 100;
          END ELSE
            IF Count < Long DIV 2 THEN BEGIN
              Sign  := SShort;                      { kurz }
              Short := (Vari*Count + (100-Vari)*Short)
                       DIV 100;
            END;
        FALSE :                         { Pausenauswertung }
          CASE Round(10*(Count/((Long + Short) DIV 2))) OF
            0..10  : Sign := PCode;
            11..30 : Sign := PLetter;
            31..99 : Sign := PWord;
          END;
      END;  { CASE }
      CASE Sign OF             { Zeichen: Queue verlängern }
        SLong  : Queue := Queue + '-';
        SShort : Queue := Queue + '.';
      END;  { CASE }
      IF (Length(Queue) = MaxLen) OR
         (Sign IN [PWord, PLetter]) AND
         (Length(Queue) > 0) THEN BEGIN
        IF WhereX > 70 THEN BEGIN
          WriteLn; WriteLn(EmpfProtF);
        END;
        ch := DekodiereZeichen(Queue);
        IF TextOnly THEN BEGIN
          Write(ch); Write(EmpfProtF, ch);
          IF Sign = PWord THEN BEGIN
            Write(' '); Write(EmpfProtF, ' ');
          END;
        END ELSE BEGIN
          Write(Queue : 8, #32);
          HighVideo; Write(ch); LowVideo;
          Write(EmpfProtF, Queue:8, #32, ch);
        END;
        Queue := '';
      END;
      Count := 0;
    END;  { IF }
  UNTIL ch = #27;
END; { Empfange }

PROCEDURE EmpfangsMenue;
VAR ch : CHAR;
BEGIN
  IF DateiExistiert(EmpfProtFName) THEN BEGIN
    Assign(EmpfProtF, EmpfProtFName);
    Append(EmpfProtF);
    WriteLn(EmpfProtF);
    WriteLn(EmpfProtF, '  Nächster Eintrag : ');
  END
  ELSE BEGIN
    Assign(EmpfProtF, EmpfProtFName);
    ReWrite(EmpfProtF);
    WriteLn(EmpfProtF, '  Erster Eintrag   : ');
  END;
  REPEAT;
    KopfZeile;
    Line(3, '⌐E m p f a n g s - M e n ü¬');
    Line(5, 'Ausgabe : ⌐T¬ext       ⌐M¬orsecode + Text');
    Line(7, 'Abgleich: ⌐P¬egel      ⌐G¬eschwindigkeit');
    Line(9, 'Ton     : ⌐U¬mschalten');
    Line(11,'⌐Esc¬     Hauptmenü');
    REPEAT InputBit;
    UNTIL KeyPressed;
    ch := UpCase(ReadKey);
    CASE ch OF
      'T': Empfange(TRUE);
      'M': Empfange(FALSE);
      'P': AdjustLevel;
      'G': AdjustSpeed;
      'U': BEGIN
             SoundOn := NOT SoundOn;
             NoSound;
           END;
    END;
  UNTIL ch = #27;
  NoSound;
  WriteLn(EmpfProtF);
  Close(EmpfProtF);
END;  { EmpfangsMenue }

FUNCTION Num2Str(Num : WORD) : STRING;
VAR s : STRING;
BEGIN
  Str(Num, s); Num2Str := s;
END;  { Num2Str }

PROCEDURE ParameterAendern;
VAR ZChar, ch : CHAR;
BEGIN
  REPEAT;
    KopfZeile;
    Line(3, '⌐P a r a m e t e r   ä n d e r n¬');
    Line(5, '⌐K¬ennung               : ' + Kennung);
    Line(6, '⌐S¬endeprotokolldatei   : ' + SendProtFName);
    Line(7, '⌐E¬mpfangsprotokolldatei: ' + EmpfProtFName);
    Line(8, '⌐F¬requenz Tonsignal    : ' +
            Num2Str(MFreq) + ' Hz');
    Line(9, 'Sende⌐g¬eschwindigkeit  : ' +
            Num2Str(ZProMin) + ' Z/min');
    Line(10,'⌐V¬ariabilität          : ' +
            Num2Str(Vari) + ' %');
    Line(12,'⌐Esc¬ Hauptmenü');
    ch := UpCase(ReadKey);
    CASE ch OF
      'K' : AcceptStr(34, 5, Kennung);
      'S' : BEGIN
              AcceptStr(34, 6, SendProtFName);
              IF Pos('.', SendProtFName) = 0 THEN
                SendProtFName := SendProtFName + '.SPF';
            END;
      'E' : BEGIN
              EmpfProtFName := '________.EPF';
              AcceptStr(34, 7, EmpfProtFName);
              IF Pos('.', EmpfProtFName) = 0
              THEN EmpfProtFName :=
                   EmpfProtFName + '.EPF';
            END;
      'F' : AcceptNum(34, 8, MFreq);
      'G' : BEGIN
              AcceptNum(34, 9, ZProMin);
              IF ZProMin > 240 THEN ZProMin := 240;
              IF ZProMin < 20  THEN ZProMin := 20;
              MTime := (70 * 80 DIV ZProMin);
            END;
      'V' : BEGIN
              AcceptNum(34, 10, Vari);
              IF Vari > 50 THEN Vari := 50;
            END;
    END;
  UNTIL ch = #27;
END; { ParameterAendern }

BEGIN                                      { Hauptprogramm }
  MFreq := 1000;                 { Tonfrequenz beim Senden }
  Kennung := 'PC-AutoMorser von A. Bartels und toolbox';
  ZProMin := 80;                    { Sendegeschwindigkeit }
  MTime := (70 * 80 DIV ZProMin);     { Länge eines kurzen
                  Sendetons in ms (70 ms bei 80 Zeich/Min) }
  Vari := 10;             { Nachjustierung pro Impuls in % }
  Short := 80; Long  := 250; { Defaultzeiten kurz und lang }
  EmpfProtFName := 'Default.EPF';       { Defaultnamen für }
  SendProtFName := 'Default.SPF';       { Protokolldateien }
  REPEAT
    KopfZeile;
    Line(3, '⌐H a u p t - M e n ü¬');
    Line(5, '⌐S¬enden  ⌐E¬mpfangen  ⌐P¬arameter ändern');
    Line(7, '⌐Esc¬ Programmende');
    CASE UpCase(ReadKey) OF
      'S' : SendeMenue;
      'E' : EmpfangsMenue;
      'P' : ParameterAendern;
      #27 : GameOver := TRUE;
    END;
  UNTIL GameOver;
  NoSound; ClrScr;
END.
(* ------------------------------------------------------ *)
(*               Ende von MORSENPC.PAS                    *)