{******************************************************************************
  ExportCGESJson.pas
  Altium DelphiScript

  Minimal CGES-style JSON export.

  Exports:
    1) cges_export.json  or cges_export_a.json, etc.

  Output folder:
    <project folder>\Exports\

  Schema shape:
  {
    "standard": {
      "name": "CGES-JSON",
      "version": "1.0"
    },
    "source": {
      "tool": "Altium Designer",
      "project_path": "...",
      "exporter": "ExportCGESJson.pas"
    },
    "parts": [
      {
        "designator": "...",
        "library_reference": "...",
        "part_id": "...",
        "document_path": "...",
        "document_name": "...",
        "parameters": {
          "Param1": "Value1"
        }
      }
    ],
    "nets": [
      {
        "name": "...",
        "full_name": "...",
        "signal_type": "...",
        "electrical": "...",
        "document_path": "...",
        "document_name": "...",
        "connections": [
          {
            "designator": "...",
            "pin_number": "...",
            "pin_name": "...",
            "full_pin_name": "..."
          }
        ]
      }
    ]
  }
******************************************************************************}

{------------------------------ Helpers --------------------------------------}

Procedure SafeStrProc(V : Variant; var S : WideString);
Begin
    Try
        S := V;
    Except
        S := '';
    End;
End;

Procedure JsonEscapeProc(const InS : WideString; var OutS : WideString);
Var
    I  : Integer;
    Ch : WideString;
    R  : WideString;
Begin
    R := '';
    For I := 1 To Length(InS) Do
    Begin
        Ch := Copy(InS, I, 1);

        If Ch = '\' Then
            R := R + '\\'
        Else If Ch = '"' Then
            R := R + '\"'
        Else
            R := R + Ch;
    End;

    OutS := R;
End;

Procedure WriteJsonStringPropProc(var F : TextFile; const KeyName : WideString; const ValueText : WideString; const AddComma : Boolean);
Var
    EscKey   : WideString;
    EscValue : WideString;
    LineText : WideString;
Begin
    JsonEscapeProc(KeyName, EscKey);
    JsonEscapeProc(ValueText, EscValue);

    LineText := '  "' + EscKey + '": "' + EscValue + '"';
    If AddComma Then
        LineText := LineText + ',';

    Writeln(F, LineText);
End;

Procedure WriteJsonStringPropIndentedProc(var F : TextFile; const IndentText : WideString; const KeyName : WideString; const ValueText : WideString; const AddComma : Boolean);
Var
    EscKey   : WideString;
    EscValue : WideString;
    LineText : WideString;
Begin
    JsonEscapeProc(KeyName, EscKey);
    JsonEscapeProc(ValueText, EscValue);

    LineText := IndentText + '"' + EscKey + '": "' + EscValue + '"';
    If AddComma Then
        LineText := LineText + ',';

    Writeln(F, LineText);
End;

Procedure ForceBackslashProc(const InS : WideString; var OutS : WideString);
Var
    L  : Integer;
    Ch : WideString;
Begin
    If Length(InS) = 0 Then
    Begin
        OutS := '';
        Exit;
    End;

    L := Length(InS);
    Ch := Copy(InS, L, 1);

    If (Ch = '\') Or (Ch = '/') Then
        OutS := InS
    Else
        OutS := InS + '\';
End;

Procedure GetProjectFolderProc(Project : Variant; var FolderPath : WideString);
Var
    FullPath : WideString;
    I        : Integer;
    Ch       : WideString;
Begin
    FolderPath := '';
    SafeStrProc(Project.DM_ProjectFullPath, FullPath);

    For I := Length(FullPath) Downto 1 Do
    Begin
        Ch := Copy(FullPath, I, 1);
        If (Ch = '\') Or (Ch = '/') Then
        Begin
            FolderPath := Copy(FullPath, 1, I);
            Exit;
        End;
    End;
End;

Procedure EnsureFolderExistsProc(const FolderPath : WideString);
Begin
    Try
        If Not DirectoryExists(FolderPath) Then
            MkDir(FolderPath);
    Except
    End;
End;

Procedure GetDocNameProc(Doc : Variant; var S : WideString);
Begin
    SafeStrProc(Doc.DM_FileName, S);
    If Length(S) = 0 Then
        SafeStrProc(Doc.DM_DisplayName, S);
End;

Procedure GetDocPathProc(Doc : Variant; var S : WideString);
Begin
    SafeStrProc(Doc.DM_FullPath, S);
End;

Procedure GetPartDesignatorProc(Part : Variant; var S : WideString);
Begin
    SafeStrProc(Part.DM_PhysicalDesignator, S);
    If Length(S) = 0 Then
        SafeStrProc(Part.DM_LogicalDesignator, S);
End;

Procedure GetPartLibRefProc(Part : Variant; var S : WideString);
Begin
    SafeStrProc(Part.DM_LibraryReference, S);
End;

Procedure GetParamNameProc(Param : Variant; var S : WideString);
Begin
    SafeStrProc(Param.DM_Name, S);
End;

Procedure GetParamValueProc(Param : Variant; var S : WideString);
Begin
    SafeStrProc(Param.DM_Value, S);
End;

Procedure GetNetNameProc(NetObj : Variant; var S : WideString);
Begin
    SafeStrProc(NetObj.DM_NetName, S);
End;

Procedure GetFullNetNameProc(NetObj : Variant; var S : WideString);
Begin
    SafeStrProc(NetObj.DM_FullNetName, S);
    If Length(S) = 0 Then
        GetNetNameProc(NetObj, S);
End;

Procedure GetNetSignalTypeProc(NetObj : Variant; var S : WideString);
Begin
    SafeStrProc(NetObj.DM_SignalType, S);
End;

Procedure GetNetElectricalProc(NetObj : Variant; var S : WideString);
Begin
    SafeStrProc(NetObj.DM_ElectricalString, S);
End;

Procedure GetPinPartDesignatorProc(PinObj : Variant; var S : WideString);
Begin
    SafeStrProc(PinObj.DM_PhysicalPartDesignator, S);
End;

Procedure GetPinNumberProc(PinObj : Variant; var S : WideString);
Begin
    SafeStrProc(PinObj.DM_PinNumber, S);
End;

Procedure GetPinNameProc(PinObj : Variant; var S : WideString);
Begin
    SafeStrProc(PinObj.DM_PinName, S);
End;

Procedure GetFullPinNameProc(PinObj : Variant; var S : WideString);
Begin
    SafeStrProc(PinObj.DM_FullPinName, S);
    If Length(S) = 0 Then
        GetPinNameProc(PinObj, S);
End;

Procedure BuildAltFileNameProc(
    const FolderPath : WideString;
    const BaseName : WideString;
    const ExtName : WideString;
    const Suffix : WideString;
    var FileName : WideString);
Begin
    If Length(Suffix) = 0 Then
        FileName := FolderPath + BaseName + ExtName
    Else
        FileName := FolderPath + BaseName + '_' + Suffix + ExtName;
End;

Procedure BuildWritableFileNameProc(
    const FolderPath : WideString;
    const BaseName : WideString;
    const ExtName : WideString;
    var FileName : WideString);
Var
    TryName : WideString;
Begin
    BuildAltFileNameProc(FolderPath, BaseName, ExtName, '', TryName);
    If Not FileExists(TryName) Then
    Begin
        FileName := TryName;
        Exit;
    End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'a', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'b', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'c', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'd', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'e', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'f', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'g', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'h', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'i', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'j', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'k', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'l', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'm', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'n', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'o', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'p', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'q', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'r', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 's', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 't', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'u', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'v', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'w', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'x', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'y', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    BuildAltFileNameProc(FolderPath, BaseName, ExtName, 'z', TryName);
    If Not FileExists(TryName) Then Begin FileName := TryName; Exit; End;

    FileName := FolderPath + BaseName + '_overflow' + ExtName;
End;

{--------------------------- JSON Writers ------------------------------------}

Procedure WriteStandardBlockProc(var F : TextFile);
Begin
    Writeln(F, '{');
    Writeln(F, '  "standard": {');
    Writeln(F, '    "name": "CGES-JSON",');
    Writeln(F, '    "version": "1.0"');
    Writeln(F, '  },');
End;

Procedure WriteSourceBlockProc(var F : TextFile; Project : Variant);
Var
    ProjectPath : WideString;
    EscPath     : WideString;
Begin
    SafeStrProc(Project.DM_ProjectFullPath, ProjectPath);
    JsonEscapeProc(ProjectPath, EscPath);

    Writeln(F, '  "source": {');
    Writeln(F, '    "tool": "Altium Designer",');
    Writeln(F, '    "project_path": "' + EscPath + '",');
    Writeln(F, '    "exporter": "ExportCGESJson.pas"');
    Writeln(F, '  },');
End;

Procedure WritePartsArrayProc(var F : TextFile; Project : Variant);
Var
    DocIdx, PartIdx, ParamIdx : Integer;
    Doc, Part, Param          : Variant;
    DocPath, DocName          : WideString;
    Designator                : WideString;
    LibRef                    : WideString;
    PartIDStr                 : WideString;
    ParamName                 : WideString;
    ParamValue                : WideString;
    EscDocPath                : WideString;
    EscDocName                : WideString;
    EscDesignator             : WideString;
    EscLibRef                 : WideString;
    EscPartID                 : WideString;
    EscParamName              : WideString;
    EscParamValue             : WideString;
    PartCount                 : Integer;
    ParamCount                : Integer;
    FirstPart                 : Boolean;
    FirstParam                : Boolean;
Begin
    Writeln(F, '  "parts": [');

    FirstPart := True;

    For DocIdx := 0 To Project.DM_LogicalDocumentCount - 1 Do
    Begin
        Doc := Project.DM_LogicalDocuments(DocIdx);
        If Doc = Nil Then
            Continue;

        Try
            PartCount := Doc.DM_PartCount;
        Except
            PartCount := -1;
        End;

        If PartCount < 0 Then
            Continue;

        GetDocPathProc(Doc, DocPath);
        GetDocNameProc(Doc, DocName);

        For PartIdx := 0 To PartCount - 1 Do
        Begin
            Part := Doc.DM_Parts(PartIdx);
            If Part = Nil Then
                Continue;

            If Not FirstPart Then
                Writeln(F, ',');

            FirstPart := False;

            GetPartDesignatorProc(Part, Designator);
            GetPartLibRefProc(Part, LibRef);
            SafeStrProc(Part.DM_PartID, PartIDStr);

            JsonEscapeProc(DocPath, EscDocPath);
            JsonEscapeProc(DocName, EscDocName);
            JsonEscapeProc(Designator, EscDesignator);
            JsonEscapeProc(LibRef, EscLibRef);
            JsonEscapeProc(PartIDStr, EscPartID);

            Writeln(F, '    {');
            Writeln(F, '      "designator": "' + EscDesignator + '",');
            Writeln(F, '      "library_reference": "' + EscLibRef + '",');
            Writeln(F, '      "part_id": "' + EscPartID + '",');
            Writeln(F, '      "document_path": "' + EscDocPath + '",');
            Writeln(F, '      "document_name": "' + EscDocName + '",');
            Writeln(F, '      "parameters": {');

            Try
                ParamCount := Part.DM_ParameterCount;
            Except
                ParamCount := 0;
            End;

            FirstParam := True;

            For ParamIdx := 0 To ParamCount - 1 Do
            Begin
                Param := Part.DM_Parameters(ParamIdx);
                If Param = Nil Then
                    Continue;

                GetParamNameProc(Param, ParamName);
                GetParamValueProc(Param, ParamValue);

                JsonEscapeProc(ParamName, EscParamName);
                JsonEscapeProc(ParamValue, EscParamValue);

                If Not FirstParam Then
                    Writeln(F, ',');

                FirstParam := False;

                Writeln(F, '        "' + EscParamName + '": "' + EscParamValue + '"');
            End;

            Writeln(F, '      }');
            Writeln(F, '    }');
        End;
    End;

    Writeln(F);
    Writeln(F, '  ],');
End;

Procedure WriteNetsArrayProc(var F : TextFile; Project : Variant);
Var
    DocIdx, NetIdx, PinIdx : Integer;
    Doc, NetObj, PinObj    : Variant;
    DocPath, DocName       : WideString;
    NetName                : WideString;
    FullNetName            : WideString;
    SignalType             : WideString;
    Electrical             : WideString;
    PinPartDesignator      : WideString;
    PinNumber              : WideString;
    PinName                : WideString;
    FullPinName            : WideString;
    EscDocPath             : WideString;
    EscDocName             : WideString;
    EscNetName             : WideString;
    EscFullNetName         : WideString;
    EscSignalType          : WideString;
    EscElectrical          : WideString;
    EscPinPartDesignator   : WideString;
    EscPinNumber           : WideString;
    EscPinName             : WideString;
    EscFullPinName         : WideString;
    NetCount               : Integer;
    PinCount               : Integer;
    FirstNet               : Boolean;
    FirstConn              : Boolean;
Begin
    Writeln(F, '  "nets": [');

    FirstNet := True;

    For DocIdx := 0 To Project.DM_LogicalDocumentCount - 1 Do
    Begin
        Doc := Project.DM_LogicalDocuments(DocIdx);
        If Doc = Nil Then
            Continue;

        Try
            NetCount := Doc.DM_NetCount;
        Except
            NetCount := -1;
        End;

        If NetCount < 0 Then
            Continue;

        GetDocPathProc(Doc, DocPath);
        GetDocNameProc(Doc, DocName);

        For NetIdx := 0 To NetCount - 1 Do
        Begin
            NetObj := Doc.DM_Nets(NetIdx);
            If NetObj = Nil Then
                Continue;

            If Not FirstNet Then
                Writeln(F, ',');

            FirstNet := False;

            GetNetNameProc(NetObj, NetName);
            GetFullNetNameProc(NetObj, FullNetName);
            GetNetSignalTypeProc(NetObj, SignalType);
            GetNetElectricalProc(NetObj, Electrical);

            JsonEscapeProc(DocPath, EscDocPath);
            JsonEscapeProc(DocName, EscDocName);
            JsonEscapeProc(NetName, EscNetName);
            JsonEscapeProc(FullNetName, EscFullNetName);
            JsonEscapeProc(SignalType, EscSignalType);
            JsonEscapeProc(Electrical, EscElectrical);

            Writeln(F, '    {');
            Writeln(F, '      "name": "' + EscNetName + '",');
            Writeln(F, '      "full_name": "' + EscFullNetName + '",');
            Writeln(F, '      "signal_type": "' + EscSignalType + '",');
            Writeln(F, '      "electrical": "' + EscElectrical + '",');
            Writeln(F, '      "document_path": "' + EscDocPath + '",');
            Writeln(F, '      "document_name": "' + EscDocName + '",');
            Writeln(F, '      "connections": [');

            Try
                PinCount := NetObj.DM_PinCount;
            Except
                PinCount := 0;
            End;

            FirstConn := True;

            For PinIdx := 0 To PinCount - 1 Do
            Begin
                PinObj := NetObj.DM_Pins(PinIdx);
                If PinObj = Nil Then
                    Continue;

                If Not FirstConn Then
                    Writeln(F, ',');

                FirstConn := False;

                GetPinPartDesignatorProc(PinObj, PinPartDesignator);
                GetPinNumberProc(PinObj, PinNumber);
                GetPinNameProc(PinObj, PinName);
                GetFullPinNameProc(PinObj, FullPinName);

                JsonEscapeProc(PinPartDesignator, EscPinPartDesignator);
                JsonEscapeProc(PinNumber, EscPinNumber);
                JsonEscapeProc(PinName, EscPinName);
                JsonEscapeProc(FullPinName, EscFullPinName);

                Writeln(F, '        {');
                Writeln(F, '          "designator": "' + EscPinPartDesignator + '",');
                Writeln(F, '          "pin_number": "' + EscPinNumber + '",');
                Writeln(F, '          "pin_name": "' + EscPinName + '",');
                Writeln(F, '          "full_pin_name": "' + EscFullPinName + '"');
                Writeln(F, '        }');
            End;

            Writeln(F, '      ]');
            Writeln(F, '    }');
        End;
    End;

    Writeln(F);
    Writeln(F, '  ]');
End;

Procedure ExportCGESJsonToFileProc(Project : Variant; const OutDir : WideString; var WrittenFile : WideString);
Var
    F        : TextFile;
    FileName : WideString;
Begin
    BuildWritableFileNameProc(OutDir, 'cges_export', '.json', FileName);
    WrittenFile := FileName;

    AssignFile(F, FileName);
    Rewrite(F);

    WriteStandardBlockProc(F);
    WriteSourceBlockProc(F, Project);
    WritePartsArrayProc(F, Project);
    WriteNetsArrayProc(F, Project);

    Writeln(F, '}');

    CloseFile(F);
End;

{----------------------------- Main ------------------------------------------}

Procedure ExportCGESJson;
Var
    WS         : Variant;
    Project    : Variant;
    ProjectDir : WideString;
    OutDir     : WideString;
    JsonFile   : WideString;
Begin
    WS := GetWorkspace;
    If WS = Nil Then
    Begin
        ShowMessage('No workspace available.');
        Exit;
    End;

    Project := WS.DM_FocusedProject;
    If Project = Nil Then
    Begin
        ShowMessage('No focused project. Open an Altium project first.');
        Exit;
    End;

    Try
        Project.DM_Compile;
    Except
        ShowMessage('Project compile failed. Please compile the project manually, then run the script again.');
        Exit;
    End;

    GetProjectFolderProc(Project, ProjectDir);
    If Length(ProjectDir) = 0 Then
    Begin
        ShowMessage('Could not determine project folder.');
        Exit;
    End;

    ForceBackslashProc(ProjectDir, ProjectDir);
    OutDir := ProjectDir + 'Exports\';

    EnsureFolderExistsProc(OutDir);

    ExportCGESJsonToFileProc(Project, OutDir, JsonFile);

    ShowMessage(
        'CGES JSON export complete.' + #13#10 + #13#10 +
        'JSON file:' + #13#10 + JsonFile
    );
End;