UNIT CollectControls.ms.dict
USES
string.ms.dict
;
USES
arrays.ms.dict
;
USES
CollectElements.ms.dict
;
USES
SaveVarAndDo.ms.dict
;
USES
ElementsRTTI.ms.dict
;
USES
GarantMetaModel.ms.dict
;
USES
Chars.ms.dict
;
USES
Out.ms.dict
;
USES
Log.ms.dict
;
PROCEDURE CollectControls
CONST cControls 'none|TeeButton|TeeCheckBox|TeeEditor|TeeEditorWithoutOperations|TeeMemoWithEditOperations|TeeRadioButton|TeeTreeView|TElPopupButton|TevMemo|TevQueryCardEditor|TnscComboBox|TnscComboBoxWithPwdChar|TnscComboBoxWithReadOnly|TnscComboLabel|TnscContextFilter|TnscEdit|TnscEditor|TnscHideField|TnscLister|TnscSimpleEditor|TnscTreeComboWithHistoryAndOperations|TnscTreeView|TnscTreeViewHotTruck|TnscTreeViewWithAdapterDragDrop|TvtButton|TvtCheckBox|TvtColorBox|TvtComboBox|TvtComboBoxQS|TvtDblClickDateEdit|TvtFocusLabel|TvtGradientWaitbar|TvtGroupBox|TvtImageLabel|TvtLabel|TvtLister|TvtPanel|TvtProportionalPanel|TvtRadioButton|TvtScrollBar|TvtSizeablePanel|TvtSplitter|TvtStyledLabel|TvtStyledFocusLabel|TBevel|TBitBtn|TComboBox|TImage|TImageEnView|TPaintBox|TRadioButton|TScrollBox|TProgressBar|TnscNavigator'
CONST cComponents 'none|TevTextSource|TImageEnIO|TImageEnProc|TnscTextSource|TTimer'
VAR l_Names
[ cControls '|' string:Split:for> NOP ]
.join> [ cComponents '|' string:Split:for> NOP ]
>>> l_Names
'Controls.ms.dict' .ProcessTmpOut: (
[ 'INCLUDE ' cQuote 'ElementsRTTI.ms.dict' cQuote ] .Out
OutLn
'AllModelControls' .OutWord: (
OutSeq: (
ProcessAllDictionaries: (
STRING IN aDict
if true then
begin
Log: ( [ 'Collect Controls: ' aDict ] strings:Cat )
aDict .ProcessDictionary: (
IN aWord
IN aDictFileName
if ( aWord .IsStereotype st_SimpleClass ) then
begin
if ( aWord .Name .InArray: l_Names ) then
begin
aWord aDictFileName .OutWordLink
end // ( aWord .Name .InArray: l_Names )
end // ( aWord .IsStereotype st_SimpleClass )
) // aDict .ProcessDictionary:
end
) // ProcessAllDictionaries:
) // OutSeq:
) // 'AllModelControls' .OutWord:
) // 'Controls.ms.dict' .ProcessTmpOut:
; // CollectControls
PROGRAM DictionaryByName.ms.script
USES
ElementsRTTI.ms.dict
;
USES
GarantMetaModel.ms.dict
;
USES
CollectElements.ms.dict
;
USES
Log.ms.dict
;
CollectInAllDictionaries:
(
STRING IN aDictName
'%%InjectedBy ' aDictName FindInFile
OR ( 'MELINK Stereotype st_ScriptKeywordsPack ;' aDictName FindInFile )
DUP ? ( Log: ( [ 'Collect Injected: ' aDictName ] strings:Cat ) )
)
(
IN aWord
aWord .Dependencies
.filter> .IsInjects
.map> .Target
if ( aWord .IsScriptKeywordsPack ) then
begin
.join> ( aWord .Inherits )
end // ( aWord .IsScriptKeywordsPack )
) // CollectInAllDictionaries:
'.ms.model.script.inj' '_InjectedElements' OutCollected
CollectInAllDictionaries:
(
STRING IN aDictName
'%%ImplementedBy ' aDictName FindInFile
AND (
( 'MELINK Stereotype st_VCMFormDefinition ;' aDictName FindInFile )
OR ( 'MELINK Stereotype st_Atom ;' aDictName FindInFile )
OR ( 'MELINK Stereotype st_Tag ;' aDictName FindInFile )
) // AND
DUP ? ( Log: ( [ 'Collect Implementors: ' aDictName ] strings:Cat ) )
)
(
IN aWord
aWord .Implements
.filter> (
IN anElement
RULES
( anElement .IsVCMFormDefinition )
true
( anElement .IsAtom )
true
DEFAULT
false
; // RULES
) // .filter>
) // CollectInAllDictionaries:
'.ms.model.script.impl' '_Implementors' OutCollected
PROGRAM DictionaryByName.ms.script
USES
ElementsRTTI.ms.dict
;
USES
GarantMetaModel.ms.dict
;
USES
CollectElements.ms.dict
;
USES
Log.ms.dict
;
CollectInAllDictionaries:
(
STRING IN aDictName
'%%InjectedBy ' aDictName FindInFile
OR ( 'MELINK Stereotype st_ScriptKeywordsPack ;' aDictName FindInFile )
DUP ? ( Log: ( [ 'Collect Injected: ' aDictName ] strings:Cat ) )
)
(
IN aWord
aWord .Dependencies
.filter> .IsInjects
.map> .Target
if ( aWord .IsScriptKeywordsPack ) then
begin
.join> ( aWord .Inherits )
end // ( aWord .IsScriptKeywordsPack )
) // CollectInAllDictionaries:
'.ms.model.script.inj' '_InjectedElements' OutCollected
CollectInAllDictionaries:
(
STRING IN aDictName
'%%ImplementedBy ' aDictName FindInFile
DUP ? ( Log: ( [ 'Collect Implementors: ' aDictName ] strings:Cat ) )
)
(
IN aWord
aWord .Implements
.filter> (
IN anElement
RULES
( anElement .IsVCMFormDefinition )
true
( anElement .IsAtom )
true
DEFAULT
false
; // RULES
) // .filter>
) // CollectInAllDictionaries:
'.ms.model.script.impl' '_Implementors' OutCollected
{ This _module is realization Boyer-Moore-Horspool search algorithm}
Unit l3TextSearch;
{ $Id: l3TextSearch.pas,v 1.2 2016/09/23 15:10:00 lulin Exp $ }
// $Log: l3TextSearch.pas,v $
// Revision 1.2 2016/09/23 15:10:00 lulin
// - подтачиваем.
//
// Revision 1.1 2016/09/23 13:00:04 lulin
// - подтачиваем.
//
// Revision 1.9 2009/02/20 10:08:38 lulin
// - чистка комментариев.
//
// Revision 1.8 2007/08/14 19:45:48 lulin
// - bug fix: не собиралась библиотека.
//
// Revision 1.7 2007/08/14 19:31:40 lulin
// - оптимизируем очистку памяти.
//
// Revision 1.6 2001/10/17 08:08:33 law
// - new lib: начинаем использовать m2.
//
// Revision 1.5 2001/09/04 14:40:07 law
// - delete unit: Language.
//
// Revision 1.4 2001/04/05 08:52:17 law
// - cleanup: использование модулей WinTypes и WinProcs заменен на Windows.
//
// Revision 1.3 2000/12/15 15:36:28 law
// - вставлены директивы Log.
//
unit msLineF;
interface
uses
System.Types,
FMX.DUnit.msLog
;
type
Pixel = Single;
TmsPointF = record
public
P : TPointF;
constructor Create(const aPoint: TPointF); overload;
constructor Create(aX: Pixel; aY: Pixel); overload;
procedure ToLog(aLog: TmsLog);
class function Normalize(const aPt: TmsPointF): TmsPointF; static;
function N: TmsPointF;
function ToString: String;
property X: Pixel
read P.X
write P.X;
property Y: Pixel
read P.Y
write P.Y;
end;//TmsPointF
TmsLineF = record
public
A : TmsPointF;
B : TmsPointF;
procedure ToLog(aLog: TmsLog);
function ToString: String;
function Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
// - пересечение линий
function SegmentsCross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
// - пересечение отрезков
constructor Create(const aA: TmsPointF; const aB: TmsPointF); overload;
constructor Create(const aA: TPointF; const aB: TPointF); overload;
constructor Create(aAX, aAY: Pixel; aBX, aBY: Pixel); overload;
function dX: Pixel;
function dY: Pixel;
function Length: Pixel;
function ScalarMul(const anOther: TmsLineF): Pixel;
function CosA(const anOther: TmsLineF): Single;
end;//TmsLineF
TmsLineFPair = record
public
L1 : TmsLineF;
L2 : TmsLineF;
constructor Create(const aL1: TmsLineF; const aL2: TmsLineF);
procedure ToLog(aLog: TmsLog);
function ToString: String;
function Cross(out theCross: TmsPointF): Boolean;
// - пересечение линий
function SegmentsCross(out theCross: TmsPointF): Boolean;
// - пересечение отрезков
end;//TmsLineFPair
TmsLineFPairs = array of TmsLineFPair;
TmsRectF = record
public
R : TRectF;
constructor Create(const aR: TRectF);
function Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
end;//TmsRectF
implementation
uses
System.SysUtils,
Math,
FMX.DUnit.msAppLog
;
// TmsPointF
constructor TmsPointF.Create(const aPoint: TPointF);
begin
P := aPoint;
end;
constructor TmsPointF.Create(aX: Pixel; aY: Pixel);
begin
Create(TPointF.Create(aX, aY));
end;
procedure TmsPointF.ToLog(aLog: TmsLog);
var
l_N : TmsPointF;
begin
l_N := Self.N;
aLog.ToLog('X:');
aLog.ToLog(FloatToStr(l_N.P.X));
aLog.ToLog('Y:');
aLog.ToLog(FloatToStr(l_N.P.Y));
end;
class function TmsPointF.Normalize(const aPt: TmsPointF): TmsPointF;
begin
Result := aPt;
end;
function TmsPointF.N: TmsPointF;
begin
Result := Normalize(Self);
end;
function TmsPointF.ToString: String;
var
l_P : TmsPointF;
begin
l_P := Self.N;
Result := FloatToStr(l_P.X) + '_' + FloatToStr(l_P.Y);
end;
// TmsLineF
procedure TmsLineF.ToLog(aLog: TmsLog);
begin
aLog.ToLog('dump line:');
aLog.ToLog('A:');
A.ToLog(aLog);
aLog.ToLog('B:');
B.ToLog(aLog);
end;
function TmsLineF.ToString: String;
begin
Result := A.ToString + '_' + B.ToString;
end;
function DoCross(const Self: TmsLineF; const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
var
dXdY : Pixel;
dYdX : Pixel;
dYdY : Pixel;
begin//DoCross
Result := false;
Assert(not IsZero(Self.dY));
// - теперь тут можно будет вставить ЛЮБОЙ ДРУГОЙ алгоритм и посмотреть - "что будет"
dXdY := Self.dX * anOther.dY;
dYdX := Self.dY * anOther.dX;
dYdY := Self.dY * anOther.dY;
if IsZero(dXdY - dYdX) then
// - условие параллельности прямых
begin
// Self.ToLog(TmsAppLog.Instance);
// anOther.ToLog(TmsAppLog.Instance);
theCross.X := -1;
theCross.Y := -1;
Exit;
end;//IsZero(dXdY - dYdX)
Assert(not IsZero(dXdY - dYdX));
theCross.Y := (
dXdY * Self.A.Y -
dYdX * anOther.A.Y +
dYdY * (anOther.A.X - Self.A.X)
)
/
(dXdY - dYdX);
theCross.X := Self.A.X +
Self.dX * (theCross.Y - Self.A.Y)
/
Self.dY;
Result := true;
end;//DoCross
function TmsLineF.Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
(*var
l_Angle : Single;*)
begin
Result := false;
theCross := TmsPointF.Create(High(Integer), High(Integer));
if IsZero(Self.Length) then
begin
theCross.X := 0;
if IsZero(anOther.Length) then
theCross.Y := 0;
Exit;
end//IsZero(Self.Length)
else
if IsZero(anOther.Length) then
begin
theCross.Y := 0;
Exit;
end;//IsZero(anOther.Length)
// Дальше нужно проверить параллельность прямых
(* l_Angle := ArcCos(Self.CosA(anOther));
if IsZero(l_Angle) OR SameValue(l_Angle, pi) OR SameValue(l_Angle, 2 * pi) then
begin
theCross.X := -1;
theCross.Y := -1;
Exit;
end;//IsZero(ArcCos(Self.CosA(anOther)))*)
if IsZero(Self.dY) then
begin
if IsZero(anOther.dX) then
begin
Result := true;
theCross.X := anOther.A.X;
theCross.Y := Self.A.Y;
Exit;
end//IsZero(anOther.dX)
else
begin
if IsZero(anOther.dY) then
begin
Result := false;
Exit;
end//IsZero(anOther.dY)
else
begin
Result := DoCross(anOther, Self, theCross);
Exit;
end;//IsZero(anOther.dY)
end;//IsZero(anOther.dX)
end//IsZero(Self.dY)
else
if IsZero(anOther.dY) then
begin
if IsZero(Self.dX) then
begin
Result := true;
theCross.X := Self.A.X;
theCross.Y := anOther.A.Y;
Exit;
end;//IsZero(Self.dX)
end;//IsZero(anOther.dY)
// Дальше можно по идее применять Мишин алгоритм:
Result := DoCross(Self, anOther, theCross);
end;
function TmsLineF.SegmentsCross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
function Btwn(aValue, aB1, aB2: Pixel): Boolean;
var
l_Min : Pixel;
l_Max : Pixel;
begin//Btwn
l_Min := Min(aB1, aB2);
l_Max := Max(aB1, aB2);
Result := ((aValue >= l_Min) OR SameValue(aValue, l_Min)) and
((aValue <= l_Max) OR SameValue(aValue, l_Max));
end;//Btwn
begin
Result := Cross(anOther, theCross);
if Result then
begin
Result := Btwn(theCross.X, Self.A.X, Self.B.X) and
Btwn(theCross.X, anOther.A.X, anOther.B.X) and
Btwn(theCross.Y, Self.A.Y, Self.B.Y) and
Btwn(theCross.Y, anOther.A.Y, anOther.B.Y);
end;//Result
end;
constructor TmsLineF.Create(const aA: TmsPointF; const aB: TmsPointF);
begin
A := aA;
B := aB;
end;
constructor TmsLineF.Create(const aA: TPointF; const aB: TPointF);
begin
Create(TmsPointF.Create(aA.X, aA.Y), TmsPointF.Create(aB.X, aB.Y));
end;
constructor TmsLineF.Create(aAX, aAY: Pixel; aBX, aBY: Pixel);
begin
Create(TmsPointF.Create(aAX, aAY), TmsPointF.Create(aBX, aBY));
end;
function TmsLineF.dX: Pixel;
begin
Result := (B.X - A.X);
end;
function TmsLineF.dY: Pixel;
begin
Result := (B.Y - A.Y);
end;
function TmsLineF.Length: Pixel;
begin
Result := Sqrt(dX * dX + dY * dY);
end;
function TmsLineF.ScalarMul(const anOther: TmsLineF): Pixel;
begin
Result := Self.dX * anOther.dX + Self.dY * anOther.dY;
end;
function TmsLineF.CosA(const anOther: TmsLineF): Single;
begin
Result := Self.ScalarMul(anOther) / (Self.Length * anOther.Length);
end;
// TmsLineFPair
constructor TmsLineFPair.Create(const aL1: TmsLineF; const aL2: TmsLineF);
begin
L1 := aL1;
L2 := aL2;
end;
procedure TmsLineFPair.ToLog(aLog: TmsLog);
begin
aLog.ToLog('L1:');
L1.ToLog(aLog);
aLog.ToLog('L2:');
L2.ToLog(aLog);
end;
function TmsLineFPair.ToString: String;
begin
Result := L1.ToString + '_' + L2.ToString;
end;
function TmsLineFPair.Cross(out theCross: TmsPointF): Boolean;
begin
Result := L1.Cross(L2, theCross);
end;
function TmsLineFPair.SegmentsCross(out theCross: TmsPointF): Boolean;
begin
Result := L1.SegmentsCross(L2, theCross);
end;
// TmsRectF
constructor TmsRectF.Create(const aR: TRectF);
begin
R := aR;
end;
function TmsRectF.Cross(const anOther: TmsLineF; out theCross: TmsPointF): Boolean;
var
l_R : array [0..3] of TmsLineF;
l_L : TmsLineF;
begin
Result := true;
l_R[0] := TmsLineF.Create(TPointF.Create(R.Left, R.Top), TPointF.Create(R.Right, R.Top));
l_R[1] := TmsLineF.Create(TPointF.Create(R.Right, R.Top), TPointF.Create(R.Right, R.Bottom));
l_R[2] := TmsLineF.Create(TPointF.Create(R.Left, R.Bottom), TPointF.Create(R.Right, R.Bottom));
l_R[3] := TmsLineF.Create(TPointF.Create(R.Left, R.Top), TPointF.Create(R.Left, R.Bottom));
for l_L in l_R do
if l_L.SegmentsCross(anOther, theCross) then
Exit;
Result := false;
end;
end.
Пример использования:
unit msConnector;
interface
uses
System.Types,
msInterfaces,
msLine,
msLineWithArrow,
Data.DBXJSONReflect
;
type
TmsConnector = class(TmsLineWithArrow{TmsLine})
strict private
[JSONMarshalled(False)]
f_LeftShape : ImsShape;
[JSONMarshalled(False)]
f_RightShape : ImsShape;
f_UIDLeft : TmsShapeUID;
f_UIDRight : TmsShapeUID;
private
function pm_GetLeftShape: ImsShape;
property LeftShape : ImsShape
read pm_GetLeftShape;
function pm_GetRightShape: ImsShape;
property RightShape : ImsShape
read pm_GetRightShape;
protected
constructor CreateInner(const aShapeClass : ImsShapeClass; const aCtx: TmsMakeShapeContext); override;
procedure SetStartPoint(const aStartPoint: TPointF); override;
function pm_GetStartPoint: TPointF; override;
function pm_GetFinishPoint: TPointF; override;
function HitTest(const aPoint: TPointF; out theShape: ImsShape): Boolean; override;
procedure MoveBy(const aCtx: TmsMoveContext); override;
function EndTo(const aCtx: TmsEndShapeContext): Boolean; override;
class function BoundByContext(const aCtx: TmsMakeShapeContext): ImsShape;
public
class function IsConnectorLike: Boolean; override;
end;//TmsConnector
implementation
uses
msLineF,
msTotalShapesList
;
// TmsConnector
class function TmsConnector.BoundByContext(const aCtx: TmsMakeShapeContext): ImsShape;
begin
Result := aCtx.rShapesController.ShapeByPt(aCtx.rStartPoint);
if (Result <> nil) then
if Result.ShapeClass.IsLineLike then
// - линии не будем привязывать к линиям
Result := nil;
end;
constructor TmsConnector.CreateInner(const aShapeClass : ImsShapeClass; const aCtx: TmsMakeShapeContext);
begin
inherited;
if (aCtx.rShapesController <> nil) then
begin
f_LeftShape := BoundByContext(aCtx);
if (f_LeftShape <> nil) then
f_UIDLeft := f_LeftShape.UID;
end;//aCtx.rShapesController <> nil
end;
function TmsConnector.pm_GetLeftShape: ImsShape;
begin
if (f_LeftShape = nil) then
if not f_UIDLeft.IsNull then
f_LeftShape := TmsTotalShapesList.ShapeByUID(f_UIDLeft);
Result := f_LeftShape;
end;
function TmsConnector.pm_GetRightShape: ImsShape;
begin
if (f_RightShape = nil) then
if not f_UIDRight.IsNull then
f_RightShape := TmsTotalShapesList.ShapeByUID(f_UIDRight);
Result := f_RightShape;
end;
procedure TmsConnector.SetStartPoint(const aStartPoint: TPointF);
begin
inherited;
end;
function TmsConnector.pm_GetStartPoint: TPointF;
var
l_A : TPointF;
l_B : TPointF;
l_R : TmsPointF;
begin
if (LeftShape <> nil) then
begin
l_A := LeftShape.StartPoint;
if (RightShape <> nil) then
l_B := RightShape.StartPoint
else
l_B := inherited pm_GetFinishPoint;
if TmsRectF.Create(LeftShape.DrawBounds).Cross(TmsLineF.Create(l_A, l_B), l_R) then
Result := l_R.P
else
Result := l_A;
end//LeftShape <> nil
else
Result := inherited;
end;
function TmsConnector.pm_GetFinishPoint: TPointF;
var
l_A : TPointF;
l_B : TPointF;
l_R : TmsPointF;
begin
(* if (inherited pm_GetStartPoint = inherited pm_GetFinishPoint) then
begin
Result := inherited pm_GetStartPoint;
Exit;
end;//inherited pm_GetStartPoint = inherited pm_GetFinishPoint*)
if (RightShape <> nil) then
begin
l_B := RightShape.StartPoint;
if (LeftShape <> nil) then
l_A := LeftShape.StartPoint
else
l_A := inherited pm_GetStartPoint;
if TmsRectF.Create(RightShape.DrawBounds).Cross(TmsLineF.Create(l_A, l_B), l_R) then
Result := l_R.P
else
Result := l_B;
end//RightShape <> nil
else
if (LeftShape = nil) then
// - если нет ОБОИХ границ, то мы - "линия"
Result := inherited
else
Result := pm_GetStartPoint;
// - если есть только левая граница, то мы - "точка"
end;
function TmsConnector.HitTest(const aPoint: TPointF; out theShape: ImsShape): Boolean;
begin
Result := true;
if (LeftShape <> nil) AND LeftShape.HitTest(aPoint, theShape) then
Exit;
if (RightShape <> nil) AND RightShape.HitTest(aPoint, theShape) then
Exit;
Result := inherited;
end;
procedure TmsConnector.MoveBy(const aCtx: TmsMoveContext);
(*var
l_Shape : ImsShape;*)
begin
(* if (aCtx.rShapesController <> nil) then
begin
if (RightShape = nil) then
begin
if SamePoint(Self.FinishPoint, aCtx.rStartPoint) then
begin
RightShape := aCtx.rShapesController.ShapeByPt(Self.FinishPoint + aCtx.rDelta);
if Self.EQ(RightShape) then
RightShape := nil;
end;//SamePoint(Self.FinishPoint, aCtx.rStartPoint)
end;//RightShape = nil
end;//aCtx.rShapesController <> nil
if (LeftShape <> nil) AND SamePoint(aCtx.rStartPoint, Self.StartPoint) then
begin
LeftShape.MoveBy(aCtx);
Exit;
end;//LeftShape <> nil
if (RightShape <> nil) AND RightShape.HitTest(aCtx.rStartPoint + aCtx.rDelta, l_Shape) then
begin
RightShape.MoveBy(aCtx);
Exit;
end;//RightShape <> nil*)
inherited;
end;
function TmsConnector.EndTo(const aCtx: TmsEndShapeContext): Boolean;
begin
if (aCtx.rShapesController <> nil) then
begin
f_RightShape := BoundByContext(aCtx);
if (f_RightShape <> nil) then
f_UIDRight := f_RightShape.UID;
end;//aCtx.rShapesController <> nil
Result := inherited;
end;
class function TmsConnector.IsConnectorLike: Boolean;
begin
Result := true;
end;
end.
enum {LEFT, RIGHT, BEYOND, BEHIND, BETWEEN, ORIGIN, DESTINATION};
// СЛЕВА, СПРАВА, ВПЕРЕДИ, ПОЗАДИ, МЕЖДУ, НАЧАЛО, КОНЕЦ
int Point::classify(Point &p0, Point &pl)
{
Point p2 = *this;
Point a = p1 - pO;
Point b = p2 - pO;
double sa = a. x * b.y - b.x * a.y;
if (sa > 0.0)
return LEFT;
if (sa < 0.0)
return RIGHT;
if ((a.x * b.x < 0.0) || (a.y * b.y < 0.0))
return BEHIND;
if (a.length() < b.length())
return BEYOND;
if (pO == p2)
return ORIGIN;
if (p1 == p2)
return DESTINATION;
return BETWEEN;
}
UNIT msm.ms.dict
USES
core.ms.dict
;
USES
ModelElementsDefinition.ms.dict
;
USES
ElementsRTTI.ms.dict
;
USES
GarantMetaModel.ms.dict
;
USES
IsNil.ms.dict
;
USES
arrays.ms.dict
;
elem_iterator NullList
[empty] >>> Result
; // NullList
WordAlias ._NullList .NullList
elem_iterator SelfList
[ Self ] >>> Result
; // SelfList
WordAlias ._SelfList .SelfList
elem_iterator Inner
Cached:
(
Self .Children
.join> ( Self .Constants )
.join> ( Self .Attributes )
.join> ( Self .Operations )
.join> ( Self .Dependencies )
.join> ( Self .Parameters )
)
>>> Result
; // Inner
USES
FirstElement.ms.dict
;
STRING elem_func UpText
Self .NameInModel >>> Result
if ( Result .IsNil ) then
begin
Self .WordName >>> Result
end // ( Result .IsNil )
if ( Self .IsUP ) then
begin
VAR l_Value
[ Self DO ]
.map> (
IN aValue
RULES
( aValue IsObj )
( aValue .Name )
DEFAULT
( aValue ToPrintable )
; // RULES
)
.FirstElement >>> l_Value
[ Result ' = ' l_Value ] strings:Cat >>> Result
end // ( Self .IsUP )
; // UpText
STRING elem_func LinkName
'' >>> Result
VAR l_St
Self .Stereotype >>> l_St
if (
( l_St .NotIsNil )
AND ( l_St .NameInModel .NotIsNil )
) then
begin
[ '<<' l_St .NameInModel '::' string:Split DROP '>>' ] strings:Cat >>> Result
end // ( l_St .NotIsNil )
if ( Self .NameInModel .NotIsNil ) then
begin
[ Result Self .NameInModel ] ' ' strings:CatSep >>> Result
end // ( Self .NameInModel .NotIsNil )
; // LinkName
STRING elem_func StereotypeName
Cached:
(
VAR l_St
Self .Stereotype >>> l_St
if (
( l_St .NotIsNil )
AND ( l_St .NameInModel .NotIsNil )
) then
begin
[ '<<' l_St .NameInModel '>>' ] strings:Cat
end // ( l_St .NotIsNil )
else
begin
[ '[[' Self .MDAClassString ']]' ] strings:Cat
// '<<default>>'
end
)
>>> Result
; // StereotypeName
STRING elem_func NameNotEmpty
Cached:
(
Self .NameInModel
>>> Result
if ( Result .IsNil ) then
begin
'(unnamed)' >>> Result
end // ( Result .IsNil )
Result
)
>>> Result
; // NameNotEmpty
STRING elem_func NameWithStereo
Cached:
(
Self .NameNotEmpty >>> Result
VAR l_St
Self .StereotypeName >>> l_St
if ( l_St .NotIsNil ) then
begin
[ l_St ' ' Result ] strings:Cat >>> Result
end // ( l_St .NotIsNil )
Result
)
>>> Result
; // NameWithStereo
STRING elem_func ValueString
'' >>> Result
VAR l_Value
Self .GetUP 'Value' >>> l_Value
if ( l_Value .IsValueValid ) then
begin
l_Value ToPrintable >>> Result
end // ( l_Value .IsValueValid )
; // ValueString
USES
CountIt.ms.dict
;
ModelElement elem_func FirstOperation
Cached:
(
Self .Operations
.filter> ( .IsLocalMethod ! )
.FirstElement
)
>>> Result
; // FirstOperation
elem_iterator MethodParameters
Cached:
(
RULES
( Self .IsMethod )
( Self .FirstOperation .Parameters )
( Self .IsFunction )
( Self .FirstOperation .Parameters )
DEFAULT
( Self .Parameters )
; // RULES
)
>>> Result
; // MethodParameters
USES
ElemMemberPrim.ms.dict
;
ModelElement elem_func MethodTarget
Cached:
(
RULES
( Self .IsMethod )
( Self .FirstOperation .Target )
( Self .IsFunction )
( Self .FirstOperation .Target )
( Self .IsViewLink )
RULES
( Self .Target .IsNil )
( Self .To )
DEFAULT
( Self .Target )
; // RULES
DEFAULT
( Self .Target )
; // RULES
)
>>> Result
; // MethodTarget
STRING elem_func ParametersString
'' >>> Result
VAR l_P
VAR l_Open
VAR l_Close
if ( Self .MDAClass class_Attribute == ) then
begin
Self .Attributes >>> l_P
'[' >>> l_Open
']' >>> l_Close
end // ( Self .MDAClass class_Attribute == )
else
begin
Self .MethodParameters >>> l_P
'(' >>> l_Open
')' >>> l_Close
end // ( Self .MDAClass class_Attribute == )
if ( l_P .NotEmpty ) then
begin
[
VAR l_WasParam
false >>> l_WasParam
l_Open
l_P .for> (
IN aParam
if l_WasParam then
', '
VAR l_St
aParam .Stereotype >>> l_St
if ( l_St .NotIsNil ) then
begin
if ( l_St .NameInModel 'in' != ) then
begin
l_St .NameInModel ' '
end // ( l_St .NameInModel 'in' != )
end // ( l_St .NotIsNil )
aParam .NameInModel
VAR l_T
aParam .Target >>> l_T
VAR l_N
if ( l_T .IsNil ) then
begin
'void' >>> l_N
end // ( l_T .IsNil )
else
begin
l_T .NameInModel >>> l_N
end // ( l_T .IsNil )
': ' l_N
VAR l_V
aParam .ValueString >>> l_V
if ( l_V .NotIsNil ) then
begin
' = ' l_V
end // ( l_V .NotIsNil )
true >>> l_WasParam
) //l_P .for>
l_Close
] strings:Cat >>> Result
end // l_P .NotEmpty
; // ParametersString
STRING elem_func Signature
Cached:
(
[ Self .NameNotEmpty Self .ParametersString ] strings:Cat >>> Result
if ( Self .IsViewLink ) then
begin
if ( Self .From .NotIsNil ) then
begin
[ Result ' ' Self .From .NameInModel ] strings:Cat >>> Result
end // ( Self .From .NotIsNil )
if ( Self .To .NotIsNil ) then
begin
[ Result ' -> ' Self .To .NameInModel ] strings:Cat >>> Result
end // ( Self .To .NotIsNil )
end // ( Self .IsViewLink )
else
begin
VAR l_T
Self .MethodTarget >>> l_T
if ( l_T .NotIsNil ) then
begin
VAR l_Name
l_T .NameInModel >>> l_Name
if ( l_Name .IsNil ) then
begin
'void' >>> l_Name
end // ( l_Name .IsNil )
[ Result ': ' l_Name ] strings:Cat >>> Result
end // ( l_T .NotIsNil )
end // ( Self .IsViewLink )
Result
)
>>> Result
; // NameNotEmpty
STRING elem_func NameWithStereoAndTarget
Cached:
(
[ Self .StereotypeName Self .Signature ] ' ' strings:CatSep
)
>>> Result
; // NameWithStereoAndTarget
STRING elem_func NameWithStereoAndTargetAndValue
Cached:
(
Self .NameWithStereoAndTarget
>>> Result
VAR l_Value
Self .ValueString >>> l_Value
if ( l_Value .NotIsNil ) then
begin
[ Result ' = ' l_Value ] strings:Cat >>> Result
end // ( l_Value .NotIsNil )
Result
)
>>> Result
; // NameWithStereoAndTargetAndValue
STRING elem_func NameWithStereoAndTargetAndValueAndDoc
Self .NameWithStereoAndTargetAndValue >>> Result
VAR l_D
Self .Documentation >>> l_D
if ( l_D .NotIsNil ) then
begin
[ Result #10 ' - ' l_D ] strings:Cat >>> Result
end // ( l_D .NotIsNil )
; // NameWithStereoAndTargetAndValueAndDoc
STRING elem_func DocumentationNotEmpty
Self .Documentation >>> Result
if ( Result .IsNil ) then
begin
'Элемент не документирован' >>> Result
end // ( Result .IsNil )
; // DocumentationNotEmpty
BOOLEAN elem_func IsFinished
Self .GetUP "finished" false ?!=
>>> Result
; // IsFinished
WordAlias .DefaultShortText .NameWithStereo
//WordAlias .DefaultText .Name
//WordAlias .DefaultSearchText .Name
WordAlias .DefaultSearchText .NameInModel
WordAlias .DefaultText .NameWithStereoAndTargetAndValue
WordAlias .DefaultFullText .DefaultText
WordAlias .DefaultTextAndDoc .NameWithStereoAndTargetAndValueAndDoc
USES
CompileTimeVar.ms.dict
;
USES
Log.ms.dict
;
BOOLEAN CompileTime-VAR g_NeedTerminate false
PROCEDURE TerminateLoadInner
true >>> g_NeedTerminate
Log: 'Terminate Request'
; // TerminateLoadInner
FORWARD .MainDiagram
elem_proc LoadChildInfo
if ( g_NeedTerminate ! ) then
begin
Self .Stereotype DROP
Self .NameWithStereo DROP
Self .DefaultText DROP
Self .Parent DROP
Self .IsSummoned DROP
Self .MainDiagram DROP
Self .Depends DROP
Self .Inherits DROP
Self .Implements DROP
//Self .Implemented DROP
//Self .Overridden DROP
//Self .Dependencies DROP
//Self .UpList DROP
//Self .DocumentationNotEmpty DROP
Self .Inner DROP
end // ( g_NeedTerminate ! )
; // LoadChildInfo
elem_proc LoadInnerPrim
if ( g_NeedTerminate ! ) then
begin
Self .LoadChildInfo
Self .Inner .for> (
if g_NeedTerminate then
begin
DROP
end // g_NeedTerminate
else
begin
call.me
end // g_NeedTerminate
) // Self .Children .for>
end // ( g_NeedTerminate ! )
; // LoadInnerPrim
BOOLEAN elem_func LoadLevel
true >>> Result
if ( g_NeedTerminate ! ) then
begin
Self .LoadChildInfo
/*{ Self .Inner .for> (
if g_NeedTerminate then
begin
DROP
end // g_NeedTerminate
else
begin
.LoadChildInfo
end // g_NeedTerminate
) // Self .Children .for>}*/
end // ( g_NeedTerminate ! )
; // LoadLevel
BOOLEAN elem_func LoadInner
Log: 'Loading'
true >>> Result
Self .LoadInnerPrim
if g_NeedTerminate then
begin
Log: 'Terminated'
end // g_NeedTerminate
else
begin
Log: 'Loaded'
end // g_NeedTerminate
; // LoadInner
USES
axiom:TColor
;
INTEGER elem_func msm:View:ForeColor
RULES
( Self .IsProject )
TColor::clGreen
( Self .IsUnit )
TColor::clGreen
( Self .IsExeTarget )
TColor::clGreen
( Self .IsLibrary )
TColor::clBlue
( Self .IsInterfaces )
TColor::clNavy
( Self .IsStereotype st_Facet )
TColor::clNavy
( Self .IsStereotype st_Interface )
TColor::clNavy
( Self .IsMixIn )
TColor::clFuchsia
//TColor::clMoneyGreen
//TColor::clLime
( Self .IsSimpleClass )
TColor::clGreen
( Self .IsUtilityPack )
TColor::clRed
( Self .IsMixInMirror )
TColor::clAqua
( Self .IsEnum )
TColor::clOlive
( Self .IsTypedef )
TColor::clMedGray
DEFAULT
TColor::clDefault
; // RULES
>>> Result
; // msm:View:ForeColor
USES
WordsRTTI.ms.dict
;
INTEGER elem_func msm:View:BackColor
INTEGER elem_func StereotypeBackColor
Cached:
(
VAR l_Color
Self .GetUP "visualization bg color" >>> l_Color
RULES
( l_Color IsInt )
l_Color
DEFAULT
begin
Self .StereotypeInModel .GetUP "visualization bg color" >>> l_Color
RULES
( l_Color IsInt )
l_Color
DEFAULT
begin
TColor::clDefault >>> l_Color
Self .Inherited.Words .for> (
IN anAncestor
VAR l_AncestorColor
anAncestor call.me >>> l_AncestorColor
RULES
(
( l_AncestorColor IsInt )
AND ( l_AncestorColor TColor::clDefault != )
)
(
l_AncestorColor >>> l_Color
BREAK-ITERATOR
)
; // RULES
) // Self .Inherited.Words .for>
l_Color
end // DEFAULT
; // RULES
end // DEFAULT
; // RULES
)
>>> Result
; // StereotypeBackColor
VAR l_Color
Self .Stereotype .StereotypeBackColor >>> l_Color
RULES
( l_Color IsInt )
RULES
( l_Color TColor::clDefault == )
( Self .msm:View:ForeColor )
DEFAULT
l_Color
; // RULES
DEFAULT
( Self .msm:View:ForeColor )
; // RESULT
>>> Result
; // msm:View:BackColor
STRING elem_func msm:View:LabelName
STRING elem_func StereotypeLabelName
Cached:
(
VAR l_Label
Self .GetUP "personal label" >>> l_Label
RULES
( l_Label .NotIsNil )
l_Label
DEFAULT
begin
Self .StereotypeInModel .GetUP "personal label" >>> l_Label
RULES
( l_Label .NotIsNil )
l_Label
DEFAULT
begin
'' >>> l_Label
Self .Inherited.Words .for> (
IN anAncestor
VAR l_AncestorLabel
anAncestor call.me >>> l_AncestorLabel
RULES
( l_AncestorLabel .NotIsNil )
(
l_AncestorLabel >>> l_Label
BREAK-ITERATOR
)
; // RULES
) // Self .Inherited.Words .for>
l_Label
end // DEFAULT
; // RULES
end // DEFAULT
; // RULES
)
>>> Result
; // StereotypeLabelName
VAR l_Label
Self .Stereotype .StereotypeLabelName >>> l_Label
RULES
( l_Label .NotIsNil )
l_Label
( Self .IsUseCase )
'code_use_case'
( Self .MDAClass class_Operation == )
'code_method'
( Self .MDAClass class_Attribute == )
'code_attr'
( Self .MDAClass class_Parameter == )
'code_param'
( Self .MDAClass class_Dependency == )
'code_mda_dependency'
( Self .MDAClass class_Inherits == )
'code_mda_dependency'
( Self .MDAClass class_Implements == )
'code_mda_dependency'
( Self .MDAClass class_Depends == )
'code_dep'
DEFAULT
''
; // RESULT
>>> Result
; // msm:View:LabelName
STRING elem_func msm:View:ImageFileName
Self .msm:View:LabelName >>> Result
if ( Result .NotIsNil ) then
begin
[ 'W:\MDProcess\MDAGenerator\other\images\' Result '.gif' ] strings:Cat >>> Result
end // ( Result .NotIsNil )
; // msm:View:ImageFileName
BOOLEAN elem_func IsCategory
Self .MDAClass class_Category ==
>>> Result
; // IsCategory
BOOLEAN elem_func IsAttribute
Self .MDAClass class_Attribute ==
>>> Result
; // IsAttribute
BOOLEAN elem_func IsAbstract
Self .Abstraction at_abstract ==
>>> Result
; // IsAbstract
BOOLEAN elem_func IsFinal
Self .Abstraction at_final ==
>>> Result
; // IsFinal
USES
axiom:TPenStyle
;
INTEGER elem_func msm:View:LinkLineStyle
Cached:
(
RULES
( Self .IsAttribute )
TPenStyle::psSolid
( Self .MDAClass class_Inherits ?== )
TPenStyle::psSolid
( Self .MDAClass class_Implements ?== )
TPenStyle::psDash
( Self .LinkViewType 'Inherits' ?== )
TPenStyle::psSolid
( Self .LinkViewType 'Implements' ?== )
TPenStyle::psDash
DEFAULT
TPenStyle::psDash
; // RULES
)
>>> Result
; // msm:View:LinkLineStyle
INTEGER elem_func msm:View:LinkLineColor
Cached:
(
RULES
( Self .IsAttribute )
TColor::clBlack
( Self .MDAClass class_Inherits ?== )
TColor::clBlack
( Self .MDAClass class_Implements ?== )
TColor::clBlack
( Self .LinkViewType 'Inherits' ?== )
TColor::clBlack
( Self .LinkViewType 'Implements' ?== )
TColor::clBlack
DEFAULT
TColor::clDefault
; // RULES
)
>>> Result
; // msm:View:LinkLineColor
BOOLEAN elem_func msm:View:LinkArrowIsPolygon
Cached:
(
RULES
( Self .IsAttribute )
false
( Self .MDAClass class_Inherits ?== )
true
( Self .MDAClass class_Implements ?== )
true
( Self .LinkViewType 'Inherits' ?== )
true
( Self .LinkViewType 'Implements' ?== )
true
DEFAULT
false
; // RULES
)
>>> Result
; // msm:View:LinkArrowIsPolygon
USES
LoadOnDemand.ms.dict
;
USES
CutSuffix.ms.dict
;
USES
CutPrefix.ms.dict
;
INTEGER elem_func X
Self 'X' 0 .ElemMember >>> Result
; // X
INTEGER elem_func Y
Self 'Y' 0 .ElemMember >>> Result
; // Y
INTEGER elem_func Width
Self 'Width' 120 .ElemMember >>> Result
; // Width
INTEGER elem_func Height
Self 'Height' 100 .ElemMember >>> Result
; // Height
WordAlias .msm:View:X .X
WordAlias .msm:View:Y .Y
WordAlias .msm:View:Width .Width
WordAlias .msm:View:Height .Height
WordAlias .msm:View:From .From
WordAlias .msm:View:To .To
elem_iterator Diagrams
Self 'Diagrams' .ElemList >>> Result
; // Diagrams
elem_iterator Views
Self 'Views' .ElemList >>> Result
; // Views
elem_iterator msm:Diagrams
VAR l_Name
Self .WordName '_view' .CutSuffix >>> l_Name
VAR l_DictName
l_Name 'ME_' .CutPrefix >>> l_DictName
l_DictName '.ms.diagram.script' Cat >>> l_DictName
l_Name '_diagrams' Cat >>> l_Name
WL l_Name l_DictName
.Diagrams
>>> Result
; // msm:Diagrams
elem_iterator MainDiagram
Self .msm:Diagrams
.FirstElement
.Views
>>> Result
; // MainDiagram
BOOLEAN elem_func HasMainDiagram
Self .MainDiagram .NotIsNil
>>> Result
; // HasMainDiagram
USES
DictionaryByName.ms.dict
;
ModelElement FUNCTION .WordByDictionaryPath
IN aPath
aPath DictionaryAndMainWordByName
>>> Result // - возвращаем слово
DROP // - выкидываем словарь
; // .WordByDictionaryPath
EXPORTS
arrays.ms.dict
EXPORTS
ElementsRTTI.ms.dict
USES
CheckValue.ms.dict
;
EXPORTS
CheckValue.ms.dict
EXPORTS
GarantMetaModel.ms.dict
USES
ElemMemberPrim.ms.dict
;
EXPORTS
ElemMemberPrim.ms.dict
