diff --git a/AppTheme.pas b/AppTheme.pas index 02a8bcb..144376a 100644 --- a/AppTheme.pas +++ b/AppTheme.pas @@ -54,6 +54,12 @@ type // Спектр — сигнал и маркеры SpecLine: TColor; SpecFilter: TColor; + // Заливка полосы главного фильтра. Отдельно от SpecFilter (тот остался + // подложкой подписей AGC): полоса теперь полупрозрачная, как у слайсов, и + // цвет ей нужен СВОЙ — SpecFilter почти совпадает с нижним цветом фонового + // градиента спектра, поэтому такая заливка читалась не оттенком, а + // затемнением. + SpecFilterBand: TColor; SpecFilterEdge: TColor; SpecAgcColor: TColor; SpecAgcHangColor: TColor; @@ -158,6 +164,10 @@ begin Result.SpecGrid := TColor($00685624); Result.SpecLine := TColor($0040FF80); Result.SpecFilter := TColor($006A4E22); + // Оттенок полосы — тёплый янтарный, из семейства курсора VFO (Amber): фон + // спектра сине-стальной, поэтому янтарь на нём читается как оттенок, а не + // как «потемнее фона». RGB(255,150,40). + Result.SpecFilterBand := TColor($002896FF); Result.SpecFilterEdge := TColor($0040FFCC); Result.SpecAgcColor := TColor($0000AAFF); Result.SpecAgcHangColor := TColor($00FFCC00); @@ -266,7 +276,10 @@ begin Result.SpecLabelText := TColor($00404038); Result.SpecGrid := TColor($00B8B4A4); Result.SpecLine := TColor($00006400); // тёмно-зелёная линия - Result.SpecFilter := TColor($00C8DCC8); // светло-зелёная полоса фильтра + Result.SpecFilter := TColor($00C8DCC8); // подложка подписей AGC + // Полоса фильтра на светлой теме: насыщённее фона (тот пергаментный), иначе + // при той же полупрозрачности её не видно. RGB(60,150,60). + Result.SpecFilterBand := TColor($003C963C); Result.SpecFilterEdge := TColor($00407840); Result.SpecAgcColor := TColor($00904000); // тёмно-оранжевый AGC Result.SpecAgcHangColor := TColor($00802000); diff --git a/DXClusterClient.pas b/DXClusterClient.pas new file mode 100644 index 0000000..f3d0047 --- /dev/null +++ b/DXClusterClient.pas @@ -0,0 +1,1506 @@ +unit DXClusterClient; + +{ + DXClusterClient.pas — telnet-клиент DX-кластера (одно соединение). + + Один рабочий поток: резолв (в отдельном одноразовом потоке — см. ниже) → + connect (неблокирующий + select, чтобы не висеть минуту на мёртвом хосте) → + логин позывным → чтение строк. Разобранные споты + кладутся ПРЯМО в TDXSpotStore (он потокобезопасен), лог соединения — во + внутреннее кольцо. В главный поток ничего не маршалим: UI сам замечает + изменения по Version стора и по LogVersion — как оверлеи замечают смену вида + по ключам кэша. Никаких LCL-зависимостей. + + Разрыв → реконнект с backoff (RECONNECT_MIN..RECONNECT_MAX). Stop() делает + SockShutdown, что разблокирует recv в потоке (на Linux одного close мало — + см. WebUtils.SockShutdown). + + ★Резолв имени вынесен в ОТДЕЛЬНЫЙ поток. Системный резолвер (getaddrinfo на + unix, gethostbyname на Windows) блокирующий и не прерывается ничем: пока он + молчит, сокета ещё нет, рвать Stop()'у нечего, а Stop зовётся из UI-потока и + делает WaitFor — окно висело бы весь DNS-таймаут. Поэтому сессия ждёт результат + КВАНТАМИ, проверяя Terminated и FStopEvent. + ★Реестр запросов GResolvePending: по одному резолверу НА ИМЯ и не больше + DX_MAX_RESOLVERS одновременно. Не дождавшись, сессия НЕ бросает запрос, а + оставляет его в реестре и на следующей попытке цепляется к тому же — иначе на + зависшем системном резолвере каждая попытка реконнекта плодила бы новый вечный + поток. Слотов несколько, а не один, чтобы смена адреса в SETUP давала попытку + по новому имени даже поверх зависшего прежнего; литеральный IP разбирается + вообще до реестра (TryLiteralIP) — ввод адреса руками обязан работать всегда. + Запись запроса живёт по счётчику ссылок (Refs: резолвер + ожидающие); кто + уронил счётчик в ноль, тот и Dispose. + ★Имя разрешается через getaddrinfo, а НЕ через netdb.ResolveHostByName: тот + ходит в DNS напрямую и /etc/hosts не читает вовсе (проверено: getent находит + localhost, ResolveHostByName — нет), т.е. локальный алиас кластера не работал + бы; вдобавок он держит глобальное состояние, а getaddrinfo реентерабелен. + + Формат спота (общий для DXSpider / AR-Cluster / CC Cluster): + DX de UA3XYZ: 14025.0 DL1ABC CW 599 tnx qso 1832Z + Всё, что не начинается с 'DX de ', в стор не идёт — только в лог. +} + +{$IFDEF FPC} + {$MODE Delphi} + {$LONGSTRINGS ON} +{$ENDIF} + +interface + +uses + Classes, SysUtils, SyncObjs, StrUtils, DateUtils, + WebUtils, // SockClose/SockShutdown/SockRecv/SockSend/SOCK_INVALID + DXSpotStore + // ★ Windows.pas здесь НЕТ намеренно: он объявляет TCriticalSection как + // ЗАПИСЬ (алиас TRTLCriticalSection) и, стоя в uses после SyncObjs, + // перекрывал класс — под win64 сборка падала на TCriticalSection.Create + // («identifier idents no member Create»). Всё, что нужно сокетам, даёт + // WinSock2; так же сделано в WsClient и HPSDRNetwork. + {$IFDEF MSWINDOWS} + , WinSock2 + {$ELSE} + , BaseUnix, Sockets, netdb, ctypes + {$ENDIF}; + +const + DX_DEFAULT_HOST = 'cluster.dxfun.com'; + DX_DEFAULT_PORT = 8000; + DX_CONNECT_MS = 8000; // потолок ожидания connect + DX_CONNECT_SLICE_MS = 200; // квант ожидания connect (чтобы Stop не ждал 8 с) + DX_DNS_MS = 10000; // потолок ожидания резолва имени + DX_DNS_SLICE_MS = 200; // квант ожидания резолва (чтобы Stop не ждал DNS) + DX_MAX_RESOLVERS = 4; // одновременных резолвер-потоков на процесс + DX_RECV_MS = 1000; // квант recv: просыпаемся проверить Terminated/очередь + DX_RECONNECT_MIN = 5; // с + DX_RECONNECT_MAX = 60; // с + DX_LOGIN_GRACE_S = 6; // не увидели приглашение — шлём позывной сами + DX_POSTLOGIN_S = 2; // пауза после последнего шага логина + DX_PASSWORD_WAIT_S = 8; // ждём приглашение пароля, потом считаем, что его не будет + DX_LOGIN_MAX_S = 20; // сервер молчит после позывного — идём дальше вслепую + DX_LOG_LINES = 300; // кольцо лога соединения + DX_SEND_RETRIES = 20; // повторов send по таймауту буфера, потом разрыв + +type + TDXClusterState = (dxsOff, dxsConnecting, dxsLogin, dxsOnline, dxsRetry, dxsError); + + TDXClusterClient = class + private + FThread: TThread; + FLock: TCriticalSection; // защищает конфиг, лог, очередь, состояние + FStopEvent: TEvent; + + // конфиг (копия под FLock — поток читает её через GetConfig) + FHost: string; + FPort: Integer; + FLogin: string; + FPassword: string; + FPostLogin: string; // строки через LineEnding + + FStore: TDXSpotStore; // не владеет + + // Сокет живого соединения — зеркало под FLock. Нужен ровно для того, чтобы + // Stop() мог сделать SockShutdown и вывести поток из блокирующего recv: + // иначе выход из программы ждал бы до конца кванта recv (и до конца + // таймаута send, если кластер перестал забирать данные). Поток снимает + // зеркало ДО close, поэтому под локом хэндл гарантированно ещё открыт. + FActiveSock: TSocket; + + FState: TDXClusterState; + FStatusMsg: string; + FSpotCount: Int64; // сколько спотов принято за сессию + + FLog: array[0..DX_LOG_LINES-1] of string; + FLogHead: Integer; // индекс следующей записи + FLogCount: Integer; + FLogVer: Int64; + + FOutQueue: TStringList; // строки на отправку в кластер + + procedure SetState(St: TDXClusterState; const Msg: string); + procedure PublishSock(S: TSocket); // зеркало хэндла для Stop (см. FActiveSock) + public + constructor Create(AStore: TDXSpotStore); + destructor Destroy; override; + + procedure Configure(const AHost: string; APort: Integer; + const ALogin, APassword, APostLogin: string); + procedure Start; + // Неблокирующая половина Stop: разбудить поток и порвать сокет, не дожидаясь + // его конца. Зовётся в начале выхода из программы, чтобы поток доживал + // ПАРАЛЛЕЛЬНО с разборкой радио, а join в Stop уже никого не ждал. + procedure RequestStop; + procedure Stop; // RequestStop + join + function Running: Boolean; + + // Отправить сырую строку в кластер (окно списка: sh/dx, set/filter, …). + procedure SendCommand(const S: string); + + // Лог соединения — снимок в порядке приёма (старые → новые). + procedure GetLog(Dst: TStrings); + function LogVersion: Int64; + procedure AddLog(const S: string); + + function State: TDXClusterState; + function StateText: string; + function StatusMessage: string; + function SpotsReceived: Int64; + + property Store: TDXSpotStore read FStore; + end; + +// Разбор строки кластера. True — это спот (Spot заполнен). +function ParseDXSpot(const Line: string; out Spot: TDXSpot): Boolean; +function DXStateName(St: TDXClusterState): string; + +implementation + +type + // Запрос на резолв, общий для сессии и одноразового резолвер-потока. Живёт в + // куче по счётчику ссылок: одна у резолвера, по одной у каждой ждущей сессии. + // Кто уронил Refs в ноль под GResolveLock, тот и делает Dispose — так + // брошенный DNS никого не переживает и ничего не течёт. + PDXResolveReq = ^TDXResolveReq; + TDXResolveReq = record + Host: string; + Addr: LongWord; // сетевой порядок байт + Ok: Boolean; + Done: Boolean; // резолвер отработал + Refs: Integer; + end; + + // Чем кончилось ожидание резолва — от этого зависит, что писать в лог. + TDXResolveOutcome = (droOk, // имя разрешено + droFailed, // резолвер ответил «нет такого имени» + droTimeout, // не дождались (или нас остановили) + droBusy); // в полёте резолв ДРУГОГО имени + + TDXResolverThread = class(TThread) + private + FReq: PDXResolveReq; + protected + procedure Execute; override; + public + constructor Create(AReq: PDXResolveReq); + end; + + TDXClusterThread = class(TThread) + private + FOwner: TDXClusterClient; + FSocket: TSocket; + FRxBuf: string; // хвост неполной строки + + // конфиг сессии (снимок на время соединения) + FHost: string; + FPort: Integer; + FLogin: string; + FPassword: string; + FPostLogin: string; + + FLoginSent: Boolean; + FLoginByPrompt: Boolean; // позывной ушёл в ответ на приглашение, не вслепую + FPassSent: Boolean; + FPostSent: Boolean; + FLoginAt: TDateTime; // когда ушёл позывной + FLoginStepAt: TDateTime; // когда ушла последняя порция учётки (позывной/пароль) + FSawAfterLogin: Boolean; // после учётки сервер что-то прислал + FConnectAt: TDateTime; + FFatal: Boolean; // отказ авторизации — реконнект бессмыслен + // Приглашение, на которое мы только что ответили, разобрав НЕЗАВЕРШЁННЫЙ + // хвост. Оно остаётся в буфере и со следующим куском доедет целой строкой — + // окно ровно на одну строку, чтобы не счесть собственное эхо новым вопросом. + FAnsweredPrompt: string; + + procedure FailAuth(const Reason: string); + function LoginSettled: Boolean; + function SendPostLogin: Boolean; + function Resolve(const Host: string; out Addr: LongWord): TDXResolveOutcome; + function ConnectSock: Boolean; + procedure CloseSock; + function SendAll(const Data: string): Boolean; + function SendLine(const S: string): Boolean; + procedure FlushOutQueue; + procedure HandleChunk(const Data: string); + procedure HandleLine(const Line: string); + procedure CheckPrompts(const Tail: string; IsTail: Boolean); + function Session: Boolean; // одно соединение; False — выйти совсем + protected + procedure Execute; override; + public + constructor Create(AOwner: TDXClusterClient); + end; + +var + // Один на все запросы резолва: они редки (одна попытка на соединение), а общий + // лок избавляет запись запроса от собственной критической секции — иначе её + // пришлось бы освобождать ровно тому, кто освобождает саму запись. + GResolveLock: TCriticalSection; + // Запросы «в полёте», по одному на имя. Слот занят ⇒ по этому имени уже + // работает резолвер-поток, и второго по нему мы не заводим (см. шапку юнита). + GResolvePending: array[0..DX_MAX_RESOLVERS - 1] of PDXResolveReq; +{$IFDEF MSWINDOWS} + GWSAData: TWSAData; +{$ENDIF} + +function DXStateName(St: TDXClusterState): string; +begin + case St of + dxsOff: Result := 'OFF'; + dxsConnecting: Result := 'CONNECTING'; + dxsLogin: Result := 'LOGIN'; + dxsOnline: Result := 'ONLINE'; + dxsRetry: Result := 'RETRY'; + else Result := 'ERROR'; + end; +end; + +function SockWouldBlock: Boolean; +// Последняя ошибка сокета означает «данных пока нет / истёк SO_RCVTIMEO / +// прерван сигналом» — соединение живо. Всё остальное (ECONNRESET, ENOTCONN, +// EPIPE…) — разрыв: без этой проверки поток крутил бы recv в пустом цикле, +// вместо того чтобы уйти на реконнект. +var E: Integer; +begin +{$IFDEF MSWINDOWS} + E := WSAGetLastError; + Result := (E = WSAEWOULDBLOCK) or (E = WSAETIMEDOUT) or (E = WSAEINTR); +{$ELSE} + E := fpgeterrno; + Result := (E = ESysEAGAIN) or (E = ESysEWOULDBLOCK) or (E = ESysEINTR); +{$ENDIF} +end; + +{ ── Разбор строки спота ──────────────────────────────────────────────────── } + +function ParseDXSpot(const Line: string; out Spot: TDXSpot): Boolean; +// 'DX de : <кГц> <позывной> <комментарий> Z [грид]' +var + S, Rest, FreqStr, TimeTok: string; + P, i: Integer; + KHz: Double; + FS: TFormatSettings; +begin + Result := False; + FillChar(Spot, SizeOf(Spot), 0); + Spot.Call := ''; Spot.Spotter := ''; Spot.Comment := ''; Spot.TimeUTC := ''; + + S := Trim(Line); + if Length(S) < 12 then Exit; + if not SameText(Copy(S, 1, 6), 'DX de ') then Exit; + + Rest := Copy(S, 7, MaxInt); + P := Pos(':', Rest); + if P <= 1 then Exit; + Spot.Spotter := Trim(Copy(Rest, 1, P - 1)); + Rest := Trim(Copy(Rest, P + 1, MaxInt)); + + // частота (кГц) — первый токен + P := Pos(' ', Rest); + if P <= 1 then Exit; + FreqStr := Copy(Rest, 1, P - 1); + Rest := TrimLeft(Copy(Rest, P + 1, MaxInt)); + + FS := DefaultFormatSettings; + FS.DecimalSeparator := '.'; + FreqStr := StringReplace(FreqStr, ',', '.', [rfReplaceAll]); + if not TryStrToFloat(FreqStr, KHz, FS) then Exit; + if (KHz <= 0) or (KHz > 100000000.0) then Exit; // мусор/битая строка + Spot.FreqHz := KHz * 1000.0; + + // позывной DX — второй токен + P := Pos(' ', Rest); + if P > 0 then + begin + Spot.Call := Copy(Rest, 1, P - 1); + Rest := TrimLeft(Copy(Rest, P + 1, MaxInt)); + end + else + begin + Spot.Call := Rest; + Rest := ''; + end; + if Spot.Call = '' then Exit; + + // Время: последний токен вида HHMMZ. Всё до него — комментарий, всё после + // (обычно грид спотера) приклеиваем к комментарию — терять жалко. + Rest := TrimRight(Rest); + P := 0; + for i := Length(Rest) - 4 downto 1 do + if (Rest[i] in ['0'..'9']) and (Rest[i+1] in ['0'..'9']) and + (Rest[i+2] in ['0'..'9']) and (Rest[i+3] in ['0'..'9']) and + (UpCase(Rest[i+4]) = 'Z') and + ((i = 1) or (Rest[i-1] = ' ')) then + begin + P := i; + Break; + end; + if P > 0 then + begin + TimeTok := Copy(Rest, P, 4); + Spot.TimeUTC := TimeTok; + Spot.Comment := Trim(Copy(Rest, 1, P - 1)); + Rest := Trim(Copy(Rest, P + 5, MaxInt)); + if Rest <> '' then Spot.Comment := Trim(Spot.Comment + ' ' + Rest); + end + else + Spot.Comment := Trim(Rest); + + Spot.Mode := DXModeFromComment(Spot.Comment); + // Комментарий молчит — берём моду с участка бэндплана: в CW и SSB её сплошь + // и рядом просто не пишут, а участок эти две моды разделяет надёжно. + // Помечаем такой спот: угаданное не должно выглядеть как сказанное спотером. + Spot.ModeGuessed := False; + if Spot.Mode = dxmUnknown then + begin + Spot.Mode := DXModeFromFreq(Spot.FreqHz); + Spot.ModeGuessed := Spot.Mode <> dxmUnknown; + end; + Spot.Stamp := Now; + Result := True; +end; + +{ ── TDXClusterClient ─────────────────────────────────────────────────────── } + +constructor TDXClusterClient.Create(AStore: TDXSpotStore); +begin + inherited Create; + FStore := AStore; + FLock := TCriticalSection.Create; + FStopEvent := TEvent.Create(nil, True, False, ''); + FOutQueue := TStringList.Create; + FHost := DX_DEFAULT_HOST; + FPort := DX_DEFAULT_PORT; + FState := dxsOff; + FLogHead := 0; + FLogCount := 0; + FLogVer := 0; + FSpotCount := 0; + FActiveSock := SOCK_INVALID; + // WSAStartup/WSACleanup здесь БЫЛИ и убраны — см. initialization юнита. +end; + +destructor TDXClusterClient.Destroy; +begin + Stop; + FOutQueue.Free; + FStopEvent.Free; + FLock.Free; + inherited Destroy; +end; + +procedure TDXClusterClient.Configure(const AHost: string; APort: Integer; + const ALogin, APassword, APostLogin: string); +begin + FLock.Enter; + try + // Смена адреса/учётки — команды, набранные для ПРЕЖНЕГО кластера, теряют + // смысл (и ушли бы на новый). Чистим очередь. + if (FHost <> Trim(AHost)) or (FPort <> APort) or (FLogin <> Trim(ALogin)) then + FOutQueue.Clear; + FHost := Trim(AHost); + FPort := APort; + FLogin := Trim(ALogin); + FPassword := APassword; + FPostLogin := APostLogin; + finally + FLock.Leave; + end; +end; + +procedure TDXClusterClient.Start; +begin + // Поток прошлой сессии мог завершиться сам (кластер отверг логин) — прибираем + // его, иначе Start молча ничего бы не сделал и кнопка CONNECT в окне + // кластера перестала бы работать до перезапуска программы. + if (FThread <> nil) and FThread.Finished then + begin + FThread.WaitFor; // уже завершён — не ждёт + FThread.Free; + FThread := nil; + end; + if FThread <> nil then Exit; + FLock.Enter; + try + if (FHost = '') or (FLogin = '') then + begin + FState := dxsError; + FStatusMsg := 'host or callsign not set'; + Exit; + end; + finally + FLock.Leave; + end; + FStopEvent.ResetEvent; + SetState(dxsConnecting, ''); + FThread := TDXClusterThread.Create(Self); +end; + +procedure TDXClusterClient.RequestStop; +begin + // Всё, что не успели отправить, к следующему соединению уже неактуально. + FLock.Enter; + try + FOutQueue.Clear; + finally + FLock.Leave; + end; + if FThread = nil then Exit; + FThread.Terminate; + FStopEvent.SetEvent; + // Терминации мало: поток стоит в блокирующем recv и проснулся бы только по + // SO_RCVTIMEO (до DX_RECV_MS), а на застрявшем send — до SO_SNDTIMEO. Всё это + // время join держал бы главный поток, т.е. окно висело бы на выходе и на + // переподключении после правки настроек. SockShutdown рвёт обе стороны + // немедленно (на Linux одного close мало — см. WebUtils.SockShutdown). + // Закрывает сокет по-прежнему сам поток: закрыть чужой хэндл значило бы + // гонку с его же recv. + FLock.Enter; + try + if FActiveSock <> SOCK_INVALID then SockShutdown(FActiveSock); + finally + FLock.Leave; + end; +end; + +procedure TDXClusterClient.Stop; +var T: TThread; +begin + RequestStop; + T := FThread; + if T = nil then + begin + SetState(dxsOff, ''); + Exit; + end; + FThread := nil; + T.WaitFor; + T.Free; + SetState(dxsOff, ''); +end; + +function TDXClusterClient.Running: Boolean; +// Завершившийся сам поток (отказ авторизации) — уже не «работаем»: иначе окно +// кластера показывало бы DISCONNECT у мёртвого соединения. +begin + Result := (FThread <> nil) and (not FThread.Finished); +end; + +procedure TDXClusterClient.PublishSock(S: TSocket); +// Зеркало хэндла для Stop. Поток зовёт с валидным хэндлом сразу после connect +// и с SOCK_INVALID ПЕРЕД close — так Stop под локом видит либо живой сокет, +// либо ничего, но не закрытый. +begin + FLock.Enter; + try + FActiveSock := S; + finally + FLock.Leave; + end; +end; + +procedure TDXClusterClient.SetState(St: TDXClusterState; const Msg: string); +begin + FLock.Enter; + try + FState := St; + FStatusMsg := Msg; + Inc(FLogVer); // UI перечитает и статус тоже + finally + FLock.Leave; + end; +end; + +function TDXClusterClient.State: TDXClusterState; +begin + FLock.Enter; + try + Result := FState; + finally + FLock.Leave; + end; +end; + +function TDXClusterClient.StateText: string; +begin + Result := DXStateName(State); +end; + +function TDXClusterClient.StatusMessage: string; +begin + FLock.Enter; + try + Result := FStatusMsg; + finally + FLock.Leave; + end; +end; + +function TDXClusterClient.SpotsReceived: Int64; +begin + FLock.Enter; + try + Result := FSpotCount; + finally + FLock.Leave; + end; +end; + +procedure TDXClusterClient.SendCommand(const S: string); +var Queued: Boolean; +begin + if Trim(S) = '' then Exit; + FLock.Enter; + try + FOutQueue.Add(S); + Queued := FState <> dxsOnline; + finally + FLock.Leave; + end; + // До конца логина поток очередь не разбирает (иначе команда ушла бы вместо + // позывного или пароля). Молча «проглоченная» команда выглядела бы как + // потеря — говорим в лог, что она ждёт. + if Queued then AddLog('*** queued until login completes: ' + S); +end; + +procedure TDXClusterClient.AddLog(const S: string); +begin + FLock.Enter; + try + FLog[FLogHead] := S; + FLogHead := (FLogHead + 1) mod DX_LOG_LINES; + if FLogCount < DX_LOG_LINES then Inc(FLogCount); + Inc(FLogVer); + finally + FLock.Leave; + end; +end; + +procedure TDXClusterClient.GetLog(Dst: TStrings); +var i, Start: Integer; +begin + if Dst = nil then Exit; + FLock.Enter; + try + Start := (FLogHead - FLogCount + DX_LOG_LINES) mod DX_LOG_LINES; + for i := 0 to FLogCount - 1 do + Dst.Add(FLog[(Start + i) mod DX_LOG_LINES]); + finally + FLock.Leave; + end; +end; + +function TDXClusterClient.LogVersion: Int64; +begin + FLock.Enter; + try + Result := FLogVer; + finally + FLock.Leave; + end; +end; + +{ ── TDXClusterThread ─────────────────────────────────────────────────────── } + +constructor TDXClusterThread.Create(AOwner: TDXClusterClient); +begin + FOwner := AOwner; + FSocket := SOCK_INVALID; + FreeOnTerminate := False; + inherited Create(False); +end; + +{ ── Резолв имени ─────────────────────────────────────────────────────────── } + +{$IFNDEF MSWINDOWS} +// getaddrinfo(3) объявляем сами: в RTL его нет (netdb использует его только +// под FPC_USE_LIBC, а этой сборки у нас нет), а тащить ради него устаревший +// пакет libc не хочется. Порядок полей структуры фиксирован ABI; BSD/macOS +// меняет местами ai_canonname и ai_addr — единственное расхождение. +{$PACKRECORDS C} +type + PCAddrInfo = ^TCAddrInfo; + TCAddrInfo = record + ai_flags: cint; + ai_family: cint; + ai_socktype: cint; + ai_protocol: cint; + ai_addrlen: cuint32; + {$IFDEF DARWIN} + ai_canonname: PChar; + ai_addr: Pointer; + {$ELSE} + ai_addr: Pointer; + ai_canonname: PChar; + {$ENDIF} + ai_next: PCAddrInfo; + end; + + PSockAddrIn4 = ^TInetSockAddr; +{$PACKRECORDS DEFAULT} + +function c_getaddrinfo(node, service: PChar; hints: PCAddrInfo; + out res: PCAddrInfo): cint; cdecl; external 'c' name 'getaddrinfo'; +procedure c_freeaddrinfo(res: PCAddrInfo); cdecl; external 'c' name 'freeaddrinfo'; +{$ENDIF} + +function TryLiteralIP(const Host: string; out Addr: LongWord): Boolean; +// Литеральный адрес разбирается БЕЗ резолвера — строкой, мгновенно. Отдельной +// функцией он нужен для того, чтобы вводом IP всегда можно было выбраться из +// повисшего системного резолвера: ждать очереди в реестре запросов ради +// «127.0.0.1» было бы издевательством. Возвращает СЕТЕВОЙ порядок байт. +{$IFDEF MSWINDOWS} +var L: LongWord; +begin + Addr := 0; + L := inet_addr(PChar(Host)); + Result := L <> INADDR_NONE; // inet_addr уже в сетевом порядке + if Result then Addr := L; +end; +{$ELSE} +var HA: THostAddr; +begin + Addr := 0; + // TryStrToHostAddr отдаёт ХОСТОВЫЙ порядок — разворачиваем. + Result := TryStrToHostAddr(Host, HA); + if Result then Addr := htonl(HA.s_addr); +end; +{$ENDIF} + +function ResolveHostSync(const Host: string; out Addr: LongWord): Boolean; +// Блокирующий системный резолв. Возвращает адрес в СЕТЕВОМ порядке байт +// (готов для sin_addr). Зовётся ТОЛЬКО из TDXResolverThread — прервать его +// нечем, поэтому ждать его результат напрямую нельзя (см. шапку юнита). +{$IFNDEF MSWINDOWS} +var Hints: TCAddrInfo; Res, AI: PCAddrInfo; +{$ELSE} +var PH: PHostEnt; +{$ENDIF} +begin + Result := False; + Addr := 0; + if Host = '' then Exit; + if TryLiteralIP(Host, Addr) then Exit(True); +{$IFDEF MSWINDOWS} + PH := gethostbyname(PChar(Host)); + if (PH = nil) or (PH^.h_addr_list = nil) or (PH^.h_addr_list^ = nil) then Exit; + Move(PH^.h_addr_list^^, Addr, 4); // hostent отдаёт сетевой порядок + Result := True; +{$ELSE} + // Системный путь: getaddrinfo идёт через NSS ⇒ видит /etc/hosts, mDNS, + // systemd-resolved — всё, что настроено у пользователя. Адрес в ai_addr уже + // в сетевом порядке, второй раз не вертим. + FillChar(Hints, SizeOf(Hints), 0); + Hints.ai_family := AF_INET; // сокет мы поднимаем IPv4 + Hints.ai_socktype := SOCK_STREAM; + Res := nil; + if (c_getaddrinfo(PChar(Host), nil, @Hints, Res) <> 0) or (Res = nil) then Exit; + try + AI := Res; + while AI <> nil do + begin + if (AI^.ai_family = AF_INET) and (AI^.ai_addr <> nil) then + begin + Addr := PSockAddrIn4(AI^.ai_addr)^.sin_addr.s_addr; + Exit(True); + end; + AI := AI^.ai_next; + end; + finally + c_freeaddrinfo(Res); + end; +{$ENDIF} +end; + +procedure ReleaseResolveLocked(Req: PDXResolveReq); +// Зовётся ТОЛЬКО под GResolveLock. Последний ушедший гасит свет. +begin + Dec(Req^.Refs); + if Req^.Refs <= 0 then Dispose(Req); +end; + +procedure UnlistResolveLocked(Req: PDXResolveReq); +// Снять запрос с реестра «в полёте». Только под GResolveLock. +var i: Integer; +begin + for i := 0 to High(GResolvePending) do + if GResolvePending[i] = Req then GResolvePending[i] := nil; +end; + +function AcquireResolve(const Host: string; + out Req: PDXResolveReq): TDXResolveOutcome; +// droOk — Req наш (ссылку обязательно вернуть через ReleaseResolveLocked). +// droBusy — все слоты заняты ЗАВИСШИМИ резолвами ЧУЖИХ имён. +// droFailed — поток не создался. +var i, Slot: Integer; +begin + Result := droBusy; + Req := nil; + GResolveLock.Enter; + try + Slot := -1; + for i := 0 to High(GResolvePending) do + if GResolvePending[i] = nil then + begin + if Slot < 0 then Slot := i; + end + else if GResolvePending[i]^.Host = Host then + begin + // Тот же хост — цепляемся к уже летящему запросу вместо второго потока. + // Именно это и держит число резолверов конечным, когда системный + // резолвер завис: КАЖДАЯ следующая попытка ждёт ТОТ ЖЕ запрос. + Req := GResolvePending[i]; + Inc(Req^.Refs); + Exit(droOk); + end; + // Слотов несколько, а не один, ради простой вещи: сменив в SETUP адрес + // кластера, пользователь обязан получить попытку по НОВОМУ имени даже если + // предыдущее намертво зависло в системном резолвере. Потолок оставлен, + // чтобы такие «вечные» потоки не копились без счёта. + if Slot < 0 then Exit; + New(Req); + Req^.Host := Host; + Req^.Addr := 0; + Req^.Ok := False; + Req^.Done := False; + Req^.Refs := 2; // резолвер + мы + GResolvePending[Slot] := Req; + try + TDXResolverThread.Create(Req); + except + GResolvePending[Slot] := nil; // поток не родился — запись ничья + Dispose(Req); + Req := nil; + Exit(droFailed); + end; + Result := droOk; + finally + GResolveLock.Leave; + end; +end; + +constructor TDXResolverThread.Create(AReq: PDXResolveReq); +begin + FReq := AReq; + FreeOnTerminate := True; // сессия его не ждёт и не освобождает + inherited Create(False); +end; + +procedure TDXResolverThread.Execute; +var + A: LongWord; + Ok: Boolean; +begin + A := 0; + Ok := False; + try + // Host записан до старта потока и больше никем не трогается — без лока. + Ok := ResolveHostSync(FReq^.Host, A); + except + // ★Любое исключение здесь обязано ЗАВЕРШИТЬСЯ снятием запроса с реестра. + // Иначе слот остался бы занят навсегда: то же имя давало бы вечные + // таймауты (Done никогда не выставится), а остальные — вечный DNS busy. + // TThread исключение проглатывает (кладёт в FatalException), так что без + // этого except мы бы даже не заметили. + Ok := False; + end; + GResolveLock.Enter; + try + FReq^.Addr := A; + FReq^.Ok := Ok; + FReq^.Done := True; + // Снимаемся с «в полёте»: следующая попытка начнёт свежий резолв, а этот + // результат достанется лишь тому, кто его уже ждёт. + UnlistResolveLocked(FReq); + ReleaseResolveLocked(FReq); // наша ссылка + finally + GResolveLock.Leave; + end; + FReq := nil; +end; + +function TDXClusterThread.Resolve(const Host: string; + out Addr: LongWord): TDXResolveOutcome; +// Ждём резолвер квантами, чтобы Stop/Terminate не упирались в системный +// DNS-таймаут. Не дождались — ссылку отдаём, но сам запрос остаётся в реестре: +// следующая попытка подождёт его же, а не заведёт второй вечный поток. +var + Req: PDXResolveReq; + Waited: Integer; + Ready: Boolean; +begin + Addr := 0; + Result := droFailed; + if Host = '' then Exit; + // ★Литеральный адрес разбираем ЗДЕСЬ, до всякого реестра: иначе, когда + // системный резолвер завис, ввод IP руками — единственный способ выбраться — + // упирался бы в чужой занятый слот ровно так же, как имя. + if TryLiteralIP(Host, Addr) then Exit(droOk); + + Result := AcquireResolve(Host, Req); + if Result <> droOk then Exit; // все слоты заняты / поток не создался + Result := droFailed; // дальше исход решает ожидание ниже + + try + Waited := 0; + while not Terminated do + begin + GResolveLock.Enter; + try + Ready := Req^.Done; + finally + GResolveLock.Leave; + end; + if Ready or (Waited >= DX_DNS_MS) then Break; + // Ждём на FStopEvent, а не Sleep: Stop будит нас немедленно. + if FOwner.FStopEvent.WaitFor(DX_DNS_SLICE_MS) = wrSignaled then Break; + Inc(Waited, DX_DNS_SLICE_MS); + end; + finally + // Ссылку отдаём при любом исходе, включая исключение в ожидании: иначе + // запись зависла бы с лишней ссылкой и не освободилась никогда. + GResolveLock.Enter; + try + if not Req^.Done then + Result := droTimeout + else if Req^.Ok then + begin + Addr := Req^.Addr; + Result := droOk; + end + else + Result := droFailed; + ReleaseResolveLocked(Req); + finally + GResolveLock.Leave; + end; + end; + + if Terminated then Result := droTimeout; // уходим — адрес уже не нужен +end; + +function TDXClusterThread.ConnectSock: Boolean; +// Неблокирующий connect + select: мёртвый хост не держит поток минуту на +// системном таймауте TCP, и Stop() отрабатывает быстро. +var + Addr: {$IFDEF MSWINDOWS}TSockAddrIn{$ELSE}TInetSockAddr{$ENDIF}; + IP: LongWord; + R, SoErr: Integer; + FDS: TFDSet; + TV: TTimeVal; + One, Waited: Integer; + {$IFDEF MSWINDOWS}ErrLen: Integer;{$ELSE}ErrLen: TSockLen;{$ENDIF} +begin + Result := False; + case Resolve(FHost, IP) of + droOk: ; + droBusy: + begin + FOwner.SetState(dxsRetry, 'DNS busy'); + FOwner.AddLog('*** DNS: previous lookup still running — retrying later'); + Exit; + end; + droTimeout: + begin + if Terminated then Exit; // это не отказ DNS, а наш же Stop + FOwner.SetState(dxsRetry, 'DNS timeout: ' + FHost); + FOwner.AddLog('*** DNS: no answer for ' + FHost); + Exit; + end; + else + if Terminated then Exit; + FOwner.SetState(dxsRetry, 'cannot resolve ' + FHost); + FOwner.AddLog('*** DNS: cannot resolve ' + FHost); + Exit; + end; + if Terminated then Exit; + + {$IFDEF MSWINDOWS} + FSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); + {$ELSE} + FSocket := fpSocket(AF_INET, SOCK_STREAM, IPPROTO_TCP); + {$ENDIF} + if FSocket = SOCK_INVALID then + begin + FOwner.SetState(dxsRetry, 'cannot create socket'); + Exit; + end; + + FillChar(Addr, SizeOf(Addr), 0); + Addr.sin_family := AF_INET; + Addr.sin_port := htons(FPort); + Addr.sin_addr.s_addr := IP; + + SockSetNonBlock(FSocket, True); + {$IFDEF MSWINDOWS} + R := WinSock2.connect(FSocket, @Addr, SizeOf(Addr)); + {$ELSE} + R := fpConnect(FSocket, @Addr, SizeOf(Addr)); + {$ENDIF} + if R <> 0 then + begin + // ожидаемо: EINPROGRESS / WSAEWOULDBLOCK — ждём готовности на запись. + // Ждём НЕ одним select на 8 с, а квантами по DX_CONNECT_SLICE_MS: иначе + // Stop() (закрытие программы) висел бы до конца таймаута соединения. + Waited := 0; + R := 0; + while (Waited < DX_CONNECT_MS) and (not Terminated) do + begin + TV.tv_sec := DX_CONNECT_SLICE_MS div 1000; + TV.tv_usec := (DX_CONNECT_SLICE_MS mod 1000) * 1000; + {$IFDEF MSWINDOWS} + FD_ZERO(FDS); + FD_SET(FSocket, FDS); + R := select(0, nil, @FDS, nil, @TV); + {$ELSE} + fpFD_ZERO(FDS); + fpFD_SET(FSocket, FDS); + R := fpSelect(FSocket + 1, nil, @FDS, nil, @TV); + {$ENDIF} + if R <> 0 then Break; // готов или ошибка select + Inc(Waited, DX_CONNECT_SLICE_MS); + end; + if Terminated then + begin + CloseSock; + Exit; + end; + if R <= 0 then + begin + CloseSock; + FOwner.SetState(dxsRetry, 'connect timeout: ' + FHost); + FOwner.AddLog('*** no answer from ' + FHost + ':' + IntToStr(FPort)); + Exit; + end; + SoErr := 0; ErrLen := SizeOf(SoErr); + {$IFDEF MSWINDOWS} + getsockopt(FSocket, SOL_SOCKET, SO_ERROR, PChar(@SoErr), ErrLen); + {$ELSE} + fpGetSockOpt(FSocket, SOL_SOCKET, SO_ERROR, @SoErr, @ErrLen); + {$ENDIF} + if SoErr <> 0 then + begin + CloseSock; + FOwner.SetState(dxsRetry, 'connection refused'); + FOwner.AddLog('*** refused: ' + FHost + ':' + IntToStr(FPort)); + Exit; + end; + end; + + SockSetNonBlock(FSocket, False); + SockSetRcvTimeout(FSocket, DX_RECV_MS); + SockSetSndTimeout(FSocket, 5000); + One := 1; + {$IFDEF MSWINDOWS} + setsockopt(FSocket, SOL_SOCKET, SO_KEEPALIVE, PChar(@One), SizeOf(One)); + {$ELSE} + fpSetSockOpt(FSocket, SOL_SOCKET, SO_KEEPALIVE, @One, SizeOf(One)); + {$ENDIF} + FOwner.PublishSock(FSocket); // с этого момента Stop может рвать нас shutdown'ом + Result := True; +end; + +procedure TDXClusterThread.CloseSock; +begin + if FSocket <> SOCK_INVALID then + begin + FOwner.PublishSock(SOCK_INVALID); // до close: Stop не должен увидеть мёртвый хэндл + SockShutdown(FSocket); + SockClose(FSocket); + FSocket := SOCK_INVALID; + end; +end; + +function TDXClusterThread.SendAll(const Data: string): Boolean; +// TCP вправе отправить меньше запрошенного — дописываем остаток. Таймаут +// (SO_SNDTIMEO) и EINTR — не ошибка соединения, пробуем ещё, но не бесконечно. +var + Sent, N, Tries: Integer; +begin + Result := False; + if (FSocket = SOCK_INVALID) or (Data = '') then Exit; + Sent := 0; + Tries := 0; + while Sent < Length(Data) do + begin + if Terminated then Exit; + N := SockSend(FSocket, @Data[Sent + 1], Length(Data) - Sent, 0); + if N > 0 then + begin + Inc(Sent, N); + Tries := 0; + end + else + begin + if not SockWouldBlock then Exit; // настоящая ошибка сокета + Inc(Tries); + if Tries > DX_SEND_RETRIES then Exit; // не отдаёт буфер — считаем разрывом + end; + end; + Result := True; +end; + +function TDXClusterThread.SendLine(const S: string): Boolean; +begin + Result := SendAll(S + #13#10); + if not Result then + FOwner.AddLog('*** send failed, dropping connection'); +end; + +procedure TDXClusterThread.FlushOutQueue; +var + Pending: TStringList; + i, j: Integer; +begin + Pending := nil; + FOwner.FLock.Enter; + try + if FOwner.FOutQueue.Count > 0 then + begin + Pending := TStringList.Create; + Pending.Assign(FOwner.FOutQueue); + FOwner.FOutQueue.Clear; + end; + finally + FOwner.FLock.Leave; + end; + if Pending = nil then Exit; + try + i := 0; + while i < Pending.Count do + begin + if not SendLine(Pending[i]) then Break; // сокет умер + FOwner.AddLog('> ' + Pending[i]); + Inc(i); + end; + // ★Не ушедшее (начиная с той самой команды) возвращаем в НАЧАЛО очереди: + // очередь выгребается целиком до отправки, и без возврата всё, до чего + // не дошли, просто пропадало бы — а обещано «отправим после реконнекта». + // В начало, потому что порядок для кластера значим (set/filter до sh/dx). + if i < Pending.Count then + begin + FOwner.FLock.Enter; + try + for j := Pending.Count - 1 downto i do + FOwner.FOutQueue.Insert(0, Pending[j]); + finally + FOwner.FLock.Leave; + end; + FOwner.AddLog(Format('*** %d command(s) held for the next connection', + [Pending.Count - i])); + end; + finally + Pending.Free; + end; +end; + +function PromptEndsWith(const U, Key: string): Boolean; +// U (уже в нижнем регистре) заканчивается ПРИГЛАШЕНИЕМ вида '…password:'. +// Двоеточие в конце — то, что отличает вопрос кластера от упоминания слова в +// приветствии («you can set a password with set/password»): на таком упоминании +// вывод «пароль отвергнут» порвал бы живое соединение. +var S: string; P: Integer; +begin + Result := False; + S := TrimRight(U); + if S = '' then Exit; + if S[Length(S)] <> ':' then Exit; + // ★Ищем ПОСЛЕДНЕЕ вхождение: в 'invalid password, enter password:' первое + // стоит далеко от конца и по нему приглашение не опозналось бы вовсе. + P := RPos(Key, S); + // Ключ должен стоять у самого конца: '…password (again):' считаем тем же. + Result := (P > 0) and (Length(S) - (P + Length(Key) - 1) <= 10); +end; + +function IsLoginPrompt(const U: string): Boolean; +// Строгая форма вопроса о позывном: 'login:', 'call:', 'callsign:', 'your +// call:'. Свободный поиск слова здесь не годится — по нему приветствие с +// упоминанием позывного сошло бы за повторный вопрос, т.е. за отказ. +begin + Result := PromptEndsWith(U, 'login') or PromptEndsWith(U, 'call'); +end; + +function LooksLikeAuthFailure(const U: string): Boolean; +// Типовые формулировки отказа. Список НАМЕРЕННО короткий и из точных фраз: +// проверяется он только в окне «учётка отправлена, логин ещё не завершён», но +// ложное срабатывание всё равно стоило бы рабочего соединения. +const + MARKS: array[0..6] of string = ( + 'invalid password', 'incorrect password', 'password incorrect', + 'wrong password', 'login incorrect', 'access denied', + 'authentication failed'); +var i: Integer; +begin + Result := True; + for i := Low(MARKS) to High(MARKS) do + if Pos(MARKS[i], U) > 0 then Exit; + Result := False; +end; + +procedure TDXClusterThread.FailAuth(const Reason: string); +// Отказ авторизации — не разрыв: реконнект с той же учёткой упрётся в то же +// самое. Гасим сессию совсем и говорим прямо; пользователь правит настройки, а +// это само поднимет клиент заново (ApplyDXConnection видит смену логина). +begin + if FFatal then Exit; + FFatal := True; + FOwner.AddLog('*** ' + Reason + ' — giving up, check callsign/password'); + FOwner.SetState(dxsError, Reason); +end; + +procedure TDXClusterThread.CheckPrompts(const Tail: string; IsTail: Boolean); +// Приглашения логина И пароля обычно приходят БЕЗ перевода строки, поэтому +// ищем их и в незавершённом хвосте буфера, а не только в целых строках. +// Флаги FLoginSent/FPassSent держат отправку однократной: хвост проверяется +// заново с каждым пришедшим куском. +// ★IsTail говорит лишь о том, ОТКУДА пришёл текст: незавершённый хвост или +// целая строка. Отвеченный хвост остаётся в буфере и со следующим куском доедет +// целой строкой — чтобы не счесть это эхо повторным вопросом (т.е. отказом), +// ответив по хвосту, мы запоминаем его в FAnsweredPrompt, и HandleLine гасит +// ровно ОДНУ следующую строку, если она совпала. Запрещать проверки для целых +// строк нельзя: приглашения вида 'Password:\r\n' — совершенно обычное дело. +var U: string; +begin + if (Tail = '') or FFatal then Exit; + U := LowerCase(Tail); + + if not FLoginSent then + begin + if (Pos('login:', U) > 0) or (Pos('call:', U) > 0) or + (Pos('callsign', U) > 0) or (Pos('your call', U) > 0) or + (Pos('enter your', U) > 0) then + begin + if not SendLine(FLogin) then Exit; + FOwner.AddLog('> ' + FLogin); + if IsTail then FAnsweredPrompt := TrimRight(U); + FLoginSent := True; + FLoginByPrompt := True; // ответили на вопрос, а не выстрелили вслепую + FLoginAt := Now; + FLoginStepAt := FLoginAt; + FSawAfterLogin := False; // ждём ответ именно на позывной + FOwner.SetState(dxsLogin, ''); + end; + Exit; + end; + + // Кластер снова просит позывной. Если наш ушёл ПО ПРИГЛАШЕНИЮ — его не + // приняли, второй раз слать тот же нечего. Если же мы стреляли вслепую + // (приглашения не дождались за DX_LOGIN_GRACE_S, а кластер спросил только + // сейчас), то это не отказ, а опоздавший вопрос — отвечаем ещё раз, ровно + // один: после этого FLoginByPrompt уже True. + if IsLoginPrompt(U) then + begin + if FLoginByPrompt then + begin + FailAuth('callsign rejected'); + Exit; + end; + if not SendLine(FLogin) then Exit; + FOwner.AddLog('> ' + FLogin + ' (prompt arrived late)'); + if IsTail then FAnsweredPrompt := TrimRight(U); + FLoginByPrompt := True; + // ★FLoginAt тоже заново: от него считается ожидание приглашения ПАРОЛЯ, а + // ждать его надо от позывного, на который кластер реально отвечает. Оставив + // старую отметку (слепой выстрел), при поздно пришедшем приглашении мы бы + // пароля уже не ждали вовсе — и по первой же приветственной строке + // высыпали бы post-login прямо перед вопросом о пароле. + FLoginAt := Now; + FLoginStepAt := FLoginAt; + FSawAfterLogin := False; + Exit; + end; + + // Приглашение пароля. И отправка, и вывод «не приняли» идут по ОДНОМУ И ТОМУ + // ЖЕ строгому детектору: по вхождению слова (как было) пароль улетел бы + // командой в кластер от одной лишь строки приветствия вида «you can set a + // password with set/password». + if PromptEndsWith(U, 'password') then + begin + // Спрашивают снова после того, как мы уже ответили, — не приняли. + if FPassSent then + begin + FailAuth('password rejected'); + Exit; + end; + if FPassword = '' then + begin + FailAuth('cluster asks for a password, none configured'); + Exit; + end; + if not SendLine(FPassword) then Exit; + FOwner.AddLog('> ********'); + if IsTail then FAnsweredPrompt := TrimRight(U); + FPassSent := True; + FLoginStepAt := Now; + // Ответ на пароль ещё впереди: вопрос о пароле ответом не считается. + FSawAfterLogin := False; + end; +end; + +function TDXClusterThread.LoginSettled: Boolean; +// Логин завершён, когда: позывной ушёл; пароль либо не нужен, либо отправлен, +// либо приглашения так и не было; сервер ОТВЕТИЛ хоть чем-то после нашей +// учётки (или молчит уже неприлично долго); и прошла пауза, за которую кластер +// успевает дожевать регистрацию. Раньше здесь стояли просто «две секунды после +// позывного» — при этом post-login команды и команды пользователя улетали в +// ещё не пройденный логин, ломая авторизацию (sh/dx вместо пароля). +var SinceLogin, SinceStep: Integer; +begin + Result := False; + if not FLoginSent then Exit; + SinceLogin := SecondsBetween(Now, FLoginAt); + SinceStep := SecondsBetween(Now, FLoginStepAt); + // Приглашение пароля ждём от отправки позывного… + if (FPassword <> '') and (not FPassSent) and (SinceLogin < DX_PASSWORD_WAIT_S) then Exit; + // …а молчание сервера считаем от ПОСЛЕДНЕЙ отправленной учётки: после пароля + // ждать ответ надо заново, иначе «принят ли пароль» никто не проверит. + if (not FSawAfterLogin) and (SinceStep < DX_LOGIN_MAX_S) then Exit; + Result := SinceStep >= DX_POSTLOGIN_S; +end; + +function TDXClusterThread.SendPostLogin: Boolean; +// False — сокет умер на отправке. Это разрыв ВСЕЙ сессии: продолжать на мёртвом +// соединении значило бы объявить ONLINE и вычерпать очередь команд в никуда. +var + PL: TStringList; + i: Integer; +begin + Result := True; + if Trim(FPostLogin) = '' then Exit; + PL := TStringList.Create; + try + PL.Text := FPostLogin; + for i := 0 to PL.Count - 1 do + if Trim(PL[i]) <> '' then + begin + if not SendLine(Trim(PL[i])) then Exit(False); + FOwner.AddLog('> ' + Trim(PL[i])); + end; + finally + PL.Free; + end; +end; + +procedure TDXClusterThread.HandleLine(const Line: string); +var + Spot: TDXSpot; + Echo: Boolean; +begin + if Line = '' then Exit; + FOwner.AddLog(Line); + + // Эхо приглашения, на которое мы уже ответили по хвосту (см. CheckPrompts). + // Окно ровно на одну строку: следующая строка — уже настоящая новость, и + // такое же приглашение в ней будет означать, что нас переспрашивают. + if FAnsweredPrompt <> '' then + begin + Echo := TrimRight(LowerCase(Line)) = FAnsweredPrompt; + FAnsweredPrompt := ''; + if Echo then Exit; // ответом сервера это НЕ считается + end; + + // Отказ ищем до всего прочего и, главное, до отметки «сервер ответил»: иначе + // «Invalid password» само же и подтверждало бы успешный логин. Окно узкое — + // учётка ушла, логин не завершён; дальше в строках обычный трафик кластера, + // где такие слова бывают в чьём угодно комментарии к споту. + if FLoginSent and (not FPostSent) and LooksLikeAuthFailure(LowerCase(Line)) then + begin + FailAuth('cluster rejected login: ' + Trim(Line)); + Exit; + end; + + // Вот теперь это действительно ответ сервера по существу: не эхо нашего же + // приглашения и не отказ. Только такое и подтверждает, что логин продвинулся. + if FLoginSent then FSawAfterLogin := True; + + if ParseDXSpot(Line, Spot) then + begin + FOwner.FStore.Add(Spot); + FOwner.FLock.Enter; + try + Inc(FOwner.FSpotCount); + finally + FOwner.FLock.Leave; + end; + if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, ''); + Exit; + end; + + CheckPrompts(Line, False); +end; + +procedure TDXClusterThread.HandleChunk(const Data: string); +var + P: Integer; + Line: string; +begin + FRxBuf := FRxBuf + Data; + while True do + begin + P := 1; + while (P <= Length(FRxBuf)) and not (FRxBuf[P] in [#10, #13]) do Inc(P); + if P > Length(FRxBuf) then Break; // перевода строки ещё нет + Line := Copy(FRxBuf, 1, P - 1); + // съедаем весь конец строки (CR, LF или CRLF) + while (P <= Length(FRxBuf)) and (FRxBuf[P] in [#10, #13]) do Inc(P); + Delete(FRxBuf, 1, P - 1); + HandleLine(TrimRight(Line)); + end; + + // Хвост без перевода строки — возможно, это приглашение логина или пароля… + if FRxBuf <> '' then + begin + // …а возможно, и сообщение об отказе: его тоже присылают без перевода + // строки, и без этой проверки оно ушло бы в «сервер ответил», т.е. в + // подтверждение логина. + if FLoginSent and (not FPostSent) and LooksLikeAuthFailure(LowerCase(FRxBuf)) then + FailAuth('cluster rejected login: ' + Trim(FRxBuf)) + else + begin + CheckPrompts(FRxBuf, True); + // Хвост подтверждает логин, только если пережил разбор: не отказ, не + // приглашение, которое мы только что отвечали (там флаг сбрасывается), и + // не остаток уже отвеченного приглашения. Считать его ответом нужно — + // многие кластеры шлют приглашение сессии БЕЗ перевода строки, и без + // этого post-login ждал бы потолка молчания на ровном месте. + if FLoginSent and (not FFatal) and (FAnsweredPrompt = '') then + FSawAfterLogin := True; + end; + end; + // Защита от мусора без переводов строк. + if Length(FRxBuf) > 8192 then FRxBuf := ''; +end; + +function TDXClusterThread.Session: Boolean; +var + Buf: array[0..4095] of Byte; + N: Integer; + Chunk: string; +begin + Result := True; + FRxBuf := ''; + FLoginSent := False; + FLoginByPrompt := False; + FPassSent := False; + FPostSent := False; + FSawAfterLogin := False; + FFatal := False; + FAnsweredPrompt := ''; + FLoginAt := Now; + FLoginStepAt := Now; + FConnectAt := Now; + + FOwner.SetState(dxsConnecting, FHost + ':' + IntToStr(FPort)); + FOwner.AddLog('*** connecting to ' + FHost + ':' + IntToStr(FPort)); + if not ConnectSock then Exit; + + FOwner.AddLog('*** connected'); + FOwner.SetState(dxsLogin, ''); + + while not Terminated do + begin + N := SockRecv(FSocket, @Buf[0], SizeOf(Buf), 0); + if N > 0 then + begin + SetLength(Chunk, N); + Move(Buf[0], Chunk[1], N); + // ★FSawAfterLogin здесь НЕ ставится. Приход байтов — факт транспортный, а + // не протокольный: отдельным пакетом может доехать один лишь '\r\n', + // закрывающий приглашение, на которое мы уже ответили, и «подтверждение + // логина» зависело бы от того, как TCP порезал поток. Флаг ставит + // HandleChunk/HandleLine — после разбора, по существу пришедшего. + HandleChunk(Chunk); + if FFatal then Break; // логин отвергнут — реконнект не поможет + end + else if N = 0 then + begin + FOwner.AddLog('*** connection closed by peer'); + Break; + end + else if not SockWouldBlock then + begin + // Не таймаут кванта recv, а настоящая ошибка сокета — уходим на реконнект. + FOwner.AddLog('*** connection lost (socket error)'); + Break; + end; + + if Terminated then Break; + + // Приглашения не дождались — шлём позывной сами (часть кластеров молчит). + if (not FLoginSent) and (SecondsBetween(Now, FConnectAt) >= DX_LOGIN_GRACE_S) then + begin + if not SendLine(FLogin) then Break; // сокет умер — на реконнект + FOwner.AddLog('> ' + FLogin + ' (no prompt seen)'); + FLoginSent := True; + FLoginByPrompt := False; // вслепую: опоздавшее приглашение = не отказ + FLoginAt := Now; + FLoginStepAt := FLoginAt; + FSawAfterLogin := False; // ждём ответ именно на позывной + end; + + // Post-login команды — один раз, когда логин действительно пройден. + if (not FPostSent) and LoginSettled then + begin + FPostSent := True; + if not SendPostLogin then Break; // сокет умер — вся сессия на реконнект + if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, ''); + end; + + // Команды пользователя — только после логина: до него кластер ждёт позывной + // и пароль, и любая наша строка ушла бы вместо них. Очередь никуда не + // девается, отправим следом. + if FPostSent then FlushOutQueue; + end; + + CloseSock; + Result := (not Terminated) and (not FFatal); +end; + +procedure TDXClusterThread.Execute; +var + Backoff: Integer; +begin + Backoff := DX_RECONNECT_MIN; + // Снимок конфига на всю жизнь потока: Configure во время работы применяется + // следующим Start (так же ведёт себя веб-сервер при смене порта). + FOwner.FLock.Enter; + try + FHost := FOwner.FHost; + FPort := FOwner.FPort; + FLogin := FOwner.FLogin; + FPassword := FOwner.FPassword; + FPostLogin := FOwner.FPostLogin; + finally + FOwner.FLock.Leave; + end; + + while not Terminated do + begin + if not Session then Break; + if Terminated then Break; + + FOwner.SetState(dxsRetry, 'reconnecting in ' + IntToStr(Backoff) + ' s'); + FOwner.AddLog('*** reconnecting in ' + IntToStr(Backoff) + ' s'); + if FOwner.FStopEvent.WaitFor(Backoff * 1000) = wrSignaled then Break; + Backoff := Backoff * 2; + if Backoff > DX_RECONNECT_MAX then Backoff := DX_RECONNECT_MAX; + end; + CloseSock; +end; + +initialization + GResolveLock := TCriticalSection.Create; + FillChar(GResolvePending, SizeOf(GResolvePending), 0); +{$IFDEF MSWINDOWS} + // ★Winsock поднимается ОДИН раз на процесс и НЕ выгружается. Раньше это + // делали конструктор и деструктор клиента — но Stop не ждёт (и не может + // ждать) резолвер-поток, а тот может в этот момент сидеть внутри + // gethostbyname: WSACleanup из-под него = обращение к выгруженному Winsock, + // то есть падение на выходе или при пересоздании клиента. Winsock освободит + // сам процесс. + WSAStartup($0202, GWSAData); +{$ENDIF} + +// ★finalization НЕТ намеренно, по той же причине: брошенный резолвер может +// стоять в системном резолвере и после выхода из программы, а прервать его +// нечем. Освободив GResolveLock, мы дали бы ему упасть на Enter уже +// освобождённой секции; один живущий до конца процесса объект — не утечка. + +end. diff --git a/DXClusterForm.pas b/DXClusterForm.pas new file mode 100644 index 0000000..3268278 --- /dev/null +++ b/DXClusterForm.pas @@ -0,0 +1,484 @@ +unit DXClusterForm; + +{ + TDXClusterForm — окно DX-кластера: список принятых спотов, лог соединения и + строка команды в кластер (sh/dx, set/filter — диалект у каждого кластера свой, + поэтому команды не угадываем, а даём отправить руками). + + Данные тянутся ПОЛЛИНГОМ: сетевой поток кладёт споты в TDXSpotStore и строки в + лог клиента, а форма раз в секунду сравнивает Version/LogVersion и перечитывает + только при изменении. Никакого Synchronize из потока в UI — та же схема, что у + оверлея спектра. + + Двойной клик по споту (или Enter) — QSY: наружу через OnTuneSpot. +} + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, + Forms, Controls, Graphics, StdCtrls, ExtCtrls, + FlatButton, FlatEdit, FlatListBox, FlatMemo, + AppTheme, DpiUtils, DXSpotStore, DXClusterClient; + +type + // QSY по споту: частота в display-Гц + мода (dxmUnknown — не трогать моду). + TDXTuneEvent = procedure(FreqHz: Double; Mode: TDXMode) of object; + + TDXClusterForm = class(TForm) + private + FStore: TDXSpotStore; // не владеет + FClient: TDXClusterClient; // не владеет + FTheme: TAppTheme; + + FTitle: TLabel; + FStatus: TLabel; + FBtnConn: TFlatButton; + FBtnClear: TFlatButton; + FBtnSort: TFlatButton; + FBtnClose: TFlatButton; + FList: TFlatListBox; + FLog: TFlatMemo; + FEdCmd: TFlatEdit; + FBtnSend: TFlatButton; + FTimer: TTimer; + + FSpots: TDXSpotArray; // снимок, параллельный строкам FList + FSortFreq: Boolean; // False = по времени (свежие сверху) + FLastVer: Int64; + FLastLogVer: Int64; + FOnTune: TDXTuneEvent; + + procedure BuildUI; + procedure StyleBtn(B: TFlatButton); + function FormatSpotLine(const S: TDXSpot): string; + procedure RefreshSpots; + procedure RefreshLog; + procedure RefreshStatus; + procedure TuneSelected; + + procedure OnTimerTick(Sender: TObject); + procedure OnConnClick(Sender: TObject); + procedure OnClearClick(Sender: TObject); + procedure OnSortClick(Sender: TObject); + procedure OnCloseClick(Sender: TObject); + procedure OnSendClick(Sender: TObject); + procedure OnListDblClick(Sender: TObject); + procedure OnListKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure OnCmdKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure OnFormClose(Sender: TObject; var CloseAction: TCloseAction); + protected + procedure DoShow; override; + procedure DoHide; override; + public + constructor CreateWith(AOwner: TComponent; AStore: TDXSpotStore; + AClient: TDXClusterClient); reintroduce; + procedure ApplyTheme(const T: TAppTheme); + property OnTuneSpot: TDXTuneEvent read FOnTune write FOnTune; + end; + +implementation + +const + FORM_W = 860; + FORM_H = 560; + MARGIN = 12; + BTN_H = 26; + LOG_H = 130; + + // Моноширинный — ТОЛЬКО там, где колонки выровнены пробелами (список спотов и + // лог соединения); всё остальное в окне идёт системным шрифтом, как везде по + // проекту. Имя платформенное, как в CWTerminalForm: 'Courier New' есть не + // всюду (на Linux fontconfig всё равно подставляет свой моноширинный). +{$IFDEF WINDOWS} + MONO_FONT = 'Consolas'; +{$ELSE} + MONO_FONT = 'Monospace'; +{$ENDIF} + +constructor TDXClusterForm.CreateWith(AOwner: TComponent; AStore: TDXSpotStore; + AClient: TDXClusterClient); +var + WorkArea: TRect; +begin + inherited CreateNew(AOwner); + FStore := AStore; + FClient := AClient; + FTheme := DarkTheme; + FSortFreq := False; + FLastVer := -1; + FLastLogVer := -1; + + Scaled := False; + Caption := 'DX Cluster'; + BorderStyle := bsSizeable; + if AOwner is TCustomForm then + begin + WorkArea := Screen.MonitorFromRect(TCustomForm(AOwner).BoundsRect).WorkareaRect; + Position := poOwnerFormCenter; + end + else + begin + WorkArea := Screen.PrimaryMonitor.WorkareaRect; + Position := poScreenCenter; + end; + Width := Min(DpiScale(FORM_W), WorkArea.Right - WorkArea.Left - DpiScale(48)); + Height := Min(DpiScale(FORM_H), WorkArea.Bottom - WorkArea.Top - DpiScale(48)); + Constraints.MinWidth := Min(DpiScale(620), Width); + Constraints.MinHeight := Min(DpiScale(380), Height); + OnClose := @OnFormClose; + + BuildUI; + ApplyTheme(DarkTheme); +end; + +procedure TDXClusterForm.BuildUI; +var + BtnW, Y: Integer; +begin + BtnW := DpiScale(96); + + FTitle := TLabel.Create(Self); + FTitle.Parent := Self; + FTitle.SetBounds(DpiScale(MARGIN), DpiScale(10), DpiScale(300), DpiScale(22)); + FTitle.Caption := 'DX CLUSTER'; + FTitle.Font.Size := 9; + FTitle.Font.Style := [fsBold]; + + FStatus := TLabel.Create(Self); + FStatus.Parent := Self; + FStatus.SetBounds(DpiScale(MARGIN), DpiScale(31), DpiScale(520), DpiScale(18)); + FStatus.Font.Size := 8; + FStatus.Anchors := [akLeft, akTop, akRight]; + + Y := DpiScale(10); + FBtnClose := TFlatButton.Create(Self); + FBtnClose.Parent := Self; + FBtnClose.SetBounds(ClientWidth - DpiScale(MARGIN) - BtnW, Y, BtnW, DpiScale(BTN_H)); + FBtnClose.Caption := 'Close'; + FBtnClose.Anchors := [akTop, akRight]; + FBtnClose.OnClick := @OnCloseClick; + + FBtnSort := TFlatButton.Create(Self); + FBtnSort.Parent := Self; + FBtnSort.SetBounds(FBtnClose.Left - BtnW - DpiScale(6), Y, BtnW, DpiScale(BTN_H)); + FBtnSort.Caption := 'BY TIME'; + FBtnSort.Anchors := [akTop, akRight]; + FBtnSort.OnClick := @OnSortClick; + + FBtnClear := TFlatButton.Create(Self); + FBtnClear.Parent := Self; + FBtnClear.SetBounds(FBtnSort.Left - BtnW - DpiScale(6), Y, BtnW, DpiScale(BTN_H)); + FBtnClear.Caption := 'CLEAR'; + FBtnClear.Anchors := [akTop, akRight]; + FBtnClear.OnClick := @OnClearClick; + + FBtnConn := TFlatButton.Create(Self); + FBtnConn.Parent := Self; + FBtnConn.SetBounds(FBtnClear.Left - BtnW - DpiScale(6), Y, BtnW, DpiScale(BTN_H)); + FBtnConn.Caption := 'CONNECT'; + FBtnConn.Anchors := [akTop, akRight]; + FBtnConn.OnClick := @OnConnClick; + + // Строка команды — внизу, над логом. + FBtnSend := TFlatButton.Create(Self); + FBtnSend.Parent := Self; + FBtnSend.SetBounds(ClientWidth - DpiScale(MARGIN) - BtnW, + ClientHeight - DpiScale(MARGIN + BTN_H), BtnW, DpiScale(BTN_H)); + FBtnSend.Caption := 'SEND'; + FBtnSend.Anchors := [akRight, akBottom]; + FBtnSend.OnClick := @OnSendClick; + + FEdCmd := TFlatEdit.Create(Self); + FEdCmd.Parent := Self; + FEdCmd.SetBounds(DpiScale(MARGIN), ClientHeight - DpiScale(MARGIN + BTN_H), + FBtnSend.Left - DpiScale(MARGIN + 6), DpiScale(BTN_H)); + FEdCmd.TextHint := 'command to cluster (sh/dx, set/filter …)'; + FEdCmd.Anchors := [akLeft, akRight, akBottom]; + FEdCmd.OnKeyDown := @OnCmdKeyDown; + + FLog := TFlatMemo.Create(Self); + FLog.Parent := Self; + FLog.SetBounds(DpiScale(MARGIN), + FEdCmd.Top - DpiScale(LOG_H + 6), + ClientWidth - DpiScale(MARGIN * 2), DpiScale(LOG_H)); + FLog.Anchors := [akLeft, akRight, akBottom]; + FLog.ReadOnly := True; + FLog.WordWrap := False; + FLog.Font.Name := MONO_FONT; + FLog.Font.Size := 8; + + FList := TFlatListBox.Create(Self); + FList.Parent := Self; + FList.SetBounds(DpiScale(MARGIN), DpiScale(56), + ClientWidth - DpiScale(MARGIN * 2), + FLog.Top - DpiScale(56 + 6)); + FList.Anchors := [akLeft, akTop, akRight, akBottom]; + FList.Font.Name := MONO_FONT; + FList.Font.Size := 9; + FList.TabStop := True; + FList.OnDblClick := @OnListDblClick; + FList.OnKeyDown := @OnListKeyDown; + + FTimer := TTimer.Create(Self); + FTimer.Interval := 1000; + FTimer.Enabled := False; + FTimer.OnTimer := @OnTimerTick; +end; + +procedure TDXClusterForm.StyleBtn(B: TFlatButton); +begin + // TFlatButton темы не знает — цвета выставляются вручную, как в ChannelsForm. + if B = nil then Exit; + B.Font.Assign(Font); + B.Font.Size := 8; + B.Font.Style := []; + B.ClrNorm := FTheme.BtnNorm; + B.ClrActive := FTheme.BtnActive; + B.ClrHot := FTheme.BtnHot; + B.ClrBorder := FTheme.BtnBorderNorm; + B.ClrText := FTheme.BtnText; + B.ClrTextAct := FTheme.BtnTextActive; + B.Invalidate; +end; + +procedure TDXClusterForm.ApplyTheme(const T: TAppTheme); +begin + FTheme := T; + Color := T.BG; + FTitle.Font.Color := T.Text; + FStatus.Font.Color := T.TextDim; + FList.SetAppTheme(T); + FLog.SetAppTheme(T); + FEdCmd.SetAppTheme(T); + StyleBtn(FBtnConn); + StyleBtn(FBtnClear); + StyleBtn(FBtnSort); + StyleBtn(FBtnClose); + StyleBtn(FBtnSend); + Invalidate; +end; + +{ ── Наполнение ───────────────────────────────────────────────────────────── } + +function TDXClusterForm.FormatSpotLine(const S: TDXSpot): string; +// Моноширинные колонки: частота | позывной | мода | UTC | спотер | комментарий. +var + FreqStr, Md: string; +begin + FreqStr := FormatFloat('0.0', S.FreqHz / 1000.0); // кГц, как в кластере + while Length(FreqStr) < 10 do FreqStr := ' ' + FreqStr; + // Мода, выведенная из бэндплана, помечена '?': спотер её не называл, и + // видеть разницу полезно — на границах участков таблица может ошибаться. + Md := DXModeName(S.Mode); + if (Md <> '') and S.ModeGuessed then Md := Md + '?'; + while Length(Md) < 5 do Md := Md + ' '; + Result := Format('%s %-12s %s %-5s %-10s %s', + [FreqStr, S.Call, Md, S.TimeUTC, S.Spotter, S.Comment]); +end; + +procedure TDXClusterForm.RefreshSpots; +var + i, j, Keep: Integer; + T: TDXSpot; + SelCall: string; + SelFreq: Double; +begin + if FStore = nil then Exit; + // Что выделено — запоминаем позывным И частотой: стор намеренно держит один + // позывной на разных диапазонах, и по одному позывному выделение после + // обновления перескочило бы на первый совпавший, а Enter/двойной клик увёл бы + // радио не на тот диапазон. + Keep := FList.ItemIndex; + SelCall := ''; + SelFreq := 0; + if (Keep >= 0) and (Keep < Length(FSpots)) then + begin + SelCall := FSpots[Keep].Call; + SelFreq := FSpots[Keep].FreqHz; + end; + + FStore.Snapshot(FSpots); // приходит отсортированным по частоте + if not FSortFreq then + // по времени, свежие сверху (вставками — список короткий, TTL его держит) + for i := 1 to High(FSpots) do + begin + T := FSpots[i]; + j := i - 1; + while (j >= 0) and (FSpots[j].Stamp < T.Stamp) do + begin + FSpots[j + 1] := FSpots[j]; + Dec(j); + end; + FSpots[j + 1] := T; + end; + + FList.Items.BeginUpdate; + try + FList.Items.Clear; + for i := 0 to High(FSpots) do + FList.Items.Add(FormatSpotLine(FSpots[i])); + finally + FList.Items.EndUpdate; + end; + + // Держим выделение на том же споте, если он ещё в списке. Допуск по частоте — + // тот же, что у дедупа стора: спот того же позывного мог чуть подвинуться. + if SelCall <> '' then + for i := 0 to High(FSpots) do + if SameText(FSpots[i].Call, SelCall) and + (Abs(FSpots[i].FreqHz - SelFreq) <= DX_DEDUP_HZ) then + begin + FList.ItemIndex := i; + Break; + end; +end; + +procedure TDXClusterForm.RefreshLog; +var + L: TStringList; +begin + if FClient = nil then Exit; + L := TStringList.Create; + try + FClient.GetLog(L); + FLog.Lines.BeginUpdate; + try + FLog.Lines.Assign(L); + finally + FLog.Lines.EndUpdate; + end; + // прокрутка в конец — свежие строки внизу + FLog.SelStart := Length(FLog.Text); + finally + L.Free; + end; +end; + +procedure TDXClusterForm.RefreshStatus; +var + St: TDXClusterState; + S: string; +begin + if FClient = nil then Exit; + St := FClient.State; + S := DXStateName(St); + if FClient.StatusMessage <> '' then S := S + ' — ' + FClient.StatusMessage; + S := S + Format(' | spots stored: %d received this session: %d', + [FStore.Count, FClient.SpotsReceived]); + FStatus.Caption := S; + if FClient.Running then FBtnConn.Caption := 'DISCONNECT' + else FBtnConn.Caption := 'CONNECT'; +end; + +{ ── События ──────────────────────────────────────────────────────────────── } + +procedure TDXClusterForm.OnTimerTick(Sender: TObject); +begin + if (FStore <> nil) and (FStore.Version <> FLastVer) then + begin + FLastVer := FStore.Version; + RefreshSpots; + end; + if (FClient <> nil) and (FClient.LogVersion <> FLastLogVer) then + begin + FLastLogVer := FClient.LogVersion; + RefreshLog; + RefreshStatus; + end; +end; + +procedure TDXClusterForm.OnConnClick(Sender: TObject); +begin + if FClient = nil then Exit; + if FClient.Running then FClient.Stop else FClient.Start; + RefreshStatus; +end; + +procedure TDXClusterForm.OnClearClick(Sender: TObject); +begin + if FStore <> nil then FStore.Clear; + FLastVer := -1; + RefreshSpots; +end; + +procedure TDXClusterForm.OnSortClick(Sender: TObject); +begin + FSortFreq := not FSortFreq; + if FSortFreq then FBtnSort.Caption := 'BY FREQ' + else FBtnSort.Caption := 'BY TIME'; + RefreshSpots; +end; + +procedure TDXClusterForm.OnCloseClick(Sender: TObject); +begin + Close; +end; + +procedure TDXClusterForm.OnSendClick(Sender: TObject); +begin + if (FClient = nil) or (Trim(FEdCmd.Text) = '') then Exit; + FClient.SendCommand(Trim(FEdCmd.Text)); + FEdCmd.Text := ''; +end; + +procedure TDXClusterForm.OnCmdKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +begin + if Key = 13 then + begin + Key := 0; + OnSendClick(nil); + end; +end; + +procedure TDXClusterForm.TuneSelected; +var i: Integer; +begin + i := FList.ItemIndex; + if (i < 0) or (i > High(FSpots)) then Exit; + if Assigned(FOnTune) then FOnTune(FSpots[i].FreqHz, FSpots[i].Mode); +end; + +procedure TDXClusterForm.OnListDblClick(Sender: TObject); +begin + TuneSelected; +end; + +procedure TDXClusterForm.OnListKeyDown(Sender: TObject; var Key: Word; + Shift: TShiftState); +// Enter по выделенной строке = то же, что двойной клик (QSY на спот). +begin + if (Key = 13) or (Key = 10) then + begin + Key := 0; + TuneSelected; + end; +end; + +procedure TDXClusterForm.OnFormClose(Sender: TObject; var CloseAction: TCloseAction); +begin + CloseAction := caHide; +end; + +procedure TDXClusterForm.DoShow; +begin + inherited DoShow; + // Поллинг живёт только пока окно видимо (как анализатор лупы маяка). + FLastVer := -1; + FLastLogVer := -1; + RefreshSpots; + RefreshLog; + RefreshStatus; + FTimer.Enabled := True; +end; + +procedure TDXClusterForm.DoHide; +begin + FTimer.Enabled := False; + inherited DoHide; +end; + +end. diff --git a/DXSpotOverlay.pas b/DXSpotOverlay.pas new file mode 100644 index 0000000..1e6f489 --- /dev/null +++ b/DXSpotOverlay.pas @@ -0,0 +1,580 @@ +unit DXSpotOverlay; + +{ + Оверлей DX-спотов на спектре: позывной в «чипе» + вертикальный штрих к своей + частоте. Пересекающиеся подписи раскладываются лесенкой по рядам сверху вниз. + + Производительность — ровно модель BandPlanOverlay/VfoOverlay, ничего нового: + + • Кэшируется ТОЛЬКО полоса подписей (W × FBandH, вверху спектра) в key-color + битмап; пересборка идёт исключительно по dirty-ключу (версия стора / вид / + ширина / тема / фильтры / тик затухания), а каждый кадр — один композит + W × FBandH с постоянной альфой (BlendBitmapKey, тот же дворд-блендинг). + Полноэкранный кэш W × H на кадр стоил бы в разы дороже — поэтому штрихи + ниже полосы в кэш НЕ входят. + • Версия стора глобальна, а окно у каждого пана своё, поэтому на смену + версии сначала берётся снимок окна и сверяется его ПОДПИСЬ: спот, севший + на чужой диапазон, до полосы подписей этого пана не доходит. Без этого + каждый пан пересобирал бы кэш (и перезаливал GL-текстуру) на любой спот + откуда угодно — цена, которая множится на число панов. + • Штрихи от полосы до низа спектра рисует вызывающая сторона теми же + примитивами, что и все прочие маркеры: CPU — RawVLine внутри RawBegin/ + RawEnd (никакого Canvas на битмапе кадра), GL — DrawLine. Оверлей отдаёт + только готовый список X/цвет (TickCount/Tick), посчитанный при пересборке + кэша, — на кадр никакой арифметики по спотам. + • GL-путь берёт ТОТ ЖЕ битмап текстурой (DrawOverlayBitmap + UploadBitmap с + color-key), заливка — только при dirty. Вид CPU и GL совпадает. + + Домен частот — display-Гц, как их видит спектр (GetViewWindow). Частота спота + кладётся как есть: на QO-100 кластеры постят downlink 10489.xxx, что совпадает + со шкалой панадаптера само собой. +} + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Graphics, Types, Math, Forms, + VfoOverlay, // BlendBitmapKey — общий keyed-композит (одна копия на проект) + DXSpotStore; + +const + DXSPOT_ALPHA = 225; // альфа композита полосы подписей + DXSPOT_ROW_BASE_H = 15; // базовая высота ряда @96dpi + DXSPOT_MAX_ROWS = 6; // потолок рядов лесенки (настройка кладётся сюда) + +type + // Один разложенный спот: где чип, где штрих, каким цветом. + TDXSpotItem = record + X: Integer; // X штриха (пиксель частоты) + Chip: TRect; // прямоугольник подписи (для хит-теста) + Color: TColor; // цвет с учётом возраста/своего позывного + Spot: TDXSpot; + end; + + TDXSpotOverlay = class(TComponent) + private + FStore: TDXSpotStore; // не владеет + FCenterFreq: Double; + FSpanHz: Double; + FEnabled: Boolean; + FLightTheme: Boolean; + FOwnCall: string; + + // фильтры + FModes: TDXModeSet; + FMaxAgeMin: Integer; + FMaxRows: Integer; + + FCache: TBitmap; + FCacheW: Integer; + FCacheDirty: Boolean; + FBandH: Integer; // высота полосы подписей (px, масштаб по DPI) + FRowH: Integer; + + // ключ кэша + FKeyCenter: Double; + FKeySpan: Double; + FKeyW: Integer; + FKeyEnabled: Boolean; + FKeyVersion: Int64; + FKeyLight: Boolean; + FKeyRows: Integer; + FKeyAgeTick: Int64; + FKeyStamp: Int64; // подпись набора, по которому собран кэш + FAgeTick: Int64; // бампается таймером UI — обновить затухание + + FRenderVer: Int64; // ++ на каждую пересборку кэша — ключ GL-текстуры + FLayoutTTL: Integer; // горизонт затухания, снят один раз на раскладку + // Снимок окна: берётся при смене вида/версии стора, живёт до пересборки — + // подпись считается по нему же, второй раз стор не дёргаем. + FArr: TDXSpotArray; + FArrN: Integer; + FArrStamp: Int64; + FItems: array of TDXSpotItem; + FItemCount: Integer; + FHidden: Integer; // сколько спотов не влезло в лесенку + + function FreqToX(FreqHz: Double; W: Integer): Integer; + function AgeColor(const S: TDXSpot): TColor; + procedure TakeSnapshot; + procedure Layout(C: TCanvas; W: Integer); + procedure DrawSelf(C: TCanvas; W: Integer); + procedure RebuildCache(W: Integer; Ver: Int64); + function ViewKeysChanged(W: Integer): Boolean; + procedure SetMaxRows(V: Integer); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure Attach(AStore: TDXSpotStore); + procedure SetView(ACenterHz, ASpanHz: Double); + procedure SetEnabled(En: Boolean); + procedure SetLightTheme(Light: Boolean); + procedure SetOwnCall(const ACall: string); + procedure SetFilters(AModes: TDXModeSet; AMaxAgeMin: Integer); + // Тик затухания: дёргается редко (раз в десятки секунд) — только чтобы + // старые споты потускнели и ушедшие по TTL исчезли. + procedure TickAge; + procedure Invalidate; + + function Active: Boolean; + + // Пересобрать кэш+раскладку, если протух ключ. Вызывается В НАЧАЛЕ кадра: + // штрихи рисуются РАНЬШЕ композита полосы, а список штрихов рождается + // именно при пересборке — иначе первый кадр после нового спота рисовал бы + // старую раскладку. + procedure EnsureRendered(W: Integer); + + // CPU-путь: композит полосы подписей вверху Target. + procedure DrawOverlay(Target: TBitmap; W, H: Integer); + // GL-путь: полоса подписей в Target-битмап (W × BandHeight) под текстуру. + procedure DrawOverlayBitmap(Target: TBitmap; W: Integer); + + // Штрихи ниже полосы — рисует вызывающая сторона (RawVLine / GL DrawLine). + function TickCount: Integer; + procedure Tick(Idx: Integer; out X: Integer; out Color: TColor); + + // Хит-тест по подписи (клик = настроиться на спот). + function SpotAtPixel(X, Y: Integer; out Spot: TDXSpot): Boolean; + + property BandHeight: Integer read FBandH; + property CenterFreq: Double read FCenterFreq; // для GL-инвалидизации + property SpanHz: Double read FSpanHz; + property MaxRows: Integer read FMaxRows write SetMaxRows; + property Hidden: Integer read FHidden; + property CacheDirty: Boolean read FCacheDirty; + // Меняется ровно тогда, когда картинка полосы стала другой. GL-путь по нему + // решает, перезаливать ли текстуру: он не зависит от того, кто первым + // дёрнул пересборку в этом кадре (штрихи или композит). + property RenderVersion: Int64 read FRenderVer; + end; + +implementation + +const + KEY_COLOR = TColor($00FF00FF); // тот же ключ прозрачности, что у VfoOverlay + + // Палитра (TColor = $00BBGGRR). Своя пара на тему: на тёмном спектре чип + // тёмный со светлой подписью, на светлом — наоборот, иначе подписи спотов + // на светлой теме сливались бы в грязное пятно. + // тёмная тема светлая тема + CLR_CHIP_BG: array[Boolean] of TColor = ($00202018, $00F2F2EC); + CLR_CHIP_TEXT: array[Boolean] of TColor = ($00F0F0F0, $00181818); + CLR_FRESH: array[Boolean] of TColor = ($00E0C040, $00A05800); // свежий + CLR_STALE: array[Boolean] of TColor = ($00706850, $00B0A898); // на исходе TTL + CLR_OWN: array[Boolean] of TColor = ($0040D0FF, $000060C8); // свой позывной + + CHIP_PAD_X = 3; + CHIP_GAP = 3; // минимальный зазор между чипами в одном ряду + + // Подпись видимого набора (FNV-1a 64). Базис — канонический $CBF29CE4…, + // сложенный из половин: цельным литералом он не влезает в Int64, а + // сравниваем мы подпись только сама с собой, так что важна лишь стабильность. + FNV_BASIS_HI = QWord($CBF29CE4); + FNV_BASIS_LO = QWord($84222325); + FNV_PRIME: QWord = $00000100000001B3; + +function Mix(A, B: TColor; Num, Den: Integer): TColor; +// A→B на Num/Den (0 = A, Den = B). +var ra, ga, ba, rb, gb, bb: Integer; +begin + if Den <= 0 then Exit(A); + ra := A and $FF; ga := (A shr 8) and $FF; ba := (A shr 16) and $FF; + rb := B and $FF; gb := (B shr 8) and $FF; bb := (B shr 16) and $FF; + ra := ra + (rb - ra) * Num div Den; + ga := ga + (gb - ga) * Num div Den; + ba := ba + (bb - ba) * Num div Den; + Result := TColor((ba shl 16) or (ga shl 8) or ra); +end; + +{ ── Создание / параметры ─────────────────────────────────────────────────── } + +constructor TDXSpotOverlay.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FRowH := Round(DXSPOT_ROW_BASE_H * Screen.PixelsPerInch / 96); + if FRowH < DXSPOT_ROW_BASE_H then FRowH := DXSPOT_ROW_BASE_H; + FMaxRows := 4; + FBandH := FRowH * FMaxRows + 4; + FCenterFreq := 0; + FSpanHz := 0; + FEnabled := False; + FModes := []; + FMaxAgeMin := 0; + FCache := TBitmap.Create; + FCache.PixelFormat := pf32bit; + FCacheW := 0; + FCacheDirty := True; + FKeyCenter := -1; FKeySpan := -1; FKeyW := -1; FKeyVersion := -1; + FKeyEnabled := False; FKeyLight := False; FKeyRows := -1; FKeyAgeTick := -1; + FKeyStamp := 0; + FArrN := 0; + FArrStamp := 0; + FAgeTick := 0; + FRenderVer := 0; +end; + +destructor TDXSpotOverlay.Destroy; +begin + FCache.Free; + inherited Destroy; +end; + +procedure TDXSpotOverlay.Attach(AStore: TDXSpotStore); +begin + FStore := AStore; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetView(ACenterHz, ASpanHz: Double); +begin + if (Abs(ACenterHz - FCenterFreq) < 1.0) and (Abs(ASpanHz - FSpanHz) < 1.0) then Exit; + FCenterFreq := ACenterHz; + FSpanHz := ASpanHz; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetEnabled(En: Boolean); +begin + if FEnabled = En then Exit; + FEnabled := En; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetLightTheme(Light: Boolean); +begin + if FLightTheme = Light then Exit; + FLightTheme := Light; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetOwnCall(const ACall: string); +begin + if SameText(FOwnCall, ACall) then Exit; + FOwnCall := UpperCase(Trim(ACall)); + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetFilters(AModes: TDXModeSet; AMaxAgeMin: Integer); +begin + if (FModes = AModes) and (FMaxAgeMin = AMaxAgeMin) then Exit; + FModes := AModes; + FMaxAgeMin := AMaxAgeMin; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.SetMaxRows(V: Integer); +begin + V := EnsureRange(V, 1, DXSPOT_MAX_ROWS); + if V = FMaxRows then Exit; + FMaxRows := V; + FBandH := FRowH * FMaxRows + 4; + FCacheDirty := True; +end; + +procedure TDXSpotOverlay.TickAge; +begin + Inc(FAgeTick); +end; + +procedure TDXSpotOverlay.Invalidate; +begin + FCacheDirty := True; +end; + +function TDXSpotOverlay.Active: Boolean; +begin + Result := FEnabled and (FStore <> nil); +end; + +function TDXSpotOverlay.FreqToX(FreqHz: Double; W: Integer): Integer; +begin + if FSpanHz <= 0 then Result := -1 + else Result := Round((FreqHz - (FCenterFreq - FSpanHz / 2)) / FSpanHz * W); +end; + +function TDXSpotOverlay.AgeColor(const S: TDXSpot): TColor; +// Свежий → CLR_FRESH, к концу окна TTL плавно уходит в CLR_STALE. Свой +// позывной выделен цветом (и тоже гаснет — иначе старый спот кричал бы +// громче свежих). TTL берётся из FLayoutTTL: он посчитан один раз на +// раскладку, чтобы не дёргать лок стора на каждый спот. +var + AgeMin, K: Integer; + Base: TColor; +begin + Base := CLR_FRESH[FLightTheme]; + if (FOwnCall <> '') and SameText(S.Call, FOwnCall) then + Base := CLR_OWN[FLightTheme]; + if FLayoutTTL <= 0 then Exit(Base); + AgeMin := Round((Now - S.Stamp) * 24 * 60); + K := EnsureRange(AgeMin * 100 div Max(FLayoutTTL, 1), 0, 100); + Result := Mix(Base, CLR_STALE[FLightTheme], K, 100); +end; + +{ ── Раскладка лесенки ────────────────────────────────────────────────────── } + +procedure TDXSpotOverlay.TakeSnapshot; +// Снимок видимого окна + его подпись. Подпись складывает всё, от чего зависит +// картинка полосы: позывной, частоту, моду и метку времени (она правит цвет +// затухания и обновляется при пере-споте). Совпала с прошлой — пересобирать +// нечего, какой бы ни стала версия стора. +var + i, k: Integer; + H: QWord; + LoHz, HiHz: Double; +begin + FArrN := 0; + SetLength(FArr, 0); + FArrStamp := 0; + if (FStore = nil) or (FSpanHz <= 0) then Exit; + + // Горизонт затухания: явный фильтр по возрасту, иначе TTL стора (чтение + // под локом — поэтому один раз на снимок, а не на каждый спот). + FLayoutTTL := FMaxAgeMin; + if FLayoutTTL <= 0 then FLayoutTTL := FStore.TTLMinutes; + + LoHz := FCenterFreq - FSpanHz / 2; + HiHz := FCenterFreq + FSpanHz / 2; + FArrN := FStore.SnapshotRange(LoHz, HiHz, FModes, FMaxAgeMin, FArr); + + // Хэш живёт переполнением — проверки снимаем локально, чтобы сборка с + // {$Q+}/{$R+} (у нас их нет, но режимы правятся в .lpi) не падала на нём. + {$PUSH}{$Q-}{$R-} + H := (FNV_BASIS_HI shl 32) or FNV_BASIS_LO; // FNV-1a 64 + for i := 0 to FArrN - 1 do + begin + for k := 1 to Length(FArr[i].Call) do + H := (H xor QWord(Ord(FArr[i].Call[k]))) * FNV_PRIME; + H := (H xor QWord(Round(FArr[i].FreqHz))) * FNV_PRIME; + H := (H xor QWord(Round(FArr[i].Stamp * 86400))) * FNV_PRIME; + H := (H xor QWord(Ord(FArr[i].Mode))) * FNV_PRIME; + end; + FArrStamp := Int64(H); + {$POP} +end; + +procedure TDXSpotOverlay.Layout(C: TCanvas; W: Integer); +// Споты приходят из стора отсортированными по частоте; каждому даём ПЕРВЫЙ +// ряд сверху, где подпись не наезжает на предыдущую. Не нашлось ряда — +// спот скрыт (считаем в FHidden), в лесенке дырок не оставляем. Работаем по +// снимку FArr — его взял TakeSnapshot перед пересборкой. +var + N, i, r, TW, ChipW, ChipX, Row: Integer; + RowRight: array[0..DXSPOT_MAX_ROWS-1] of Integer; +begin + FItemCount := 0; + FHidden := 0; + if (FStore = nil) or (FSpanHz <= 0) or (W <= 0) then Exit; + N := FArrN; + if N = 0 then Exit; + + for r := 0 to FMaxRows - 1 do RowRight[r] := -CHIP_GAP - 1; + SetLength(FItems, N); + + for i := 0 to N - 1 do + begin + TW := C.TextWidth(FArr[i].Call); + ChipW := TW + CHIP_PAD_X * 2; + ChipX := FreqToX(FArr[i].FreqHz, W) - ChipW div 2; + if ChipX < 0 then ChipX := 0; + if ChipX + ChipW > W then ChipX := W - ChipW; + if ChipX < 0 then Continue; // подпись шире окна — не рисуем + + Row := -1; + for r := 0 to FMaxRows - 1 do + if ChipX > RowRight[r] + CHIP_GAP then + begin + Row := r; + Break; + end; + if Row < 0 then + begin + Inc(FHidden); + Continue; + end; + RowRight[Row] := ChipX + ChipW; + + FItems[FItemCount].X := FreqToX(FArr[i].FreqHz, W); + FItems[FItemCount].Chip := Rect(ChipX, Row * FRowH + 2, + ChipX + ChipW, Row * FRowH + FRowH); + FItems[FItemCount].Color := AgeColor(FArr[i]); + FItems[FItemCount].Spot := FArr[i]; + Inc(FItemCount); + end; + SetLength(FItems, FItemCount); +end; + +procedure TDXSpotOverlay.DrawSelf(C: TCanvas; W: Integer); +// Рендер полосы подписей в канвас W × FBandH. Фон — KEY_COLOR (прозрачный +// при композите и в GL-текстуре). +var + i: Integer; + R: TRect; + Col: TColor; +begin + C.Brush.Color := KEY_COLOR; + C.Brush.Style := bsSolid; + C.Pen.Style := psClear; + C.FillRect(Rect(0, 0, W, FBandH)); + + // Гарнитуру НЕ задаём — системная, как договорено по проекту: позывные тут + // не в колонках, ширина чипа и так меряется по TextWidth. Задан только + // размер, привязанный к высоте ряда (а не к point-size), — подпись влезает + // при любом DPI-масштабе, как в бэндплане. + C.Font.Style := [fsBold]; + C.Font.Height := -Max(8, Round(FRowH * 0.62)); + + Layout(C, W); + + for i := 0 to FItemCount - 1 do + begin + R := FItems[i].Chip; + Col := FItems[i].Color; + + // Штрих от низа чипа до низа полосы (дальше его продолжает вызывающая + // сторона по TickCount/Tick — уже прямо в кадре). + if (FItems[i].X >= 0) and (FItems[i].X < W) then + begin + C.Pen.Style := psSolid; C.Pen.Color := Col; C.Pen.Width := 1; + C.MoveTo(FItems[i].X, R.Bottom); + C.LineTo(FItems[i].X, FBandH); + end; + + // Чип: тёмная подложка + кромка цветом спота + позывной. + C.Brush.Color := CLR_CHIP_BG[FLightTheme]; C.Brush.Style := bsSolid; + C.Pen.Style := psSolid; C.Pen.Color := Col; C.Pen.Width := 1; + C.Rectangle(R.Left, R.Top, R.Right, R.Bottom); + + C.Brush.Style := bsClear; + C.Font.Color := CLR_CHIP_TEXT[FLightTheme]; + C.TextOut(R.Left + CHIP_PAD_X, + R.Top + (R.Bottom - R.Top - C.TextHeight('W')) div 2, + FItems[i].Spot.Call); + end; + C.Pen.Style := psSolid; +end; + +{ ── Кэш ──────────────────────────────────────────────────────────────────── } + +function TDXSpotOverlay.ViewKeysChanged(W: Integer): Boolean; +// Всё, что делает картинку заведомо другой, КРОМЕ версии стора: её разбирает +// EnsureRendered отдельно (версия глобальна, окно — наше). +var HalfPxHz: Double; +begin + if FStore = nil then Exit(False); + // Порог по центру/спану — полпикселя (как в бэндплане): суб-пиксельный + // дрейф центра при QO-100 decoder-lock не должен гонять полную пересборку. + HalfPxHz := 0.5 * FSpanHz / Max(W, 1); + if HalfPxHz < 1.0 then HalfPxHz := 1.0; + Result := FCacheDirty or (FCacheW <> W) or (FKeyW <> W) + or (FKeyEnabled <> FEnabled) + or (FKeyLight <> FLightTheme) + or (FKeyRows <> FMaxRows) + or (FKeyAgeTick <> FAgeTick) + or (Abs(FKeyCenter - FCenterFreq) >= HalfPxHz) + or (Abs(FKeySpan - FSpanHz) >= HalfPxHz); +end; + +procedure TDXSpotOverlay.RebuildCache(W: Integer; Ver: Int64); +// Снимок (TakeSnapshot) к этому моменту уже взят вызывающим — здесь только +// рисование и запись ключей. +begin + if (W <= 0) or (FStore = nil) then + begin + FCacheW := 0; FCacheDirty := False; FItemCount := 0; + Inc(FRenderVer); + Exit; + end; + if (FCache.Width <> W) or (FCache.Height <> FBandH) then + FCache.SetSize(W, FBandH); + DrawSelf(FCache.Canvas, W); + Inc(FRenderVer); + FCacheW := W; + FKeyCenter := FCenterFreq; + FKeySpan := FSpanHz; + FKeyW := W; + FKeyEnabled := FEnabled; + FKeyVersion := Ver; + FKeyStamp := FArrStamp; + FKeyLight := FLightTheme; + FKeyRows := FMaxRows; + FKeyAgeTick := FAgeTick; + FCacheDirty := False; +end; + +{ ── Рисование ────────────────────────────────────────────────────────────── } + +procedure TDXSpotOverlay.EnsureRendered(W: Integer); +var Ver: Int64; +begin + if (not Active) or (W <= 0) then Exit; + Ver := FStore.Version; + if ViewKeysChanged(W) then + begin + TakeSnapshot; + RebuildCache(W, Ver); + Exit; + end; + if FKeyVersion = Ver then Exit; // в сторе с прошлого кадра ничего + // Стор правили — но, может, не в нашем окне: снимок с подписью дешевле + // пересборки полосы (и, в GL, перезаливки текстуры). Версию запоминаем в + // любом случае: этот вопрос уже разобран. + FKeyVersion := Ver; + TakeSnapshot; + if FArrStamp = FKeyStamp then Exit; + RebuildCache(W, Ver); +end; + +procedure TDXSpotOverlay.DrawOverlay(Target: TBitmap; W, H: Integer); +begin + if (not Active) or (Target = nil) or (W <= 0) or (H <= FBandH) then Exit; + EnsureRendered(W); + if FCacheW <= 0 then Exit; + BlendBitmapKey(Target, FCache, 0, 0, DXSPOT_ALPHA); +end; + +procedure TDXSpotOverlay.DrawOverlayBitmap(Target: TBitmap; W: Integer); +begin + if (Target = nil) or (W <= 0) then Exit; + // Раскладка/список штрихов должны быть свежими и в GL-пути. + EnsureRendered(W); + Target.PixelFormat := pf32bit; + Target.SetSize(W, FBandH); + Target.Canvas.Draw(0, 0, FCache); +end; + +function TDXSpotOverlay.TickCount: Integer; +begin + if not Active then Result := 0 else Result := FItemCount; +end; + +procedure TDXSpotOverlay.Tick(Idx: Integer; out X: Integer; out Color: TColor); +begin + if (Idx < 0) or (Idx >= FItemCount) then + begin + X := -1; Color := clNone; + Exit; + end; + X := FItems[Idx].X; + Color := FItems[Idx].Color; +end; + +function TDXSpotOverlay.SpotAtPixel(X, Y: Integer; out Spot: TDXSpot): Boolean; +// Хит только по полосе подписей: ниже неё живут тюнинг/маркеры/слайсы, и +// перехватывать там клик было бы поперёк привычного поведения спектра. +var i: Integer; +begin + Result := False; + if (not Active) or (Y < 0) or (Y > FBandH) then Exit; + for i := 0 to FItemCount - 1 do + if (X >= FItems[i].Chip.Left - 2) and (X <= FItems[i].Chip.Right + 2) and + (Y >= FItems[i].Chip.Top - 2) and (Y <= FItems[i].Chip.Bottom + 2) then + begin + Spot := FItems[i].Spot; + Exit(True); + end; +end; + +end. diff --git a/DXSpotStore.pas b/DXSpotStore.pas new file mode 100644 index 0000000..18577ca --- /dev/null +++ b/DXSpotStore.pas @@ -0,0 +1,509 @@ +unit DXSpotStore; + +{ + DXSpotStore.pas — потокобезопасное хранилище DX-спотов. + + Единственная точка обмена между сетевым потоком кластера (TDXClusterClient, + пишет) и UI (оверлей спектра + окно списка, читают). Поэтому здесь НЕТ ни + Synchronize, ни очередей в главный поток: поток кластера кладёт спот прямо + сюда под критической секцией, а UI замечает изменение по монотонному + счётчику Version — ровно так же, как оверлеи замечают смену вида по своим + ключам кэша. Никаких LCL-зависимостей (юнит компилируется и в headless). + + Дедуп: спот с тем же позывным в пределах DEDUP_HZ считается тем же самым — + обновляем частоту/время/комментарий, а не плодим строки. Тот же позывной на + другом диапазоне — отдельная запись. + + TTL: споты старше FTTLMinutes выбрасываются при каждой правке/снимке. +} + +{$IFDEF FPC} + {$MODE Delphi} + {$LONGSTRINGS ON} +{$ENDIF} + +interface + +uses + SysUtils, Classes, SyncObjs, DateUtils, StrUtils; // StrUtils — PosEx + +const + DX_DEDUP_HZ = 5000.0; // тот же позывной в этом окне = тот же спот + DX_DEFAULT_TTL = 30; // мин + DX_DEFAULT_MAX = 500; // потолок записей + +type + // Мода спота. Определяется по комментарию кластера (FT8/CW/…), при неудаче — + // остаётся dxmUnknown: гадать по частоте не пытаемся, бэндпланы разные. + TDXMode = (dxmUnknown, dxmCW, dxmSSB, dxmDigi, dxmFT8, dxmFT4, dxmRTTY, + dxmPSK, dxmFM, dxmSSTV); + + TDXModeSet = set of TDXMode; + + TDXSpot = record + FreqHz: Double; // частота DX-станции, Гц (кластер отдаёт кГц) + Call: string; // позывной DX + Spotter: string; // кто заспотил + Comment: string; // комментарий кластера (уже без времени) + TimeUTC: string; // 'HHMM' как пришло от кластера + Stamp: TDateTime; // локальное время приёма — для TTL и затухания + Mode: TDXMode; + ModeGuessed: Boolean; // мода не из комментария, а из бэндплана (см. ниже) + end; + + TDXSpotArray = array of TDXSpot; + + TDXSpotStore = class + private + FLock: TCriticalSection; + FSpots: TDXSpotArray; + FCount: Integer; + FVersion: Int64; + FTTLMinutes: Integer; + FMaxSpots: Integer; + procedure PurgeLocked; + procedure DropOldestLocked; + function GetTTLMinutes: Integer; + procedure SetTTLMinutes(V: Integer); + function GetMaxSpots: Integer; + procedure SetMaxSpots(V: Integer); + public + constructor Create; + destructor Destroy; override; + + // Добавить/обновить спот (вызывается из потока кластера). + procedure Add(const S: TDXSpot); + procedure Clear; + // Выбросить просроченное прямо сейчас. Нужен тому, кто следит за временем + // снаружи: сам стор чистится только на Add и снимках, а когда споты никто + // не берёт и не приходит новых, устаревать им иначе негде. + procedure Purge; + + // Снимок всех спотов, отсортированный по частоте. + function Snapshot(out Arr: TDXSpotArray): Integer; + // Снимок окна [LoHz..HiHz] с фильтром по моде (Modes = [] — без фильтра) + // и по возрасту (MaxAgeMin <= 0 — только общий TTL). Для оверлея. + function SnapshotRange(LoHz, HiHz: Double; Modes: TDXModeSet; + MaxAgeMin: Integer; out Arr: TDXSpotArray): Integer; + + // Монотонный счётчик правок — ключ инвалидации кэша оверлея/списка. + function Version: Int64; + function Count: Integer; + + // Читаются сетевым потоком (PurgeLocked/Add), пишутся из UI — только через + // критическую секцию, как и всё остальное состояние стора. + property TTLMinutes: Integer read GetTTLMinutes write SetTTLMinutes; + property MaxSpots: Integer read GetMaxSpots write SetMaxSpots; + end; + +// Мода по комментарию кластера ('FT8 -12 dB' → dxmFT8). Пусто/непонятно — +// dxmUnknown. +function DXModeFromComment(const Comment: string): TDXMode; +// Мода по участку бэндплана — запасной путь, когда комментарий молчит (в CW и +// SSB его сплошь и рядом просто не пишут). dxmUnknown = участок спорный или +// вне таблицы; см. DX_BAND_PLAN о том, где мы намеренно не гадаем. +function DXModeFromFreq(FreqHz: Double): TDXMode; +function DXModeName(M: TDXMode): string; + +implementation + +const + MODE_NAMES: array[TDXMode] of string = + ('', 'CW', 'SSB', 'DIGI', 'FT8', 'FT4', 'RTTY', 'PSK', 'FM', 'SSTV'); + +function DXModeName(M: TDXMode): string; +begin + Result := MODE_NAMES[M]; +end; + +function DXModeFromComment(const Comment: string): TDXMode; +// Ищем маркер моды как ОТДЕЛЬНОЕ слово: 'CW' внутри 'CWOPS' или позывного +// модой не является. Порядок проверки — от длинных/специфичных к общим. +var + U: string; + + function HasWord(const W: string): Boolean; + var P, L, N: Integer; OkL, OkR: Boolean; + begin + Result := False; + L := Length(W); N := Length(U); + P := Pos(W, U); + while P > 0 do + begin + OkL := (P = 1) or not (U[P-1] in ['A'..'Z', '0'..'9', '/', '-']); + OkR := (P + L > N) or not (U[P+L] in ['A'..'Z', '0'..'9', '/', '-']); + if OkL and OkR then Exit(True); + P := PosEx(W, U, P + 1); + end; + end; + +begin + Result := dxmUnknown; + if Comment = '' then Exit; + U := UpperCase(Comment); + if HasWord('FT8') then Result := dxmFT8 + else if HasWord('FT4') then Result := dxmFT4 + else if HasWord('RTTY') then Result := dxmRTTY + else if HasWord('PSK') or HasWord('PSK31') or HasWord('BPSK') then Result := dxmPSK + else if HasWord('SSTV') then Result := dxmSSTV + else if HasWord('CW') then Result := dxmCW + else if HasWord('SSB') or HasWord('USB') or HasWord('LSB') then Result := dxmSSB + else if HasWord('FM') then Result := dxmFM + else if HasWord('JT65') or HasWord('JT9') or HasWord('JS8') or + HasWord('MSK144') or HasWord('OLIVIA') or HasWord('DIGI') then + Result := dxmDigi; +end; + +{ ── Мода по бэндплану ────────────────────────────────────────────────────── } + +type + TDXBandSeg = record + LoKHz, HiKHz: Double; // [Lo; Hi) + Mode: TDXMode; + end; + +const + // Участки бэндплана для запасного определения моды. Читается СВЕРХУ ВНИЗ, + // первое попадание выигрывает — поэтому узкие «водопои» цифры стоят раньше + // широких сегментов, внутрь которых они попадают (FT8 на 7074 живёт посреди + // телефонного участка R1, FT4 на 21140 — посреди 15-метрового). + // + // ★ Границы — по плану IARU Region 1 (наш регион): у R2/R3 они другие, и + // спорные куски мы НАМЕРЕННО оставляем пустыми, а не гадаем — пропуск честнее + // ошибки. Отсюда дырки: 1843-1850 (R1 SSB против R2 CW), 7053-7125 у R2 — + // данные, а не телефон, и т.п. Мода из комментария всегда важнее этой + // таблицы, сюда попадают только споты, где комментарий промолчал. + DX_BAND_PLAN: array[0..47] of TDXBandSeg = ( + // ── узкие окна FT8/FT4 (перекрывают широкие сегменты ниже) ── + (LoKHz: 1840.0; HiKHz: 1843.0; Mode: dxmFT8), + (LoKHz: 3573.0; HiKHz: 3576.0; Mode: dxmFT8), + (LoKHz: 7047.0; HiKHz: 7049.0; Mode: dxmFT4), + (LoKHz: 7074.0; HiKHz: 7078.0; Mode: dxmFT8), + (LoKHz: 10136.0; HiKHz: 10139.0; Mode: dxmFT8), + (LoKHz: 10140.0; HiKHz: 10142.0; Mode: dxmFT4), + (LoKHz: 14074.0; HiKHz: 14078.0; Mode: dxmFT8), + (LoKHz: 14080.0; HiKHz: 14082.0; Mode: dxmFT4), + (LoKHz: 18100.0; HiKHz: 18102.0; Mode: dxmFT8), + (LoKHz: 18104.0; HiKHz: 18106.0; Mode: dxmFT4), + (LoKHz: 21074.0; HiKHz: 21078.0; Mode: dxmFT8), + (LoKHz: 21140.0; HiKHz: 21142.0; Mode: dxmFT4), + (LoKHz: 24915.0; HiKHz: 24917.0; Mode: dxmFT8), + (LoKHz: 24919.0; HiKHz: 24921.0; Mode: dxmFT4), + (LoKHz: 28074.0; HiKHz: 28078.0; Mode: dxmFT8), + (LoKHz: 28180.0; HiKHz: 28182.0; Mode: dxmFT4), + (LoKHz: 50313.0; HiKHz: 50323.0; Mode: dxmFT8), + (LoKHz: 144174.0; HiKHz: 144180.0; Mode: dxmFT8), + (LoKHz: 432174.0; HiKHz: 432180.0; Mode: dxmFT8), + + // ── КВ, широкие сегменты ── + (LoKHz: 1800.0; HiKHz: 1838.0; Mode: dxmCW), + (LoKHz: 1838.0; HiKHz: 1843.0; Mode: dxmDigi), + (LoKHz: 1850.0; HiKHz: 2000.0; Mode: dxmSSB), + + (LoKHz: 3500.0; HiKHz: 3570.0; Mode: dxmCW), + (LoKHz: 3570.0; HiKHz: 3600.0; Mode: dxmDigi), + (LoKHz: 3600.0; HiKHz: 4000.0; Mode: dxmSSB), + + (LoKHz: 7000.0; HiKHz: 7040.0; Mode: dxmCW), + (LoKHz: 7040.0; HiKHz: 7053.0; Mode: dxmDigi), + (LoKHz: 7053.0; HiKHz: 7300.0; Mode: dxmSSB), + + (LoKHz: 10100.0; HiKHz: 10130.0; Mode: dxmCW), + (LoKHz: 10130.0; HiKHz: 10150.0; Mode: dxmDigi), + + (LoKHz: 14000.0; HiKHz: 14070.0; Mode: dxmCW), + (LoKHz: 14070.0; HiKHz: 14099.0; Mode: dxmDigi), + (LoKHz: 14101.0; HiKHz: 14350.0; Mode: dxmSSB), + + (LoKHz: 18068.0; HiKHz: 18095.0; Mode: dxmCW), + (LoKHz: 18095.0; HiKHz: 18109.0; Mode: dxmDigi), + (LoKHz: 18111.0; HiKHz: 18168.0; Mode: dxmSSB), + + (LoKHz: 21000.0; HiKHz: 21070.0; Mode: dxmCW), + (LoKHz: 21070.0; HiKHz: 21120.0; Mode: dxmDigi), + (LoKHz: 21151.0; HiKHz: 21450.0; Mode: dxmSSB), + + (LoKHz: 24890.0; HiKHz: 24915.0; Mode: dxmCW), + (LoKHz: 24915.0; HiKHz: 24929.0; Mode: dxmDigi), + (LoKHz: 24931.0; HiKHz: 24990.0; Mode: dxmSSB), + + (LoKHz: 28000.0; HiKHz: 28070.0; Mode: dxmCW), + (LoKHz: 28070.0; HiKHz: 28190.0; Mode: dxmDigi), + (LoKHz: 28300.0; HiKHz: 29100.0; Mode: dxmSSB), + (LoKHz: 29100.0; HiKHz: 29700.0; Mode: dxmFM), + + // ── УКВ (минимум, где регионы согласны) ── + (LoKHz: 50000.0; HiKHz: 50100.0; Mode: dxmCW), + (LoKHz: 50100.0; HiKHz: 50500.0; Mode: dxmSSB)); + +function DXModeFromFreq(FreqHz: Double): TDXMode; +var + K: Double; + i: Integer; +begin + Result := dxmUnknown; + if FreqHz <= 0 then Exit; + + // QO-100 (узкополосный транспондер, DOWNLINK). Отдельно от КВ-таблицы: план + // AMSAT-DL, границы те же, что рисует BandPlanOverlay. Маяки (…500-505 и + // …745-755) и «mixed modes» (…850-990) — не гадаем. + K := FreqHz / 1000.0; + if (K >= 10489500.0) and (K < 10490000.0) then + begin + if (K >= 10489505.0) and (K < 10489540.0) then Result := dxmCW + else if (K >= 10489540.0) and (K < 10489650.0) then Result := dxmDigi + else if (K >= 10489650.0) and (K < 10489745.0) then Result := dxmSSB + else if (K >= 10489755.0) and (K < 10489850.0) then Result := dxmSSB; + Exit; + end; + + for i := Low(DX_BAND_PLAN) to High(DX_BAND_PLAN) do + if (K >= DX_BAND_PLAN[i].LoKHz) and (K < DX_BAND_PLAN[i].HiKHz) then + Exit(DX_BAND_PLAN[i].Mode); +end; + +{ ── TDXSpotStore ─────────────────────────────────────────────────────────── } + +constructor TDXSpotStore.Create; +begin + inherited Create; + FLock := TCriticalSection.Create; + FCount := 0; + FVersion := 0; + FTTLMinutes := DX_DEFAULT_TTL; + FMaxSpots := DX_DEFAULT_MAX; + SetLength(FSpots, DX_DEFAULT_MAX); +end; + +destructor TDXSpotStore.Destroy; +begin + FLock.Free; + inherited Destroy; +end; + +procedure TDXSpotStore.PurgeLocked; +// Выбрасывает споты старше TTL, уплотняя массив на месте. +var + i, Dst: Integer; + Cutoff: TDateTime; +begin + if FTTLMinutes <= 0 then Exit; + Cutoff := IncMinute(Now, -FTTLMinutes); + Dst := 0; + for i := 0 to FCount - 1 do + if FSpots[i].Stamp >= Cutoff then + begin + if Dst <> i then FSpots[Dst] := FSpots[i]; + Inc(Dst); + end; + if Dst <> FCount then + begin + FCount := Dst; + Inc(FVersion); + end; +end; + +procedure TDXSpotStore.DropOldestLocked; +var i, Oldest: Integer; +begin + if FCount <= 0 then Exit; + Oldest := 0; + for i := 1 to FCount - 1 do + if FSpots[i].Stamp < FSpots[Oldest].Stamp then Oldest := i; + for i := Oldest to FCount - 2 do FSpots[i] := FSpots[i + 1]; + Dec(FCount); +end; + +procedure TDXSpotStore.Add(const S: TDXSpot); +var + i: Integer; + UCall: string; +begin + if S.Call = '' then Exit; + FLock.Enter; + try + PurgeLocked; + UCall := UpperCase(S.Call); + for i := 0 to FCount - 1 do + if (UpperCase(FSpots[i].Call) = UCall) and + (Abs(FSpots[i].FreqHz - S.FreqHz) <= DX_DEDUP_HZ) then + begin + FSpots[i] := S; // тот же спот — обновляем целиком + Inc(FVersion); + Exit; + end; + if Length(FSpots) < FMaxSpots then SetLength(FSpots, FMaxSpots); + while FCount >= FMaxSpots do DropOldestLocked; + FSpots[FCount] := S; + Inc(FCount); + Inc(FVersion); + finally + FLock.Leave; + end; +end; + +procedure TDXSpotStore.Purge; +begin + FLock.Enter; + try + PurgeLocked; // сам поднимет Version, если что-то выбросил + finally + FLock.Leave; + end; +end; + +procedure TDXSpotStore.Clear; +begin + FLock.Enter; + try + if FCount = 0 then Exit; + FCount := 0; + Inc(FVersion); + finally + FLock.Leave; + end; +end; + +function CompareSpotFreq(const A, B: TDXSpot): Integer; +begin + if A.FreqHz < B.FreqHz then Result := -1 + else if A.FreqHz > B.FreqHz then Result := 1 + else Result := 0; +end; + +procedure SortByFreq(var Arr: TDXSpotArray; N: Integer); +// Вставками: N здесь десятки-сотни и массив почти всегда уже почти +// отсортирован (споты приходят вперемешку, но окно узкое). +var i, j: Integer; T: TDXSpot; +begin + for i := 1 to N - 1 do + begin + T := Arr[i]; + j := i - 1; + while (j >= 0) and (CompareSpotFreq(Arr[j], T) > 0) do + begin + Arr[j + 1] := Arr[j]; + Dec(j); + end; + Arr[j + 1] := T; + end; +end; + +function TDXSpotStore.Snapshot(out Arr: TDXSpotArray): Integer; +var i: Integer; +begin + FLock.Enter; + try + PurgeLocked; + SetLength(Arr, FCount); + for i := 0 to FCount - 1 do Arr[i] := FSpots[i]; + Result := FCount; + finally + FLock.Leave; + end; + SortByFreq(Arr, Result); +end; + +function TDXSpotStore.SnapshotRange(LoHz, HiHz: Double; Modes: TDXModeSet; + MaxAgeMin: Integer; out Arr: TDXSpotArray): Integer; +var + i, N: Integer; + Cutoff: TDateTime; + UseAge: Boolean; +begin + N := 0; + UseAge := MaxAgeMin > 0; + Cutoff := 0; + if UseAge then Cutoff := IncMinute(Now, -MaxAgeMin); + FLock.Enter; + try + PurgeLocked; + SetLength(Arr, FCount); + for i := 0 to FCount - 1 do + begin + if (FSpots[i].FreqHz < LoHz) or (FSpots[i].FreqHz > HiHz) then Continue; + if (Modes <> []) and not (FSpots[i].Mode in Modes) then Continue; + if UseAge and (FSpots[i].Stamp < Cutoff) then Continue; + Arr[N] := FSpots[i]; + Inc(N); + end; + SetLength(Arr, N); + Result := N; + finally + FLock.Leave; + end; + SortByFreq(Arr, Result); +end; + +function TDXSpotStore.GetTTLMinutes: Integer; +begin + FLock.Enter; + try + Result := FTTLMinutes; + finally + FLock.Leave; + end; +end; + +procedure TDXSpotStore.SetTTLMinutes(V: Integer); +begin + if V < 1 then V := 1; + FLock.Enter; + try + if FTTLMinutes = V then Exit; + FTTLMinutes := V; + PurgeLocked; // укоротили TTL — лишнее выбрасываем сразу + finally + FLock.Leave; + end; +end; + +function TDXSpotStore.GetMaxSpots: Integer; +begin + FLock.Enter; + try + Result := FMaxSpots; + finally + FLock.Leave; + end; +end; + +procedure TDXSpotStore.SetMaxSpots(V: Integer); +begin + if V < 16 then V := 16; + FLock.Enter; + try + if FMaxSpots = V then Exit; + FMaxSpots := V; + if Length(FSpots) < FMaxSpots then SetLength(FSpots, FMaxSpots); + while FCount > FMaxSpots do + begin + DropOldestLocked; + Inc(FVersion); + end; + finally + FLock.Leave; + end; +end; + +function TDXSpotStore.Version: Int64; +begin + FLock.Enter; + try + Result := FVersion; + finally + FLock.Leave; + end; +end; + +function TDXSpotStore.Count: Integer; +begin + FLock.Enter; + try + Result := FCount; + finally + FLock.Leave; + end; +end; + +end. diff --git a/FlatListBox.pas b/FlatListBox.pas index 3a90086..ffa9569 100644 --- a/FlatListBox.pas +++ b/FlatListBox.pas @@ -69,6 +69,10 @@ type property Visible; property OnClick; property OnDblClick; + // Клавиатура: собственный KeyDown обрабатывает стрелки/PgUp/Home, а + // необработанные клавиши (Enter и прочее) достаются владельцу через + // inherited — поэтому событие имеет смысл публиковать. + property OnKeyDown; end; implementation diff --git a/FlatMemo.pas b/FlatMemo.pas index b91b2b6..9cf60b9 100644 --- a/FlatMemo.pas +++ b/FlatMemo.pas @@ -23,6 +23,7 @@ type FScrollBar: TOverlayScrollBar; FTheme: TAppTheme; FSyncing: Boolean; + FOnChange: TNotifyEvent; function GetLines: TStrings; function GetReadOnly: Boolean; procedure SetReadOnly(AValue: Boolean); @@ -65,6 +66,8 @@ type property TabOrder; property TabStop; property Visible; + // Правка текста пользователем (проброс OnChange внутреннего TMemo). + property OnChange: TNotifyEvent read FOnChange write FOnChange; end; implementation @@ -192,6 +195,7 @@ end; procedure TFlatMemo.MemoChange(Sender: TObject); begin UpdateScrollBar; + if Assigned(FOnChange) then FOnChange(Self); end; procedure TFlatMemo.MemoKeyUp(Sender: TObject; var Key: Word; diff --git a/MainForm.pas b/MainForm.pas index 59b7512..9857dc4 100644 --- a/MainForm.pas +++ b/MainForm.pas @@ -22,8 +22,9 @@ unit MainForm; interface uses - Classes, SysUtils, StrUtils, FreqDisplay, DeviceForm, FilterPopup, + Classes, SysUtils, StrUtils, DateUtils, FreqDisplay, DeviceForm, FilterPopup, VfoOverlay, SampleRateOverlay, BandPlanOverlay, + DXSpotStore, DXClusterClient, DXSpotOverlay, DXClusterForm, FlatButton, FlatSlider, FlatDropDown, OverlayScrollBar, AppTheme, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, Buttons, Menus, Math, Types, SyncObjs, @@ -139,7 +140,18 @@ type FSliceDrag: Boolean; // тащим маркер несущей слайса по спектру FSliceDragId: Integer; // какой слайс тащим FSampleRateOverlay: TSampleRateOverlay; // оверлей span/hide слева вверху спектра - FBandPlanOverlay: TBandPlanOverlay; // полоска бэндплана QO-100 внизу спектра + FBandPlanOverlay: TBandPlanOverlay; // полоска бэндплана QO-100 + // ── DX-кластер ──────────────────────────────────────────────────────── + FDXStore: TDXSpotStore; // общая база спотов (поток кластера пишет) + FDXClient: TDXClusterClient; // telnet-соединение (свой поток) + FDXSpotOverlay: TDXSpotOverlay; // подписи спотов на спектре + FDXClusterForm: TDXClusterForm; // окно списка (ПКМ по кнопке DX) + FDXCfg: TDXClusterSettings; + FDXConnCfg: TDXClusterSettings; // параметры, с которыми поднят клиент + FDXPendingCfg: TDXClusterSettings; // правки SETUP, ждущие тишины + FDXPending: Boolean; + FDXPendingAt: TDateTime; + FDXAgeTickAt: TDateTime; // когда последний раз гасили старые споты внизу спектра FPanelHidden: Boolean; // True = левая панель скрыта FLeftPanelW: Integer; // ширина панели до скрытия (DPI-safe restore) FPendingBoardType: Integer; // BoardType устройства для подключения @@ -360,6 +372,8 @@ type LblAtt: TLabel; LblAttVal: TLabel; TrkAtt: TFlatSlider; + // Ряд CTUN | DX | Channel | BEACON. + BtnDXCluster: TFlatButton; // ЛКМ — споты на спектре, ПКМ — окно кластера BtnChannels: TFlatButton; FChannelsDropDown: TFlatDropDown; // TX-профиль: кнопка с именем активного (блок TX, ряд DUP) + список. @@ -497,6 +511,22 @@ type procedure BtnRxMuteClick(Sender: TObject); procedure UpdateRxMuteButton; // видимость (Pluto+full-duplex) + стиль кнопки RX MUTE procedure UpdateBandPlanOverlay; // вкл/выкл полоски бэндплана QO-100 по InQO100 + // ── DX-кластер ──────────────────────────────────────────────────────── + procedure InitDXCluster; // стор+клиент+оверлей, чтение настроек + procedure ServiceDXCluster; // тик затухания спотов (редкий) + procedure ApplyDXClusterSettings(const D: TDXClusterSettings); + procedure AttachPanDXSpots(P: TPanafallPanel); // свой оверлей спотов на пан + procedure ApplyDXOverlayCfg(O: TDXSpotOverlay); // настройки вида → один оверлей + procedure DXTuneSpotOnPan(P: TPanafallPanel; FreqHz: Double; Mode: TDXMode); + procedure UpdateDXClusterButton; + procedure BtnDXClusterClick(Sender: TObject); + procedure BtnDXClusterMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure ShowDXClusterForm; + procedure ApplyDXConnection(const D: TDXClusterSettings); + procedure OnDXClusterSettingsChange(const D: TDXClusterSettings); + procedure CommitDXClusterSettings; + procedure OnDXTuneSpot(FreqHz: Double; Mode: TDXMode); procedure BtnTUNClick(Sender: TObject); procedure ApplyTUN(Active: Boolean); // PureSignal: ЛКМ по PS = вкл/выкл, ПКМ = поповер настроек. @@ -1357,9 +1387,14 @@ begin end; procedure TMainForm.FormDestroy(Sender: TObject); +var i: Integer; begin FMeterTimer.Enabled := False; FSpectrumTimer.Enabled := False; + // Поток кластера будим ПЕРВЫМ делом, не дожидаясь его: пока идёт (небыстрая) + // разборка радио, он успевает выйти сам, и join в FreeAndNil(FDXClient) ниже + // уже никого не ждёт. Иначе окно висело бы на выходе. + if FDXClient <> nil then FDXClient.RequestStop; // Грациозный стоп радио (Run=0) до освобождения; сами движки закрывает и // освобождает TRadioController.Destroy (FreeEngines) ниже. if FController.FNetwork.Running then @@ -1373,6 +1408,22 @@ begin PanelSplitter := nil; PbWaterfall := nil; PbPanZoom := nil; + // DX-кластер: незакоммиченную правку SETUP дописываем в конфиг (соединение + // при этом не трогаем — программа закрывается), гасим сетевой поток (его + // Stop делает shutdown сокета и ждёт поток), потом базу спотов. Оверлеи + // панов живут до гибели своих панов (ниже) и на общую базу ссылаются — + // поэтому сначала отвязываем их: после Detach оверлей неактивен и к стору + // не ходит, даже если между этими строками прилетит перерисовка. + if FDXPending then + begin + FDXPending := False; + FController.FSettings.SaveDXClusterSettings(FDXPendingCfg); + end; + for i := 0 to MAX_PANS - 1 do + if FPans[i] <> nil then FPans[i].DetachDXSpots; + FDXSpotOverlay := nil; + FreeAndNil(FDXClient); + FreeAndNil(FDXStore); DestroyAllExtraPans; // доп. паны (DDC/движок/панели) — до пана 0 FreeAndNil(FPan); FPans[0] := nil; @@ -1976,6 +2027,8 @@ begin BtnDiscover := MakeBtn(PanelToolbar, 'DISCOVER', X, 3, 80, BTN_H, BtnDiscoverClick); BtnStartStop := MakeBtn(PanelToolbar, 'START', X+84, 3, 76, BTN_H, BtnStartStopClick); BtnSettings := MakeBtn(PanelToolbar, 'SETUP', X+164, 3, 66, BTN_H, BtnSettingsClick); + // DX живёт в блоке RX левой панели, рядом с CTUN (см. ниже): споты — часть + // приёмного вида, а не глобальная команда уровня DISCOVER/START/SETUP. // DISCOVER — синеватый акцент BtnDiscover.ClrNorm := TColor($00101828); @@ -2231,7 +2284,7 @@ begin Inc(Y, 100); - // RX block: CTUN + VOL + NR/NB/SNB/ANF/MUTE + // RX block: CTUN + DX + Channel + BEACON, VOL, NR/NB/SNB/ANF/MUTE PanelRXBlock := TPanel.Create(Self); PanelRXBlock.Parent := PanelLeft; PanelRXBlock.SetBounds(0, Y, LEFT_W, RX_BLOCK_H_ATT); @@ -2239,15 +2292,23 @@ begin MakeLbl(PanelRXBlock, 'RX', 4, 2); BtnCTun := MakeBtn(PanelRXBlock, 'CTUN', - LeftPanelButtonLeft(LEFT_W, 3, 0), 20, - LeftPanelButtonWidth(LEFT_W, 3, 0), + LeftPanelButtonLeft(LEFT_W, 4, 0), 20, + LeftPanelButtonWidth(LEFT_W, 4, 0), BTN_H, BtnCTunClick); BtnCTun.Tag := 0; StyleButton(BtnCTun, FController.FCTun); + // DX — споты кластера: ЛКМ включает/выключает подписи на спектре, ПКМ + // открывает окно списка (та же семантика, что у BEACON → окно констелляции). + BtnDXCluster := MakeBtn(PanelRXBlock, 'DX', + LeftPanelButtonLeft(LEFT_W, 4, 1), 20, + LeftPanelButtonWidth(LEFT_W, 4, 1), + BTN_H, BtnDXClusterClick); + BtnDXCluster.OnMouseDown := BtnDXClusterMouseDown; + BtnChannels := MakeBtn(PanelRXBlock, 'Channel', - LeftPanelButtonLeft(LEFT_W, 3, 1), 20, - LeftPanelButtonWidth(LEFT_W, 3, 1), + LeftPanelButtonLeft(LEFT_W, 4, 2), 20, + LeftPanelButtonWidth(LEFT_W, 4, 2), BTN_H, BtnChannelsClick); BtnChannels.OnMouseDown := BtnChannelsMouseDown; StyleButton(BtnChannels, False); @@ -2257,11 +2318,11 @@ begin FChannelsDropDown.OnSelect := OnChannelsDropDownSelect; RefreshChannelsDropDown; - // QO-100 beacon lock — 3-я колонка ряда. Видима только в XVTR-режиме + // QO-100 beacon lock — 4-я колонка ряда. Видима только в XVTR-режиме // (см. рендер rfXvtr ниже). Подпись/подсветка обновляются по rfBeaconLock. BtnBeacon := MakeBtn(PanelRXBlock, 'BEACON', - LeftPanelButtonLeft(LEFT_W, 3, 2), 20, - LeftPanelButtonWidth(LEFT_W, 3, 2), + LeftPanelButtonLeft(LEFT_W, 4, 3), 20, + LeftPanelButtonWidth(LEFT_W, 4, 3), BTN_H, BtnBeaconClick); BtnBeacon.Visible := False; BtnBeacon.OnMouseDown := BtnBeaconMouseDown; // ПКМ → декодер + окно констелляции @@ -2641,6 +2702,9 @@ begin FBandPlanOverlay.SetView(FController.FCenterFreq, FController.FSpanHz); FSpecView.BandPlanOverlay := FBandPlanOverlay; + // DX-кластер: база спотов + сетевой поток + оверлей подписей. + InitDXCluster; + // S-метр — внутри PanelToolbar, справа PanelSMeterRight := TPanel.Create(Self); PanelSMeterRight.Parent := PanelToolbar; @@ -3316,6 +3380,8 @@ begin StyleButton(Btn2Ton, Btn2Ton.Active); StyleButton(BtnRxMute, BtnRxMute.Active); StyleButton(BtnBeacon, BtnBeacon.Active); + // DX — тумблер подписей спотов, состояние берём из самой кнопки (сосед CTUN). + if BtnDXCluster <> nil then StyleButton(BtnDXCluster, BtnDXCluster.Active); if BtnFMSQ <> nil then StyleButton(BtnFMSQ, BtnFMSQ.Active); if TrkFMSQ <> nil then DS(TrkFMSQ); if BtnFMCTCSS <> nil then StyleButton(BtnFMCTCSS, BtnFMCTCSS.Active); @@ -3337,6 +3403,9 @@ begin if FPans[i] <> nil then begin FPans[i].View.SetTheme(T); + // Палитра подписей спотов парная под тему — у каждого пана свой оверлей. + if FPans[i].DXOverlay <> nil then + FPans[i].DXOverlay.SetLightTheme(FLightTheme); if FPans[i].PbSpectrum is TPaintBox then TPaintBox(FPans[i].PbSpectrum).Color := T.BG; if FPans[i].PbWaterfall is TPaintBox then @@ -3451,6 +3520,8 @@ begin if FCWMsgForm <> nil then TCWMessagesForm(FCWMsgForm).ApplyTheme(T); if FCWTermForm <> nil then TCWTerminalForm(FCWTermForm).ApplyTheme(T); if FBeaconScopeForm <> nil then FBeaconScopeForm.ApplyTheme(T); + if FDXClusterForm <> nil then FDXClusterForm.ApplyTheme(T); + // Оверлеи спотов перекрашены в ApplyDarkTheme — общим циклом по FPans. FController.FSettings.SaveTheme(V); FController.FSettings.Save; if (FSettingsForm <> nil) and TSettingsForm(FSettingsForm).Visible then @@ -3690,6 +3761,9 @@ begin // отсекает неизменное → пересборки кэша на каждый вызов нет. if Assigned(FBandPlanOverlay) then FBandPlanOverlay.SetView(ViewCenter, ViewSpan); + // Подписи спотов — тот же видимый домен, что у бэндплана. + if Assigned(FDXSpotOverlay) then + FDXSpotOverlay.SetView(ViewCenter, ViewSpan); if UpdateWidebandFrequencyView and FController.FShowWideband and (PbWideband <> nil) then PbWideband.Invalidate; UpdatePanZoomBar; // линейка пана следует за частотой/зумом (no-op если без изменений) @@ -3714,6 +3788,9 @@ var PeakDiff, MinDiff: Double; PeakAlpha, MinAlpha: Double; begin + // Затухание спотов не зависит от того, крутится ли приём. + ServiceDXCluster; + if not FController.FRunning then begin if PbSMeterRight <> nil then PbSMeterRight.Invalidate; @@ -4947,6 +5024,293 @@ begin StyleButton(BtnRxMute, FController.FRxMuteOnTx); end; +// ═══════════════════════════════════════════════════════════════════════════ +// DX-кластер: база спотов + telnet-клиент + оверлей подписей на спектре +// ═══════════════════════════════════════════════════════════════════════════ + +function DXModeSetFromMask(Mask: LongWord): TDXModeSet; +// Маска настроек → множество мод. 0 = без фильтра (показываем всё). +var M: TDXMode; +begin + Result := []; + if Mask = 0 then Exit; + for M := Low(TDXMode) to High(TDXMode) do + if (Mask and (LongWord(1) shl Ord(M))) <> 0 then Include(Result, M); +end; + +procedure TMainForm.InitDXCluster; +begin + FDXStore := TDXSpotStore.Create; + FDXClient := TDXClusterClient.Create(FDXStore); + + // Оверлей пана 0 живёт в самом пане, как и у панов N; FDXSpotOverlay — только + // алиас на него (как FSpecView для FPan.View), чтобы главный пан не был + // особым случаем в настройках/теме/тике. + FPan.AttachDXSpots(FDXStore); + FDXSpotOverlay := FPan.DXOverlay; + FDXSpotOverlay.SetLightTheme(FLightTheme); + FDXSpotOverlay.SetView(FController.FCenterFreq, FController.FSpanHz); + + FDXAgeTickAt := Now; + FController.FSettings.LoadDXClusterSettings(FDXCfg); + FDXStore.TTLMinutes := FDXCfg.TTLMinutes; + ApplyDXClusterSettings(FDXCfg); + // FDXConnCfg пуст → ApplyDXConnection увидит смену параметров и поднимет + // соединение, если оно включено и позывной задан. + ApplyDXConnection(FDXCfg); +end; + +procedure TMainForm.ApplyDXClusterSettings(const D: TDXClusterSettings); +// Вид: оверлей + кнопка. Применяется сразу на каждую правку в SETUP — это +// дёшево, обратимо и даёт живой отклик. Всё, что МЕНЯЕТ ДАННЫЕ (TTL стора) или +// трогает соединение, откладывается до CommitDXClusterSettings: набирая «30» в +// поле TTL, пользователь на миг проходит через «3», а это выбросило бы из базы +// все споты старше трёх минут — необратимо. +var i: Integer; +begin + FDXCfg := D; + // Настройки общие для всех панов: споты рисуются на каждом, где частота + // попадает в его окно. + for i := 0 to MAX_PANS - 1 do + if FPans[i] <> nil then + begin + ApplyDXOverlayCfg(FPans[i].DXOverlay); + if i > 0 then MarkPanDirty(FPans[i]); + end; + UpdateDXClusterButton; + FSpectrumDirty := True; +end; + +procedure TMainForm.ApplyDXOverlayCfg(O: TDXSpotOverlay); +// Вид одного оверлея по текущему FDXCfg (сеттеры сами гасят «то же самое»). +begin + if O = nil then Exit; + O.MaxRows := FDXCfg.MaxRows; + O.SetOwnCall(FDXCfg.Login); + O.SetFilters(DXModeSetFromMask(FDXCfg.ModeMask), FDXCfg.TTLMinutes); + O.SetEnabled(FDXCfg.ShowSpots); + O.Invalidate; +end; + +procedure TMainForm.AttachPanDXSpots(P: TPanafallPanel); +// Доп. пан получает СВОЙ оверлей на общей базе спотов: кэш полосы подписей +// ключуется центром/спаном/шириной пана, поэтому один экземпляр на всех +// пересобирался бы по кругу на каждый пан каждый кадр — ровно то, ради чего +// кэш и заводился. +var VC, VS: Double; +begin + if (P = nil) or (FDXStore = nil) then Exit; + P.AttachDXSpots(FDXStore); + ApplyDXOverlayCfg(P.DXOverlay); + P.DXOverlay.SetLightTheme(FLightTheme); + PanViewWindow(P, VC, VS); + P.DXOverlay.SetView(VC, VS); +end; + +procedure TMainForm.ApplyDXConnection(const D: TDXClusterSettings); +// Соединение: конфиг в клиент + поднять/положить/переподнять. Поток снимает +// конфиг один раз на сессию, поэтому смена адреса/учётки требует рестарта — +// как у веб-сервера при смене порта. +var Reconnect: Boolean; +begin + if FDXClient = nil then Exit; + Reconnect := (D.Host <> FDXConnCfg.Host) or (D.Port <> FDXConnCfg.Port) or + (D.Login <> FDXConnCfg.Login) or + (D.Password <> FDXConnCfg.Password) or + (D.PostLogin <> FDXConnCfg.PostLogin); + FDXConnCfg := D; + FDXClient.Configure(D.Host, D.Port, D.Login, D.Password, D.PostLogin); + + // Без позывного логиниться нечем — не поднимаем соединение вообще. + if (not D.Enabled) or (Trim(D.Login) = '') then + begin + if FDXClient.Running then FDXClient.Stop; + Exit; + end; + if FDXClient.Running then + begin + if not Reconnect then Exit; + FDXClient.Stop; + end; + FDXClient.Start; +end; + +procedure TMainForm.OnDXClusterSettingsChange(const D: TDXClusterSettings); +// Каждая правка в SETUP прилетает сюда ПОСИМВОЛЬНО (OnChange поля). Вид +// применяем сразу, а запись в конфиг и переподключение откладываем: иначе +// набор позывного «UA3XYZ» дёргал бы шесть реконнектов и шесть записей JSON. +begin + ApplyDXClusterSettings(D); + FDXPendingCfg := D; + FDXPendingAt := Now; + FDXPending := True; +end; + +procedure TMainForm.CommitDXClusterSettings; +// Отложенный коммит правок SETUP: пользователь перестал печатать. +begin + FDXPending := False; + FController.FSettings.SaveDXClusterSettings(FDXPendingCfg); + if FDXStore <> nil then FDXStore.TTLMinutes := FDXPendingCfg.TTLMinutes; + ApplyDXConnection(FDXPendingCfg); +end; + +procedure TMainForm.ServiceDXCluster; +// Раз в DX_AGE_TICK_SEC подталкиваем оверлей пересобраться: споты тускнеют с +// возрастом и уходят по TTL, а без нового спота версия стора не меняется и +// повода для пересборки бы не было. Реже — незаметно, чаще — впустую. +const + DX_AGE_TICK_SEC = 30; + DX_SETTINGS_QUIET_MS = 1200; // тишина в SETUP, после которой коммитим +var i: Integer; +begin + // Отложенный коммит настроек: пользователь перестал печатать в SETUP. + if FDXPending and (MilliSecondsBetween(Now, FDXPendingAt) >= DX_SETTINGS_QUIET_MS) then + CommitDXClusterSettings; + + if SecondsBetween(Now, FDXAgeTickAt) < DX_AGE_TICK_SEC then Exit; + FDXAgeTickAt := Now; + + // TTL — свойство базы, а не картинки. Стор чистится только внутри Add и + // снимков, поэтому с выключенными подписями и молчащим (или отключённым) + // кластером просроченные споты не выбрасывал бы никто: новых Add нет, версия + // стора не меняется, окно списка снимок не берёт, тик оверлея выключен. + if FDXStore <> nil then FDXStore.Purge; + + if FDXSpotOverlay = nil then Exit; + if not FDXSpotOverlay.Active then Exit; + // Тик получают оверлеи всех панов: возраст спота от пана не зависит. + for i := 0 to MAX_PANS - 1 do + if (FPans[i] <> nil) and (FPans[i].DXOverlay <> nil) then + begin + FPans[i].DXOverlay.TickAge; + if i > 0 then MarkPanDirty(FPans[i]); + end; + FSpectrumDirty := True; +end; + +procedure TMainForm.UpdateDXClusterButton; +begin + if BtnDXCluster = nil then Exit; + StyleButton(BtnDXCluster, + (FDXSpotOverlay <> nil) and FDXSpotOverlay.Active); +end; + +procedure TMainForm.BtnDXClusterClick(Sender: TObject); +// ЛКМ — показывать/не показывать подписи спотов на спектре (настройка живёт +// в конфиге, чтобы состояние пережило перезапуск). Кнопка одна на все паны: +// применяем через общий Apply, иначе тумблер гасил бы только главный. +begin + if FDXSpotOverlay = nil then Exit; + FDXCfg.ShowSpots := not FDXCfg.ShowSpots; + ApplyDXClusterSettings(FDXCfg); + FController.FSettings.SaveDXClusterSettings(FDXCfg); + // Правки SETUP ждут тишины в СВОЕЙ копии конфига. Не поправив её, отложенный + // коммит записал бы старый FDXPendingCfg целиком и молча вернул прежнее + // состояние тумблера — на экране новое, в файле старое. + if FDXPending then FDXPendingCfg.ShowSpots := FDXCfg.ShowSpots; + // Открытый SETUP держит СВОЮ копию конфига: без синхронизации галка «Show + // spots» осталась бы старой, и первая же правка любого поля на этой странице + // вернула бы подписи обратно. + if (FSettingsForm <> nil) and TSettingsForm(FSettingsForm).Visible then + TSettingsForm(FSettingsForm).LoadDXClusterSettings(FDXCfg); +end; + +procedure TMainForm.BtnDXClusterMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + if Button = mbRight then ShowDXClusterForm; +end; + +procedure TMainForm.ShowDXClusterForm; +begin + if FDXClusterForm = nil then + begin + FDXClusterForm := TDXClusterForm.CreateWith(Self, FDXStore, FDXClient); + FDXClusterForm.OnTuneSpot := OnDXTuneSpot; + end; + FDXClusterForm.ApplyTheme(CurrentAppTheme); + if FDXClusterForm.Visible then FDXClusterForm.Hide + else FDXClusterForm.Show; +end; + +function DXSpotRadioMode(FreqHz: Double; Mode: TDXMode): Integer; +// Мода спота → режим приёмника. −1 = однозначно не определяется (dxmUnknown): +// текущую в этом случае не трогаем — гадать хуже, чем не менять. +begin + Result := -1; + case Mode of + dxmCW: Result := MODE_CWU; + // Боковая по общепринятому правилу: ниже 10 МГц — LSB, выше — USB. + dxmSSB: if FreqHz < 10000000.0 then Result := MODE_LSB else Result := MODE_USB; + dxmFT8, dxmFT4, dxmDigi, dxmRTTY, dxmPSK: Result := MODE_DIGU; + dxmSSTV: Result := MODE_USB; + dxmFM: Result := MODE_FM; + end; +end; + +procedure TMainForm.OnDXTuneSpot(FreqHz: Double; Mode: TDXMode); +// QSY по споту: клик по подписи на главном пане или двойной клик в окне списка. +// Крутим ТОТ VFO, который сейчас активен, — ровно как обычный клик по спектру +// (DoSpectrumClick): иначе при активном B спот уводил бы неактивный A. +var NewMode: Integer; +begin + if FreqHz <= 0 then Exit; + if FController.FActiveVfo = 0 then + ApplyVfoA(Round(FreqHz)) + else + FController.SetVfoB(Round(FreqHz)); // рендер через OnControllerState(rfVfoB) + NewMode := DXSpotRadioMode(FreqHz, Mode); + if (NewMode >= 0) and (NewMode <> FController.FMode) then + FController.SetMode(NewMode); +end; + +procedure TMainForm.DXTuneSpotOnPan(P: TPanafallPanel; FreqHz: Double; + Mode: TDXMode); +// QSY по споту на доп. пане. Цель — слайс ЭТОГО пана (активный, если он здесь, +// иначе первый; нет ни одного — создаём в точке), ровно как у клика по фону +// пана: своего VFO у панов N нет, а ретюнить их DDC под спот нельзя — это +// увезло бы весь пан. +var + Id, NewMode: Integer; + Hz: Int64; + S: TCtrlSlice; +begin + if (P = nil) or (FreqHz <= 0) then Exit; + Hz := Round(FreqHz); + // Спот видим в окне пана, но окно может быть шире полосы захвата (зум) — + // слайс вне capture не поставить. + if not FController.SliceFitsCapture(Hz, P.PanId) then Exit; + + if (FActiveSliceId <> 0) and FController.GetSlice(FActiveSliceId, S) and + (S.PanId = P.PanId) then + Id := FActiveSliceId + else + Id := P.FirstSliceId; + + NewMode := DXSpotRadioMode(FreqHz, Mode); + if Id = 0 then + begin + AddSliceAtFreqPan(P, Hz); // ставит FActiveSliceId + Id := FActiveSliceId; + if Id = 0 then Exit; + end + else + FController.SetSliceTarget(Id, Hz); + + // Режим слайса — с полосой пресета ЭТОГО режима: тащить полосу с главного + // приёмника (как делает AddSliceAtFreqPan для нового слайса) значило бы + // слушать телеграф в 2.7 кГц. + if NewMode >= 0 then + FController.SetSliceModeBW(Id, NewMode, + FController.FilterBWFor(NewMode, FilterDefIdx(NewMode))); + + FActiveSliceId := Id; + P.PushSliceFlagState(Id); + P.LayoutFlags; + MarkPanDirty(P); +end; + procedure TMainForm.UpdateBandPlanOverlay; // Полоска бэндплана видна только в QO-100 (Pluto + full-duplex транспондер). begin @@ -5251,7 +5615,9 @@ end; // Спектр procedure TMainForm.PbSpectrumMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); -var VC, VS: Double; +var + VC, VS: Double; + DXSpot: TDXSpot; begin if FPan.DispatchFlagsMouseDown(Button, X, Y) then begin @@ -5261,6 +5627,15 @@ begin if Assigned(FSampleRateOverlay) and FSampleRateOverlay.HandleMouseDown(Button, X, Y) then Exit; + // ЛКМ по подписи DX-спота — QSY на него. Проверяется до тюнинга/драга, но + // только в полосе подписей вверху: ниже неё поведение спектра прежнее. + if (Button = mbLeft) and Assigned(FDXSpotOverlay) and + FDXSpotOverlay.SpotAtPixel(X, Y, DXSpot) then + begin + OnDXTuneSpot(DXSpot.FreqHz, DXSpot.Mode); + Exit; + end; + // Ctrl+ЛКМ по спектру — добавить софт-слайс на этой частоте (в пределах захвата). if (Button = mbLeft) and (ssCtrl in Shift) and (PbSpectrum.Width > 0) then begin @@ -6507,6 +6882,9 @@ begin FController.GetPanViewWindow(P.PanId, VC, VS); P.View.CenterFreq := VC; P.View.SpanHz := VS; + // Подписи спотов пана следуют за его окном (SetView сам отсекает неизменное + // → пересборки кэша на каждый кадр нет). + if P.DXOverlay <> nil then P.DXOverlay.SetView(VC, VS); // Сетка каналов по шагу FM — как на главном пане, но по режиму слайсов // ЭТОГО пана (у доп. панов нет своего FMode). if FController.PanHasFMSlice(P.PanId) then @@ -7158,6 +7536,8 @@ begin P.View.VfoA := -1e15; P.View.VfoB := -1e15; P.View.TXFreq := -1e15; + // Подписи DX-спотов: свой оверлей на общей базе, настройки/тема — общие. + AttachPanDXSpots(P); // Сплиттер над паном. Split := TPanel.Create(Self); @@ -7539,6 +7919,7 @@ var VC, VS: Double; Id, W: Integer; IsSpec: Boolean; + DXSpot: TDXSpot; begin P := PanFromSender(Sender); if P = nil then Exit; @@ -7550,6 +7931,14 @@ begin P.ProcessPendingSliceClose; Exit; end; + // ЛКМ по подписи DX-спота на пане — QSY слайса ЭТОГО пана (у панов N нет + // VFO A). Как на главном: только в полосе подписей, ниже поведение прежнее. + if IsSpec and (Button = mbLeft) and (P.DXOverlay <> nil) and + P.DXOverlay.SpotAtPixel(X, Y, DXSpot) then + begin + DXTuneSpotOnPan(P, DXSpot.FreqHz, DXSpot.Mode); + Exit; + end; W := TControl(Sender).Width; if W <= 0 then Exit; if (Button = mbLeft) and (ssCtrl in Shift) then @@ -9286,6 +9675,7 @@ begin SF.OnWfAGCNFChange := ApplyWfAGCNF; SF.OnADCChange := ApplyADCSettings; SF.OnWebSettingsChange := ApplyWebSettings; + SF.OnDXClusterChange := OnDXClusterSettingsChange; end; SF := TSettingsForm(FSettingsForm); PushTXProfilesToSettings; @@ -9340,6 +9730,7 @@ begin SF.LoadADCSettings(FController.FDitherEnabled, FController.FRandomEnabled); SF.LoadWebSettings(FWebEnabled, FWebPort, FWebBindAddr, FWebUser, FWebPass, FWebSpecPixels); + SF.LoadDXClusterSettings(FDXCfg); SF.LoadFPS(FDisplayFPS); SF.LoadLightTheme(FLightTheme); SF.LoadFreqMhzDigits(FFreqMhzDigits); diff --git a/PanafallPanel.pas b/PanafallPanel.pas index c93be98..794ddf9 100644 --- a/PanafallPanel.pas +++ b/PanafallPanel.pas @@ -35,6 +35,7 @@ uses LCLIntf, LCLType, OpenGLContextEx, AppTheme, WDSPEngine, RadioController, DMRDecoder, VfoOverlay, + DXSpotStore, DXSpotOverlay, SpectrumView, SpectrumViewOpengl, PanZoomBar, FlatButton, DpiUtils; type @@ -83,6 +84,10 @@ type FSliceFlags: array of TVfoOverlay; // флаги B+ (Owner=Self) FActiveFlag: TVfoOverlay; // чьё событие сейчас обрабатывается FPendingSliceClose: Integer; // SliceId к удалению после мыши (0=нет) + // Подписи DX-спотов на спектре ЭТОГО пана. Экземпляр свой на каждый пан: + // кэш полосы подписей ключуется центром/спаном/шириной, а у панов они свои + // — общий оверлей пересобирался бы на каждый пан каждый кадр. + FDXOverlay: TDXSpotOverlay; // Owner=Self, база спотов общая FMainFlagPinned: Boolean; // True = левая панель хозяина скрыта FMainFlagForced: Boolean; // True = есть доп. панадаптеры FLastSliceMeterMs: QWord; // троттлинг S-метра слайсов (~10 Гц) @@ -268,6 +273,14 @@ type // полный пересчёт (у него wideband/S-метр/оверлеи). property OnSplitterMoved: TNotifyEvent read FOnSplitterMoved write FOnSplitterMoved; + // ---- Подписи DX-спотов ---- + // Своя копия оверлея на пан; база спотов (стор) — общая, её владелец хозяин. + // Вид (центр/спан) пана заливает хозяин, как и прочие параметры вьюхи. + procedure AttachDXSpots(AStore: TDXSpotStore); + // Отвязать от базы (хозяин освобождает стор раньше панов). + procedure DetachDXSpots; + property DXOverlay: TDXSpotOverlay read FDXOverlay; + // ---- Флаги слайсов ---- // Главный флаг (слайс A) создаёт хозяин (проводка событий у него) и отдаёт // сюда; панель подключает его к view и включает в раскладку/диспетчер. @@ -1108,6 +1121,21 @@ begin FView.VfoOverlay := O; end; +procedure TPanafallPanel.AttachDXSpots(AStore: TDXSpotStore); +begin + if FDXOverlay = nil then + begin + FDXOverlay := TDXSpotOverlay.Create(Self); + FView.DXSpotOverlay := FDXOverlay; + end; + FDXOverlay.Attach(AStore); +end; + +procedure TPanafallPanel.DetachDXSpots; +begin + if FDXOverlay <> nil then FDXOverlay.Attach(nil); +end; + function TPanafallPanel.CurSliceId: Integer; begin if Assigned(FActiveFlag) then Result := FActiveFlag.SliceId else Result := 0; diff --git a/Settings.pas b/Settings.pas index 0ae2855..bee3176 100644 --- a/Settings.pas +++ b/Settings.pas @@ -427,6 +427,25 @@ type end; // Web-сервер — глобальные настройки (не привязаны к устройству, секция "web"). + // DX-кластер: телнет-соединение + вид спотов на панадаптере. + // Хранится глобально (секция "dxcluster"), не per-device: кластер и позывной + // от железа не зависят. + TDXClusterSettings = record + Enabled: Boolean; // подключаться при старте + ShowSpots: Boolean; // рисовать оверлей на спектре + Host: string; + Port: Integer; // 1..65535 + Login: string; // позывной для логина в кластер (он же «свой» в оверлее) + Password: string; // редкий кластер спрашивает — обычно пусто + PostLogin: string; // команды после логина (по строке; сюда же set/filter) + TTLMinutes: Integer; // сколько держать спот (он же горизонт затухания) + MaxRows: Integer; // рядов лесенки подписей (1..DXSPOT_MAX_ROWS) + // Фильтр по модам. Пустая маска = показывать все (в т.ч. неопознанные). + // Биты соответствуют TDXMode: 1=CW,2=SSB,3=DIGI,4=FT8,5=FT4,6=RTTY,7=PSK, + // 8=FM,9=SSTV; бит 0 = споты без распознанной моды. + ModeMask: LongWord; + end; + TWebSettings = record Enabled: Boolean; Port: Integer; // 1..65535 @@ -754,6 +773,9 @@ type function LoadPans(const MAC: array of Byte; const Ctx: string; out P: TPansConfig): Boolean; procedure SavePans(const MAC: array of Byte; const Ctx: string; const P: TPansConfig); // Web-сервер — глобальные настройки (секция "web" в корне JSON). + class procedure DefaultDXCluster(out D: TDXClusterSettings); + procedure LoadDXClusterSettings(out D: TDXClusterSettings); + procedure SaveDXClusterSettings(const D: TDXClusterSettings); class procedure DefaultWeb(out W: TWebSettings); procedure LoadWebSettings(out W: TWebSettings); procedure SaveWebSettings(const W: TWebSettings); @@ -2873,6 +2895,55 @@ begin end; end; +class procedure TSettingsManager.DefaultDXCluster(out D: TDXClusterSettings); +begin + D.Enabled := False; // без позывного подключаться всё равно нечем + D.ShowSpots := False; // подписи включает пользователь кнопкой DX + D.Host := 'cluster.dxfun.com'; + D.Port := 8000; + D.Login := ''; + D.Password := ''; + D.PostLogin := ''; + D.TTLMinutes := 30; + D.MaxRows := 4; + D.ModeMask := 0; // 0 = без фильтра по модам +end; + +procedure TSettingsManager.LoadDXClusterSettings(out D: TDXClusterSettings); +var O: TJSONObject; +begin + DefaultDXCluster(D); + if FRoot.Find('dxcluster') = nil then Exit; + O := EnsureObj(FRoot, 'dxcluster'); + D.Enabled := JB(O, 'enabled', False); + D.ShowSpots := JB(O, 'show_spots', False); + D.Host := JS(O, 'host', 'cluster.dxfun.com'); + D.Port := EnsureRange(JI(O, 'port', 8000), 1, 65535); + D.Login := JS(O, 'login', ''); + D.Password := JS(O, 'password', ''); + D.PostLogin := JS(O, 'post_login', ''); + D.TTLMinutes := EnsureRange(JI(O, 'ttl_minutes', 30), 1, 1440); + D.MaxRows := EnsureRange(JI(O, 'max_rows', 4), 1, 6); + D.ModeMask := LongWord(JI(O, 'mode_mask', 0)); +end; + +procedure TSettingsManager.SaveDXClusterSettings(const D: TDXClusterSettings); +var O: TJSONObject; +begin + O := EnsureObj(FRoot, 'dxcluster'); + JW(O, 'enabled', D.Enabled); + JW(O, 'show_spots', D.ShowSpots); + JWS(O, 'host', D.Host); + JW(O, 'port', D.Port); + JWS(O, 'login', D.Login); + JWS(O, 'password', D.Password); + JWS(O, 'post_login', D.PostLogin); + JW(O, 'ttl_minutes', D.TTLMinutes); + JW(O, 'max_rows', D.MaxRows); + JW(O, 'mode_mask', Integer(D.ModeMask)); + Save; +end; + class procedure TSettingsManager.DefaultWeb(out W: TWebSettings); begin W.Enabled := True; diff --git a/SettingsForm.pas b/SettingsForm.pas index b7d7cbf..a1870f6 100644 --- a/SettingsForm.pas +++ b/SettingsForm.pas @@ -28,7 +28,7 @@ uses Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls, LCLType, FlatButton, FlatCheckBox, FlatComboBox, FlatEdit, FlatSpinEdit, FlatFloatSpinEdit, - FlatRadioButton, + FlatRadioButton, FlatMemo, EqualizerControl, OverlayScrollBar, AudioOutput, AudioInput, AppTheme, Settings, BoardUtils, DpiUtils; @@ -86,6 +86,10 @@ type TOnThemeChange = procedure(LightTheme: Boolean) of object; TOnWfAGCNFChange = procedure(WfAGC, WfNF: Boolean) of object; TOnADCChange = procedure(Dither, Random: Boolean) of object; + // Настройки DX-кластера уезжают наружу целиком записью: полей много и + // добавлять их по одному в сигнатуру (как у веб-сервера) уже неудобно. + TOnDXClusterChange = procedure(const D: TDXClusterSettings) of object; + TOnWebSettingsChange = procedure(Enabled: Boolean; Port: Integer; const BindAddr, User, Pass: string; SpecPixels: Integer) of object; TOnCATChange = procedure( @@ -124,6 +128,19 @@ type FPageWaterfall: TScrollBox; FPagePA: TScrollBox; FPageAdvanced: TScrollBox; + FPageDXCluster: TScrollBox; + // DX-кластер + FChkDXEnabled: TFlatCheckBox; + FChkDXShow: TFlatCheckBox; + FEdDXHost: TFlatEdit; + FEdDXPort: TFlatSpinEdit; + FEdDXLogin: TFlatEdit; + FEdDXPass: TFlatEdit; + FEdDXPostLogin: TFlatMemo; + FEdDXTTL: TFlatSpinEdit; + FEdDXRows: TFlatSpinEdit; + FChkDXMode: array[0..9] of TFlatCheckBox; // индекс = Ord(TDXMode) + FDXCfg: TDXClusterSettings; FPageCAT: TScrollBox; FPageSlices: TScrollBox; FPageTransmit: TScrollBox; @@ -133,6 +150,7 @@ type FNavWaterfall: TFlatButton; FNavPA: TFlatButton; FNavAdvanced: TFlatButton; + FNavDXCluster: TFlatButton; FNavCAT: TFlatButton; FNavSlices: TFlatButton; FNavTransmit: TFlatButton; @@ -465,6 +483,7 @@ type FOnVHFCalChange: TOnVHFCalChange; FOnADCChange: TOnADCChange; FOnWebSettingsChange: TOnWebSettingsChange; + FOnDXClusterChange: TOnDXClusterChange; FOnDisplayChange: TOnDisplayParamChange; FOnWaterfallChange: TOnWaterfallParamChange; FOnWfRenderChange: TOnWfRenderChange; @@ -572,6 +591,8 @@ type OnChange: TNotifyEvent): TFlatComboBox; function MakeGroupPanel(AParent: TWinControl; const Cap: string; ALeft, ATop, AW, AH: Integer): TPanel; + procedure BuildDXClusterTab; + procedure OnDXAnyChange(Sender: TObject); function MakeScrollPage: TScrollBox; procedure AddPageBottomSpace(APage: TScrollBox); procedure UpdatePageBottomSpace(APage: TScrollBox); @@ -696,6 +717,7 @@ type ResLimit, SpeedDiv: Integer); procedure LoadSpecMSAA(Samples: Integer); procedure LoadADCSettings(Dither, Random: Boolean); + procedure LoadDXClusterSettings(const D: TDXClusterSettings); procedure LoadWebSettings(Enabled: Boolean; Port: Integer; const BindAddr, User, Pass: string; SpecPixels: Integer); @@ -734,6 +756,7 @@ type property OnWfAGCNFChange: TOnWfAGCNFChange read FOnWfAGCNFChange write FOnWfAGCNFChange; property OnADCChange: TOnADCChange read FOnADCChange write FOnADCChange; property OnWebSettingsChange: TOnWebSettingsChange read FOnWebSettingsChange write FOnWebSettingsChange; + property OnDXClusterChange: TOnDXClusterChange read FOnDXClusterChange write FOnDXClusterChange; end; implementation @@ -1113,6 +1136,7 @@ begin FNavCAT := MakeNavButton('CAT', 496); FNavSlices := MakeNavButton('Slices', 528); FNavAdvanced := MakeNavButton('Advanced', 560); + FNavDXCluster := MakeNavButton('DX Cluster', 592); FContentPanel := TPanel.Create(Self); FContentPanel.Parent := Self; @@ -1135,6 +1159,7 @@ begin FPagePA := MakeScrollPage; FPageCalib := MakeScrollPage; FPageAdvanced := MakeScrollPage; + FPageDXCluster := MakeScrollPage; FPageCAT := MakeScrollPage; FPageSlices := MakeScrollPage; FPageAlex := MakeScrollPage; @@ -1154,6 +1179,7 @@ begin BuildPATab; BuildCalibrationTab; BuildAdvancedTab; + BuildDXClusterTab; BuildCATTab; BuildSlicesTab; BuildAlexTab; @@ -1168,6 +1194,7 @@ begin AddPageBottomSpace(FPageWaterfall); AddPageBottomSpace(FPageCalib); AddPageBottomSpace(FPageCAT); + AddPageBottomSpace(FPageDXCluster); AddPageBottomSpace(FPageOC); FBtnClose := TFlatButton.Create(Self); @@ -1390,6 +1417,7 @@ begin ResizePage(FPagePA, CardWidth); ResizePage(FPageCalib, CardWidth); ResizePage(FPageAdvanced, CardWidth); + ResizePage(FPageDXCluster, CardWidth); ResizePage(FPageCAT, CardWidth); ResizePage(FPageSlices, CardWidth); ResizePage(FPageAlex, CardWidth); @@ -1408,6 +1436,7 @@ begin else if Sender = FNavPA then SelectPage(FPagePA, FNavPA) else if Sender = FNavCalib then SelectPage(FPageCalib, FNavCalib) else if Sender = FNavAdvanced then SelectPage(FPageAdvanced, FNavAdvanced) + else if Sender = FNavDXCluster then SelectPage(FPageDXCluster, FNavDXCluster) else if Sender = FNavCAT then SelectPage(FPageCAT, FNavCAT) else if Sender = FNavSlices then SelectPage(FPageSlices, FNavSlices) else if Sender = FNavAlex then SelectPage(FPageAlex, FNavAlex) @@ -1429,6 +1458,7 @@ begin FPagePA.Visible := APage = FPagePA; FPageCalib.Visible := APage = FPageCalib; FPageAdvanced.Visible := APage = FPageAdvanced; + FPageDXCluster.Visible := APage = FPageDXCluster; FPageCAT.Visible := APage = FPageCAT; FPageSlices.Visible := APage = FPageSlices; FPageAlex.Visible := APage = FPageAlex; @@ -1444,6 +1474,7 @@ begin FNavPA.Active := ANav = FNavPA; FNavCalib.Active := ANav = FNavCalib; FNavAdvanced.Active := ANav = FNavAdvanced; + FNavDXCluster.Active := ANav = FNavDXCluster; FNavCAT.Active := ANav = FNavCAT; FNavSlices.Active := ANav = FNavSlices; FNavAlex.Active := ANav = FNavAlex; @@ -3412,6 +3443,227 @@ begin Lbl.Font.Size := 8; end; +procedure TSettingsForm.BuildDXClusterTab; +const + MARGIN = 22; + GRP_PAD = 18; + LBL_W = 110; + ED_W = 220; + ROW_H = 42; + R1 = 42; + // Подписи для чекбоксов фильтра мод. Порядок = Ord(TDXMode), включая + // dxmUnknown («без моды») — иначе фильтр молча съедал бы такие споты. + MODE_CAPS: array[0..9] of string = + ('no mode', 'CW', 'SSB', 'DIGI', 'FT8', 'FT4', 'RTTY', 'PSK', 'FM', 'SSTV'); +var + Grp: TPanel; + Chk: TFlatCheckBox; + Ed: TFlatEdit; + Spin: TFlatSpinEdit; + Lbl: TLabel; + Y, i, CX, CY: Integer; +begin + TSettingsManager.DefaultDXCluster(FDXCfg); + + MakePageHeader(FPageDXCluster, 'DX Cluster', + 'Telnet connection to a DX cluster and how spots look on the panadapter.'); + + // ── Соединение ──────────────────────────────────────────────────────────── + Grp := MakeGroupPanel(FPageDXCluster, 'Connection', MARGIN, 86, SETTINGS_CARD_W, 366); + + Y := R1; + Chk := TFlatCheckBox.Create(Self); + Chk.Parent := Grp; + Chk.Caption := 'Connect at startup'; + Chk.SetBounds(DpiScale(GRP_PAD), DpiScale(Y), DpiScale(300), DpiScale(22)); + Chk.Font.Size := 9; + Chk.Font.Color := CLR_TEXT; + Chk.OnChange := OnDXAnyChange; + FChkDXEnabled := Chk; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Host:', GRP_PAD, Y + 4, LBL_W); + Ed := TFlatEdit.Create(Self); + Ed.Parent := Grp; + Ed.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(ED_W), DpiScale(BTN_H)); + Ed.Color := CLR_INPUT; + Ed.Font.Color := CLR_INPUT_TEXT; + Ed.Font.Size := 9; + Ed.Text := FDXCfg.Host; + Ed.OnChange := OnDXAnyChange; + FEdDXHost := Ed; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Port:', GRP_PAD, Y + 4, LBL_W); + Spin := TFlatSpinEdit.Create(Self); + Spin.Parent := Grp; + Spin.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(90), DpiScale(BTN_H)); + Spin.Color := CLR_INPUT; + Spin.Font.Color := CLR_INPUT_TEXT; + Spin.Font.Size := 9; + Spin.MinValue := 1; + Spin.MaxValue := 65535; + Spin.Value := FDXCfg.Port; + Spin.OnChange := OnDXAnyChange; + FEdDXPort := Spin; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Callsign:', GRP_PAD, Y + 4, LBL_W); + Ed := TFlatEdit.Create(Self); + Ed.Parent := Grp; + Ed.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(140), DpiScale(BTN_H)); + Ed.Color := CLR_INPUT; + Ed.Font.Color := CLR_INPUT_TEXT; + Ed.Font.Size := 9; + Ed.OnChange := OnDXAnyChange; + FEdDXLogin := Ed; + Lbl := MakeLbl(Grp, 'used to log in; spots for this call are highlighted', + GRP_PAD + LBL_W + 12 + 150, Y + 4, 340); + Lbl.Font.Size := 8; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Password:', GRP_PAD, Y + 4, LBL_W); + Ed := TFlatEdit.Create(Self); + Ed.Parent := Grp; + Ed.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(140), DpiScale(BTN_H)); + Ed.Color := CLR_INPUT; + Ed.Font.Color := CLR_INPUT_TEXT; + Ed.Font.Size := 9; + Ed.PasswordChar := '*'; + Ed.OnChange := OnDXAnyChange; + FEdDXPass := Ed; + Lbl := MakeLbl(Grp, 'usually not needed', GRP_PAD + LBL_W + 12 + 150, Y + 4, 200); + Lbl.Font.Size := 8; + + Y := Y + ROW_H; + MakeLbl(Grp, 'After login:', GRP_PAD, Y + 4, LBL_W); + FEdDXPostLogin := TFlatMemo.Create(Self); + FEdDXPostLogin.Parent := Grp; + FEdDXPostLogin.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), + DpiScale(ED_W + 120), DpiScale(70)); + FEdDXPostLogin.Color := CLR_INPUT; + FEdDXPostLogin.Font.Color := CLR_INPUT_TEXT; + FEdDXPostLogin.Font.Size := 9; + FEdDXPostLogin.WordWrap := False; + FEdDXPostLogin.OnChange := OnDXAnyChange; + Lbl := MakeLbl(Grp, 'one command per line (set/filter, sh/dx …) — dialects differ between clusters', + GRP_PAD, Y + 76, 520); + Lbl.Font.Size := 8; + + // ── Отображение ─────────────────────────────────────────────────────────── + Grp := MakeGroupPanel(FPageDXCluster, 'Spots on panadapter', MARGIN, 468, + SETTINGS_CARD_W, 292); + + Y := R1; + Chk := TFlatCheckBox.Create(Self); + Chk.Parent := Grp; + Chk.Caption := 'Show spots on the spectrum'; + Chk.SetBounds(DpiScale(GRP_PAD), DpiScale(Y), DpiScale(300), DpiScale(22)); + Chk.Font.Size := 9; + Chk.Font.Color := CLR_TEXT; + Chk.OnChange := OnDXAnyChange; + FChkDXShow := Chk; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Keep for, min:', GRP_PAD, Y + 4, LBL_W); + Spin := TFlatSpinEdit.Create(Self); + Spin.Parent := Grp; + Spin.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(90), DpiScale(BTN_H)); + Spin.Color := CLR_INPUT; + Spin.Font.Color := CLR_INPUT_TEXT; + Spin.Font.Size := 9; + Spin.MinValue := 1; + Spin.MaxValue := 1440; + Spin.Value := FDXCfg.TTLMinutes; + Spin.OnChange := OnDXAnyChange; + FEdDXTTL := Spin; + Lbl := MakeLbl(Grp, 'also the fade horizon: a spot dims and then disappears', + GRP_PAD + LBL_W + 114, Y + 4, 360); + Lbl.Font.Size := 8; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Label rows:', GRP_PAD, Y + 4, LBL_W); + Spin := TFlatSpinEdit.Create(Self); + Spin.Parent := Grp; + Spin.SetBounds(DpiScale(GRP_PAD + LBL_W + 12), DpiScale(Y), DpiScale(90), DpiScale(BTN_H)); + Spin.Color := CLR_INPUT; + Spin.Font.Color := CLR_INPUT_TEXT; + Spin.Font.Size := 9; + Spin.MinValue := 1; + Spin.MaxValue := 6; + Spin.Value := FDXCfg.MaxRows; + Spin.OnChange := OnDXAnyChange; + FEdDXRows := Spin; + Lbl := MakeLbl(Grp, 'ladder height: more rows means fewer hidden spots', + GRP_PAD + LBL_W + 114, Y + 4, 360); + Lbl.Font.Size := 8; + + Y := Y + ROW_H; + MakeLbl(Grp, 'Modes:', GRP_PAD, Y + 4, LBL_W); + CX := GRP_PAD + LBL_W + 12; + CY := Y; + for i := 0 to High(FChkDXMode) do + begin + Chk := TFlatCheckBox.Create(Self); + Chk.Parent := Grp; + Chk.Caption := MODE_CAPS[i]; + Chk.SetBounds(DpiScale(CX), DpiScale(CY), DpiScale(90), DpiScale(22)); + Chk.Font.Size := 9; + Chk.Font.Color := CLR_TEXT; + Chk.OnChange := OnDXAnyChange; + FChkDXMode[i] := Chk; + CX := CX + 96; + if CX > 480 then begin CX := GRP_PAD + LBL_W + 12; CY := CY + 26; end; + end; + Lbl := MakeLbl(Grp, 'none checked — every spot is shown', + GRP_PAD + LBL_W + 12, CY + 28, 360); + Lbl.Font.Size := 8; +end; + +procedure TSettingsForm.OnDXAnyChange(Sender: TObject); +var i: Integer; +begin + if FLoading then Exit; + if not Assigned(FOnDXClusterChange) then Exit; + FDXCfg.Enabled := FChkDXEnabled.Checked; + FDXCfg.ShowSpots := FChkDXShow.Checked; + FDXCfg.Host := Trim(FEdDXHost.Text); + FDXCfg.Port := FEdDXPort.Value; + FDXCfg.Login := Trim(FEdDXLogin.Text); + FDXCfg.Password := FEdDXPass.Text; + FDXCfg.PostLogin := FEdDXPostLogin.Text; + FDXCfg.TTLMinutes := FEdDXTTL.Value; + FDXCfg.MaxRows := FEdDXRows.Value; + FDXCfg.ModeMask := 0; + for i := 0 to High(FChkDXMode) do + if (FChkDXMode[i] <> nil) and FChkDXMode[i].Checked then + FDXCfg.ModeMask := FDXCfg.ModeMask or (LongWord(1) shl i); + FOnDXClusterChange(FDXCfg); +end; + +procedure TSettingsForm.LoadDXClusterSettings(const D: TDXClusterSettings); +var i: Integer; +begin + FLoading := True; + try + FDXCfg := D; + FChkDXEnabled.Checked := D.Enabled; + FChkDXShow.Checked := D.ShowSpots; + FEdDXHost.Text := D.Host; + FEdDXPort.Value := EnsureRange(D.Port, 1, 65535); + FEdDXLogin.Text := D.Login; + FEdDXPass.Text := D.Password; + FEdDXPostLogin.Text := D.PostLogin; + FEdDXTTL.Value := EnsureRange(D.TTLMinutes, 1, 1440); + FEdDXRows.Value := EnsureRange(D.MaxRows, 1, 6); + for i := 0 to High(FChkDXMode) do + if FChkDXMode[i] <> nil then + FChkDXMode[i].Checked := (D.ModeMask and (LongWord(1) shl i)) <> 0; + finally + FLoading := False; + end; +end; + procedure TSettingsForm.OnADCChkChange(Sender: TObject); begin if FLoading then Exit; @@ -3540,6 +3792,11 @@ procedure TSettingsForm.ApplyTheme(const T: TAppTheme); TFlatFloatSpinEdit(Ctrl).SetAppTheme(T) else if Ctrl is TFlatRadioButton then TFlatRadioButton(Ctrl).SetAppTheme(T) + // TFlatMemo — обёртка над TMemo со своим scrollbar: тему знает сама, + // рекурсивный обход внутрь ей только навредил бы (внутренний TMemo не + // подходит ни под одну ветку и остался бы серым). + else if Ctrl is TFlatMemo then + TFlatMemo(Ctrl).SetAppTheme(T) else if Ctrl is TListBox then begin TListBox(Ctrl).Color := T.BG; diff --git a/SpectrumView.pas b/SpectrumView.pas index 017bde8..73420f2 100644 --- a/SpectrumView.pas +++ b/SpectrumView.pas @@ -20,7 +20,7 @@ interface uses Classes, SysUtils, Graphics, GraphType, ExtCtrls, Controls, Math, AppTheme, - AlertOverlay, SampleRateOverlay, VfoOverlay, BandPlanOverlay, + AlertOverlay, SampleRateOverlay, VfoOverlay, BandPlanOverlay, DXSpotOverlay, WaterfallView, SMeterView, RulerView, RadioModes, Settings; // FilterEdgesFromBW — единственная таблица знака боковой @@ -106,6 +106,7 @@ type FVfoOverlay: TVfoOverlay; FSliceOverlays: TFPList; // доп. слайс-флаги (B+); не владеет (владелец MainForm) FBandPlanOverlay: TBandPlanOverlay; + FDXSpotOverlay: TDXSpotOverlay; // споты DX-кластера (полоса подписей + штрихи) // ── Marker ──────────────────────────────────────────────────────────────── FMarkerActive: Boolean; FMarkerX: Integer; @@ -159,7 +160,7 @@ type procedure RawHLine(Y, X1, X2: Integer; Color: TColor; OnPx: Integer = 0; OffPx: Integer = 0); procedure RawFillRect(X1, Y1, X2, Y2: Integer; Color: TColor); - procedure RawTriangleDown(CX, HalfW, Hgt: Integer; Color: TColor); + procedure RawTriangleDown(CX, Top, HalfW, Hgt: Integer; Color: TColor); procedure RawCurve(W: Integer; Color: TColor); function GetTextMask(const S: string; FontSize: Integer; Bold: Boolean): TBitmap; @@ -171,7 +172,12 @@ type procedure DrawSliceFilterBands(W, H: Integer); procedure DrawSliceFilterLinesRaw(W, H: Integer); procedure DrawBandLetterRaw(X1, X2: Integer; L: Char; Clr: TColor); + // Y, с которого начинать вертикаль несущей, чтобы не перечеркнуть букву. + function CarrierTopY(X1, X2, CarrierX: Integer; L: Char): Integer; procedure DrawBeaconMarkersRaw(W, H: Integer); + // Штрихи DX-спотов ниже полосы подписей. Раскладка уже посчитана оверлеем + // при пересборке кэша — здесь только N вертикальных линий. + procedure DrawDXSpotTicksRaw(W, H: Integer); // 2TON/IMD: замер пиков по TX-буферу (общий для CPU/GL рендеров). // Возвращает число валидных маркеров в M (0 если измерять нечего): // [0..1] тона, [2..3] IMD3 (2f1−f2, 2f2−f1). Обновляет FIMDSummary. @@ -179,7 +185,6 @@ type procedure DrawIMDMarkersRaw(W, H: Integer; DBmax, InvRange: Double); procedure RawCircle(CX, CY, R: Integer; Color: TColor); procedure BlendBand(X1, X2, H: Integer; R, G, B, Alpha: Byte); - procedure FillBandRaw(X1, X2, H: Integer; Color: TColor); procedure CopyGridToSpectrum(W, H: Integer); procedure DrawADCOverloadRaw(W, H: Integer); procedure CalcFilterBandX(VfoFreq: Double; W: Integer; @@ -318,6 +323,7 @@ type function SliceOverlayCount: Integer; function SliceOverlayAt(Index: Integer): TVfoOverlay; property BandPlanOverlay: TBandPlanOverlay read FBandPlanOverlay write FBandPlanOverlay; + property DXSpotOverlay: TDXSpotOverlay read FDXSpotOverlay write FDXSpotOverlay; // ── Данные от DSP ───────────────────────────────────────────────────────── procedure SetSpectrumData(const Pixels: array of Single; Count: Integer); virtual; @@ -361,6 +367,9 @@ const // Полоса фильтра передающего тракта (главный VFO при TX / передающий слайс). // TColor = $00BBGGRR, младший байт = R (как в BlendBand/RawPack). CLR_TX_BAND = TColor($003030E0); + // Кегль буквы слайса на полосе фильтра. Один на рисование буквы и на расчёт + // зазора под неё (CarrierTopY) — иначе зазор разъедется с глифом. + BAND_LETTER_FONT = 8; // Упаковка TColor в пиксель кадра (непрозрачный). Раскладка байтов как в // BlendBand: non-Darwin = BGRA, Darwin = ARGB. @@ -669,6 +678,26 @@ begin FBeaconDecHalf := HalfHz; end; +procedure TSpectrumView.DrawDXSpotTicksRaw(W, H: Integer); +// Штрих от низа полосы подписей до низа спектра — по одному на видимый спот. +// Пунктиром, чтобы не спорить с кривой сигнала и краями фильтра. Раскладка +// готова (EnsureRendered в начале кадра), здесь только N линий. +var + i, X: Integer; + Col: TColor; +begin + if (FDXSpotOverlay = nil) or (not FDXSpotOverlay.Active) then Exit; + // Низкий пан (сетка панов): полоса подписей в него не влезла и не рисуется — + // тогда и штрихам не от чего идти. + if H <= FDXSpotOverlay.BandHeight + 2 then Exit; + for i := 0 to FDXSpotOverlay.TickCount - 1 do + begin + FDXSpotOverlay.Tick(i, X, Col); + if (X < 0) or (X >= W) then Continue; + RawVLine(X, FDXSpotOverlay.BandHeight, H - 1, Col, 1, 2, 3); + end; +end; + procedure TSpectrumView.DrawBeaconMarkersRaw(W, H: Integer); // Две вертикали: опорная частота маяка (зелёная пунктир) и отслеживаемый // центроид (оранжевая сплошная). Расхождение видно глазом → понятно, сел ли @@ -930,14 +959,16 @@ begin end; // Треугольник остриём вниз (курсор VFO): вершина основания на Y=0. -procedure TSpectrumView.RawTriangleDown(CX, HalfW, Hgt: Integer; Color: TColor); +procedure TSpectrumView.RawTriangleDown(CX, Top, HalfW, Hgt: Integer; Color: TColor); +// Top — верх треугольника: «голова» несущей уезжает вниз, когда её иначе +// накрыла бы буква слайса (см. CarrierTopY). var Y, Half: Integer; begin for Y := 0 to Hgt do begin Half := Round(HalfW * (Hgt - Y) / Hgt); - RawHLine(Y, CX - Half, CX + Half + 1, Color); + RawHLine(Top + Y, CX - Half, CX + Half + 1, Color); end; end; @@ -1136,41 +1167,6 @@ end; // Canvas.FillRect для полосы фильтра в DrawSpectrum: полоса рисуется в // raw-фазе (между memcpy сетки и градиентом), а FillRect дёргал бы Canvas // и форсил лишнюю синхронизацию битмапа на Qt6. -procedure TSpectrumView.FillBandRaw(X1, X2, H: Integer; Color: TColor); -var - Y, W: Integer; - Row: PLongWord; - Px: LongWord; - R, G, B: Byte; -begin - if FSpectrumBitmap = nil then Exit; - W := FSpectrumBitmap.Width; - if X1 < 0 then X1 := 0; - if X2 > W then X2 := W; - if X2 <= X1 then Exit; - R := Color and $FF; G := (Color shr 8) and $FF; B := (Color shr 16) and $FF; -{$IFDEF DARWIN} - // ARGB в памяти (см. BlendBand): байт 0 = альфа, дальше R,G,B. - Px := LongWord($FF) or (LongWord(R) shl 8) or (LongWord(G) shl 16) or - (LongWord(B) shl 24); -{$ELSE} - // BGRA в памяти: байты B,G,R,A. - Px := LongWord(B) or (LongWord(G) shl 8) or (LongWord(R) shl 16) or $FF000000; -{$ENDIF} - FSpectrumBitmap.BeginUpdate(False); - try - for Y := 0 to H - 1 do - begin - Row := PLongWord(FSpectrumBitmap.ScanLine[Y]); - if Row = nil then Continue; - Inc(Row, X1); - FillDWord(Row^, X2 - X1, Px); - end; - finally - FSpectrumBitmap.EndUpdate(False); - end; -end; - // Маркер фильтра каждого слайса (B+) на спектре — полупрозрачная полоса // пропускания + края + центральная несущая. Янтарный цвет, как в GL-вьюхе // (SpectrumViewOpengl.DrawSliceFilterMarkers). Полосы (raw ScanLine-блендинг) @@ -1192,7 +1188,7 @@ begin CalcSliceBandX(O, W, SX1, SX2, SVfoX); if SX2 > SX1 then BlendBand(SX1, SX2, H, Clr and $FF, (Clr shr 8) and $FF, (Clr shr 16) and $FF, - IfThen(O.TxActive, 100, 60)); + IfThen(O.TxActive, SPEC_BAND_ALPHA_TX, SPEC_BAND_ALPHA)); end; end; @@ -1211,7 +1207,9 @@ begin CalcSliceBandX(O, W, SX1, SX2, SVfoX); RawVLine(SX1, 0, H - 1, Clr); RawVLine(SX2, 0, H - 1, Clr); - RawVLine(SVfoX, 0, H - 13, Clr, 2); // несущая (жирнее) + // Несущая (жирнее). В AM/FM/DSB она приходится ровно на букву — начинаем + // под ней, чтобы буква читалась (в SSB/CW несущая у кромки, зазор = 0). + RawVLine(SVfoX, CarrierTopY(SX1, SX2, SVfoX, O.SliceLetter), H - 13, Clr, 2); // Буква слайса внутри полосы фильтра сверху — привязка полосы к флагу, // цвет = цвет слайса (совпадает с бейджем во флаге). DrawBandLetterRaw(SX1, SX2, O.SliceLetter, SliceColor(O.SliceLetter)); @@ -1226,7 +1224,30 @@ var begin if (L < 'A') or (L > 'Z') then Exit; cx := (X1 + X2) div 2; - RawText(cx - RawTextWidth(L, 8, True) div 2, 0, L, Clr, 8, True, clNone); + RawText(cx - RawTextWidth(L, BAND_LETTER_FONT, True) div 2, 0, L, Clr, + BAND_LETTER_FONT, True, clNone); +end; + +function TSpectrumView.CarrierTopY(X1, X2, CarrierX: Integer; L: Char): Integer; +// Вертикаль несущей идёт от самого верха полосы — и в модуляциях с несущей +// (AM/FM/DSB) она приходится ровно на букву слайса: и буква, и несущая стоят по +// центру полосы. В SSB/CW несущая лежит у кромки, пересечения нет, поэтому +// раньше это в глаза не бросалось. Здесь считаем, накрывает ли вертикаль букву, +// и если да — начинаем её ПОД буквой. L = #0 (или полоса без буквы) → 0. +const + CLEAR_X = 3; // запас по бокам от глифа + CLEAR_Y = 2; // зазор между буквой и началом вертикали +var + M: TBitmap; + cx: Integer; +begin + Result := 0; + if (L < 'A') or (L > 'Z') or (X2 <= X1) then Exit; + M := GetTextMask(L, BAND_LETTER_FONT, True); + if M = nil then Exit; + cx := (X1 + X2) div 2; + if Abs(CarrierX - cx) <= M.Width div 2 + CLEAR_X then + Result := M.Height + CLEAR_Y; end; procedure TSpectrumView.CopyGridToSpectrum(W, H: Integer); @@ -1544,7 +1565,8 @@ var DBmin, DBmax, dB: Double; VfoX, X1, X2: Integer; TXVfoX, TXX1, TXX2: Integer; - AGCy, AGCHangY: Integer; + AGCy, AGCHangY, CarrY: Integer; + MainLetter: Char; SrcF, Frac, dBv: Double; S0, S1: Integer; InvRange: Double; @@ -1705,6 +1727,10 @@ begin FSpPts[W] := Point(W-1, H); FSpPts[W+1] := Point(0, H); + // Раскладка спотов — ДО RawBegin: штрихи в фазе raw берут из неё готовые X, + // а сама пересборка идёт на своём кэш-битмапе и только по dirty-ключу. + if Assigned(FDXSpotOverlay) then FDXSpotOverlay.EnsureRendered(W); + // ═══ Фаза 1: raw — весь кадр одним локом ═════════════════════════════════ {$IFDEF DARWIN} // Cocoa-вариант CopyGridToSpectrum идёт через Canvas.Draw — до RawBegin. @@ -1727,7 +1753,14 @@ begin end else if X2 > X1 then BlendBand(X1, X2, H, $E0, $30, $30, 100); end else - if X2 > X1 then FillBandRaw(X1, X2, H, FTheme.SpecFilter); + // Полупрозрачная заливка тем же способом, что у слайсов (SPEC_BAND_ALPHA): + // раньше главная полоса заливалась НЕПРОЗРАЧНО и выглядела плотным блоком + // рядом с просвечивающими слайсовыми. Цвет — SpecFilterBand (свой, не + // подложка подписей AGC): см. комментарий в AppTheme. + if X2 > X1 then + BlendBand(X1, X2, H, FTheme.SpecFilterBand and $FF, + (FTheme.SpecFilterBand shr 8) and $FF, + (FTheme.SpecFilterBand shr 16) and $FF, SPEC_BAND_ALPHA); // Полосы фильтра слайсов (B+) — под градиентом/кривой, как в GL-вьюхе. DrawSliceFilterBands(W, H); @@ -1738,12 +1771,34 @@ begin DrawSpectrumGradient(FSpPts, W, H); + // ★ Кромки, несущая и буква ГЛАВНОГО фильтра — здесь, ДО кривой спектра, + // ровно как у слайсов ниже и как в GL-вьюхе (там весь блок фильтров идёт + // перед DrawSpectrumCurve). Раньше этот кусок стоял ПОСЛЕ кривой, и на + // CPU-пути главный фильтр единственный лез поверх сигнала — с виду толще и + // ярче слайсовых, хотя цвета и толщина те же. + RawVLine(X1, 0, H - 1, FTheme.SpecFilterEdge); + RawVLine(X2, 0, H - 1, FTheme.SpecFilterEdge); // Буква главного флага (A) на его полосе — только когда есть слайсы, - // иначе одиночный приём не засоряем. + // иначе одиночный приём не засоряем. Букву запоминаем: под неё + // подстраиваются вертикаль несущей и её треугольник. + MainLetter := #0; if (FSliceOverlays <> nil) and (FSliceOverlays.Count > 0) and (FActiveVfo = 0) and Assigned(FVfoOverlay) then - DrawBandLetterRaw(X1, X2, FVfoOverlay.SliceLetter, - SliceColor(FVfoOverlay.SliceLetter)); + MainLetter := FVfoOverlay.SliceLetter; + CarrY := CarrierTopY(X1, X2, VfoX, MainLetter); + RawVLine(VfoX, CarrY, H - 13, FTheme.SpecVfoCursor, 2); + RawTriangleDown(VfoX, CarrY, 5, 8, FTheme.SpecVfoCursor); + if FTXOverlay and (FTXVfoIndex <> FActiveVfo) then + begin + RawVLine(TXX1, 0, H - 1, TColor($002030E0)); + RawVLine(TXX2, 0, H - 1, TColor($002030E0)); + // Буква нарисована на RX-полосе (X1..X2) — с ней и сверяемся. + CarrY := CarrierTopY(X1, X2, TXVfoX, MainLetter); + RawVLine(TXVfoX, CarrY, H - 13, TColor($002030E0), 2); + RawTriangleDown(TXVfoX, CarrY, 5, 8, TColor($002030E0)); + end; + if MainLetter <> #0 then + DrawBandLetterRaw(X1, X2, MainLetter, SliceColor(MainLetter)); // Края/несущие/буквы слайсов (полосы уже нарисованы выше). DrawSliceFilterLinesRaw(W, H); @@ -1779,21 +1834,12 @@ begin // Линия спектра RawCurve(W, FTheme.SpecLine); - // Края фильтра + VFO - RawVLine(X1, 0, H - 1, FTheme.SpecFilterEdge); - RawVLine(X2, 0, H - 1, FTheme.SpecFilterEdge); - RawVLine(VfoX, 0, H - 13, FTheme.SpecVfoCursor, 2); - RawTriangleDown(VfoX, 5, 8, FTheme.SpecVfoCursor); - if FTXOverlay and (FTXVfoIndex <> FActiveVfo) then - begin - RawVLine(TXX1, 0, H - 1, TColor($002030E0)); - RawVLine(TXX2, 0, H - 1, TColor($002030E0)); - RawVLine(TXVfoX, 0, H - 13, TColor($002030E0), 2); - RawTriangleDown(TXVfoX, 5, 8, TColor($002030E0)); - end; + // (кромки/несущая главного фильтра нарисованы выше — до кривой) if FMarkerActive then DrawMarkerLineRaw(W, H); if FBeaconMarkActive or FBeaconDecActive then DrawBeaconMarkersRaw(W, H); + // Штрихи DX-спотов — под маркерами наведения, но над кривой. + DrawDXSpotTicksRaw(W, H); // 2TON: кружки с уровнями на пиках тонов/IMD3 (активирует MainForm при // 2TON+TX+DUP — реальный сигнал после PA виден на RX-спектре) if FIMDActive then DrawIMDMarkersRaw(W, H, DBmax, InvRange); @@ -1809,6 +1855,9 @@ begin // Бэндплан QO-100 — полоска внизу спектра, под панелями оверлеев. if Assigned(FBandPlanOverlay) then FBandPlanOverlay.DrawOverlay(FSpectrumBitmap, W, H); + // Полоса подписей DX-спотов — вверху спектра, под флагами VFO. + if Assigned(FDXSpotOverlay) then + FDXSpotOverlay.DrawOverlay(FSpectrumBitmap, W, H); if Assigned(FSampleRateOverlay) then FSampleRateOverlay.DrawOverlay(FSpectrumBitmap, C, W, H); if Assigned(FVfoOverlay) then diff --git a/SpectrumViewOpengl.pas b/SpectrumViewOpengl.pas index 66af4af..50104cc 100644 --- a/SpectrumViewOpengl.pas +++ b/SpectrumViewOpengl.pas @@ -18,6 +18,7 @@ uses Classes, SysUtils, Graphics, Controls, Math, Types, OpenGLContextEx, GL, AppTheme, AlertOverlay, SpectrumView, VfoOverlay, BandPlanOverlay, + DXSpotOverlay, WaterfallView, WaterfallViewOpengl; type @@ -36,6 +37,7 @@ type FSampleOverlayDirty: Boolean; FVfoOverlayDirty: Boolean; FBandOverlayDirty: Boolean; + FDXOverlayDirty: Boolean; FGridLabelTex: TGLTextureCache; FAGCLabelTex: TGLTextureCache; FAGCHangLabelTex: TGLTextureCache; @@ -44,6 +46,7 @@ type FSampleOverlayTex: TGLTextureCache; FVfoOverlayTex: TGLTextureCache; FBandOverlayTex: TGLTextureCache; + FDXOverlayTex: TGLTextureCache; // Текстуры флагов слайсов (B+), привязка по указателю оверлея. FSliceTex: array of record Overlay: TVfoOverlay; @@ -72,6 +75,8 @@ type FLastBandW: Integer; FLastBandCenter: Double; FLastBandSpan: Double; + FLastDXW: Integer; + FLastDXRender: Int64; FGLSpectrumW: Integer; FGLSpectrumH: Integer; FSpY: array of Integer; @@ -93,6 +98,7 @@ type procedure DrawSpectrumCurve(W, H: Integer; DBmax, InvRange: Double); procedure DrawMarker(W, H: Integer); procedure DrawBeaconMarkersGL(W, H: Integer); + procedure DrawDXSpotTicksGL(W, H: Integer); procedure DrawCircleGL(CX, CY: Integer; R: Single; C: TColor); procedure DrawIMDMarkersGL(W, H: Integer; DBmax, InvRange: Double); procedure DrawADCOverlay(W, H: Integer); @@ -100,6 +106,9 @@ type procedure DrawSliceOverlays(W, H: Integer); procedure DrawSliceFilterMarkers(W, H: Integer); procedure DrawBandLetterGL(X1, X2: Integer; L: Char); + // Y начала вертикали несущей, чтобы она не легла на букву (двойник + // CPU-CarrierTopY; метрику берём из той же текстуры буквы). + function CarrierTopYGL(X1, X2, CarrierX: Integer; L: Char): Integer; function SliceTexIndex(O: TVfoOverlay): Integer; // индекс в FSliceTex, -1 если нет function FormatFreqGL(Hz: Double): string; function ActiveVfoFrequency: Double; @@ -152,8 +161,10 @@ begin FSampleOverlayDirty := True; FVfoOverlayDirty := True; FBandOverlayDirty := True; + FDXOverlayDirty := True; FLastBandW := -MaxInt; FLastBandCenter := -1; FLastBandSpan := -1; + FLastDXW := -MaxInt; FLastDXRender := -1; FLastAGCY := -MaxInt; FLastAGCHangY := -MaxInt; FLastMarkerX := -MaxInt; @@ -173,6 +184,7 @@ begin DeleteTexture(FSampleOverlayTex); DeleteTexture(FVfoOverlayTex); DeleteTexture(FBandOverlayTex); + DeleteTexture(FDXOverlayTex); for i := 0 to High(FSliceTex) do DeleteTexture(FSliceTex[i].Tex); for i := 0 to High(FLetterTex) do DeleteTexture(FLetterTex[i]); for i := 0 to High(FIMDLabelTex) do DeleteTexture(FIMDLabelTex[i]); @@ -454,6 +466,7 @@ begin Zap(FADCOverlayTex); Zap(FSampleOverlayTex); Zap(FVfoOverlayTex); + Zap(FDXOverlayTex); Zap(FBandOverlayTex); for i := 0 to High(FSliceTex) do Zap(FSliceTex[i].Tex); for i := 0 to High(FLetterTex) do Zap(FLetterTex[i]); @@ -469,6 +482,7 @@ begin FSampleOverlayDirty := True; FVfoOverlayDirty := True; FBandOverlayDirty := True; + FDXOverlayDirty := True; FGLSpectrumW := 0; FGLSpectrumH := 0; // Водопад — свой контекст/текстуры (история + маркер). При reparent (pop-out) @@ -581,7 +595,8 @@ end; procedure TSpectrumViewOpenGL.DrawFilterAndCursors(W, H: Integer); var - X1, X2, VfoX, TXX1, TXX2, TXVfoX: Integer; + X1, X2, VfoX, TXX1, TXX2, TXVfoX, CarrY: Integer; + MainLetter: Char; begin TXX1 := 0; TXX2 := 0; @@ -607,24 +622,35 @@ begin else if X2 > X1 then DrawRect(X1, 0, X2, H, CLR_TX_BAND, 100 / 255); end else if X2 > X1 then - DrawRect(X1, 0, X2, H, FTheme.SpecFilter, 1); + // Как у слайсов: полупрозрачная заливка (раньше здесь была alpha=1, и + // главная полоса выглядела плотным блоком рядом с просвечивающими). + // Цвет — SpecFilterBand, свой у полосы (см. AppTheme). + DrawRect(X1, 0, X2, H, FTheme.SpecFilterBand, SPEC_BAND_ALPHA / 255); + + // Буква главного флага (A) на его полосе — только когда есть слайсы. Саму + // букву рисуем ниже, но знать о ней надо здесь: под неё уходит начало + // вертикали несущей и её «шляпка». + MainLetter := #0; + if (SliceOverlayCount > 0) and (FActiveVfo = 0) and Assigned(FVfoOverlay) then + MainLetter := FVfoOverlay.SliceLetter; DrawLine(X1, 0, X1, H, FTheme.SpecFilterEdge, 1, False); DrawLine(X2, 0, X2, H, FTheme.SpecFilterEdge, 1, False); - DrawLine(VfoX, 0, VfoX, H - 12, FTheme.SpecVfoCursor, 2, False); - DrawRect(VfoX - 5, 0, VfoX + 5, 8, FTheme.SpecVfoCursor, 1); + CarrY := CarrierTopYGL(X1, X2, VfoX, MainLetter); + DrawLine(VfoX, CarrY, VfoX, H - 12, FTheme.SpecVfoCursor, 2, False); + DrawRect(VfoX - 5, CarrY, VfoX + 5, CarrY + 8, FTheme.SpecVfoCursor, 1); if FTXOverlay and (FTXVfoIndex <> FActiveVfo) then begin DrawLine(TXX1, 0, TXX1, H, TColor($002030E0), 1, False); DrawLine(TXX2, 0, TXX2, H, TColor($002030E0), 1, False); - DrawLine(TXVfoX, 0, TXVfoX, H - 12, TColor($002030E0), 2, False); - DrawRect(TXVfoX - 5, 0, TXVfoX + 5, 8, TColor($002030E0), 1); + // Буква нарисована на RX-полосе (X1..X2) — с ней и сверяемся. + CarrY := CarrierTopYGL(X1, X2, TXVfoX, MainLetter); + DrawLine(TXVfoX, CarrY, TXVfoX, H - 12, TColor($002030E0), 2, False); + DrawRect(TXVfoX - 5, CarrY, TXVfoX + 5, CarrY + 8, TColor($002030E0), 1); end; - // Буква главного флага (A) на его полосе — только когда есть слайсы. - if (SliceOverlayCount > 0) and (FActiveVfo = 0) and Assigned(FVfoOverlay) then - DrawBandLetterGL(X1, X2, FVfoOverlay.SliceLetter); + if MainLetter <> #0 then DrawBandLetterGL(X1, X2, MainLetter); DrawSliceFilterMarkers(W, H); end; @@ -646,10 +672,13 @@ begin else Clr := SliceColor(O.SliceLetter); CalcSliceBandX(O, W, SX1, SX2, SVfoX); if SX2 > SX1 then - DrawRect(SX1, 0, SX2, H, Clr, IfThen(O.TxActive, 100, 60) / 255); + DrawRect(SX1, 0, SX2, H, Clr, + IfThen(O.TxActive, SPEC_BAND_ALPHA_TX, SPEC_BAND_ALPHA) / 255); DrawLine(SX1, 0, SX1, H, Clr, 1, False); DrawLine(SX2, 0, SX2, H, Clr, 1, False); - DrawLine(SVfoX, 0, SVfoX, H - 12, Clr, 2, False); + // Несущая — под буквой, если она приходится на неё (AM/FM/DSB). + DrawLine(SVfoX, CarrierTopYGL(SX1, SX2, SVfoX, O.SliceLetter), + SVfoX, H - 12, Clr, 2, False); DrawBandLetterGL(SX1, SX2, O.SliceLetter); end; end; @@ -668,6 +697,29 @@ begin DrawTexture(FLetterTex[idx], cx - FLetterTex[idx].W div 2, 0); end; +function TSpectrumViewOpenGL.CarrierTopYGL(X1, X2, CarrierX: Integer; + L: Char): Integer; +// То же правило, что в CPU-пути: в модуляциях с несущей (AM/FM/DSB) вертикаль +// приходится ровно на букву — начинаем её ПОД буквой; в SSB/CW несущая у кромки +// полосы, пересечения нет и зазор нулевой. Текстуру буквы при необходимости +// заливаем здесь же: она нужна нам раньше, чем до неё дойдёт DrawBandLetterGL +// (порядок вызовов в кадре — линии, потом буквы). +const + CLEAR_X = 3; + CLEAR_Y = 2; +var + idx: Integer; +begin + Result := 0; + if (L < 'A') or (L > 'H') or (X2 <= X1) then Exit; + idx := Ord(L) - Ord('A'); + if FLetterTex[idx].Tex = 0 then + UploadText(FLetterTex[idx], L, SliceColor(L), 8, True); + if FLetterTex[idx].H <= 0 then Exit; + if Abs(CarrierX - (X1 + X2) div 2) <= FLetterTex[idx].W div 2 + CLEAR_X then + Result := FLetterTex[idx].H + CLEAR_Y; +end; + procedure TSpectrumViewOpenGL.DrawAGCLines(W, H: Integer; DBmax, InvRange: Double); var @@ -820,6 +872,28 @@ begin end; end; +procedure TSpectrumViewOpenGL.DrawDXSpotTicksGL(W, H: Integer); +// GL-двойник DrawDXSpotTicksRaw: те же X и цвета из раскладки оверлея, только +// линиями GL. EnsureRendered здесь и держит раскладку свежей — текстуру полосы +// DrawCachedOverlays перезальёт по RenderVersion, кто бы ни пересобрал кэш. +var + i, X, Y0: Integer; + Col: TColor; +begin + if (FDXSpotOverlay = nil) or (not FDXSpotOverlay.Active) then Exit; + FDXSpotOverlay.EnsureRendered(W); + Y0 := FDXSpotOverlay.BandHeight; + // Низкий пан: полоса подписей не влезла (её текстуру DrawCachedOverlays тоже + // пропускает) — штрихам не от чего идти. + if H <= Y0 + 2 then Exit; + for i := 0 to FDXSpotOverlay.TickCount - 1 do + begin + FDXSpotOverlay.Tick(i, X, Col); + if (X < 0) or (X >= W) then Continue; + DrawLine(X, Y0, X, H, Col, 1, True); // пунктир — как в CPU-пути + end; +end; + procedure TSpectrumViewOpenGL.DrawCircleGL(CX, CY: Integer; R: Single; C: TColor); // Залитый кружок (triangle fan, 20 сегментов) — маркер пика 2TON/IMD. var @@ -947,6 +1021,31 @@ begin DrawTexture(FBandOverlayTex, 0, H - FBandOverlayTex.H); end; + // Полоса подписей DX-спотов — вверху спектра. Тот же битмап, что в CPU-пути, + // заливается текстурой ТОЛЬКО при dirty (новый спот меняет CacheDirty + // оверлея, вид — центр/спан/ширину). + // Низкому пану полоса подписей не по росту — пропускаем её целиком (тот же + // гейт, что в CPU-пути DrawOverlay). + if Assigned(FDXSpotOverlay) and FDXSpotOverlay.Active and + (H > FDXSpotOverlay.BandHeight) then + begin + if FOverlayDirty or FDXOverlayDirty or FDXOverlayTex.Dirty or + (FLastDXW <> W) or (FLastDXRender <> FDXSpotOverlay.RenderVersion) then + begin + B := TBitmap.Create; + try + FDXSpotOverlay.DrawOverlayBitmap(B, W); + UploadBitmap(FDXOverlayTex, B, True, DXSPOT_ALPHA); + finally + B.Free; + end; + FLastDXW := W; + FLastDXRender := FDXSpotOverlay.RenderVersion; + FDXOverlayDirty := False; + end; + DrawTexture(FDXOverlayTex, 0, 0); + end; + if Assigned(FSampleRateOverlay) then begin OW := Min(FSampleRateOverlay.Width, W - FSampleRateOverlay.Left); @@ -1098,6 +1197,7 @@ begin DrawSpectrumCurve(W, H, DBmax, InvRange); DrawMarker(W, H); if FBeaconMarkActive or FBeaconDecActive then DrawBeaconMarkersGL(W, H); + DrawDXSpotTicksGL(W, H); // 2TON: кружки с уровнями на пиках тонов/IMD3 (активирует MainForm при // 2TON+TX+DUP — реальный сигнал после PA виден на RX-спектре) if FIMDActive then DrawIMDMarkersGL(W, H, DBmax, InvRange); diff --git a/VfoOverlay.pas b/VfoOverlay.pas index 804a649..7ef6f0e 100644 --- a/VfoOverlay.pas +++ b/VfoOverlay.pas @@ -38,7 +38,11 @@ const // бейджа-карточки во флаге и для буквы на полосе фильтра в спектре. SLICE_COLORS: array[0..7] of TColor = ( TColor($0060E040), // A — зелёный - TColor($0010A8FF), // B — оранжевый + // B был оранжевым и спорил с янтарной полосой главного фильтра + // (AppTheme.SpecFilterBand). Васильковый выбран по свободному месту в круге + // оттенков: занято 0°(TX)/31°(полоса)/38/55/132/190/195/276/308, самый + // широкий незанятый промежуток — 195..276°, середина ≈236°. RGB(97,118,255). + TColor($00FF7661), // B — васильковый (indigo) TColor($00F0D030), // C — голубой TColor($00E070F0), // D — розовый/маджента TColor($0030E0F0), // E — жёлтый @@ -46,6 +50,11 @@ const TColor($00E0C060), // G — бирюзовый TColor($00C0C0C0)); // H — серый + // Прозрачность заливки полосы фильтра на спектре — одна на главный VFO и на + // слайсы, чтобы полосы читались одинаково (и в CPU-, и в GL-вьюхе). + SPEC_BAND_ALPHA = 60; // приём + SPEC_BAND_ALPHA_TX = 100; // передающая полоса — плотнее + // Цвет слайса по его букве (A..). За пределами таблицы — по кругу. function SliceColor(L: Char): TColor; @@ -283,6 +292,12 @@ type property OnInvalidate: TNotifyEvent read FOnInvalidate write FOnInvalidate; end; +{ BlendBitmapKey — общий keyed-композит кэш-битмапа оверлея в кадр (дворд- + блендинг, магента = прозрачность). Живёт здесь исторически; вынесен в + interface, чтобы другие оверлеи той же модели (DXSpotOverlay) не заводили + вторую копию этого же цикла. } +procedure BlendBitmapKey(Target, Source: TBitmap; DstX, DstY: Integer; Alpha: Byte); + implementation function SliceColor(L: Char): TColor; diff --git a/WebUtils.pas b/WebUtils.pas index a995f5f..07dbd47 100644 --- a/WebUtils.pas +++ b/WebUtils.pas @@ -59,6 +59,11 @@ procedure SockSetNonBlock(S: TSocket; NB: Boolean); если буфер клиента переполнен, держа при этом FClientLock и блокируя Stop(). } procedure SockSetSndTimeout(S: TSocket; Ms: Integer); +{ SockSetRcvTimeout — ограничивает время блокирующего SockRecv. Нужен клиентам, + которым между пакетами надо просыпаться самим (проверить Terminated, отдать + накопившиеся команды): recv возвращает -1 по таймауту, соединение живо. } +procedure SockSetRcvTimeout(S: TSocket; Ms: Integer); + { ── SHA-1 ─────────────────────────────────────────────────────────────────── } type @@ -123,6 +128,13 @@ begin setsockopt(S, SOL_SOCKET, SO_SNDTIMEO, @T, SizeOf(T)); end; +procedure SockSetRcvTimeout(S: TSocket; Ms: Integer); +var T: DWORD; +begin + T := Ms; + setsockopt(S, SOL_SOCKET, SO_RCVTIMEO, @T, SizeOf(T)); +end; + {$ELSE} function SockClose(S: TSocket): Integer; @@ -165,6 +177,14 @@ begin fpSetSockOpt(S, SOL_SOCKET, SO_SNDTIMEO, @TV, SizeOf(TV)); end; +procedure SockSetRcvTimeout(S: TSocket; Ms: Integer); +var TV: TTimeVal; +begin + TV.tv_sec := Ms div 1000; + TV.tv_usec := (Ms mod 1000) * 1000; + fpSetSockOpt(S, SOL_SOCKET, SO_RCVTIMEO, @TV, SizeOf(TV)); +end; + {$ENDIF} { ═══════════════════════════════════════════════════════════════════════════ diff --git a/ewsdr.lpi b/ewsdr.lpi index 28fef8b..358b700 100644 --- a/ewsdr.lpi +++ b/ewsdr.lpi @@ -17,9 +17,9 @@ - + - + @@ -147,6 +147,8 @@ + +