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)
    FAbortReq:  Boolean;     // «бросить и отпустить ключ» (под FLock)
    FBusy:      Boolean;     // идёт передача (под FLock)
    FWPM:       Integer;     // под FLock
    FWeight:    Integer;     // 33..66, 50 = симметрично (под FLock)
    // Эхо для окна-терминала: ушедшее в эфир и хвост очереди (под FLock).
    FSent:      string;
    FUnsent:    string;
    FTrimTail:  Boolean;     // Backspace дотянулся до уже взятого текста
    function  TakeText: string;
    function  Aborted: Boolean;
    procedure Key(Down: Boolean);
    // Выдержать Ms миллисекунд, просыпаясь дробно ради отзывчивости на abort.
    // Возвращает False, если передачу оборвали.
    function  Hold(Deadline: QWord): Boolean;
    procedure SendChar(Ch: Char; var Deadline: QWord);
  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;

// Код знака: строка из '.' и '-'. Пустая — знака нет в таблице (пропускаем,
// иначе опечатка в макросе превратилась бы в мусор в эфире).
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
    FAbortReq := False;
    FPending  := FPending + S;
  finally
    FLock.Leave;
  end;
  FWake.SetEvent;
end;

procedure TCWSender.AbortSending;
begin
  FLock.Enter;
  try
    FPending  := '';
    FAbortReq := True;
  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: string;
begin
  FLock.Enter;
  try
    Result   := FPending;
    FPending := '';
  finally
    FLock.Leave;
  end;
end;

function TCWSender.Aborted: Boolean;
begin
  FLock.Enter;
  try
    Result := FAbortReq;
  finally
    FLock.Leave;
  end;
end;

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

function TCWSender.Hold(Deadline: QWord): Boolean;
var Now_: QWord; Slice: Integer;
begin
  Result := True;
  repeat
    if Terminated or Aborted 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);
// 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);
    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) then begin Key(False); Exit; end;
    Key(False);
    Inc(Deadline, Gap);                       // пауза между элементами знака
    if not Hold(Deadline) then Exit;
  end;
  Inc(Deadline, 2 * Dit);                     // добор до 3 точек между знаками
  Hold(Deadline);
end;

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

    FLock.Enter;
    try
      FBusy     := True;
      FAbortReq := False;
    finally
      FLock.Leave;
    end;
    try
      Deadline := GetTickCount64;
      i := 1;
      while i <= Length(Text) do
      begin
        if Terminated or Aborted 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);
        // Дописанное в очередь по ходу передачи подхватываем без паузы —
        // иначе поток допередал бы «старый» текст и уснул на 200 мс.
        if i = Length(Text) then Text := Text + TakeText;
        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;

end.