diff --git a/DXClusterClient.pas b/DXClusterClient.pas new file mode 100644 index 0000000..62648f3 --- /dev/null +++ b/DXClusterClient.pas @@ -0,0 +1,883 @@ +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). + + Формат спота (общий для 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 + {$IFDEF MSWINDOWS} + , Windows, WinSock2 + {$ELSE} + , BaseUnix, Sockets, netdb + {$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_RECV_MS = 1000; // квант recv: просыпаемся проверить Terminated/очередь + DX_RECONNECT_MIN = 5; // с + DX_RECONNECT_MAX = 60; // с + DX_LOGIN_GRACE_S = 6; // не увидели приглашение — шлём позывной сами + DX_POSTLOGIN_S = 2; // пауза после позывного перед post-login командами + 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; // не владеет + + 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); + public + constructor Create(AStore: TDXSpotStore); + destructor Destroy; override; + + procedure Configure(const AHost: string; APort: Integer; + const ALogin, APassword, APostLogin: string); + procedure Start; + procedure Stop; + 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 + TDXClusterThread = class(TThread) + private + FOwner: TDXClusterClient; + FSocket: TSocket; + FRxBuf: string; // хвост неполной строки + + // конфиг сессии (снимок на время соединения) + FHost: string; + FPort: Integer; + FLogin: string; + FPassword: string; + FPostLogin: string; + + FLoginSent: Boolean; + FPassSent: Boolean; + FPostSent: Boolean; + FLoginAt: TDateTime; + FConnectAt: TDateTime; + + function Resolve(const Host: string; out Addr: LongWord): Boolean; + 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); + function Session: Boolean; // одно соединение; False — выйти совсем + protected + procedure Execute; override; + public + constructor Create(AOwner: TDXClusterClient); + end; + +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); + Spot.Stamp := Now; + Result := True; +end; + +{ ── TDXClusterClient ─────────────────────────────────────────────────────── } + +constructor TDXClusterClient.Create(AStore: TDXSpotStore); +{$IFDEF MSWINDOWS} +var wsa: TWSAData; +{$ENDIF} +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; + {$IFDEF MSWINDOWS} + WSAStartup($0202, wsa); + {$ENDIF} +end; + +destructor TDXClusterClient.Destroy; +begin + Stop; + FOutQueue.Free; + FStopEvent.Free; + FLock.Free; + {$IFDEF MSWINDOWS} + WSACleanup; + {$ENDIF} + 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 + 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.Stop; +var T: TThread; +begin + // Всё, что не успели отправить, к следующему соединению уже неактуально. + FLock.Enter; + try + FOutQueue.Clear; + finally + FLock.Leave; + end; + + T := FThread; + if T = nil then + begin + SetState(dxsOff, ''); + Exit; + end; + FThread := nil; + T.Terminate; + FStopEvent.SetEvent; + // Сокет закрывает сам поток (TDXClusterThread.CloseSock из Execute); + // FStopEvent + Terminate выводят его из ожиданий, а recv рвётся по таймауту. + T.WaitFor; + T.Free; + SetState(dxsOff, ''); +end; + +function TDXClusterClient.Running: Boolean; +begin + Result := FThread <> nil; +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); +begin + if Trim(S) = '' then Exit; + FLock.Enter; + try + FOutQueue.Add(S); + finally + FLock.Leave; + end; +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; + +function TDXClusterThread.Resolve(const Host: string; out Addr: LongWord): Boolean; +// Возвращает адрес в СЕТЕВОМ порядке байт (готов для sin_addr). +{$IFNDEF MSWINDOWS} +var HE: THostEntry; HA: THostAddr; +{$ELSE} +var PH: PHostEnt; L: LongWord; +{$ENDIF} +begin + Result := False; + Addr := 0; + if Host = '' then Exit; +{$IFDEF MSWINDOWS} + L := inet_addr(PChar(Host)); + if L <> INADDR_NONE then // литеральный IP (уже в сетевом порядке) + begin + Addr := L; + Exit(True); + end; + 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} + // Литеральный IP: TryStrToHostAddr отдаёт ХОСТОВЫЙ порядок — разворачиваем. + if TryStrToHostAddr(Host, HA) then + begin + Addr := htonl(HA.s_addr); + Exit(True); + end; + // DNS (netdb читает /etc/resolv.conf и /etc/hosts). Здесь адрес приходит + // прямо из DNS-ответа, т.е. УЖЕ в сетевом порядке — второй раз не вертим. + if ResolveHostByName(Host, HE) then + begin + Addr := HE.Addr.s_addr; + Exit(True); + end; +{$ENDIF} +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; + if not Resolve(FHost, IP) then + begin + FOwner.SetState(dxsRetry, 'cannot resolve ' + FHost); + FOwner.AddLog('*** DNS: cannot resolve ' + FHost); + Exit; + end; + + {$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} + Result := True; +end; + +procedure TDXClusterThread.CloseSock; +begin + if FSocket <> SOCK_INVALID then + begin + 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: 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 + for i := 0 to Pending.Count - 1 do + begin + if not SendLine(Pending[i]) then Break; // сокет умер — остальное на реконнект + FOwner.AddLog('> ' + Pending[i]); + end; + finally + Pending.Free; + end; +end; + +procedure TDXClusterThread.CheckPrompts(const Tail: string); +// Приглашения логина И пароля обычно приходят БЕЗ перевода строки, поэтому +// ищем их и в незавершённом хвосте буфера, а не только в целых строках. +// Флаги FLoginSent/FPassSent держат отправку однократной: хвост проверяется +// заново с каждым пришедшим куском. +var U: string; +begin + if Tail = '' 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); + FLoginSent := True; + FLoginAt := Now; + FOwner.SetState(dxsLogin, ''); + end; + Exit; + end; + + if (FPassword <> '') and (not FPassSent) and (Pos('password', U) > 0) then + begin + if not SendLine(FPassword) then Exit; + FOwner.AddLog('> ********'); + FPassSent := True; + end; +end; + +procedure TDXClusterThread.HandleLine(const Line: string); +var + Spot: TDXSpot; +begin + if Line = '' then Exit; + FOwner.AddLog(Line); + + 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); +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 CheckPrompts(FRxBuf); + // Защита от мусора без переводов строк. + if Length(FRxBuf) > 8192 then FRxBuf := ''; +end; + +function TDXClusterThread.Session: Boolean; +var + Buf: array[0..4095] of Byte; + N: Integer; + Chunk: string; + PL: TStringList; + i: Integer; +begin + Result := True; + FRxBuf := ''; + FLoginSent := False; + FPassSent := False; + FPostSent := False; + 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); + HandleChunk(Chunk); + 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; + FLoginAt := Now; + end; + + // Post-login команды — один раз, чуть погодя после позывного. + if FLoginSent and (not FPostSent) and + (SecondsBetween(Now, FLoginAt) >= DX_POSTLOGIN_S) then + begin + FPostSent := True; + if Trim(FPostLogin) <> '' then + begin + 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 Break; + FOwner.AddLog('> ' + Trim(PL[i])); + end; + finally + PL.Free; + end; + end; + if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, ''); + end; + + FlushOutQueue; + end; + + CloseSock; + Result := not Terminated; +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; + +end. diff --git a/DXClusterForm.pas b/DXClusterForm.pas new file mode 100644 index 0000000..f6f427b --- /dev/null +++ b/DXClusterForm.pas @@ -0,0 +1,459 @@ +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; + +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 := 'Courier New'; + 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 := 'Courier New'; + 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); + while Length(Md) < 4 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; + Sel: string; +begin + if FStore = nil then Exit; + Keep := FList.ItemIndex; + Sel := ''; + if (Keep >= 0) and (Keep < Length(FSpots)) then Sel := FSpots[Keep].Call; + + 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 Sel <> '' then + for i := 0 to High(FSpots) do + if SameText(FSpots[i].Call, Sel) 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..efd34e4 --- /dev/null +++ b/DXSpotOverlay.pas @@ -0,0 +1,507 @@ +unit DXSpotOverlay; + +{ + Оверлей DX-спотов на спектре: позывной в «чипе» + вертикальный штрих к своей + частоте. Пересекающиеся подписи раскладываются лесенкой по рядам сверху вниз. + + Производительность — ровно модель BandPlanOverlay/VfoOverlay, ничего нового: + + • Кэшируется ТОЛЬКО полоса подписей (W × FBandH, вверху спектра) в key-color + битмап; пересборка идёт исключительно по dirty-ключу (версия стора / вид / + ширина / тема / фильтры / тик затухания), а каждый кадр — один композит + W × FBandH с постоянной альфой (BlendBitmapKey, тот же дворд-блендинг). + Полноэкранный кэш W × H на кадр стоил бы в разы дороже — поэтому штрихи + ниже полосы в кэш НЕ входят. + • Штрихи от полосы до низа спектра рисует вызывающая сторона теми же + примитивами, что и все прочие маркеры: 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; + FAgeTick: Int64; // бампается таймером UI — обновить затухание + + FRenderVer: Int64; // ++ на каждую пересборку кэша — ключ GL-текстуры + FLayoutTTL: Integer; // горизонт затухания, снят один раз на раскладку + FItems: array of TDXSpotItem; + FItemCount: Integer; + FHidden: Integer; // сколько спотов не влезло в лесенку + + function FreqToX(FreqHz: Double; W: Integer): Integer; + function AgeColor(const S: TDXSpot): TColor; + procedure Layout(C: TCanvas; W: Integer); + procedure DrawSelf(C: TCanvas; W: Integer); + procedure RebuildCache(W: Integer); + function NeedsRebuild(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; // минимальный зазор между чипами в одном ряду + +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; + 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.Layout(C: TCanvas; W: Integer); +// Споты приходят из стора отсортированными по частоте; каждому даём ПЕРВЫЙ +// ряд сверху, где подпись не наезжает на предыдущую. Не нашлось ряда — +// спот скрыт (считаем в FHidden), в лесенке дырок не оставляем. +var + Arr: TDXSpotArray; + N, i, r, TW, ChipW, ChipX, Row: Integer; + RowRight: array[0..DXSPOT_MAX_ROWS-1] of Integer; + LoHz, HiHz: Double; +begin + FItemCount := 0; + FHidden := 0; + if (FStore = nil) or (FSpanHz <= 0) or (W <= 0) then Exit; + + // Горизонт затухания: явный фильтр по возрасту, иначе TTL стора (чтение + // под локом — поэтому один раз на раскладку, а не на каждый спот). + FLayoutTTL := FMaxAgeMin; + if FLayoutTTL <= 0 then FLayoutTTL := FStore.TTLMinutes; + + LoHz := FCenterFreq - FSpanHz / 2; + HiHz := FCenterFreq + FSpanHz / 2; + N := FStore.SnapshotRange(LoHz, HiHz, FModes, FMaxAgeMin, Arr); + 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(Arr[i].Call); + ChipW := TW + CHIP_PAD_X * 2; + ChipX := FreqToX(Arr[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(Arr[i].FreqHz, W); + FItems[FItemCount].Chip := Rect(ChipX, Row * FRowH + 2, + ChipX + ChipW, Row * FRowH + FRowH); + FItems[FItemCount].Color := AgeColor(Arr[i]); + FItems[FItemCount].Spot := Arr[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)); + + // Шрифт привязан к высоте ряда (а не к point-size) — подпись влезает при + // любом DPI-масштабе, как в бэндплане. + C.Font.Name := 'Courier New'; + 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.NeedsRebuild(W: Integer): Boolean; +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 (FKeyVersion <> FStore.Version) + 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); +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 := FStore.Version; + FKeyLight := FLightTheme; + FKeyRows := FMaxRows; + FKeyAgeTick := FAgeTick; + FCacheDirty := False; +end; + +{ ── Рисование ────────────────────────────────────────────────────────────── } + +procedure TDXSpotOverlay.EnsureRendered(W: Integer); +begin + if (not Active) or (W <= 0) then Exit; + if NeedsRebuild(W) then RebuildCache(W); +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..9a389ff --- /dev/null +++ b/DXSpotStore.pas @@ -0,0 +1,382 @@ +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; + 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; + + // Снимок всех спотов, отсортированный по частоте. + 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; +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; + +{ ── 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.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..1f73c6c 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 устройства для подключения @@ -263,6 +275,7 @@ type BtnDiscover: TFlatButton; BtnStartStop: TFlatButton; BtnSettings: TFlatButton; + BtnDXCluster: TFlatButton; // ЛКМ — споты на спектре, ПКМ — окно кластера // ---- Left panel ---- PanelLeft: TPanel; @@ -497,6 +510,19 @@ 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 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 = вкл/выкл, ПКМ = поповер настроек. @@ -1373,6 +1399,17 @@ begin PanelSplitter := nil; PbWaterfall := nil; PbPanZoom := nil; + // DX-кластер: незакоммиченную правку SETUP дописываем в конфиг (соединение + // при этом не трогаем — программа закрывается), гасим сетевой поток (его + // Stop делает shutdown сокета и ждёт поток), потом базу спотов — оверлей + // к этому моменту уже мёртв вместе с view пана. + if FDXPending then + begin + FDXPending := False; + FController.FSettings.SaveDXClusterSettings(FDXPendingCfg); + end; + FreeAndNil(FDXClient); + FreeAndNil(FDXStore); DestroyAllExtraPans; // доп. паны (DDC/движок/панели) — до пана 0 FreeAndNil(FPan); FPans[0] := nil; @@ -1976,6 +2013,10 @@ 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 — споты кластера: ЛКМ включает/выключает подписи на спектре, ПКМ + // открывает окно списка (та же семантика, что у BEACON → окно констелляции). + BtnDXCluster := MakeBtn(PanelToolbar, 'DX', X+234, 3, 46, BTN_H, BtnDXClusterClick); + BtnDXCluster.OnMouseDown := BtnDXClusterMouseDown; // DISCOVER — синеватый акцент BtnDiscover.ClrNorm := TColor($00101828); @@ -2641,6 +2682,9 @@ begin FBandPlanOverlay.SetView(FController.FCenterFreq, FController.FSpanHz); FSpecView.BandPlanOverlay := FBandPlanOverlay; + // DX-кластер: база спотов + сетевой поток + оверлей подписей. + InitDXCluster; + // S-метр — внутри PanelToolbar, справа PanelSMeterRight := TPanel.Create(Self); PanelSMeterRight.Parent := PanelToolbar; @@ -2763,6 +2807,9 @@ begin SafeLeft := MARGIN; if BtnSettings <> nil then SafeLeft := BtnSettings.Left + BtnSettings.Width + SETTINGS_GAP; + // Кнопка DX стоит правее SETUP — группа VFO начинается уже за ней. + if (BtnDXCluster <> nil) and BtnDXCluster.Visible then + SafeLeft := Max(SafeLeft, BtnDXCluster.Left + BtnDXCluster.Width + SETTINGS_GAP); SafeRight := ClientWidth - MARGIN; if PanelLeft <> nil then begin @@ -3301,6 +3348,9 @@ begin BtnStartStop.ClrTextAct:= T.TbStartText; BtnStartStop.Invalidate; StyleButton(BtnSettings, False); + // DX — тумблер подписей спотов: состояние берём из самой кнопки, как у + // прочих тумблеров ниже (BtnCTun/BtnBeacon). + if BtnDXCluster <> nil then StyleButton(BtnDXCluster, BtnDXCluster.Active); // Обычные кнопки — все массивы for i := 0 to BAND_COUNT-1 do StyleButton(BtnBand[i], BtnBand[i].Active); @@ -3451,6 +3501,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); + if FDXSpotOverlay <> nil then FDXSpotOverlay.SetLightTheme(FLightTheme); FController.FSettings.SaveTheme(V); FController.FSettings.Save; if (FSettingsForm <> nil) and TSettingsForm(FSettingsForm).Visible then @@ -3690,6 +3742,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 +3769,9 @@ var PeakDiff, MinDiff: Double; PeakAlpha, MinAlpha: Double; begin + // Затухание спотов не зависит от того, крутится ли приём. + ServiceDXCluster; + if not FController.FRunning then begin if PbSMeterRight <> nil then PbSMeterRight.Invalidate; @@ -4947,6 +5005,186 @@ 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); + + FDXSpotOverlay := TDXSpotOverlay.Create(Self); + FDXSpotOverlay.Attach(FDXStore); + FDXSpotOverlay.SetLightTheme(FLightTheme); + FDXSpotOverlay.SetView(FController.FCenterFreq, FController.FSpanHz); + FSpecView.DXSpotOverlay := FDXSpotOverlay; + + 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», а это выбросило бы из базы +// все споты старше трёх минут — необратимо. +begin + FDXCfg := D; + if FDXSpotOverlay <> nil then + begin + FDXSpotOverlay.MaxRows := D.MaxRows; + FDXSpotOverlay.SetOwnCall(D.Login); + FDXSpotOverlay.SetFilters(DXModeSetFromMask(D.ModeMask), D.TTLMinutes); + FDXSpotOverlay.SetEnabled(D.ShowSpots); + FDXSpotOverlay.Invalidate; + end; + UpdateDXClusterButton; + FSpectrumDirty := True; +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, после которой коммитим +begin + // Отложенный коммит настроек: пользователь перестал печатать в SETUP. + if FDXPending and (MilliSecondsBetween(Now, FDXPendingAt) >= DX_SETTINGS_QUIET_MS) then + CommitDXClusterSettings; + + if FDXSpotOverlay = nil then Exit; + if SecondsBetween(Now, FDXAgeTickAt) < DX_AGE_TICK_SEC then Exit; + FDXAgeTickAt := Now; + if not FDXSpotOverlay.Active then Exit; + FDXSpotOverlay.TickAge; + 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); +// ЛКМ — показывать/не показывать подписи спотов на спектре (настройка живёт +// в конфиге, чтобы состояние пережило перезапуск). +begin + if FDXSpotOverlay = nil then Exit; + FDXCfg.ShowSpots := not FDXCfg.ShowSpots; + FDXSpotOverlay.SetEnabled(FDXCfg.ShowSpots); + FController.FSettings.SaveDXClusterSettings(FDXCfg); + UpdateDXClusterButton; + FSpectrumDirty := True; +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; + +procedure TMainForm.OnDXTuneSpot(FreqHz: Double; Mode: TDXMode); +// QSY по споту: клик по подписи на спектре или двойной клик в окне списка. +// Мода ставится только когда она однозначна из комментария кластера; при +// dxmUnknown текущую не трогаем — гадать хуже, чем не менять. +var NewMode: Integer; +begin + if FreqHz <= 0 then Exit; + ApplyVfoA(Round(FreqHz)); + NewMode := -1; + case Mode of + dxmCW: NewMode := MODE_CWU; + // Боковая по общепринятому правилу: ниже 10 МГц — LSB, выше — USB. + dxmSSB: if FreqHz < 10000000.0 then NewMode := MODE_LSB else NewMode := MODE_USB; + dxmFT8, dxmFT4, dxmDigi, dxmRTTY, dxmPSK: NewMode := MODE_DIGU; + dxmSSTV: NewMode := MODE_USB; + dxmFM: NewMode := MODE_FM; + end; + if (NewMode >= 0) and (NewMode <> FController.FMode) then + FController.SetMode(NewMode); +end; + procedure TMainForm.UpdateBandPlanOverlay; // Полоска бэндплана видна только в QO-100 (Pluto + full-duplex транспондер). begin @@ -5251,7 +5489,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 +5501,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 @@ -9286,6 +9535,7 @@ begin SF.OnWfAGCNFChange := ApplyWfAGCNF; SF.OnADCChange := ApplyADCSettings; SF.OnWebSettingsChange := ApplyWebSettings; + SF.OnDXClusterChange := OnDXClusterSettingsChange; end; SF := TSettingsForm(FSettingsForm); PushTXProfilesToSettings; @@ -9340,6 +9590,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/Settings.pas b/Settings.pas index 0ae2855..3f4eb06 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 := True; + 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', True); + 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..5646323 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; @@ -172,6 +173,9 @@ type procedure DrawSliceFilterLinesRaw(W, H: Integer); procedure DrawBandLetterRaw(X1, X2: Integer; L: Char; Clr: TColor); 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. @@ -318,6 +322,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; @@ -669,6 +674,23 @@ 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; + 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); // Две вертикали: опорная частота маяка (зелёная пунктир) и отслеживаемый // центроид (оранжевая сплошная). Расхождение видно глазом → понятно, сел ли @@ -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. @@ -1794,6 +1820,8 @@ begin 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 +1837,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..d237e20 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); @@ -152,8 +158,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 +181,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 +463,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 +479,7 @@ begin FSampleOverlayDirty := True; FVfoOverlayDirty := True; FBandOverlayDirty := True; + FDXOverlayDirty := True; FGLSpectrumW := 0; FGLSpectrumH := 0; // Водопад — свой контекст/текстуры (история + маркер). При reparent (pop-out) @@ -820,6 +831,25 @@ 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; + 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 +977,28 @@ begin DrawTexture(FBandOverlayTex, 0, H - FBandOverlayTex.H); end; + // Полоса подписей DX-спотов — вверху спектра. Тот же битмап, что в CPU-пути, + // заливается текстурой ТОЛЬКО при dirty (новый спот меняет CacheDirty + // оверлея, вид — центр/спан/ширину). + if Assigned(FDXSpotOverlay) and FDXSpotOverlay.Active 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 +1150,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..71f9ce4 100644 --- a/VfoOverlay.pas +++ b/VfoOverlay.pas @@ -283,6 +283,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} { ═══════════════════════════════════════════════════════════════════════════