mirror of
http://gitlab.expertsoft.com.ua/git/expertcad
synced 2026-01-12 00:45:40 +02:00
655 lines
17 KiB
ObjectPascal
655 lines
17 KiB
ObjectPascal
unit U_ArchStroyCalc;
|
|
|
|
interface
|
|
|
|
uses Forms, StdCtrls, SysUtils, Classes, ComCtrls, Windows, Controls, Contnrs, Messages, Dialogs, Math, TypInfo, RTLConsts,
|
|
DB,kbmMemTable,kbmMemBinaryStreamFormat,kbmMemCSVStreamFormat;
|
|
|
|
const
|
|
// Object sys names
|
|
osnRoom = 'ÊÎÌÍ';
|
|
osnBrickWall = 'ÊÈÐÑÒÅÍÀ';
|
|
osnWallDivision = 'ÏÅÐÅÃ';
|
|
osnWallVolume = 'ÑÒÅÍ';
|
|
osnBasement = 'ÔÓÍÄ';
|
|
osnBasementColumn = 'ÑÒÎËÁ_ÔÓÍÄÀÌÅÍÒÀ';
|
|
osnFacade = 'ÔÀÑÀÄ';
|
|
|
|
type
|
|
TASCObject = class;
|
|
TASCObjectList = class;
|
|
TASCBuildingList = class;
|
|
|
|
TASCBasic = class(TComponent)
|
|
private
|
|
FCaption: String;
|
|
public
|
|
procedure LoadFromFile(const AFileName: String);
|
|
procedure LoadFromStream(AStream: TStream);
|
|
procedure SaveToFile(const AFileName: String);
|
|
procedure SaveToStream(AStream: TStream);
|
|
published
|
|
property Caption: string read FCaption write FCaption;
|
|
end;
|
|
|
|
TASCItem = class(TCollectionItem)
|
|
private
|
|
FCaption: String;
|
|
public
|
|
FSrcObj: TObject;
|
|
constructor Create(Collection: TCollection); override;
|
|
published
|
|
property Caption: string read FCaption write FCaption;
|
|
end;
|
|
|
|
|
|
// Ïðîåêò/Îðãàíèçàöèÿ
|
|
TASCProject = class(TASCBasic)
|
|
private
|
|
FBuildings: TASCBuildingList;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Buildings: TASCBuildingList read FBuildings write FBuildings;
|
|
end;
|
|
|
|
// Ñòðîéêà
|
|
TASCBuilding = class(TASCItem)
|
|
private
|
|
FObjects: TASCObjectList;
|
|
public
|
|
constructor Create(Collection: TCollection); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Objects: TASCObjectList read FObjects write FObjects;
|
|
end;
|
|
TASCBuildingList = class(TCollection)
|
|
protected
|
|
function GetItem(Index: Integer): TASCBuilding;
|
|
procedure SetItem(Index: Integer; Value: TASCBuilding);
|
|
public
|
|
property Item[Index: Integer]: TASCBuilding read GetItem write SetItem; default;
|
|
constructor Create;
|
|
end;
|
|
|
|
// Îáúåêò (Êîìíàòà)
|
|
TASCObject = class(TASCItem)
|
|
private
|
|
FLength: Double;
|
|
FWidth: Double;
|
|
FHeight: Double;
|
|
FSysName: String;
|
|
FMemTableDump: String;
|
|
|
|
FObjects: TASCObjectList;
|
|
public
|
|
constructor Create(Collection: TCollection); override;
|
|
destructor Destroy; override;
|
|
procedure LoadDumpFromMemTable(AMT: TkbmMemTable);
|
|
procedure SaveDumpToMemTable(AMT: TkbmMemTable);
|
|
published
|
|
Property Length: Double read FLength write FLength;
|
|
Property Width: Double read FWidth write FWidth;
|
|
Property Height: Double read FHeight write FHeight;
|
|
Property SysName: String read FSysName write FSysName;
|
|
Property MemTableDump: String read FMemTableDump write FMemTableDump;
|
|
property Objects: TASCObjectList read FObjects write FObjects;
|
|
end;
|
|
TASCObjectList = class(TCollection)
|
|
protected
|
|
function GetItem(Index: Integer): TASCObject;
|
|
procedure SetItem(Index: Integer; Value: TASCObject);
|
|
public
|
|
property Item[Index: Integer]: TASCObject read GetItem write SetItem; default;
|
|
constructor Create;
|
|
end;
|
|
|
|
procedure ImportToStroyCalcTest;
|
|
procedure ObjectBinaryToTextView(Input, Output: TStream);
|
|
|
|
var
|
|
GSFBinary: TkbmBinaryStreamFormat;
|
|
GSFCSV: TkbmCSVStreamFormat;
|
|
GSCDebugMode: Boolean=false;
|
|
|
|
implementation
|
|
|
|
{ TASCBasic }
|
|
|
|
procedure TASCBasic.LoadFromFile(const AFileName: String);
|
|
var
|
|
Stream: TFileStream;
|
|
begin
|
|
Stream := TFileStream.Create(AFileName, fmOpenRead);
|
|
try
|
|
LoadFromStream(Stream);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TASCBasic.LoadFromStream(AStream: TStream);
|
|
var
|
|
MemStream: TMemoryStream;
|
|
begin
|
|
//AStream.ReadComponent(Self);
|
|
|
|
MemStream := TMemoryStream.Create;
|
|
ObjectTextToBinary(AStream, MemStream);
|
|
MemStream.Position := 0;
|
|
MemStream.ReadComponent(Self);
|
|
MemStream.Free;
|
|
end;
|
|
|
|
procedure TASCBasic.SaveToFile(const AFileName: String);
|
|
var
|
|
Stream: TFileStream;
|
|
begin
|
|
Stream := TFileStream.Create(AFileName, fmCreate);
|
|
try
|
|
SaveToStream(Stream);
|
|
finally
|
|
Stream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TASCBasic.SaveToStream(AStream: TStream);
|
|
var
|
|
MemStream: TMemoryStream;
|
|
begin
|
|
//AStream.WriteComponent(Self);
|
|
|
|
MemStream := TMemoryStream.Create;
|
|
MemStream.WriteComponent(Self);
|
|
MemStream.Position := 0;
|
|
if Not GSCDebugMode then
|
|
ObjectBinaryToText(MemStream, AStream)
|
|
else
|
|
ObjectBinaryToTextView(MemStream, AStream);
|
|
MemStream.Free;
|
|
end;
|
|
|
|
|
|
constructor TASCItem.Create(Collection: TCollection);
|
|
begin
|
|
inherited Create(Collection);
|
|
FSrcObj := nil;
|
|
end;
|
|
|
|
{ TASCBProject }
|
|
|
|
constructor TASCProject.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBuildings := TASCBuildingList.Create;
|
|
end;
|
|
|
|
destructor TASCProject.Destroy;
|
|
begin
|
|
FBuildings.Free;
|
|
inherited;
|
|
end;
|
|
|
|
{ TASCObjectList }
|
|
|
|
constructor TASCObjectList.Create;
|
|
begin
|
|
inherited Create(TASCObject);
|
|
end;
|
|
|
|
function TASCObjectList.GetItem(Index: Integer): TASCObject;
|
|
begin
|
|
Result := TASCObject(inherited GetItem(Index));
|
|
end;
|
|
|
|
procedure TASCObjectList.SetItem(Index: Integer; Value: TASCObject);
|
|
begin
|
|
inherited SetItem(Index, Value);
|
|
end;
|
|
|
|
{ TASCBuildingList }
|
|
|
|
constructor TASCBuildingList.Create;
|
|
begin
|
|
inherited Create(TASCBuilding);
|
|
end;
|
|
|
|
function TASCBuildingList.GetItem(Index: Integer): TASCBuilding;
|
|
begin
|
|
Result := TASCBuilding(inherited GetItem(Index));
|
|
end;
|
|
|
|
procedure TASCBuildingList.SetItem(Index: Integer; Value: TASCBuilding);
|
|
begin
|
|
inherited SetItem(Index, Value);
|
|
end;
|
|
|
|
{ TASCBuilding }
|
|
|
|
constructor TASCBuilding.Create(Collection: TCollection);
|
|
begin
|
|
inherited Create(Collection);
|
|
FObjects := TASCObjectList.Create;
|
|
end;
|
|
|
|
destructor TASCBuilding.Destroy;
|
|
begin
|
|
FObjects.Free;
|
|
inherited;
|
|
end;
|
|
|
|
{ TASCObject }
|
|
|
|
constructor TASCObject.Create(Collection: TCollection);
|
|
begin
|
|
inherited Create(Collection);
|
|
FObjects := TASCObjectList.Create;
|
|
end;
|
|
|
|
destructor TASCObject.Destroy;
|
|
begin
|
|
FObjects.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TASCObject.LoadDumpFromMemTable(AMT: TkbmMemTable);
|
|
var
|
|
StrStream: TStringStream;
|
|
begin
|
|
StrStream := TStringStream.Create('');
|
|
if Not GSCDebugMode then
|
|
AMT.SaveToStreamViaFormat(StrStream, GSFBinary)
|
|
else
|
|
AMT.SaveToStreamViaFormat(StrStream, GSFCSV);
|
|
StrStream.Position := 0;
|
|
Self.MemTableDump := StrStream.DataString;
|
|
StrStream.Free;
|
|
end;
|
|
|
|
procedure TASCObject.SaveDumpToMemTable(AMT: TkbmMemTable);
|
|
var
|
|
StrStream: TStringStream;
|
|
begin
|
|
StrStream := TStringStream.Create(Self.MemTableDump);
|
|
StrStream.Position := 0;
|
|
AMT.LoadFromStreamViaFormat(StrStream, GSFBinary);
|
|
StrStream.Free;
|
|
end;
|
|
|
|
procedure ImportToStroyCalcTest;
|
|
var
|
|
ASCProject: TASCProject;
|
|
ASCBuilding: TASCBuilding;
|
|
ASCObject: TASCObject;
|
|
|
|
MT: TKbmMemTable;
|
|
sfCSV: TkbmCSVStreamFormat;
|
|
i: Integer;
|
|
begin
|
|
try
|
|
ASCProject := TASCProject.Create(nil);
|
|
//ASCProject.Caption;
|
|
ASCProject.LoadFromFile('C:\Temp\stroyCalcProj.scp');
|
|
ASCProject.SaveToFile('C:\Temp\stroyCalcProj_ret.scp');
|
|
|
|
if ASCProject.Buildings.Count > 0 then
|
|
begin
|
|
ASCBuilding := ASCProject.Buildings[0];
|
|
//ASCBuilding.Caption
|
|
if ASCBuilding.Objects.Count > 0 then
|
|
begin
|
|
sfCSV := TkbmCSVStreamFormat.Create(nil);
|
|
for i := 0 to ASCBuilding.Objects.Count - 1 do
|
|
begin
|
|
ASCObject := ASCBuilding.Objects[i];
|
|
//ASCObject.Caption
|
|
MT := TKbmMemTable.Create(nil);
|
|
ASCObject.SaveDumpToMemTable(MT);
|
|
MT.SaveToFileViaFormat('C:\Temp\stroyCalcProj_'+IntToStr(i)+'.csv', sfCSV);
|
|
|
|
MT.Free;
|
|
end;
|
|
sfCSV.Free;
|
|
end;
|
|
end;
|
|
|
|
FreeAndNil(ASCProject);
|
|
except
|
|
on E: Exception do ShowMessage('ImportToStroyCalcTest: '+ E.Message);
|
|
end;
|
|
end;
|
|
|
|
procedure ObjectBinaryToTextView(Input, Output: TStream);
|
|
var
|
|
NestingLevel: Integer;
|
|
SaveSeparator: Char;
|
|
Reader: TReader;
|
|
Writer: TWriter;
|
|
ObjectName, PropName: string;
|
|
|
|
procedure WriteIndent;
|
|
const
|
|
Blanks: array[0..1] of Char = ' ';
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
|
|
end;
|
|
|
|
procedure WriteStr(const S: string);
|
|
begin
|
|
Writer.Write(S[1], Length(S));
|
|
end;
|
|
|
|
procedure NewLine;
|
|
begin
|
|
WriteStr(sLineBreak);
|
|
WriteIndent;
|
|
end;
|
|
|
|
procedure ConvertValue; forward;
|
|
|
|
procedure ConvertHeader;
|
|
var
|
|
ClassName: string;
|
|
Flags: TFilerFlags;
|
|
Position: Integer;
|
|
begin
|
|
Reader.ReadPrefix(Flags, Position);
|
|
ClassName := Reader.ReadStr;
|
|
ObjectName := Reader.ReadStr;
|
|
WriteIndent;
|
|
if ffInherited in Flags then
|
|
WriteStr('inherited ')
|
|
else if ffInline in Flags then
|
|
WriteStr('inline ')
|
|
else
|
|
WriteStr('object ');
|
|
if ObjectName <> '' then
|
|
begin
|
|
WriteStr(ObjectName);
|
|
WriteStr(': ');
|
|
end;
|
|
WriteStr(ClassName);
|
|
if ffChildPos in Flags then
|
|
begin
|
|
WriteStr(' [');
|
|
WriteStr(IntToStr(Position));
|
|
WriteStr(']');
|
|
end;
|
|
|
|
if ObjectName = '' then
|
|
ObjectName := ClassName; // save for error reporting
|
|
|
|
WriteStr(sLineBreak);
|
|
end;
|
|
|
|
procedure ConvertBinary;
|
|
const
|
|
BytesPerLine = 32;
|
|
var
|
|
MultiLine: Boolean;
|
|
I: Integer;
|
|
Count: Longint;
|
|
Buffer: array[0..BytesPerLine - 1] of Char;
|
|
Text: array[0..BytesPerLine * 2 - 1] of Char;
|
|
begin
|
|
Reader.ReadValue;
|
|
WriteStr('{');
|
|
Inc(NestingLevel);
|
|
Reader.Read(Count, SizeOf(Count));
|
|
MultiLine := Count >= BytesPerLine;
|
|
while Count > 0 do
|
|
begin
|
|
if MultiLine then NewLine;
|
|
if Count >= 32 then I := 32 else I := Count;
|
|
Reader.Read(Buffer, I);
|
|
BinToHex(Buffer, Text, I);
|
|
Writer.Write(Text, I * 2);
|
|
Dec(Count, I);
|
|
end;
|
|
Dec(NestingLevel);
|
|
WriteStr('}');
|
|
end;
|
|
|
|
procedure ConvertProperty; forward;
|
|
|
|
procedure ConvertValue;
|
|
const
|
|
LineLength = 64;
|
|
var
|
|
I, J, K, L: Integer;
|
|
S: string;
|
|
W: WideString;
|
|
LineBreak: Boolean;
|
|
begin
|
|
case Reader.NextValue of
|
|
vaList:
|
|
begin
|
|
Reader.ReadValue;
|
|
WriteStr('(');
|
|
Inc(NestingLevel);
|
|
while not Reader.EndOfList do
|
|
begin
|
|
NewLine;
|
|
ConvertValue;
|
|
end;
|
|
Reader.ReadListEnd;
|
|
Dec(NestingLevel);
|
|
WriteStr(')');
|
|
end;
|
|
vaInt8, vaInt16, vaInt32:
|
|
WriteStr(IntToStr(Reader.ReadInteger));
|
|
vaExtended:
|
|
WriteStr(FloatToStr(Reader.ReadFloat));
|
|
vaSingle:
|
|
WriteStr(FloatToStr(Reader.ReadSingle) + 's');
|
|
vaCurrency:
|
|
WriteStr(FloatToStr(Reader.ReadCurrency * 10000) + 'c');
|
|
vaDate:
|
|
WriteStr(FloatToStr(Reader.ReadDate) + 'd');
|
|
vaWString, vaUTF8String:
|
|
begin
|
|
W := Reader.ReadWideString;
|
|
L := Length(W);
|
|
if L = 0 then WriteStr('''''') else
|
|
begin
|
|
I := 1;
|
|
Inc(NestingLevel);
|
|
try
|
|
if L > LineLength then NewLine;
|
|
K := I;
|
|
repeat
|
|
LineBreak := False;
|
|
if (W[I] >= ' ') and (W[I] <> '''') and (Ord(W[i]) <= 127) then
|
|
begin
|
|
J := I;
|
|
repeat
|
|
Inc(I)
|
|
until (I > L) or (W[I] < ' ') or (W[I] = '''') or
|
|
((I - K) >= LineLength) or (Ord(W[i]) > 127);
|
|
if ((I - K) >= LineLength) then LineBreak := True;
|
|
WriteStr('''');
|
|
while J < I do
|
|
begin
|
|
WriteStr(Char(W[J]));
|
|
Inc(J);
|
|
end;
|
|
WriteStr('''');
|
|
end else
|
|
begin
|
|
//WriteStr('#');
|
|
//WriteStr(IntToStr(Ord(W[I])));
|
|
WriteStr(W[I]);
|
|
Inc(I);
|
|
if ((I - K) >= LineLength) then LineBreak := True;
|
|
end;
|
|
if LineBreak and (I <= L) then
|
|
begin
|
|
WriteStr(' +');
|
|
NewLine;
|
|
K := I;
|
|
end;
|
|
until I > L;
|
|
finally
|
|
Dec(NestingLevel);
|
|
end;
|
|
end;
|
|
end;
|
|
vaString, vaLString:
|
|
begin
|
|
S := Reader.ReadString;
|
|
L := Length(S);
|
|
if L = 0 then WriteStr('''''') else
|
|
begin
|
|
I := 1;
|
|
Inc(NestingLevel);
|
|
try
|
|
if L > LineLength then NewLine;
|
|
K := I;
|
|
repeat
|
|
LineBreak := False;
|
|
if (S[I] >= ' ') and (S[I] <> '''') then
|
|
begin
|
|
J := I;
|
|
repeat
|
|
Inc(I)
|
|
until (I > L) or (S[I] < ' ') or (S[I] = '''') or
|
|
((I - K) >= LineLength);
|
|
if ((I - K) >= LineLength) then
|
|
begin
|
|
LIneBreak := True;
|
|
if ByteType(S, I) = mbTrailByte then Dec(I);
|
|
end;
|
|
WriteStr('''');
|
|
Writer.Write(S[J], I - J);
|
|
WriteStr('''');
|
|
end else
|
|
begin
|
|
//WriteStr('#');
|
|
//WriteStr(IntToStr(Ord(S[I])));
|
|
WriteStr(S[I]);
|
|
Inc(I);
|
|
if ((I - K) >= LineLength) then LineBreak := True;
|
|
end;
|
|
if LineBreak and (I <= L) then
|
|
begin
|
|
WriteStr(' +');
|
|
NewLine;
|
|
K := I;
|
|
end;
|
|
until I > L;
|
|
finally
|
|
Dec(NestingLevel);
|
|
end;
|
|
end;
|
|
end;
|
|
vaIdent, vaFalse, vaTrue, vaNil, vaNull:
|
|
WriteStr(Reader.ReadIdent);
|
|
vaBinary:
|
|
ConvertBinary;
|
|
vaSet:
|
|
begin
|
|
Reader.ReadValue;
|
|
WriteStr('[');
|
|
I := 0;
|
|
while True do
|
|
begin
|
|
S := Reader.ReadStr;
|
|
if S = '' then Break;
|
|
if I > 0 then WriteStr(', ');
|
|
WriteStr(S);
|
|
Inc(I);
|
|
end;
|
|
WriteStr(']');
|
|
end;
|
|
vaCollection:
|
|
begin
|
|
Reader.ReadValue;
|
|
WriteStr('<');
|
|
Inc(NestingLevel);
|
|
while not Reader.EndOfList do
|
|
begin
|
|
NewLine;
|
|
WriteStr('item');
|
|
if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
|
|
begin
|
|
WriteStr(' [');
|
|
ConvertValue;
|
|
WriteStr(']');
|
|
end;
|
|
WriteStr(sLineBreak);
|
|
Reader.CheckValue(vaList);
|
|
Inc(NestingLevel);
|
|
while not Reader.EndOfList do ConvertProperty;
|
|
Reader.ReadListEnd;
|
|
Dec(NestingLevel);
|
|
WriteIndent;
|
|
WriteStr('end');
|
|
end;
|
|
Reader.ReadListEnd;
|
|
Dec(NestingLevel);
|
|
WriteStr('>');
|
|
end;
|
|
vaInt64:
|
|
WriteStr(IntToStr(Reader.ReadInt64));
|
|
else
|
|
raise EReadError.CreateResFmt(@sPropertyException,
|
|
[ObjectName, DotSep, PropName, IntToStr(Ord(Reader.NextValue))]);
|
|
end;
|
|
end;
|
|
|
|
procedure ConvertProperty;
|
|
begin
|
|
WriteIndent;
|
|
PropName := Reader.ReadStr; // save for error reporting
|
|
WriteStr(PropName);
|
|
WriteStr(' = ');
|
|
ConvertValue;
|
|
WriteStr(sLineBreak);
|
|
end;
|
|
|
|
procedure ConvertObject;
|
|
begin
|
|
ConvertHeader;
|
|
Inc(NestingLevel);
|
|
while not Reader.EndOfList do ConvertProperty;
|
|
Reader.ReadListEnd;
|
|
while not Reader.EndOfList do ConvertObject;
|
|
Reader.ReadListEnd;
|
|
Dec(NestingLevel);
|
|
WriteIndent;
|
|
WriteStr('end' + sLineBreak);
|
|
end;
|
|
|
|
begin
|
|
NestingLevel := 0;
|
|
Reader := TReader.Create(Input, 4096);
|
|
SaveSeparator := DecimalSeparator;
|
|
DecimalSeparator := '.';
|
|
try
|
|
Writer := TWriter.Create(Output, 4096);
|
|
try
|
|
Reader.ReadSignature;
|
|
ConvertObject;
|
|
finally
|
|
Writer.Free;
|
|
end;
|
|
finally
|
|
DecimalSeparator := SaveSeparator;
|
|
Reader.Free;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
//RegisterClass(TASCBuilding);
|
|
GSFBinary := TkbmBinaryStreamFormat.Create(nil);
|
|
GSFCSV := TkbmCSVStreamFormat.Create(nil);
|
|
|
|
finalization
|
|
FreeAndNil(GSFBinary);
|
|
FreeAndNil(GSFCSV);
|
|
|
|
end.
|