Census Code

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is Census                                                *}
{*                                                                            *}
{* The Initial Developer of the Original Code is Justin Wilkins               *}
{*                                                                            *}
{* Portions created by Justin Wilkins are Copyright (C)2001-2011              *}
{* Justin Wilkins. All Rights Reserved.                                       *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

unit llp;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Math, Mask, JvToolEdit, JvMaskEdit, JvSpin, JvComponent,
  ExtCtrls, Brkapart, Registry, JvExControls, JvxCheckListBox, JvExMask;

type
  TfrmLLP = class(TForm)
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    edtOutput: TJvDirectoryEdit;
    edtRunStart: TJvSpinEdit;
    Label1: TLabel;
    GroupBox3: TGroupBox;
    lstParams: TJvxCheckListBox;
    GroupBox4: TGroupBox;
    chk60: TCheckBox;
    chk50: TCheckBox;
    chk40: TCheckBox;
    chk30: TCheckBox;
    chk20: TCheckBox;
    chk15: TCheckBox;
    chk10: TCheckBox;
    chk5: TCheckBox;
    chkScript: TCheckBox;
    edtScript: TEdit;
    btnCancel: TButton;
    btnGo: TButton;
    Panel1: TPanel;
    Label2: TLabel;
    Label3: TLabel;
    cbxFormat: TComboBox;
    brkUp: TBrkApart;
    edtInput: TEdit;
    GroupBox5: TGroupBox;
    edtLabel: TEdit;
    Label4: TLabel;
    brkUp2: TBrkApart;
    chk80: TCheckBox;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnGoClick(Sender: TObject);
    procedure CreateOutput(inFile: string);
    procedure FormCreate(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    function SigFigs(const Value: Extended; const SigFigCount: Integer): string;
    procedure chkScriptClick(Sender: TObject);
    function UnixSave(strOut: TStrings; FileName: string): Boolean;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmLLP: TfrmLLP;

implementation

uses main;

{$R *.dfm}

procedure TfrmLLP.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
  frmLLP := nil;
end;

procedure TfrmLLP.btnGoClick(Sender: TObject);
begin
  if FileExists(edtInput.Text) then
  begin
    CreateOutput(edtInput.Text);
  end;
end;

procedure TfrmLLP.CreateOutput(inFile: string);
var
  strIn, strOut, strStore: TStrings;
  arPercs, strBatch, strEta: TStrings;
  strTemp: string;
  n, m, p, q, r, s, intTheta, intTemp, intLine, intCt: Integer;
  intProblem, intEtaStart, intEtaEnd, intSigmaStart, intSigmaEnd: Integer;
  regIni: TRegIniFile;
begin
  strIn := TStringList.Create;
  strOut := TStringList.Create;
  arPercs := TStringList.Create;
  strStore := TStringList.Create;
  strBatch := TStringList.Create;
  strEta := TStringList.Create;

  intLine := 0;
  intProblem := 0;
  intEtaStart := 0;
  intEtaEnd := 0;
  intSigmaStart := 0;
  intSigmaEnd := 0;
  intCt := edtRunStart.AsInteger;

  if chk80.Checked then
    arPercs.Add('-0.8');
  if chk60.Checked then
    arPercs.Add('-0.6');
  if chk50.Checked then
    arPercs.Add('-0.5');
  if chk40.Checked then
    arPercs.Add('-0.4');
  if chk30.Checked then
    arPercs.Add('-0.3');
  if chk20.Checked then
    arPercs.Add('-0.2');
  if chk15.Checked then
    arPercs.Add('-0.15');
  if chk10.Checked then
    arPercs.Add('-0.1');
  if chk5.Checked then
    arPercs.Add('-0.05');
  if chk5.Checked then
    arPercs.Add('0.05');
  if chk10.Checked then
    arPercs.Add('0.1');
  if chk15.Checked then
    arPercs.Add('0.15');
  if chk20.Checked then
    arPercs.Add('0.2');
  if chk30.Checked then
    arPercs.Add('0.3');
  if chk40.Checked then
    arPercs.Add('0.4');
  if chk50.Checked then
    arPercs.Add('0.5');
  if chk60.Checked then
    arPercs.Add('0.6');
  if chk80.Checked then
    arPercs.Add('0.8');

  strIn.LoadFromFile(inFile);
  intTheta := 0;
  brkUp.AllowEmptyString := False;

  for n := 0 to lstParams.Items.Count - 1 do
  begin

    strStore.Clear;
    if lstParams.State[n] = cbChecked then
    begin

    // Thetas
      if Pos('Th', lstParams.Items[n]) > 0 then
      begin
        strTemp := Trim(Copy(lstParams.Items[n], 3, 3));
        intTemp := StrToInt(strTemp);

        frmNMRun.tblThetas.First;

        while intTemp <> frmNMRun.tblThetasTheta.Value do
          frmNMRun.tblThetas.Next;

        for p := 0 to arPercs.Count - 1 do
        begin
          strStore.Add('$THETA ' +
            SigFigs(frmNMRun.tblThetasThetaValue.Value +
            (frmNMRun.tblThetasThetaValue.Value * StrToFloat(arPercs[p])), 3) + ' FIX                ; ' +
            frmNMRun.tblThetasThetaLabel.Value + ' | ' + FloatToStr(StrToFloat(arPercs[p]) * 100) +
            '%');
        end;

        //ShowMessage(strStore.Text);

        for m := 0 to strIn.Count - 1 do
        begin
          if Pos('$THETA', Trim(strIn[m])) = 1 then
            if Pos(frmNMRun.tblThetasThetaLabel.Value, strIn[m]) > 0 then
              intLine := m;
          if Pos('$PROB', Trim(strIn[m])) = 1 then
            intProblem := m;
          if (Pos('$SIGMA', Trim(strIn[m])) = 1) and (intSigmaStart = 0) then
            intSigmaStart := m;
          if Pos('$SIGMA', Trim(strIn[m])) = 1 then
            intSigmaEnd := m;
        end;

        strOut.Assign(strIn);

        if DirectoryExists(edtOutput.LongName) = False then
        try
          CreateDir(edtOutput.LongName);
        except
          MessageDlg('Unable to create the specified directory.', mtError,
            [mbOK], 0);
          Exit;
        end;
        regIni := TRegIniFile.Create('Software\Arrhytmia\Drumsticks');

        for m := 0 to strStore.Count - 1 do
        begin
          strOut[intLine] := strStore[m];
          strOut[intProblem] := StringReplace(StringReplace('$PROB ' + edtLabel.Text,
            '{P}', frmNMRun.tblThetasThetaLabel.Value, [rfReplaceAll]),
            '{%}', '(' + FloatToStr(StrToFloat(arPercs[m]) * 100) + '%)', [rfReplaceAll]);

          try
            if cbxFormat.ItemIndex = 0 then
              strOut.SaveToFile(edtOutput.LongName + '\' +
                regIni.ReadString('Options', 'RunPrefix', 'run') +
                IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod'))
            else
              UnixSave(strOut, edtOutput.LongName + '\' +
                regIni.ReadString('Options', 'RunPrefix', 'run') +
                IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod'));
          except
            MessageDlg('Unable to create an output file (' + edtOutput.LongName + '\' +
              regIni.ReadString('Options', 'RunPrefix', 'run') +
              IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod') + ').', mtError,
              [mbOK], 0);
            Exit;
          end;
          strBatch.Add(regIni.ReadString('Options', 'NMVersion', 'nmfe5') + ' ' +
            regIni.ReadString('Options', 'RunPrefix', 'run') +
            IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod') +
            ' ' + regIni.ReadString('Options', 'RunPrefix', 'run') +
            IntToStr(intCt) + regIni.ReadString('Options', 'ExtLst', '.lst'));
          intCt := intCt + 1;
        end;
      end;

      // Etas
      if Pos('Om', lstParams.Items[n]) > 0 then
      begin

        strTemp := Trim(Copy(lstParams.Items[n], 3, 3));
        intTemp := StrToInt(strTemp);
        strEta.Clear;

        frmNMRun.tblEtas.First;

        while intTemp <> frmNMRun.tblEtasEta.Value do
          frmNMRun.tblEtas.Next;

        for p := 0 to arPercs.Count - 1 do
        begin
          strStore.Add(
            SigFigs(frmNMRun.tblEtasEtaValue.Value +
            (frmNMRun.tblEtasEtaValue.Value * StrToFloat(arPercs[p])), 3) + ' FIX                ; ' +
            frmNMRun.tblEtasEtaLabel.Value + ' | ' + FloatToStr(StrToFloat(arPercs[p]) * 100) +
            '%');
        end;

        for m := 0 to strIn.Count - 1 do
        begin
          if Pos('$PROB', Trim(strIn[m])) = 1 then
            intProblem := m;
          if (Pos('$OMEGA', Trim(strIn[m])) = 1) and (intEtaStart = 0) then
            intEtaStart := m;
          if Pos('$OMEGA', Trim(strIn[m])) = 1 then
            intEtaEnd := m;
        end;

        strTemp := '';
        for p := intEtaStart to intEtaEnd do
          strTemp := strTemp + ' ' + strIn[p];

        brkUp.StringList.Clear;
        brkUp.BaseString := strTemp;
        brkUp.BreakString := '$OMEGA';
        brkUp.BreakApart;

        for r := 0 to brkUp.StringList.Count - 1 do
        begin
          if Pos('BLOCK(1)', brkUp.StringList[r]) = 0 then
          begin
            brkUp2.StringList.Clear;
            brkUp2.BaseString := brkUp.StringList[r];
            brkUp2.BreakString := ' ';
            brkUp2.BreakApart;
            for s := 0 to brkUp2.StringList.Count - 1 do
              strEta.Add(brkUp2.StringList[s]);
          end
          else
            strEta.Add(brkUp.StringList[r]);
        end;
        // ShowMessage(strEta.Text);

        for m := 0 to strStore.Count - 1 do
        begin
          strOut.Clear;
          for p := 0 to intEtaStart - 1 do
            strOut.Add(strIn[p]);

          for s := 0 to strEta.Count - 1 do
            if s = intTemp - 1 then
            begin
              if Pos('BLOCK(1)', strEta[s]) > 0 then
                strOut.Add('$OMEGA BLOCK(1) ' + Trim(strStore[m]))
              else
                strOut.Add('$OMEGA ' + Trim(strStore[m]));
            end
            else
              strOut.Add('$OMEGA ' + Trim(strEta[s]));

          for p := intEtaEnd + 1 to strIn.Count - 1 do
            strOut.Add(strIn[p]);

          strOut[intProblem] := StringReplace(StringReplace('$PROB ' + edtLabel.Text,
            '{P}', 'IIV-' + frmNMRun.tblEtasEtaLabel.Value + ' (' +
            IntToStr(frmNMRun.tblEtasEta.Value) + ')', [rfReplaceAll]),
            '{%}', '(' + FloatToStr(StrToFloat(arPercs[m]) * 100) + '%)', [rfReplaceAll]);

          if DirectoryExists(edtOutput.LongName) = False then
          try
            CreateDir(edtOutput.LongName);
          except
            MessageDlg('Unable to create the specified directory.', mtError,
              [mbOK], 0);
            Exit;
          end;
          regIni := TRegIniFile.Create('Software\Arrhytmia\Drumsticks');

          try
            if cbxFormat.ItemIndex = 0 then
              strOut.SaveToFile(edtOutput.LongName + '\' +
                regIni.ReadString('Options', 'RunPrefix', 'run') +
                IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod'))
            else
              UnixSave(strOut, edtOutput.LongName + '\' +
                regIni.ReadString('Options', 'RunPrefix', 'run') +
                IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod'));
          except
            MessageDlg('Unable to create an output file (' + edtOutput.LongName + '\' +
              regIni.ReadString('Options', 'RunPrefix', 'run') +
              IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod') + ').', mtError,
              [mbOK], 0);
            Exit;
          end;
          strBatch.Add(regIni.ReadString('Options', 'NMVersion', 'nmfe5') + ' ' +
            regIni.ReadString('Options', 'RunPrefix', 'run') +
            IntToStr(intCt) + regIni.ReadString('Options', 'ExtCtl', '.mod') +
            ' ' + regIni.ReadString('Options', 'RunPrefix', 'run') +
            IntToStr(intCt) + regIni.ReadString('Options', 'ExtLst', '.lst'));
          intCt := intCt + 1;

        end;

      end;

    end;
  end;

  strIn.Free;
  strOut.Free;
  arPercs.Free;
  strStore.Free;
  strEta.Free;

  if chkScript.Checked then
    if cbxFormat.ItemIndex = 0 then
      strBatch.SaveToFile(edtOutput.LongName + '\' + edtScript.Text)
    else
      UnixSave(strBatch, edtOutput.LongName + '\' + edtScript.Text);
  MessageDlg('Completed! Files have been placed in the specified directory.',
    mtInformation, [mbOK], 0);
  Close;
end;

procedure TfrmLLP.FormCreate(Sender: TObject);
var
  n: Integer;
begin
  edtInput.Text := frmNMRun.tblRunsCtl.Value;
  edtLabel.Text := frmNMRun.tblRunsComment.Value + ' - LLP - {P} {%}';
  frmNMRun.tblThetas.First;
  for n := 0 to frmNMRun.tblThetas.RecordCount - 1 do
  begin
    if frmNMRun.tblThetasLower.Value <> frmNMRun.tblThetasUpper.Value then
      lstParams.Items.Add('Th ' + IntToStr(frmNMRun.tblThetasTheta.Value) +
        ' (' + frmNMRun.tblThetasThetaLabel.Value + ')');
    frmNMRun.tblThetas.Next;
  end;
  frmNMRun.tblEtas.First;
  for n := 0 to frmNMRun.tblEtas.RecordCount - 1 do
  begin
    lstParams.Items.Add('Om ' + IntToStr(frmNMRun.tblEtasEta.Value) +
      ' (' + frmNMRun.tblEtasEtaLabel.Value + ')');
    frmNMRun.tblEtas.Next;
  end;
  frmNMRun.tblSigmas.First;
  for n := 0 to frmNMRun.tblSigmas.RecordCount - 1 do
  begin
    lstParams.Items.Add('Sg ' + IntToStr(frmNMRun.tblSigmasSigma.Value));
    frmNMRun.tblSigmas.Next;
  end;
  edtOutput.Text := ExtractFilePath(frmNMRun.tblRunsCtl.Value);
  edtRunStart.Value := frmNMRun.tblRunsiRunNo.Value + 1;
end;

procedure TfrmLLP.btnCancelClick(Sender: TObject);
begin
  Close;
end;

{
  This (imperfect) function formats a value to a given number of significant
  figures.

  Sometimes an extra digit will be returned, for example the following
assertion
  fails:

  Assert(SigFigs(0.001, 1) = '0.001'); // SigFigs returns '0.0010'

  Author: Gary Williams
}

function TfrmLLP.SigFigs(const Value: Extended; const SigFigCount: Integer): string;
var
  DecimalCount: Integer; // may be negative
  Scale: Extended;

begin
  Assert(SigFigCount > 0);

  if (Value = 0.0) then
    DecimalCount := SigFigCount - 1
  else
    DecimalCount := SigFigCount - Floor(Log10(Abs(Value))) - 1;

  if (DecimalCount >= 0) then
    Result := Format('%1.' + IntToStr(DecimalCount) + 'f', [Value])
  else
  begin
    Scale := IntPower(10.0, DecimalCount);
    Result := Format('%1.0f', [Round(Value * Scale) / Scale]); // change superfluous digits to '0'
  end;
end;

procedure TfrmLLP.chkScriptClick(Sender: TObject);
begin
  if chkScript.Checked then
    edtScript.Enabled := True
  else
    edtScript.Enabled := False;
end;

function TfrmLLP.UnixSave(strOut: TStrings; FileName: string): Boolean;
const
  CR = $0D;
  LF = $0A;
  zero: Byte = 0;
var
  stmIn: TMemoryStream;
  pcData: PChar;
  pcCR: PChar;
  strLine: string;
begin
  stmIn := TMemoryStream.Create;

  try
    strOut.SaveToStream(stmIn);
    if stmIn.Size > 0 then begin
      stmIn.Seek(0, soFromEnd);
      stmIn.Write(zero, 1);
      pcData := PChar(stmIn.Memory);
      repeat
        pcCR := StrScan(pcData, #13);
        if pcCR <> nil then begin
          pcCR[0] := #32;
          // strLine  := StrPas(pcData);
          // strLine  := strLine + #13#10;
          // Do what you need with the line here.
          pcData := pcCR + 1;
        end;
      until pcCR = nil;
    end;
  finally
    stmIn.SaveToFile(FileName);
    stmIn.Free;
  end;

end;

end.