ewsdr/CWMorse.pas

unit CWMorse;

{$mode objfpc}{$H+}

// ---------------------------------------------------------------------------
//  Программная передача телеграфа: текст → точки/тире → ключ.
//
//  Кто держит тайминги. У openHPSDR P2 есть ДВА пути в эфир:
//    * манипулятор в разъёме трансивера — элементы формирует кейер в FPGA, PC
//      только отдаёт ему скорость/вес (DUC Specific байт 5..10). Джиттера нет;
//    * бит CWX в High Priority — это «ключ нажат», сырая линия. Прошивка по
//      нему даёт несущую с той же формой фронта (CWRampPeriod), но КОГДА
//      нажать и отпустить, решает PC. Именно этот путь используется для
//      передачи текста (макросы, CAT KY) — так же устроен Thetis (cwx.cs).
//
//  Отсюда устройство юнита: отдельный поток, который спит до дедлайнов и
//  дёргает колбэк ключа. Дедлайны АБСОЛЮТНЫЕ (GetTickCount64), иначе ошибка
//  каждого сна накапливалась бы и знак «плыл» бы по длине.
// ---------------------------------------------------------------------------

interface

uses
  Classes, SysUtils, SyncObjs;

type
  // Вызывается из потока передачи на каждом фронте ключа.
  TCWKeyEvent = procedure(Down: Boolean) of object;

  TCWSender = class(TThread)
  private
    FKeyEvent:  TCWKeyEvent;
    FLock:      TCriticalSection;
    FWake:      TEvent;
    FPending:   string;      // очередь текста (под FLock)
    FAbortGen:  Cardinal;    // «бросить и отпустить ключ» — СЧЁТЧИК, не флаг
                             // (под FLock): см. AbortSending
    FBusy:      Boolean;     // идёт передача (под FLock)
    FWPM:       Integer;     // под FLock
    FWeight:    Integer;     // 33..66, 50 = симметрично (под FLock)
    // Эхо для окна-терминала: ушедшее в эфир и хвост очереди (под FLock).
    FSent:      string;
    FUnsent:    string;
    FTrimTail:  Boolean;     // Backspace дотянулся до уже взятого текста
    // Текст и поколение обрыва берутся ОДНИМ заходом под лок: между ними
    // AbortSending вклиниться не может, иначе обрыв достался бы уже взятому
    // тексту и потерялся.
    function  TakeText(out Gen: Cardinal): string;
    // Добор в идущее сообщение. Если обрыв уже случился — не берём ничего:
    // набранное ПОСЛЕ обрыва дождётся следующего сообщения со своим поколением.
    function  TakeMore(Gen: Cardinal): string;
    function  Aborted(Gen: Cardinal): Boolean;
    procedure Key(Down: Boolean);
    // Выдержать Ms миллисекунд, просыпаясь дробно ради отзывчивости на abort.
    // Возвращает False, если передачу оборвали.
    function  Hold(Deadline: QWord; Gen: Cardinal): Boolean;
    procedure SendChar(Ch: Char; var Deadline: QWord; Gen: Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create(AKeyEvent: TCWKeyEvent);
    destructor  Destroy; override;
    procedure Enqueue(const S: string);
    procedure AbortSending;
    procedure SetSpeed(WPM, Weight: Integer);
    function  Busy: Boolean;
    // Терминал: знаки, ушедшие в эфир с прошлого опроса; хвост очереди; стереть
    // последний ненабранный знак. Смысл тот же, что у TCWLocalKeyer.
    function  TakeSentText: string;
    function  PendingText: string;
    function  Backspace: Boolean;
  end;

  { Элемент манипуляции с ЗАДАННОЙ длительностью: посылка (Mark = True) или
    пауза. Из таких элементов состоит чужая манипуляция, пришедшая по сети —
    у неё нет ни скорости, ни веса, есть только измеренные интервалы. }
  TCWElement = record
    Mark: Boolean;
    Ms:   Integer;
  end;

  { Проигрыватель чужой манипуляции: очередь элементов → тот же колбэк ключа.

    ЗАЧЕМ ОТДЕЛЬНО ОТ TCWSender. Текст мы разбираем сами и знаем скорость; здесь
    наоборот — знаки не разбираются вовсе, а длительности приходят готовыми
    (команда TCI KEYER: клиент замеряет свой ключ и присылает длину КАЖДОГО
    завершившегося интервала). Проиграть их надо ровно так, как они были нажаты.

    ★Почему нельзя просто дёргать ключ по приходу пакета. Между клиентом и нами
    сеть: приход пакета говорит, что интервал КОНЧИЛСЯ, а не сколько он длился.
    Манипуляция «по приходу» — это сетевой джиттер прямо в эфир, тот самый
    «пьяный матрос», ради которого в протоколе и заведён третий аргумент.
    Поэтому элементы становятся в очередь и играются ПОДРЯД по абсолютным
    дедлайнам: сумма длительностей равна времени у клиента, значит отставание
    постоянно (сеть + один элемент) и не накапливается.

    Очередь опустела — ключ отпускаем и начинаем следующую пачку с чистого
    дедлайна: элементы всегда чередуются (посылка, пауза, посылка…), так что
    отпускание на пустой очереди ничего не искажает, зато не оставляет в эфире
    несущую, если клиент замолчал или отвалился. }
  TCWElemPlayer = class(TThread)
  private
    FKeyEvent: TCWKeyEvent;
    FLock:     TCriticalSection;
    FWake:     TEvent;
    FQ:        array of TCWElement;   // кольцо (под FLock)
    FHead:     Integer;
    FCount:    Integer;
    FAbortGen: Cardinal;              // растёт на каждый AbortPlay (под FLock)
    FBusy:     Boolean;
    FDown:     Boolean;               // состояние ключа (только поток)
    procedure Key(Down: Boolean);
    function  CurGen: Cardinal;
    function  Take(Gen: Cardinal; out E: TCWElement): Boolean;
    function  Aborted(Gen: Cardinal): Boolean;
    function  Hold(Deadline: QWord; Gen: Cardinal): Boolean;
  protected
    procedure Execute; override;
  public
    constructor Create(AKeyEvent: TCWKeyEvent);
    destructor  Destroy; override;
    { Поставить элемент в очередь. Слишком длинные обрезаются вызывающим —
      здесь принимается то, что дали. }
    procedure Enqueue(Mark: Boolean; Ms: Integer);
    { Бросить очередь и отпустить ключ (оператор тронул манипулятор, снят MOX). }
    procedure AbortPlay;
    function  Busy: Boolean;
    function  Pending: Integer;
  end;

// Сколько элементов держим в очереди. Живая манипуляция даёт ~30 элементов в
// секунду, так что это секунды звука: клиент, сыплющий быстрее, чем играется,
// нам не друг, и лишнее просто отбрасывается.
const
  CW_ELEM_QUEUE_MAX = 512;

// Код знака: строка из '.' и '-'. Пустая — знака нет в таблице (пропускаем,
// иначе опечатка в макросе превратилась бы в мусор в эфире).
function MorseCode(Ch: Char): string;

implementation

const
  // Точка при 1 WPM = 1200 мс (стандарт PARIS).
  DIT_MS_AT_1WPM = 1200;

function MorseCode(Ch: Char): string;
begin
  case UpCase(Ch) of
    'A': Result := '.-';      'B': Result := '-...';    'C': Result := '-.-.';
    'D': Result := '-..';     'E': Result := '.';       'F': Result := '..-.';
    'G': Result := '--.';     'H': Result := '....';    'I': Result := '..';
    'J': Result := '.---';    'K': Result := '-.-';     'L': Result := '.-..';
    'M': Result := '--';      'N': Result := '-.';      'O': Result := '---';
    'P': Result := '.--.';    'Q': Result := '--.-';    'R': Result := '.-.';
    'S': Result := '...';     'T': Result := '-';       'U': Result := '..-';
    'V': Result := '...-';    'W': Result := '.--';     'X': Result := '-..-';
    'Y': Result := '-.--';    'Z': Result := '--..';
    '0': Result := '-----';   '1': Result := '.----';   '2': Result := '..---';
    '3': Result := '...--';   '4': Result := '....-';   '5': Result := '.....';
    '6': Result := '-....';   '7': Result := '--...';   '8': Result := '---..';
    '9': Result := '----.';
    '.': Result := '.-.-.-';  ',': Result := '--..--';  '?': Result := '..--..';
    '/': Result := '-..-.';   '=': Result := '-...-';   '+': Result := '.-.-.';
    '-': Result := '-....-';  '(': Result := '-.--.';   ')': Result := '-.--.-';
    ':': Result := '---...';  '''':Result := '.----.';  '"': Result := '.-..-.';
    '@': Result := '.--.-.';  '!': Result := '-.-.--';  ';': Result := '-.-.-.';
    '$': Result := '...-..-';
  else
    Result := '';
  end;
end;

constructor TCWSender.Create(AKeyEvent: TCWKeyEvent);
begin
  FKeyEvent := AKeyEvent;
  FLock     := TCriticalSection.Create;
  FWake     := TEvent.Create(nil, False, False, '');
  FWPM      := 20;
  FWeight   := 50;
  FreeOnTerminate := False;
  inherited Create(False);
end;

destructor TCWSender.Destroy;
begin
  Terminate;
  FWake.SetEvent;
  WaitFor;
  FWake.Free;
  FLock.Free;
  inherited Destroy;
end;

procedure TCWSender.Enqueue(const S: string);
begin
  if S = '' then Exit;
  FLock.Enter;
  try
    // Поколение обрыва здесь НЕ трогаем: снять его вправе только сам поток,
    // когда отпустил ключ. Иначе символ, набранный (или присланный логгером
    // командой KY) в те миллисекунды, пока поток спит в Hold, отменял бы уже
    // отданный AbortSending — оператор берёт манипулятор, а софт продолжает
    // манипулировать вместе с ним остатком сообщения.
    FPending  := FPending + S;
  finally
    FLock.Leave;
  end;
  FWake.SetEvent;
end;

procedure TCWSender.AbortSending;
begin
  FLock.Enter;
  try
    FPending  := '';
    Inc(FAbortGen);   // счётчик: обрыв не потеряется и не отменится
  finally
    FLock.Leave;
  end;
  FWake.SetEvent;
end;

procedure TCWSender.SetSpeed(WPM, Weight: Integer);
begin
  if WPM < 5  then WPM := 5;
  if WPM > 60 then WPM := 60;
  if Weight < 33 then Weight := 33;
  if Weight > 66 then Weight := 66;
  FLock.Enter;
  try
    FWPM    := WPM;
    FWeight := Weight;
  finally
    FLock.Leave;
  end;
end;

function TCWSender.Busy: Boolean;
begin
  FLock.Enter;
  try
    Result := FBusy or (FPending <> '');
  finally
    FLock.Leave;
  end;
end;

function TCWSender.TakeSentText: string;
begin
  FLock.Enter;
  try
    Result := FSent;
    FSent  := '';
  finally
    FLock.Leave;
  end;
end;

function TCWSender.PendingText: string;
begin
  FLock.Enter;
  try
    Result := FUnsent + FPending;
  finally
    FLock.Leave;
  end;
end;

function TCWSender.Backspace: Boolean;
// Стираем с хвоста очереди: то, что уже звучит, вернуть нельзя.
begin
  FLock.Enter;
  try
    Result := False;
    if FPending <> '' then
    begin
      SetLength(FPending, Length(FPending) - 1);
      Result := True;
    end
    else if FUnsent <> '' then
    begin
      SetLength(FUnsent, Length(FUnsent) - 1);
      FTrimTail := True;
      Result := True;
    end;
  finally
    FLock.Leave;
  end;
end;

function TCWSender.TakeText(out Gen: Cardinal): string;
begin
  FLock.Enter;
  try
    Result   := FPending;
    FPending := '';
    Gen      := FAbortGen;
  finally
    FLock.Leave;
  end;
end;

function TCWSender.TakeMore(Gen: Cardinal): string;
begin
  FLock.Enter;
  try
    if FAbortGen <> Gen then Exit('');
    Result   := FPending;
    FPending := '';
  finally
    FLock.Leave;
  end;
end;

function TCWSender.Aborted(Gen: Cardinal): Boolean;
// «Обрыв случился после того, как поток взял этот текст».
begin
  FLock.Enter;
  try
    Result := FAbortGen <> Gen;
  finally
    FLock.Leave;
  end;
end;

procedure TCWSender.Key(Down: Boolean);
begin
  if Assigned(FKeyEvent) then FKeyEvent(Down);
end;

function TCWSender.Hold(Deadline: QWord; Gen: Cardinal): Boolean;
var Now_: QWord; Slice: Integer;
begin
  Result := True;
  repeat
    if Terminated or Aborted(Gen) then Exit(False);
    Now_ := GetTickCount64;
    if Now_ >= Deadline then Exit(True);
    // Дробим сон: обрыв передачи не должен ждать конца длинного тире.
    Slice := Integer(Deadline - Now_);
    if Slice > 5 then Slice := 5;
    Sleep(Slice);
  until False;
end;

procedure TCWSender.SendChar(Ch: Char; var Deadline: QWord; Gen: Cardinal);
// Deadline — момент, к которому знак должен закончиться; ведём его вперёд,
// чтобы длительности не «уползали» на ошибке каждого Sleep.
var
  Code: string;
  i, Dit, Mark, Gap, WPM, Weight: Integer;
begin
  FLock.Enter;
  try
    WPM    := FWPM;
    Weight := FWeight;
  finally
    FLock.Leave;
  end;
  Dit := DIT_MS_AT_1WPM div WPM;
  // Вес: 50 = точка равна паузе. Выше — посылки длиннее за счёт пауз внутри
  // знака (межзнаковые интервалы остаются стандартными, иначе «плывёт» темп).
  Mark := (Dit * Weight) div 50;
  Gap  := (Dit * (100 - Weight)) div 50;
  if Mark < 1 then Mark := 1;
  if Gap  < 1 then Gap  := 1;

  if Ch = ' ' then
  begin
    // Межсловный интервал = 7 точек; 3 из них уже отданы после прошлого знака.
    Inc(Deadline, 4 * Dit);
    Hold(Deadline, Gen);
    Exit;
  end;

  Code := MorseCode(Ch);
  if Code = '' then Exit;
  for i := 1 to Length(Code) do
  begin
    Key(True);
    if Code[i] = '-' then Inc(Deadline, 3 * Mark) else Inc(Deadline, Mark);
    if not Hold(Deadline, Gen) then begin Key(False); Exit; end;
    Key(False);
    Inc(Deadline, Gap);                       // пауза между элементами знака
    if not Hold(Deadline, Gen) then Exit;
  end;
  Inc(Deadline, 2 * Dit);                     // добор до 3 точек между знаками
  Hold(Deadline, Gen);
end;

procedure TCWSender.Execute;
var
  Text: string;
  i, KeepLen: Integer;
  Trim: Boolean;
  Deadline: QWord;
  Gen: Cardinal;
begin
  while not Terminated do
  begin
    FWake.WaitFor(200);
    if Terminated then Break;
    Text := TakeText(Gen);
    if Text = '' then Continue;

    FLock.Enter;
    try
      FBusy := True;
    finally
      FLock.Leave;
    end;
    try
      Deadline := GetTickCount64;
      i := 1;
      while i <= Length(Text) do
      begin
        if Terminated or Aborted(Gen) then Break;
        // Backspace мог съесть хвост уже взятого текста — отсекаем.
        FLock.Enter;
        try
          Trim    := FTrimTail;
          FTrimTail := False;
          KeepLen := i - 1 + Length(FUnsent);
        finally
          FLock.Leave;
        end;
        if Trim then
        begin
          if KeepLen < i then Break;                 // стёрли всё впереди
          if Length(Text) > KeepLen then SetLength(Text, KeepLen);
          if i > Length(Text) then Break;
        end;
        // Эхо в окно-терминал: знак пошёл в эфир; хвост очереди — для строки
        // набора (там должно остаться только НЕ переданное).
        FLock.Enter;
        try
          FSent   := FSent + Text[i];
          FUnsent := Copy(Text, i + 1, MaxInt);
          if Length(FSent) > 4096 then FSent := Copy(FSent, Length(FSent) - 4095, 4096);
        finally
          FLock.Leave;
        end;
        SendChar(Text[i], Deadline, Gen);
        // Дописанное в очередь по ходу передачи подхватываем без паузы —
        // иначе поток допередал бы «старый» текст и уснул на 200 мс.
        if i = Length(Text) then Text := Text + TakeMore(Gen);
        Inc(i);
      end;
    finally
      Key(False);                    // ключ всегда отпущен, что бы ни случилось
      FLock.Enter;
      try
        FUnsent   := '';
        FTrimTail := False;
      finally
        FLock.Leave;
      end;
      FLock.Enter;
      try
        FBusy := False;
      finally
        FLock.Leave;
      end;
    end;
  end;
  Key(False);
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Проигрыватель чужой манипуляции
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TCWElemPlayer.Create(AKeyEvent: TCWKeyEvent);
begin
  FKeyEvent := AKeyEvent;
  FLock     := TCriticalSection.Create;
  FWake     := TEvent.Create(nil, False, False, '');
  SetLength(FQ, CW_ELEM_QUEUE_MAX);
  FreeOnTerminate := False;
  inherited Create(False);
end;

destructor TCWElemPlayer.Destroy;
begin
  Terminate;
  FWake.SetEvent;
  WaitFor;
  FWake.Free;
  FLock.Free;
  inherited Destroy;
end;

procedure TCWElemPlayer.Enqueue(Mark: Boolean; Ms: Integer);
var i: Integer;
begin
  if Ms <= 0 then Exit;
  FLock.Enter;
  try
    // Очередь переполнена — молча теряем новый элемент. Ронять уже принятую
    // манипуляцию из-за захлебнувшегося клиента незачем.
    if FCount >= Length(FQ) then Exit;
    i := (FHead + FCount) mod Length(FQ);
    FQ[i].Mark := Mark;
    FQ[i].Ms   := Ms;
    Inc(FCount);
    // Поколение аборта здесь НЕ трогаем: сбрасывать его вправе только сам
    // проигрыватель, когда увидел обрыв. Иначе элемент, прилетевший из сети в
    // те миллисекунды, пока поток спит в Hold, отменял бы уже отданный
    // AbortPlay — оператор жмёт манипулятор, а чужая манипуляция продолжается.
    FBusy      := True;
  finally
    FLock.Leave;
  end;
  FWake.SetEvent;
end;

function TCWElemPlayer.CurGen: Cardinal;
begin
  FLock.Enter;
  try
    Result := FAbortGen;
  finally
    FLock.Leave;
  end;
end;

function TCWElemPlayer.Take(Gen: Cardinal; out E: TCWElement): Boolean;
begin
  Result := False;
  FLock.Enter;
  try
    if (FAbortGen <> Gen) or (FCount = 0) then Exit;
    E     := FQ[FHead];
    FHead := (FHead + 1) mod Length(FQ);
    Dec(FCount);
    Result := True;
  finally
    FLock.Leave;
  end;
end;

procedure TCWElemPlayer.AbortPlay;
begin
  FLock.Enter;
  try
    Inc(FAbortGen);   // не флаг, а счётчик: обрыв не потеряется и не отменится
    FHead     := 0;
    FCount    := 0;
  finally
    FLock.Leave;
  end;
  FWake.SetEvent;
end;

function TCWElemPlayer.Aborted(Gen: Cardinal): Boolean;
// «Обрыв случился после того, как поток взял это поколение».
begin
  FLock.Enter;
  try
    Result := FAbortGen <> Gen;
  finally
    FLock.Leave;
  end;
end;

function TCWElemPlayer.Busy: Boolean;
begin
  FLock.Enter;
  try
    Result := FBusy;
  finally
    FLock.Leave;
  end;
end;

function TCWElemPlayer.Pending: Integer;
begin
  FLock.Enter;
  try
    Result := FCount;
  finally
    FLock.Leave;
  end;
end;

procedure TCWElemPlayer.Key(Down: Boolean);
begin
  if Down = FDown then Exit;         // лишних фронтов в эфир не шлём
  FDown := Down;
  if Assigned(FKeyEvent) then FKeyEvent(Down);
end;

function TCWElemPlayer.Hold(Deadline: QWord; Gen: Cardinal): Boolean;
// Тот же приём, что у TCWSender: абсолютный дедлайн и дробный сон, чтобы обрыв
// не ждал конца длинного тире.
var Now_: QWord; Slice: Integer;
begin
  repeat
    if Terminated or Aborted(Gen) then Exit(False);
    Now_ := GetTickCount64;
    if Now_ >= Deadline then Exit(True);
    Slice := Integer(Deadline - Now_);
    if Slice > 5 then Slice := 5;
    Sleep(Slice);
  until False;
end;

procedure TCWElemPlayer.Execute;
var
  E: TCWElement;
  Deadline: QWord;
  Gen: Cardinal;
begin
  Deadline := 0;
  Gen      := CurGen;
  while not Terminated do
  begin
    FWake.WaitFor(200);
    if Terminated then Break;
    while Take(Gen, E) do
    begin
      // Первая пачка (или после простоя) начинается «сейчас»: догонять прошлое
      // нечего, а старый дедлайн проиграл бы очередь одним махом.
      if (Deadline = 0) or (GetTickCount64 > Deadline) then
        Deadline := GetTickCount64;
      Key(E.Mark);
      Inc(Deadline, QWord(E.Ms));
      if not Hold(Deadline, Gen) then Break;
    end;
    // Очередь кончилась (или её бросили) — ключ отпускаем всегда: несущая без
    // хозяина в эфире не остаётся, а следующая пачка начнётся заново.
    Key(False);
    Deadline := 0;
    FLock.Enter;
    try
      // Обрыв отработан — ключ отпущен, старая очередь брошена. Принимаем
      // текущее поколение: то, что клиент прислал уже ПОСЛЕ обрыва, играем.
      Gen := FAbortGen;
      if FCount = 0 then FBusy := False;
    finally
      FLock.Leave;
    end;
  end;
  Key(False);
end;

end.