From 9db58b953d4ea1c3aa5945e1d2e6e37a646505ab Mon Sep 17 00:00:00 2001 From: Mike Brashler Date: Wed, 28 Aug 2024 00:13:30 -0700 Subject: [PATCH] Implement ARRL Sweepstakes Contest #55 --- ArrlSS.pas | 413 +++++++++++++++++++++++++++++++ DxStn.pas | 10 +- ExchFields.pas | 8 +- Ini.pas | 22 +- Log.pas | 52 +++- Main.pas | 158 +++++++++++- MorseRunner.dpr | 5 +- MorseRunner.dproj | 9 + Readme.txt | 42 ++++ Station.pas | 10 +- Util/ArrlSections.pas | 65 +++++ Util/SSExchParser.pas | 559 ++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 1332 insertions(+), 21 deletions(-) create mode 100644 ArrlSS.pas create mode 100644 Util/ArrlSections.pas create mode 100644 Util/SSExchParser.pas diff --git a/ArrlSS.pas b/ArrlSS.pas new file mode 100644 index 0000000..ef9324b --- /dev/null +++ b/ArrlSS.pas @@ -0,0 +1,413 @@ +unit ArrlSS; + +{$ifdef FPC} +{$MODE Delphi} +{$endif} + +interface + +uses + Generics.Defaults, + Generics.Collections, + Classes, // for TStringList + Log, // for TQso + SSExchParser, + Contest, Station, DxStn; + +type + TSweepstakesCallRec = class + public + Call: string; // call sign + Section: string; // ARRL/RAC Section (e.g. OR) + Check: integer; // Check (2-digit year first licensed or station first licensed) + UserText: string; // optional UserText (displayed in status bar) + function GetString: string; // returns (.e.g 'A 72 OR') + class function compareCall(const left, right: TSweepstakesCallRec) : integer; static; + end; + +TSweepstakes = class(TContest) +private + SweepstakesCallList: TObjectList; + Comparer: IComparer; + ExchValidator: TSSExchParser; + Sections2Idx: TDictionary; + + function GetAlternateSection(const ASection: string): string; + +public + constructor Create; + destructor Destroy; override; + function LoadCallHistory(const AUserCallsign : string) : boolean; override; + + function ValidateMyExchange(const AExchange: string; + ATokens: TStringList; + out AExchError: string): boolean; override; + + function PickStation(): integer; override; + procedure DropStation(id : integer); override; + function GetCall(id : integer): string; override; // returns station callsign + procedure GetExchange(id: integer; out station: TDxStation); override; + + function FindCallRec(out ssrec: TSweepstakesCallRec; const ACall: string): Boolean; + procedure SendMsg(const AStn: TStation; const AMsg: TStationMessage); override; + function ValidateEnteredExchange(const ACall, AExch1, AExch2: string; + out AExchError: String) : boolean; override; + procedure SaveEnteredExchToQso(var Qso: TQso; const AExch1, AExch2: string); override; + function GetStationInfo(const ACallsign: string) : string; override; + function ExtractMultiplier(Qso: PQso) : string; override; + function GetCheckSection(const ACallsign: string; AThreshold: extended = 0): String; + function IsNum(Num: String): Boolean; +end; + +implementation + +uses + SysUtils, + PerlRegEx, // for regular expression support + Ini, // for ActiveContest + ArrlSections, // SectionsTbl + ARRL; + +function TSweepstakes.LoadCallHistory(const AUserCallsign : string) : boolean; +const + DelimitChar: char = ','; +var + Lexer: TSSLexer; + slst, tl: TStringList; + i: integer; + rec: TSweepstakesCallRec; +begin + // reload call history if empty + Result := SweepstakesCallList.Count <> 0; + if Result then + Exit; + + Lexer := TSSLexer.Create; + slst:= TStringList.Create; + tl:= TStringList.Create; + tl.Delimiter := DelimitChar; + tl.StrictDelimiter := True; + rec := nil; + + try + slst.LoadFromFile(ParamStr(1) + 'SSCW.TXT'); + + for i:= 0 to slst.Count-1 do begin + tl.DelimitedText := slst.Strings[i]; + + if (tl.Count > 3) then begin + if (tl.Strings[0] = '!!Order!!') then continue; + + if rec = nil then + rec := TSweepstakesCallRec.Create; + rec.Call := UpperCase(tl.Strings[0]); + rec.Section := UpperCase(tl.Strings[1]); + if not TryStrToInt(tl.Strings[3], rec.Check) then continue; + if (tl.Count >= 5) then rec.UserText := tl.Strings[4] + else rec.UserText := ''; + if rec.Call='' then continue; + if not Lexer.IsValidCall(rec.Call) then continue; + if rec.Section='' then continue; + + SweepstakesCallList.Add(rec); + rec := nil; + end; + end; + + SweepstakesCallList.Sort(Comparer); + Result := True; + + finally + Lexer.Free; + slst.Free; + tl.Free; + if rec <> nil then rec.Free; + end; +end; + + +constructor TSweepstakes.Create; +var + I: integer; +begin + inherited Create; + Comparer := TComparer.Construct(TSweepstakesCallRec.compareCall); + SweepstakesCallList := TObjectList.Create(Comparer); + ExchValidator := TSSExchParser.Create; + Sections2Idx := TDictionary.Create; + + // load Sections2Idx... + for I := Low(SectionsTbl) to High(SectionsTbl) do + Sections2Idx.Add(SectionsTbl[I], I); +end; + + +destructor TSweepstakes.Destroy; +begin + FreeAndNil(SweepstakesCallList); + FreeAndNil(ExchValidator); + FreeAndNil(Sections2Idx); + inherited; +end; + + +{ + ValidateMyExchange will validate user-entered exchange and + return Exch1 and Exch2 tokens. These tokens will be stored to send + as my transmissions. + + Syntax: [nr | #]
+ Entered Exchange: # *
+ where precedence=Q,A,B,U,M,S, check='year licenced', ARRL/RAC section. + Sent Exchange: # A W7SST 72 OR + + Entered: [123|#]
+ Returned: Exch1 = '[123|#] ', Exch2 = '
' +} +function TSweepstakes.ValidateMyExchange(const AExchange: string; + ATokens: TStringList; + out AExchError: string): boolean; +const + // Syntax: [123|#][ ]
+ Regexpr: string = ' *(?P(?P[0-9]+|#)? *(?P[QABUMS])) +' + + '(?P[0-9]{2}) +(?P[A-Z]+) *'; +var + reg: TPerlRegEx; + Exch1, Exch2: string; +begin + reg := TPerlRegEx.Create(); + try + // parse into two strings [Exch1, Exch2] + reg.Subject := UTF8Encode(AExchange); + reg.RegEx := UTF8Encode('^' + Regexpr + '$'); + Result := Reg.Match; + if Result then + begin + Exch1 := String(Reg.Groups[Reg.NamedGroup('exch1')]); + Exch2 := format('%s %s', + [Reg.Groups[Reg.NamedGroup('chk')], Reg.Groups[Reg.NamedGroup('sect')]]); + ATokens.Clear; + ATokens.Add(Exch1); + ATokens.Add(Exch2); + end + else + begin + if not Result then + AExchError := Format('Invalid exchange: ''%s'' - expecting %s.', + [AExchange, ActiveContest.Msg]); + end; + + finally + reg.Free; + end; +end; + + +function TSweepstakes.PickStation(): integer; +begin + result := random(SweepstakesCallList.Count); +end; + + +procedure TSweepstakes.DropStation(id : integer); +begin + assert(id < SweepstakesCallList.Count); + SweepstakesCallList.Delete(id); +end; + + +function TSweepstakes.FindCallRec(out ssrec: TSweepstakesCallRec; const ACall: string): Boolean; +var + rec: TSweepstakesCallRec; +{$ifdef FPC} + index: int64; +{$else} + index: integer; +{$endif} +begin + rec := TSweepstakesCallRec.Create(); + rec.Call := ACall; + ssrec:= nil; + try + if SweepstakesCallList.BinarySearch(rec, index, Comparer) then + ssrec:= SweepstakesCallList.Items[index]; + finally + rec.Free; + end; + Result:= ssrec <> nil; +end; + + +{ + Overrides TContest.SendMsg() to send contest-specific messages. + + Adding a contest: TContest.SendMsg(AMsg): send contest-specfic messages +} +procedure TSweepstakes.SendMsg(const AStn: TStation; const AMsg: TStationMessage); +begin + case AMsg of + msgCQ: SendText(AStn, 'CQ SS '); + msgLongCQ: SendText(AStn, 'CQ CQ SS SS'); // QrmStation only + else + inherited SendMsg(AStn, AMsg); + end; +end; + + +{ + Validate user-entered Exchange before sending TU and logging the QSO. + Overriden here to handle complex ARRL Sweepstakes exchange. +} +function TSweepstakes.ValidateEnteredExchange(const ACall, AExch1, AExch2: string; + out AExchError: String) : boolean; +begin + Result := ExchValidator.ValidateEnteredExchange(ACall, AExch1, AExch2, AExchError); +end; + + +{ + ARRL Sweepstakes has a specialized exchange and requires special processing + when saving exchange information into the QSO. +} +procedure TSweepstakes.SaveEnteredExchToQso(var Qso: TQso; const AExch1, AExch2: string); +begin + Qso.Nr := ExchValidator.NR; + Qso.Prec := ExchValidator.Precedence; + Qso.Check := StrToIntDef(ExchValidator.Check, 0); + Qso.Sect := ExchValidator.Section; + + if not ExchValidator.Call.IsEmpty then + Qso.Call := ExchValidator.Call; + + Qso.Exch1 := format('%d %s', [Qso.Nr, Qso.Prec]); + Qso.Exch2 := format('%.02d %s', [Qso.Check, Qso.Sect]); +end; + + +// return status bar information string from SSCW call history file. +// this string is used in MainForm.sbar.Caption (status bar). +// Format: ' - ' +function TSweepstakes.GetStationInfo(const ACallsign: string) : string; +var + ssrec : TSweepstakesCallRec; +begin + if FindCallRec(ssrec, ACallsign) and not ssrec.UserText.IsEmpty then + result:= ACallsign + ' - ' + ssrec.UserText + else + result:= ''; +end; + + +function TSweepstakes.getCall(id:integer): string; // returns station callsign +begin + result := SweepstakesCallList.Items[id].Call; +end; + + +{ + Called by TDxStation.CreateStation. + Constructs the Exchange values for this station. + Overriden for complex exchanges. +} +procedure TSweepstakes.GetExchange(id : integer; out station : TDxStation); +const + PrecedenceTbl: array[0..5] of string = ('Q', 'A', 'B', 'U', 'M', 'S'); +begin + station.NR := GetRandomSerialNR; // serial number + station.Prec := PrecedenceTbl[Random(6)]; + station.Chk := SweepstakesCallList.Items[id].Check; + station.Sect := SweepstakesCallList.Items[id].Section; + station.UserText := SweepstakesCallList.Items[id].UserText; + + // Exch1: (e.g. 123 A) + station.Exch1 := format('%d %s', [station.NR, station.Prec]); + + // Exch2:
(e.g. 72 OR) + station.Exch2 := format('%.02d %s', [station.Chk, station.Sect]); +end; + + +class function TSweepstakesCallRec.compareCall(const left, right: TSweepstakesCallRec) : integer; +begin + Result := CompareStr(left.Call, right.Call); +end; + + +function TSweepstakesCallRec.GetString: string; // returns (.e.g 'A 72 OR') +begin + Result := Format(' - CK %.02d, Sect %s', [Check, Section]); +end; + + +{ + Extract multiplier string for ARRL Sweepstakes Contest. + + ARRL Sweepstakes Rules state: + "Each contact counts for 2 QSO points. To calculate your final score, + multiply the total QSO points by the number of ARRL and RAC sections + you contacted." + + Sets contest-specific Qso.Points for this QSO. + Returns ARRL/RAC Section string. +} +function TSweepstakes.ExtractMultiplier(Qso: PQso) : string; +begin + Qso^.Points := 2; + Result := Qso^.Sect; +end; + + +{ + MRCE will insert
into the exchange field to match + other logging program behaviors. Periodically this value will be modified + so the user has to correct the string being copied. +} +function TSweepstakes.GetCheckSection(const ACallsign: string; + AThreshold: extended): String; +var + ssrec: TSweepstakesCallRec; + section: string; +begin + if FindCallRec(ssrec, ACallsign) then + begin + if (Random < AThreshold) then + section := GetAlternateSection(ssrec.Section) + else + section := ssrec.Section; + result := format('%.02d %s', [ssrec.Check, section]); + end + else + result:= ''; +end; + +function TSweepstakes.GetAlternateSection(const ASection: string): string; +var + index: integer; +begin + index := Sections2Idx.Items[ASection]; + if ((Random < 0.5) and (index > 0)) or (index = High(SectionsTbl)) then + Dec(index) + else + Inc(index); + Result := SectionsTbl[index]; +end; + + +function TSweepstakes.IsNum(Num: String): Boolean; +var + X : Integer; +begin + Result := Length(Num) > 0; + for X := 1 to Length(Num) do begin + if Pos(copy(Num,X,1),'0123456789') = 0 then begin + Result := False; + Exit; + end; + end; +end; + + +end. + + + diff --git a/DxStn.pas b/DxStn.pas index 09ec0c0..7ad9def 100644 --- a/DxStn.pas +++ b/DxStn.pas @@ -217,7 +217,7 @@ procedure TDxStation.SendMsg(AMsg: TStationMessage); if BDebugExchSettings and (AMsg in [msgNR, msgR_NR, msgR_NR2, msgDeMyCallNr1, msgDeMyCallNr2, msgMyCallNr1, msgMyCallNr2]) then begin - if (Mainform.Edit2.Text = '') then + if (Mainform.Edit2.Text = '') and not (SimContest in [scArrlSS]) then Mainform.Edit2.Text := Exch1; if (Mainform.Edit3.Text = '') and ((SimContest <> scNaQp) or (Exch2 <> 'DX')) then @@ -240,6 +240,10 @@ procedure TDxStation.DataToLastQso; etRST: TrueExch1 := IntToStr(Self.RST); etOpName: TrueExch1 := Self.OpName; etFdClass: TrueExch1 := Self.Exch1; + etSSNrPrecedence: begin + TrueNR := Self.NR; + TruePrec := Self.Prec; + end; else assert(false); end; @@ -255,6 +259,10 @@ procedure TDxStation.DataToLastQso; etJaPref: TrueExch2 := Self.Exch2; etJaCity: TrueExch2 := Self.Exch2; etNaQpExch2, etNaQpNonNaExch2: TrueExch2 := Self.Exch2; + etSSCheckSection: begin + TrueCheck := Self.Chk; // check (e.g. 72) + TrueSect := Self.Sect; // section (e.g. OR) + end else assert(false); end; diff --git a/ExchFields.pas b/ExchFields.pas index 9427e0d..db01257 100644 --- a/ExchFields.pas +++ b/ExchFields.pas @@ -13,12 +13,12 @@ interface type // Exchange Field #1 types - TExchange1Type = (etRST, etOpName, etFdClass); + TExchange1Type = (etRST, etOpName, etFdClass, etSSNrPrecedence); // Exchange Field #2 Types TExchange2Type = (etSerialNr, etGenericField, etArrlSection, etStateProv, etCqZone, etItuZone, etAge, etPower, etJaPref, etJaCity, - etNaQpExch2, etNaQpNonNaExch2); + etNaQpExch2, etNaQpNonNaExch2, etSSCheckSection); { Defines the characteristics and behaviors of an exchange field. @@ -44,6 +44,8 @@ TFieldDefinition = record (C: 'RST'; R: '[1-5E][1-9N][1-9N]'; L: 3; T:Ord(etRST)) ,(C: 'Name'; R: '[A-Z][A-Z]*'; L: 10; T:Ord(etOpName)) ,(C: 'Class'; R: '[1-9][0-9]*[A-F]'; L: 3; T:Ord(etFdClass)) + // ARRL SS does not parse user-entered Exchange 1 field; Exchange 2 field is used. + ,(C: ''; R: '([0-9]+|#)? *[QABUMS]'; L: 4; T:Ord(etSSNrPrecedence)) ); // Exchange Field 2 settings/rules @@ -63,6 +65,8 @@ TFieldDefinition = record // Non-NA stations send name only ,(C: 'State'; R: '([0-9A-Z/]*)'; L: 6; T:Ord(etNaQpExch2)) ,(C: 'State'; R: '()|([0-9A-Z/]*)'; L: 6; T:Ord(etNaQpNonNaExch2)) + ,(C: 'Nr Prec Call CK Sect'; + R: '[0-9ONT]{1,2} +[A-Z]+'; L: 32; T:Ord(etSSCheckSection)) ); implementation diff --git a/Ini.pas b/Ini.pas index acbf21b..712b3ec 100644 --- a/Ini.pas +++ b/Ini.pas @@ -27,7 +27,7 @@ interface type // Adding a contest: Append new TSimContest enum value for each contest. TSimContest = (scWpx, scCwt, scFieldDay, scNaQp, scHst, scCQWW, scArrlDx, - scSst, scAllJa, scAcag, scIaruHf); + scSst, scAllJa, scAcag, scIaruHf, scArrlSS); TRunMode = (rmStop, rmPileup, rmSingle, rmWpx, rmHst); // Serial NR types @@ -200,7 +200,22 @@ TContestDefinition = record ExchFieldEditable: True; ExchDefault: '5NN 6'; Msg: '''RST '' (e.g. 5NN 6)'; - T:scIaruHf) + T:scIaruHf), + + (Name: 'ARRL Sweepstakes'; + Key: 'SSCW'; + ExchType1: etSSNrPrecedence; // full exchange info is entered via Exch2; or my serial number (sent) + ExchType2: etSSCheckSection; + ExchFieldEditable: True; + ExchDefault: 'A 72 OR'; + Msg: '''[#|123]
'' (e.g. A 72 OR)'; + T:scArrlSS) + // Entered Exchange: # *
+ // where precedence={Q,A,B,U,M,S}, check='year licenced', ARRL/RAC section. + // Sent Exchange: # A W7SST 72 OR + // Fields: NR:numeric, Prec:string, Check:numeric, Section:string + // N1MM default ordering w/ call history: 72 OR. I type 123A + // N1MM automatic rendering: 123A 72 OR ); var @@ -239,6 +254,7 @@ TContestDefinition = record NoActivityCnt: integer=0; NoStopActivity: integer=0; GetWpmUsesGaussian: boolean = false; + ShowCheckSection: integer=50; Duration: integer = 30; RunMode: TRunMode = rmStop; @@ -417,6 +433,7 @@ procedure FromIni(cb : TErrMessageCallback); WpmStepRate := Max(1, Min(20, ReadInteger(SEC_SET, 'WpmStepRate', WpmStepRate))); RitStepIncr := ReadInteger(SEC_SET, 'RitStepIncr', RitStepIncr); RitStepIncr := Max(-500, Min(500, RitStepIncr)); + ShowCheckSection := ReadInteger(SEC_SET, 'ShowCheckSection', ShowCheckSection); // [Debug] DebugExchSettings := ReadBool(SEC_DBG, 'DebugExchSettings', DebugExchSettings); @@ -499,6 +516,7 @@ procedure ToIni; WriteInteger(SEC_SET, 'FarnsworthCharacterRate', FarnsworthCharRate); WriteInteger(SEC_SET, 'WpmStepRate', WpmStepRate); WriteInteger(SEC_SET, 'RitStepIncr', RitStepIncr); + WriteInteger(SEC_SET, 'ShowCheckSection', ShowCheckSection); finally Free; diff --git a/Log.pas b/Log.pas index 62b330e..195370f 100644 --- a/Log.pas +++ b/Log.pas @@ -47,7 +47,8 @@ procedure DebugLnExit(const AFormat: string; const AArgs: array of const) overlo type TLogError = (leNONE, leNIL, leDUP, leCALL, leRST, leNAME, leCLASS, leNR, leSEC, leQTH, - leZN, leSOC, leST, lePWR, leERR); + leZN, leSOC, leST, lePWR, leERR, + lePREC, leCHK); PQso = ^TQso; TQso = record @@ -55,6 +56,9 @@ TQso = record Call, TrueCall, RawCallsign: string; Rst, TrueRst: integer; Nr, TrueNr: integer; + Prec, TruePrec: string; // SS' Precedence character + Check, TrueCheck: integer; // SS' Chk (year licensed) + Sect, TrueSect: string; // SS' Arrl/RAC Section Exch1, TrueExch1: string; // exchange 1 (e.g. 3A, OpName) Exch2, TrueExch2: string; // exchange 2 (e.g. OR, CWOPSNum) TrueWpm: string; // WPM of sending DxStn (reported in log) @@ -175,6 +179,9 @@ implementation WPX_EXCH_COL = 'Exch,6,L'; HST_EXCH_COL = 'Exch,6,L'; CQ_ZONE_COL = 'CQ-Zone,7,L'; + SS_PREC_COL = 'Pr,2,C'; + SS_CHECK_COL = 'Chk,3,C'; + SS_SECT_COL = 'Sect,4,L'; {$ifdef DEBUG} DEBUG_INDENT: Integer = 3; @@ -249,6 +256,7 @@ function FormatScore(const AScore: integer):string; procedure TQso.SetColumnErrorFlag(AColumnInx: integer); begin + assert((AColumnInx > -1) and (AColumnInx < 32)); if AColumnInx <> -1 then ColumnErrorFlags := ColumnErrorFlags or (1 shl AColumnInx); end; @@ -259,7 +267,7 @@ function TQso.TestColumnErrorFlag(ColumnInx: Integer): Boolean; end; { - Initialize the Log Report. + Initialize the Call Log Report. An array of ColDefs is passed in with one entry for each column. Each column definition string is defined as follows: @@ -446,6 +454,11 @@ procedure Clear; ScoreTableInit([UTC_COL, CALL_COL, NAME_COL, SST_EXCH_COL, CORRECTIONS_COL, WPM_FARNS_COL]); scFieldDay: ScoreTableInit([UTC_COL, CALL_COL, FD_CLASS_COL, ARRL_SECT_COL, CORRECTIONS_COL, WPM_COL]); + scArrlSS: + begin + ScoreTableInit([UTC_COL, CALL_COL, NR_COL, SS_PREC_COL, SS_CHECK_COL, ARRL_SECT_COL, CORRECTIONS_COL, WPM_COL]); + SetExchColumns(2, 4, 3, 5); + end; scNaQp: ScoreTableInit([UTC_COL, 'Call,8,L', NAME_COL, STATE_PROV_COL, PREFIX_COL, CORRECTIONS_COL, WPM_COL]); scCQWW: @@ -818,7 +831,8 @@ procedure SaveQso; MainForm.WipeBoxes; //inc NR - if Tst.Me.SentExchTypes.Exch2 = etSerialNr then + if (Tst.Me.SentExchTypes.Exch1 in [etSSNrPrecedence]) or + (Tst.Me.SentExchTypes.Exch2 in [etSerialNr]) then Inc(Tst.Me.NR); end; @@ -898,6 +912,13 @@ procedure LastQsoToScreen; , format('%.3d', [Rst]) , Exch2 , Err, format('%3s', [TrueWpm])); + scArrlSS: + ScoreTableInsert(FormatDateTime('hh:nn:ss', t), Call + , format('%4d', [NR]) + , Prec + , format('%.2d', [Check]) + , Sect + , Err, format('%3s', [TrueWpm])); else assert(false, 'missing case'); end; @@ -915,6 +936,11 @@ procedure TQso.CheckExch1(var ACorrections: TStringList); etRST: if TrueRst <> Rst then Exch1Error := leRST; etOpName: if TrueExch1 <> Exch1 then Exch1Error := leNAME; etFdClass: if TrueExch1 <> Exch1 then Exch1Error := leCLASS; + etSSNrPrecedence: begin + // For ARRL SS, exchange 1 tests the raw NR and Prec values + if TrueNR <> NR then Exch1Error := leNR; + if TruePrec <> Prec then Exch1ExError := lePrec; + end else assert(false, 'missing exchange 1 case'); end; @@ -922,9 +948,13 @@ procedure TQso.CheckExch1(var ACorrections: TStringList); case Exch1Error of leNONE: ; leRST: ACorrections.Add(Format('%d', [TrueRst])); + leNR: ACorrections.Add(Format('%d', [TrueNR])); else ACorrections.Add(TrueExch1); end; + case Exch1ExError of + lePrec: ACorrections.Add(TruePrec); + end; end; @@ -985,6 +1015,10 @@ procedure TQso.CheckExch2(var ACorrections: TStringList); if not (TrueExch2.Equals(Exch2) or (Exch2.Equals('DX') and TrueExch2.IsEmpty)) then Exch2Error := leST; + etSSCheckSection: begin + if TrueCheck <> Check then Exch2Error := leCHK; + if TrueSect <> Sect then Exch2ExError := leSEC; + end else assert(false, 'missing exchange 2 case'); end; @@ -997,14 +1031,23 @@ procedure TQso.CheckExch2(var ACorrections: TStringList); assert(Mainform.RecvExchTypes.Exch2 = etSerialNr); ACorrections.Add(format('%.4d', [TrueNR])); end + else if (SimContest = scArrlSS) then + ACorrections.Add(TrueSect) else ACorrections.Add(TrueExch2); + leCHK: + ACorrections.Add(format('%.02d', [TrueCheck])); else ACorrections.Add(TrueExch2); end; case Exch2ExError of leNONE: ; + leSEC: + begin + assert(SimContest = scArrlSS); + ACorrections.Add(TrueSect); + end; else assert(false); end; @@ -1016,7 +1059,8 @@ procedure CheckErr; ErrorStrs: array[TLogError] of string = ( '', 'NIL', 'DUP', 'CALL', 'RST', 'NAME', 'CL', 'NR', 'SEC', 'QTH', - 'ZN', 'SOC', 'ST', 'PWR', 'ERR'); + 'ZN', 'SOC', 'ST', 'PWR', 'ERR', + 'PREC', 'CHK'); var Corrections: TStringList; begin diff --git a/Main.pas b/Main.pas index 8b3d718..0b5ec84 100644 --- a/Main.pas +++ b/Main.pas @@ -381,6 +381,10 @@ function ToStr(const val : TExchange2Type): string; overload; var MainForm: TMainForm; + SaveEdit1Width: integer = 0; + SaveLabel3Left: integer = 0; + SaveEdit3Left: integer = 0; + SaveEdit3Width: integer = 0; { debug switches - set via .INI file or compile-time switches (above) } BDebugExchSettings: boolean; // display parsed Exchange field settings @@ -391,7 +395,7 @@ implementation uses ARRL, ARRLFD, NAQP, CWOPS, CQWW, CQWPX, ARRLDX, CWSST, ALLJA, ACAG, - IARUHF, + IARUHF, ARRLSS, MorseKey, FarnsKeyer, CallLst, SysUtils, ShellApi, Crc32, Idhttp, Math, IniFiles, Dialogs, System.UITypes, TypInfo, ScoreDlg, Log, PerlRegEx, StrUtils; @@ -489,6 +493,7 @@ function TMainForm.CreateContest(AContestId : TSimContest) : TContest; scAllJa: Result := TALLJA.Create; scAcag: Result := TACAG.Create; scIaruHf: Result := TIaruHf.Create; + scArrlSS: Result := TSweepstakes.Create; else assert(false); end; @@ -654,6 +659,12 @@ procedure TMainForm.Edit3KeyPress(Sender: TObject; var Key: Char); if not CharInSet(Key, ['0'..'9', 'L', 'M', 'H', 'P', 'l', 'm', 'h', 'p', #8]) then Key := #0; end; + etSSCheckSection: + begin + // valid NR/Prec/Call/Check/Section characters + if not CharInSet(Key, ['0'..'9', 'A'..'Z', 'a'..'z', '/', #32, #8]) then + Key := #0; + end else assert(false, Format('invalid exchange field 2 type: %s', [ToStr(RecvExchTypes.Exch2)])); @@ -711,7 +722,8 @@ procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char); end; ' ': // advance to next exchange field - if ActiveControl <> ExchangeEdit then + if (ActiveControl <> ExchangeEdit) and + not ((ActiveControl = Edit3) and (SimContest = scArrlSS)) then ProcessSpace else Exit; @@ -827,7 +839,10 @@ procedure TMainForm.ProcessSpace; begin if SimContest = scFieldDay then UpdateSbar(Edit1.Text); - ActiveControl := Edit2; + if SimContest = scArrlSS then + ActiveControl := Edit3 + else + ActiveControl := Edit2; end else if ActiveControl = Edit2 then ActiveControl := Edit3 @@ -904,9 +919,14 @@ procedure TMainForm.ProcessEnter; //current state C := CallSent; N := NrSent; // 'Nr' represents the exchange ( ). - Q := Edit2.Text <> ''; - R := (Edit3.Text <> '') or ((SimContest = scNaQp) and - (RecvExchTypes.Exch2 = etNaQpNonNaExch2)); + Q := (Edit2.Text <> '') or (SimContest in [scArrlSS]); + case SimContest of + scArrlSS: + R := Tst.ValidateEnteredExchange(Edit1.Text, Edit2.Text, Edit3.Text, ExchError); + else + R := (Edit3.Text <> '') or ((SimContest = scNaQp) and + (RecvExchTypes.Exch2 = etNaQpNonNaExch2)); + end; //send his call if did not send before, or if call changed if (not C) or ((not N) and (not R)) then @@ -1017,7 +1037,7 @@ procedure TMainForm.SetContest(AContestNum: TSimContest); // Adding a contest: add each contest to this set. TODO - implement alternative // validate selected contest if not (AContestNum in [scWpx, scCwt, scFieldDay, scNaQp, scHst, - scCQWW, scArrlDx, scSst, scAllJa, scAcag, scIaruHf]) then + scCQWW, scArrlDx, scSst, scAllJa, scAcag, scIaruHf, scArrlSS]) then begin ShowMessage('The selected contest is not yet supported.'); SimContestCombo.ItemIndex := @@ -1091,6 +1111,10 @@ procedure TMainForm.SetContest(AContestNum: TSimContest); My "sent" exchange types (Tst.Me.SentExchTypes) have been previously set by SetMyCall(). + + Beginning with ARRL Sweepstakes contest, the exchange will have more than + two values, namely '# A 72 OR'. For the case of ARRL Sweepstakes, we will + break this into two pieces: Exch1='# A', Exch2='72 OR'. } function TMainForm.SetMyExchange(const AExchange: string) : Boolean; var @@ -1104,8 +1128,8 @@ function TMainForm.SetMyExchange(const AExchange: string) : Boolean; 'set by TMainForm.SetMyCall'); SentExchTypes := Tst.Me.SentExchTypes; - // parse into two strings [Exch1, Exch2] - // validate sent exchange strings + // ValidateMyExchange will parse user-entered exchange and + // return Exch1 and Exch2 tokens. if not Tst.ValidateMyExchange(AExchange, sl, ExchError) then begin Result := False; @@ -1128,6 +1152,20 @@ function TMainForm.SetMyExchange(const AExchange: string) : Boolean; sbar.Caption := ''; end; + // restore Edit3 if not ARRL Sweepstakes + if (SimContest <> scArrlSS) and (SaveEdit3Left <> 0) then + begin + Edit1.Width := SaveEdit1Width; + Label3.Left := SaveLabel3Left; + Edit3.Left := SaveEdit3Left; + Edit3.Width := SaveEdit3Width; + Label2.Show; + Edit2.Show; + SaveLabel3Left := 0; + SaveEdit3Left := 0; + SaveEdit3Width := 0; + end; + // set contest-specific sent exchange values SetMyExch1(SentExchTypes.Exch1, sl[0]); SetMyExch2(SentExchTypes.Exch2, sl[1]); @@ -1270,6 +1308,10 @@ procedure TMainForm.ConfigureExchangeFields; procedure TMainForm.SetMyExch1(const AExchType: TExchange1Type; const Avalue: string); +const + DIGITS = ['0'..'9']; +var + L: integer; begin // Adding a contest: setup contest-specific exchange field 1 case AExchType of @@ -1299,6 +1341,63 @@ procedure TMainForm.SetMyExch1(const AExchType: TExchange1Type; Tst.Me.Exch1 := Avalue; if BDebugExchSettings then Edit2.Text := Avalue; // testing only end; + etSSNrPrecedence: + begin + // Active during ARRL Sweepstakes contest. + // '#A' | '# A' | '123A' | '123 A' | 'A' + // --> Exch1 = 'A' | ' A' // optional leading space + // We want to send what is specified. If they say, '#A', then so space. + // We can can store leading space in Tst.Me.Exch1 = ' A', so strip + // the leading '#' or numeric ('123'). + // - pull the leading numeric or '#' and store in NumberStr + // - convert '' to '''' + // - convert ' ' to '' ' ' + // - insert leading space if count=2 + Ini.UserExchange1[SimContest] := Avalue; + + if Avalue.IsEmpty then + begin + Tst.Me.NR := 1; + Tst.Me.Exch1 := ''; + end + else if Avalue[1] = '#' then + begin + // optional leading '#' ('#A' | '# A') + if SerialNR in [snMidContest, snEndContest] then + Tst.Me.NR := 1 + (Tst.GetRandomSerialNR div 10) * 10 + else + Tst.Me.NR := 1; + L := 2; + if Avalue[L] = ' ' then + while Avalue[L+1] = ' ' do + Inc(L); + Tst.Me.Exch1 := Avalue.Substring(L-1); + end + else if CharInSet(Avalue[1], DIGITS) then + begin + // optional leading serial number ('123A' | '123 A') + L := 1; + repeat + Inc(L) + until not CharInSet(Avalue[L], DIGITS); + Tst.Me.NR := AValue.Substring(0,L-1).ToInteger; + if Avalue[L] = ' ' then + while Avalue[L+1] = ' ' do + Inc(L); + Tst.Me.Exch1 := Avalue.Substring(L-1); + if BDebugExchSettings then Edit2.Text := Avalue; // testing only + end + else + begin + // no leading serial number. use assigned serial number behavior. + if SerialNR in [snMidContest, snEndContest] then + Tst.Me.NR := 1 + (Tst.GetRandomSerialNR div 10) * 10 + else + Tst.Me.NR := 1; + Tst.Me.Exch1 := ' ' + Avalue; + end; + if BDebugExchSettings then Edit2.Text := Avalue; // testing only + end; else assert(false, Format('Unsupported exchange 1 type: %s.', [ToStr(AExchType)])); end; @@ -1375,6 +1474,33 @@ procedure TMainForm.SetMyExch2(const AExchType: TExchange2Type; Tst.Me.Exch2 := Avalue; if BDebugExchSettings then Edit3.Text := Avalue; // testing only end; + etSSCheckSection: + begin + // retain current field sizes + SaveEdit1Width := Edit1.Width; + SaveLabel3Left := Label3.Left; + SaveEdit3Left := Edit3.Left; + SaveEdit3Width := Edit3.Width; + + // hide Exch1 (Edit2) + Edit2.Hide; + Label2.Hide; + + // reduce Edit1 width; shift Exch Field 2 to the left and grow + var Reduce1: integer := (SaveEdit1Width * 4) div 9; + Label3.Left := Label3.Left - (Label3.Left - Label2.Left) - Reduce1; + Edit3.Left := Edit2.Left - Reduce1; + Edit3.Width := Edit3.Width + (SaveEdit3Left - Edit2.Left + Reduce1 + 15); + Edit1.Width := Edit1.Width - Reduce1; + + Ini.UserExchange2[SimContest] := Avalue; // (e.g. 72 OR) + Tst.Me.Exch2 := Avalue; + if BDebugExchSettings then + begin + Edit3.Text := Edit2.Text + ' ' + Avalue; // testing only + Edit2.Text := ''; + end; + end; else assert(false, Format('Unsupported exchange 2 type: %s.', [ToStr(AExchType)])); end; @@ -2059,10 +2185,22 @@ procedure TMainForm.Advance; else begin { otherwise advance to next field, skipping RST } - if Edit2IsRST then + if Edit2IsRST or not Edit2.Showing then ActiveControl := Edit3 else ActiveControl := Edit2; + + if (SimContest = scArrlSS) and + (Ini.ShowCheckSection > 0) and + (ActiveControl = Edit3) and (Edit3.Text = '') and + (Random < (ShowCheckSection/100)) then + begin + var S: string := (Tst as TSweepstakes).GetCheckSection(Edit1.Text, 0.25); + if not S.IsEmpty then + S := S + ' '; + Edit3.Text := S; + Edit3.SelStart := S.Length; + end; end; MustAdvance := false; diff --git a/MorseRunner.dpr b/MorseRunner.dpr index d3c6d07..3c6f3ee 100644 --- a/MorseRunner.dpr +++ b/MorseRunner.dpr @@ -37,6 +37,7 @@ uses PerlRegEx in 'PerlRegEx\PerlRegEx.pas', ARRL in 'ARRL.pas', ArrlFd in 'ArrlFd.pas', + ArrlSS in 'ArrlSS.pas', NaQp in 'NaQp.pas', CWOPS in 'CWOPS.pas', CqWW in 'CqWW.pas', @@ -48,7 +49,9 @@ uses IaruHf in 'IaruHf.pas', ExchFields in 'ExchFields.pas', SerNRGen in 'SerNRGen.pas', - Lexer in 'Util\Lexer.pas'; + Lexer in 'Util\Lexer.pas', + ArrlSections in 'Util\ArrlSections.pas', + SSExchParser in 'Util\SSExchParser.pas'; {$R *.RES} diff --git a/MorseRunner.dproj b/MorseRunner.dproj index b8dbfb9..da2022e 100644 --- a/MorseRunner.dproj +++ b/MorseRunner.dproj @@ -155,6 +155,7 @@ + @@ -167,6 +168,8 @@ + + Base @@ -287,6 +290,12 @@ + + + MorseRunner.exe + true + + 1 diff --git a/Readme.txt b/Readme.txt index e658304..d46c5da 100644 --- a/Readme.txt +++ b/Readme.txt @@ -469,6 +469,48 @@ CONTEST INFORMATION F: Emergency Operation Centers Rules: https://contests.arrl.org/ContestRules/Field-Day-Rules.pdf + ARRL Sweepstates + When: First full weekend in November + How: Stations in US/Canada exchange information with other US/Canada stations. + Exchange:
+ where: + Serial number: sequential serial number for each contact + Precedence: A, B, Q, M, S, U + Callsign: your call sign + Check: last two digits of the year the operator or station was first licenced + Section: ARRL/RAC Section + for example: "123 A 72 OR" + Rules: https://contests.arrl.org/ContestRules/SS-Rules.pdf + Entering your Exchange: + - This contest uses a single field to enter the four parts of the SS-Rules + exchange. The exchange parts can be entered in any order as long as the + 'numeric part' is followed by its corresponding 'character part.' + - For example, the two exchange parts can be entered in either order: + a) "123 A 72 OR" + b) "72 OR 123 A" + - If a correction needs to be made, just type it at the end. For example, + while copying you realize a mistake (123 should be 124). In this case, + simply type the correction at the end: + "123 A 72 OR 124 A" + This allows corrections to be made while you are copying the exchange + without using any arrow, delete or backspace keys. + - The spaces between the numeric and characters parts are optional. + The following are equivalent: + "123 A 72 OR" + "123A 72OR" + "72 OR 123 A" + "72OR 123A" + - Callsigns corrections can be optionally entered into the Exchange field. + If the caller sends a corrected callsign, you can enter the updated call + anywhere in the exchange field without changing focus to the original + callsign entry field. For example, entering "W1AW 123 A 38 CT" will + update the callsign when storing the QSO into the log. + - For added realism, the simulation will populate the exchange field + with the Check and Section entries for the entered callsign. This + behavior matches current N1MM behavior. However, the simulation will + occasionally modify the Section to simulate that the operator is + operating from a different location. + CQ WPX When: Last weekend in May How: Multi may operate 48 hours, Singles may work 36 hours. diff --git a/Station.pas b/Station.pas index 42946ea..5ccf58d 100644 --- a/Station.pas +++ b/Station.pas @@ -93,6 +93,9 @@ TStation = class (TCollectionItem) NR, RST: integer; MyCall, HisCall: string; OpName: string; + Prec: string; // Sweepstakes precedence character (one of: QABUMS) + Chk: integer; // Sweepstakes check value (first year licensed) + Sect: string; // Sweepstakes Section value (ARRL/RAC Section) Exch1: string; // Exchange field 1 (e.g. class, name, etc.) Exch2: string; // Exchange field 2 (e.g. zone, state/prov, section, grid, etc.) UserText: string; // club name or description (from fdHistory file) @@ -377,6 +380,11 @@ function TStation.NrAsText: string; Result := Format('%s %s', [Exch1, Exch2]); scAllJa, scAcag: Result := Format('%s %s', [Exch1, Exch2]); + scArrlSS: + if Call = MyCall then + Result := Format('%d%s %s %s', [NR, Exch1, MyCall, Exch2]) + else + Result := Format('%s %s %s', [Exch1, MyCall, Exch2]); else if Call = MyCall then Result := Format('%d%.3d', [RST, NR]) @@ -384,7 +392,7 @@ function TStation.NrAsText: string; var pRange : PSerialNRSettings := @Ini.SerialNRSettings[Ini.SerialNR]; // R1 is a random number assigned when this station was created. // It provides a consistent result since this function is called - // mutliple times. + // multiple times. if R1 < 0.5 then // add leading zeros digits := pRange.minDigits else diff --git a/Util/ArrlSections.pas b/Util/ArrlSections.pas new file mode 100644 index 0000000..a6ba730 --- /dev/null +++ b/Util/ArrlSections.pas @@ -0,0 +1,65 @@ +unit ArrlSections; + +interface + +uses + Generics.Collections; // for TList<> + +type + TArrlSections = class + Sections: TList; + end; + +const + // https://contests.arrl.org/contestmultipliers.php?a=wve + SectionsTbl: array[0..84] of PCHAR = ( + // Call Area 0 + 'CO', 'IA', 'KS', 'MN', 'MO', + 'ND', 'NE', 'SD', + + // Call Area 1 + 'CT', 'EMA', 'ME', 'NH', 'RI', + 'VT', 'WMA', + + // Call Area 2 + 'ENY', 'NLI', 'NNJ', 'NNY', 'SNJ', + 'WNY', + + // Call Area 3 + 'DE', 'EPA', 'MDC', 'WPA', + + // Call Area 4 + 'AL', 'GA', 'KY', 'NC', 'NFL', + 'SC', 'SFL', 'TN', 'VA', 'WCF', + 'PR', 'VI', + + // Call Area 5 + 'AR', 'LA', 'MS', 'NM', 'NTX', + 'OK', 'STX', 'WTX', + + // Call Area 6 + 'EB', 'LAX', 'ORG', 'SB', 'SCV', + 'SDG', 'SF', 'SJV', 'SV', 'PAC', + + // Call Area 7 + 'AK', 'AZ', 'EWA', 'ID', 'MT', + 'NV', 'OR', 'UT', 'WWA', 'WY', + + // Call Area 8 + 'MI', 'OH', 'WV', + + // Call Area 9 + 'IL', 'IN', 'WI', + + // RAC Sections + 'AB', 'BC', 'GH', 'MB', 'NB', + 'NL', 'NS', 'ONE', 'ONN', 'ONS', + 'PE', 'QC', 'SK', 'TER' + ); + +implementation + + +end. + + diff --git a/Util/SSExchParser.pas b/Util/SSExchParser.pas new file mode 100644 index 0000000..07ba7bf --- /dev/null +++ b/Util/SSExchParser.pas @@ -0,0 +1,559 @@ +unit SSExchParser; + +interface + +uses + Lexer, + System.Generics.Collections, // TObjectList + System.Classes, // TStringList + PerlRegEx; // for regular expression support (TPerlRegEx, TPerlRegExList) + +type + TExchTokenType = ( + ttEOS, // End of String token + ttDigit1, // numeric token, 1-digit + ttDigit2, // numeric token, 2-digit + ttDigits, // numeric token, 3 or more digits + ttAlpha, // Alpha characters only token + ttCallsign, // callsign token + ttPrec, // Precedence token (added by TSSLexer) + ttSect); // Section token (added by TSSLexer) + + TSSExchToken = class + TokenType: TExchTokenType; + Value: string; + Pos: integer; + + constructor Create; overload; + constructor Create(const token: TExchToken); overload; + constructor Create(const token: TSSExchToken); overload; + + procedure Clear; + procedure Init(const token: TExchToken); overload; + procedure Init(const token: TSSExchToken); overload; + function IsValid: Boolean; + end; + + TSSLexer = class(TLexer) + private + Sections: TStringList; + public + constructor Create; + destructor Destroy; override; + + function NextToken(var AToken: TExchToken): Boolean; override; + function IsValidCall(const Call: string): Boolean; + function IsValidSection(const Section: string): Boolean; + end; + + TMyExchParser = class + private + Reg : TPerlRegEx; + Lexer: TLexer; + protected + FErrorStr: String; + public + constructor Create; + destructor Destroy; override; + + function ParseMyExch(const AExchange: string): boolean; + function GroupByName(const name: string): string; + + public + property ErrorStr: string read FErrorStr; + end; + + TSSExchParser = class + private + protected + IsValidExchange: Boolean; + Lexer: TSSLexer; + PreviousCall: String; + Tokens: TObjectList; + TwoDigitList: TList; // insert each new 2digit token into this list (mru at 0) + CheckTokenstack: TStack; // each new check token is pushed + UnboundNRs: TStack; // holds 's not yet bound to + NRToken: TSSExchToken; + PrecedenceToken: TSSExchToken; + CheckToken: TSSExchToken; + SectionToken: TSSExchToken; + FExchError: String; // most recent exchange parsing error + procedure Reset; + + public + NR: Integer; + Precedence: String; + Check: String; + Section: String; + Call: String; + property ExchError: String read FExchError; + + constructor Create; + destructor Destroy; override; + + function ValidateEnteredExchange(const ACall, AExch1, AExch2: string; + out AExchError: String) : boolean; + end; + +{$ifdef DEBUG} + var + // helpful for enabling breakpoints in the debugger while running UnitTests + DbgBreak: Boolean = False; +{$endif} + + const + SSLexerRules: array[0..4] of TTokenRuleDef = ( + // - https://en.wikipedia.org/wiki/Amateur_radio_call_signs + // - the leading positive-lookbehind ('(<=\b)') makes sure there is + // whitespace before the callsign. + // (See: https://www.regular-expressions.info/lookaround.html) + (R: '(?<=\b)([A-Z\d]{2,}\/)?([A-Z]{1,2}|\d[A-Z]|[A-Z]\d|\d[A-Z]{2})([0-9])([A-Z\d]*[A-Z])(\/[A-Z\d]+)?(\/[A-Z\d]+)?\b'; + T: Ord(ttCallsign)), + (R: '\d\d\d+'; T: Ord(ttDigits)), + (R: '\d\d'; T: Ord(ttDigit2)), + (R: '\d'; T: Ord(ttDigit1)), + (R: '[A-Z]+'; T: Ord(ttAlpha)) + ); + +function ToStr(const val: TExchTokenType): String; overload; + +implementation + +uses + ArrlSections, // for ARRL/RAC Sections + TypInfo, // for typeInfo + StrUtils, + System.SysUtils; + +const + MyExchRegExpr: string = '^ *(?P(?P[0-9]+|#)? *(?P[QABUMS])) +' + + '(?P[0-9]{2}) *(?P[A-Z]+) *$'; + +function ToStr(const val: TExchTokenType): String; overload; +begin + Result := GetEnumName(typeInfo(TExchTokenType), Ord(val)); +end; + + +constructor TSSExchToken.Create; +begin + Clear; +end; + +constructor TSSExchToken.Create(const token: TExchToken); +begin + Init(token); +end; + +constructor TSSExchToken.Create(const token: TSSExchToken); +begin + TokenType := token.TokenType; + Value := token.Value; + Pos := token.Pos; +end; + +procedure TSSExchToken.Clear; +begin + TokenType := TExchTokenType(-1); + Value := ''; + Pos := -1; + assert(not IsValid); +end; + +procedure TSSExchToken.Init(const token: TExchToken); +begin + TokenType := TExchTokenType(token.TokenType); + Value := token.Value; + Pos := token.Pos; +end; + +procedure TSSExchToken.Init(const token: TSSExchToken); +begin + TokenType := token.TokenType; + Value := token.Value; + Pos := token.Pos; +end; + + +function TSSExchToken.IsValid: Boolean; +begin + Result := TokenType <> TExchTokenType(-1); +end; + +constructor TSSLexer.Create; +var + I: integer; +begin + inherited Create(SSLexerRules, True); + Sections := TStringList.Create(False); + + Sections.Capacity := High(SectionsTbl) - Low(SectionsTbl); + for I := Low(SectionsTbl) to High(SectionsTbl) do + Sections.Append(SectionsTbl[I]); + Sections.Sort; +end; + +destructor TSSLexer.Destroy; +begin + FreeAndNil(Sections); + inherited Destroy; +end; + +function TSSLexer.NextToken(var AToken: TExchToken): Boolean; +var + Index: Integer; +begin + Result := inherited NextToken(AToken); + if not Result then + Exit; + + case TExchTokenType(AToken.TokenType) of + ttAlpha: + if (AToken.Value.Length = 1) and + (System.Pos(AToken.Value, 'QABUMS') > 0) then + AToken.TokenType := Ord(ttPrec) + else if Sections.Find(AToken.Value, Index) then + AToken.TokenType := Ord(ttSect); + + ttDigit1: + // treat '0' as a possible 2-digit value (convert '0' to '00') + if AToken.Value.Equals('0') then + begin + AToken.TokenType := Ord(ttDigit2); + AToken.Value := '00'; + end; + end; +end; + + +function TSSLexer.IsValidCall(const Call: string): Boolean; +var + token: TExchToken; +begin + Input(Call); + Result := NextToken(token) and (token.TokenType = Integer(ttCallsign)); +end; + + +function TSSLexer.IsValidSection(const Section: string): Boolean; +var + Index: Integer; +begin + Result := Sections.Find(Section, Index); +end; + + +constructor TMyExchParser.Create; +begin + Lexer := TSSLexer.Create; + Reg := TPerlRegEx.Create; + Reg.RegEx := UTF8Encode(MyExchRegExpr); + Reg.Compile; + Reg.Study; +end; + + +destructor TMyExchParser.Destroy; +begin + FreeAndNil(Reg); + FreeAndNil(Lexer); +end; + + +function TMyExchParser.ParseMyExch(const AExchange: string): boolean; +const + Expected: string = '''[#|123]
'' (e.g. A 72 OR)'; +begin + assert(Reg.Compiled); + + Reg.Subject := UTF8Encode(AExchange); + Result := Reg.Match; + + FErrorStr := ''; + if not Result then + FErrorStr := format('invalid exchange ''%s''', [AExchange]); +end; + + +function TMyExchParser.GroupByName(const name: string): string; +begin + var Index: Integer := Reg.NamedGroup(UTF8String(name)); + assert(Index >= 0); + Result := String(Reg.Groups[Index]); +end; + + +{ TSSExchParser } + +constructor TSSExchParser.Create; +begin + Lexer := TSSLexer.Create; + Tokens := TObjectList.Create(True); + TwoDigitList:= TList.Create; + CheckTokenstack := TStack.Create; + UnboundNRs := TStack.Create; + PreviousCall := ''; + NRToken := nil; + PrecedenceToken := nil; + CheckToken := nil; + SectionToken := nil; +end; + +destructor TSSExchParser.Destroy; +begin + Reset; + TwoDigitList.Free; + CheckTokenstack.Free; + UnboundNRs.Free; + Tokens.Free; + FreeAndNil(Lexer); +end; + +procedure TSSExchParser.Reset; +begin + NRToken := nil; + PrecedenceToken := nil; + CheckToken := nil; + SectionToken := nil; + + Tokens.Clear; + TwoDigitList.Clear; + CheckTokenstack.Clear; + UnboundNRs.Clear; + + NR := 0; + Precedence := ''; + Check := ''; + Section := ''; + Call := ''; + + IsValidExchange := False; +end; + +function TSSExchParser.ValidateEnteredExchange(const ACall, AExch1, AExch2: string; + out AExchError: String) : boolean; +var + token: TSSExchToken; + NrIsBound: Boolean; // 1, 3, or 4-digit has been entered, + // or bound with or implied with
+begin + // optimization - return if user-entered exchange has not changed + if (ACall = PreviousCall) and +{$ifdef DEBUG} + not DbgBreak and +{$endif} + (AExch2 = Lexer.Buf) then + begin + AExchError := FExchError; + Result := IsValidExchange; + Exit; + end; + + Self.Reset; + AExchError := ''; + NrIsBound := False; + + try + Lexer.Input(AExch2); + PreviousCall := ACall; + + // Pass 1 -- build tokens array; grab callsign + begin + var token0: TExchToken; + while Lexer.NextToken(token0) do begin + case TExchTokenType(token0.TokenType) of + ttCallsign: + Call := token0.Value; + else + Tokens.Add(TSSExchToken.Create(token0)); + end; + end; + end; + + // Pass 2 -- process each token + var SkipNextToken: Boolean := False; + var I: Integer; + for I := 0 to Tokens.Count-1 do begin + if SkipNextToken then begin + SkipNextToken := False; + Continue; + end; + + token := Tokens[I]; + case token.TokenType of + ttDigit1, ttDigits: // one digit or three or more digits + begin + if token.Value.ToInteger > 10000 then + token.Value := '10000'; + + // is next token a possible Section value (length = 2 or 3)? + if ((I+1) < Tokens.Count) and + (Tokens[I+1].TokenType in [ttSect, ttAlpha]) and + (Tokens[I+1].Value.Length in [2,3]) then + begin + // Verify current token contains a valid Check value (00..99) + if token.Value.ToInteger < 100 then + begin + CheckToken := token; + CheckTokenstack.Clear; + TwoDigitList.Clear; + NrIsBound := True; + UnboundNRs.Push(token); + + if Tokens[I+1].TokenType = ttSect then + SectionToken := Tokens[I+1]; + end; + + SkipNextToken := True; + end + else // otherwise, treat this token as a serial NR + begin + NrToken := token; + NrIsBound := True; + UnboundNRs.Push(token); + + // Is next token a Precedence value? + if ((I+1) < Tokens.Count) and + (Tokens[I+1].TokenType in [ttPrec, ttAlpha]) and + (Tokens[I+1].Value.Length = 1) then + begin + if (Tokens[I+1].TokenType = ttPrec) or + (System.Pos(Tokens[I+1].Value, 'QABUMS') > 0) then + PrecedenceToken := Tokens[I+1]; + + SkipNextToken := True; + end + end; + end; + + ttDigit2: // two digits, 1st is Nr, 2nd is Chk + begin + TwoDigitList.Add(token); + + // is next token a possible Precedence value (length = 1) + if ((I+1) < Tokens.Count) and + (Tokens[I+1].TokenType in [ttPrec, ttAlpha]) and + (Tokens[I+1].Value.Length = 1) then + begin + NRToken := token; + TwoDigitList.Clear; + CheckTokenstack.Clear; + NrIsBound := True; + + if (Tokens[I+1].TokenType = ttPrec) or + (System.Pos(Tokens[I+1].Value, 'QABUMS') > 0) then + begin + PrecedenceToken := Tokens[I+1]; + SkipNextToken := True; + end; + end + + // Is next token a possible Section token (ttSect or ttAlpha with length [2,3] + else if ((I+1) < Tokens.Count) and + (Tokens[I+1].TokenType in [ttSect, ttAlpha]) and + (Tokens[I+1].Value.Length in [2,3]) then + begin + if not NrIsBound and (CheckTokenstack.Count > 0) then + NRToken := CheckToken; + CheckToken := token; + CheckTokenstack.Clear; + + if Tokens[I+1].TokenType = ttSect then + SectionToken := Tokens[I+1]; + + SkipNextToken := True; + end + + // if Check/Section are bound, update Check + else if Assigned(CheckToken) and Assigned(SectionToken) then // Check/Section is bound + begin + if not NrIsBound and (CheckTokenstack.Count > 0) then + NRToken := CheckToken; + CheckToken := token; + CheckTokenstack.Push(CheckToken); + end + // otherwise update Chk and optionally NR + else + begin + if Assigned(CheckToken) and not NrIsBound and + (CheckTokenstack.Count > 0) then + NRToken := CheckToken; + CheckToken := token; + CheckTokenstack.Push(CheckToken); + end; + end; + + ttAlpha: // other character strings, not valid Precedence nor Section + begin +{$ifdef DEBUG} + if token.Value = 'XYZZY' then + begin + FExchError := 'A MAZE OF TWISTY LITTLE PASSAGES, ALL ALIKE'; + AExchError := FExchError; + IsValidExchange := False; + Result := IsValidExchange; + Exit; + end; +{$endif} + if token.Value.Length = 2 then + begin + if TwoDigitList.Count > 0 then + begin + assert(Assigned(NRToken)); + assert(CheckToken = TwoDigitList.Last); + CheckToken := TwoDigitList.Last; + CheckTokenstack.Push(CheckToken); + end + else if UnboundNRs.Count > 0 then + begin + CheckToken := UnboundNRs.Pop; + CheckTokenstack.Push(CheckToken); + if UnboundNRs.Count > 0 then + NRToken := UnboundNRs.Peek; + end; + end; + end; + + ttPrec: + begin + PrecedenceToken := token; + if Assigned(NRToken) then + NRIsBound := True; + end; + + ttSect: + SectionToken := token; + end; + end; + + if Assigned(NRToken) then NR := StrToIntDef(NRToken.Value, 0); + if Assigned(PrecedenceToken) then Precedence := PrecedenceToken.Value; + if Assigned(CheckToken) then Check := format('%.02d', [StrToIntDef(CheckToken.Value, 0)]); + if Assigned(SectionToken) then Section := SectionToken.Value; + + if not Assigned(NRToken) then + FExchError := 'Missing/Invalid Serial Number' + else if not Assigned(PrecedenceToken) then + FExchError := 'Missing/Invalid Precedence' + else if not Assigned(CheckToken) then + FExchError := 'Missing/Invalid Check' + else if not Assigned(SectionToken) then + FExchError := 'Missing/Invalid Section' + else + FExchError := ''; + + IsValidExchange := FExchError.IsEmpty; + + except + on E: TLexer.ELexerError do begin + FExchError := E.Message; + IsValidExchange := False; + end; + end; + + AExchError := FExchError; + Result := IsValidExchange; +end; + + +end.