пятница, 30 сентября 2016 г.

#1276. Побрюзжу... Об "общей модели системы"...

http://18delphi.blogspot.ru/2013/09/blog-post_1303.html

Я придумал, как "так" не делать, но это уже вряд ли кому-то интересно.

Главное, что "главные идеологи" - они "давно умыли свои руки"...

Та же "банда" и "прочие Бруксы"... Не говоря уж про идеологов "помельче"...

#1275. И ещё ещё просто код

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

#1274. И ещё просто код

По мотивам - http://programmingmindstream.blogspot.ru/2016/09/1273.html

Тут "лямбды" - "везде".

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


#1273. Ссылка. А ваш язык программирования так может?

http://local.joelonsoftware.com/wiki/%D0%90_%D0%B2%D0%B0%D1%88_%D1%8F%D0%B7%D1%8B%D0%BA_%D0%BF%D1%80%D0%BE%D0%B3%D1%80%D0%B0%D0%BC%D0%BC%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F_%D1%82%D0%B0%D0%BA_%D0%BC%D0%BE%D0%B6%D0%B5%D1%82%3F

"Мой" - может...

"Во многих старых языках программирования просто нет способа проделать этот трюк. Другие языки позволят вам сделать это, но достаточно сложно (например, в С есть указатели на функции, но вы должны объявить и определить функцию где-либо в другом месте). Объектно-ориентированные языки программирования не вполне уверены, что вам следует разрешить делать что-нибудь с функциями.
Java требует от вас создать отдельный объект с одним методом, так называемый функтор, если вы хотите представить функцию как объект первого рода (прим. пер.: first class object, те сущности языка программирования, которые можно использовать без ограничений при хранении в переменных, хранении в более сложных структурах, передаче в функции как аргумент, и т.д.). Добавьте к этому факт, что множество ОО-языков вынуждают вас создавать отдельный файл для каждого класса, и это делает код неуклюжим очень быстро. Если ваш язык программирования требует от вас использования функторов, вы не получите всех преимуществ современной среды программирования. Посмотрите, сможете ли вы получить ваши деньги обратно.
Какое преимущество вы реально получите от написания крошечных функций, которые не делают ничего более, чем пробегают по массиву и проделывают что-нибудь с каждым элементом?
Хорошо, давайте вернемся к функции map. Когда вам нужно сделать что-нибудь с каждым элементом массива по очереди на самом деле вам возможно не важно в какой очередности вы это делаете. Вы можете пробежаться по массиву вперед или назад и получить одинаковый результат, верно? В действительности, если у вас в распоряжении есть два процессора, может быть вы напишете какой-нибудь код для того, чтобы каждый процессор обрабатывал половину элементов, и внезапно map становится в два раза быстрее.
Или, возможно, чисто гипотетически, у вас есть сотни тысяч серверов в нескольких центрах обработки данных по всему миру, и у вас есть действительно большой массив, содержащий, скажем, опять чисто гипотетически, всё содержимое Internet'а. Теперь вы можете запустить map на тысячах компьютеров, каждый из которых будет штурмовать маленькую часть проблемы.
Таким образом сейчас, например, написание какого-либо по-настоящему быстрого кода для поиска во всём содержимом Internet'а просто сводится к вызову функции map с простой функцией поиска строки в качестве аргумента.
Действительно интересная вещь, на которую я хочу обратить ваше внимание здесь, что как только вы подумаете о map и reduce как о функциях, которые все могут использовать (и используют их), вам нужен только супергений, чтобы написать тяжелый код, чтобы запустить map и reduce на глобальном параллельном массиве компьютеров, и весь старый код, который отлично работал, когда вы запускали небольшие циклы, по-прежнему работает, только в огромное число раз быстрее, что значит он может использоваться для решения действительно больших проблем за секунду."

#1272. Просто код

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

четверг, 29 сентября 2016 г.

#1271. Ни о чём. История одного модуля...

{ 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.
//

16-ть лет...

суббота, 24 сентября 2016 г.

#1270. Ссылка. И ещё про коллинеарность

http://programmingmindstream.blogspot.ru/2014/07/blog-post_5.html

По "мотивам" - http://programmingmindstream.blogspot.ru/2016/09/1267.html

И что тут есть sa?

И как sa сравнивать с нулём? В какой "эпсилон окрестности"?

#1269. Кстати о коллинеарности векторов

http://programmingmindstream.blogspot.ru/2014/07/blog-post_7.html

Я там правда скалярное произведение с векторным перепутал.

Но это же "мелочи"...

#1268. Только код. Определение места пересечения прямой с прямоугольником (Bounding Rect)

По "мотивам" - http://programmingmindstream.blogspot.ru/2016/09/1267.html

Всё те же "определители матрицы" и "векторные произведения"...

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.


#1267. Хотел написать "ругательный пост"

Хотел написать "ругательный пост". О "программистах" и "математиках".

Вместо этого "пока лишь" задам вопрос".

Вот тут - http://algolist.manual.ru/maths/geom/datastruct.php

Обсуждается "задача определения принадлежности точки прямой".

И всё вроде бы "хорошо". Даже "решение" дано:

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;
}

И "пояснительный текст":

"Вначале проверяется ориентация точек p0, p1 и р2, чтобы определить, располагается ли точка р2 слева или справа, или она коллинеарна с отрезком p0p1. В последнем случае необходимы дополнительные вычисления, ели векторы a=pl-pO и b=р2-p0 имеют противоположное направление, то точка р2 лежит позади направленного отрезка p0p1 если вектор а короче вектора b, то точка р2 расположена после отрезка p0p1. В противном случае точка р2 сравнивается с точками p0 и р1 для определения, совпадает ли с одной из этих концевых точек или лежит между ними."

И "теоретическая база"...

И всё такое...

Векторное произведение. "Площадь параллелограмма". Коллинеарность и "всё такое"..

Определитель матрицы "если точнее"...

Но! Почему это НЕ РАБОТАЕТ?

И что такое sa?

И ПОЧЕМУ там написано sa < 0 и sa > 0?

И НИКТО не подумал про "эпсилон окрестность"... И дело даже не в "разрядной сетке".

А вот в чём?

Вот ЗАДАЮ вопрос - "в чём дело и ПОЧЕМУ ЭТО не работает".

И как это ИСПРАВИТЬ?

Не надо только думать, что я "лох который не смог разобраться".

Я то - разобрался.

И НАШЁЛ как "это" исправить".

И даже "понял" - почему этот метод НЕЛЬЗЯ применять "на практике".

В этом кстати кроется отличие между "математиками" и "программистами"...

Так вот "почему" и "что не работает"?

И как заставить работать?

И ещё вопрос.

Раз уж мы говорим о векторах и углах между ними.

То ПОЧЕМУ бы нам просто не посчитать УГЛЫ от оси X для одного вектора и другого. В РАДИАНАХ. И не сравнить их равенство в "той самой эпсилон окрестности"?

Ну или "длину нормали к прямой" уж на "худой конец". Хотя "в пределе" она будет стремиться к "разнице углов в радианах".

Ну или почему бы просто не "решить уравнение" прямой - https://habrahabr.ru/post/148325/

Ну и "на закуску" - http://math.stackexchange.com/questions/175896/finding-a-point-along-a-line-a-certain-distance-away-from-another-point

http://gospodaretsva.com/urok-31-proverka-prinadlezhnosti-tochki-otrezku.html

http://forum.codenet.ru/q35421/

"Если вместо x и y подставить координаты точки, то:
(x - x1) * (y2 - y1) - (x2 - x1) * (y - y1) > 0 , когда точка лежит ниже(правее) линии и
(x - x1) * (y2 - y1) - (x2 - x1) * (y - y1) < 0 , когда точка лежит выше(левее) линии.
Линию с заданной толщиной воспринимай как две линии, смещенные в разные стороны на половину толщины."

ОПЯТЬ! Тоже самое "векторное произведение" или "определитель матрицы".

Ну и ПОЧЕМУ это НЕЛЬЗЯ использовать?

Особенно на "длинных" отрезках.

B ЧТО написать ВМЕСТО sa < 0 и sa> 0?

Хинт.. |sa| < e, Где e - это "эпсилон вычислительной точности" - НЕ РАБОТАЕТ!

четверг, 15 сентября 2016 г.

#1265. Скрипты рисовалки модели

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

#1264. Скришот из рисовалки модели №8



#1263. Скришот из рисовалки модели №7


понедельник, 5 сентября 2016 г.