l(*

Компонент позволяющий отображать формулы (наследник от TCustomLabel).Возможности: вывод греческих символов, вывод специальных математических символов (в пределах фонта Symbol, использование верхних и нижних индексов, но не одновременно, выравнивание выводимой формулы по вертикали и горизонтали, смена начертания внутри формулы.   Для задания формулы используется текст свойства Caption. Формула описывается в текстовом режиме.

Зарезервированные символы

  <пробел>, '\', '^','_', '}','{'.

  Для вывода зарезервированных символов необходимо использовать их совместно с

  символом \. Например для вывода пробела ипользуется  \<пробел>,

  правая фигурная скобка\}. Символы {} зарезервированы для дальнейшнго

  расширения.

 

  Символы греческого алфавита и спецсимволы:

  \Delta,           \Downarrow, \Gamma,       \Lambda,     \LeftArrow,

  \Leftrightarrow,  \Omega,     \RightArrow,  \Phi,        \Pi,

  \Psi,             \Sigma,     \Theta,       \Uparrow,    \Upsilon,

  \Xi,              \alpha,     \angle,       \approx,     \beta,

  \bullet,          \cap,       \cdot,        \chi,        \cong,

  \delta,           \diamond,   \div,         \downarrow,  \epsilon,

  \equiv,           \eta,       \gamma,       \ge,         \gets,

  \in,              \infinity,  \iota,        \kappa,      \lambda,

  \le,              \mu,        \ne,          \notin,      \nu,

  \omega,           \oplus,     \oslash,      \otimes,     \partial,

  \perp,            \phi,       \pi,          \pm,         \psi,

  \rho,             \sigma,     \subset,      \subseteq,   \supset,

  \tau,             \theta,     \times,       \to,         \uncup,

  \uparrow,         \upsilon,   \varepsilon,  \varphi,     \varpi,

  \varsigma,        \vee,       \wedge,       \xi,         \zeta.

 

 Для задания верхних и нижних идексов используются символы ^ и _ соответственно.

 Для смены начертания символов

  \it  -- италика (курсив)

  \bl  -- bold    (жирный)

  \ul  -- underline (подчеркнутый)

  \st  -- strike  (перечеркнутый)

  \rm  -- отмена смены начертания

 

 Недостатки: невозможность использовать струтурные скобки {}

 работа только на одной базовой линии (нельзя использовать \frac) и т.д.

 Да и нельзя реализовать TeX в 20-30 строках кода.

 

 

 Примеры:

  S=\pi R^2  -- площадь круга

  С_2 H_5 OH -- OН и есть

  \Delta \phi = 0 уравнение Пуассона

*)

 

unit MathLabel;

 

interface

uses

  Windows, Messages, SysUtils, Graphics, Classes, Controls, StdCtrls;

 

type

  TAlignH=(taLeftJustifyH, taRightJustifyH, taCenterH, taAutoH);

  TAlignV=(taTopJustifyV,  taDownJustifyV,  taCenterV, taAutoV);

 

  TMathLabel = class(TCustomLabel)

  private

   FontList:TList;

   FAlignH:TAlignH;

   FAlignV:TAlignV;

   FOldText:string;

   RectText:TRect;

   procedure ClearFontList;

   procedure FillFontList;

   procedure SetAlignH(Value:TAlignH);

   procedure SetAlignV(Value:TAlignV);

  protected

   procedure PrepareDrawText;

   procedure DoDrawText(var Rect: TRect; Flags: Longint);override;

   procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;

   procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

  public

   constructor Create(AOwner:TComponent);override;

   destructor  Destroy;override;

  published

   property Caption;

   property Font;

   property AlignH:TAlignH read FAlignH write SetAlignH;

   property AlignV:TAlignV read FAlignV write SetAlignV;

  end;

 

implementation

uses Math;

Type

 TCharSymbol=(

 s__Delta, s__Downarrow, s__Gamma, s__Lambda, s__LeftArrow,

 s__Leftrightarrow, s__Omega, s__RightArrow, s__Phi, s__Pi,

 s__Psi, s__Sigma, s__Theta, s__Uparrow, s__Upsilon, s__Xi,

 s_alpha, s_angle, s_approx, s_beta, s_bullet, s_cap,

 s_cdot, s_chi, s_cong, s_delta, s_diamond, s_div,

 s_downarrow, s_epsilon, s_equiv, s_eta, s_gamma,

 s_ge, s_gets, s_in, s_infinity, s_iota, s_kappa,

 s_lambda, s_le, s_mu, s_ne, s_notin, s_nu, s_omega,

 s_oplus, s_oslash, s_otimes, s_partial, s_perp, s_phi,

 s_pi, s_pm, s_psi, s_rho, s_sigma, s_subset,

 s_subseteq, s_supset, s_tau, s_theta, s_times,s_to,

 s_uncup, s_uparrow, s_upsilon, s_varepsilon, s_varphi,

 s_varpi, s_varsigma, s_vee, s_wedge, s_xi, s_zeta

 );

const

 ArrNameSymbol:array[Ord(s__Delta)..Ord(s_zeta)] of string=

 ('Delta', 'Downarrow', 'Gamma', 'Lambda', 'LeftArrow',

 'Leftrightarrow', 'Omega', 'RightArrow', 'Phi', 'Pi',

 'Psi', 'Sigma', 'Theta', 'Uparrow', 'Upsilon', 'Xi',

 'alpha', 'angle', 'approx', 'beta', 'bullet', 'cap',

 'cdot', 'chi', 'cong', 'delta', 'diamond', 'div',

 'downarrow', 'epsilon', 'equiv', 'eta', 'gamma',

 'ge', 'gets', 'in', 'infinity', 'iota', 'kappa',

 'lambda', 'le', 'mu', 'ne', 'notin', 'nu', 'omega',

 'oplus', 'oslash', 'otimes', 'partial', 'perp', 'phi',

 'pi', 'pm', 'psi', 'rho', 'sigma', 'subset',

 'subseteq', 'supset', 'tau', 'theta', 'times','to',

 'uncup', 'uparrow', 'upsilon', 'varepsilon', 'varphi',

 'varpi', 'varsigma', 'vee', 'wedge', 'xi', 'zeta');

 

 

 ArrCodeCharSymbol:array[Ord(s__Delta)..Ord(s_zeta)] of byte=

 ($44, $DF, $47, $4C, $DC, $DB, $57, $DE, $46, $50, $52, $53, $51,

  $DD, $A1, $58, $61, $D0, $BB, $62, $B7, $C7, $D7, $63, $40, $64,

  $E0, $B8, $AF, $65, $BA, $68, $67, $B3, $AC, $CE, $A5, $69, $6B,

  $6C, $A3, $6D, $B9, $CF, $6E, $77, $C5, $C6, $C4, $B6, $5E, $66,

  $70, $B1, $79, $72, $73, $CC, $CD, $C9, $74, $71, $B4, $AE, $C8,

  $AD, $75, $65, $6A, $76, $56, $DA, $D9, $78, $74);

 

 

 

 

const

 Blank =[#9, #10, #13, ' '];

 Special=['\', '^','_', '}','{'];

 LatLetter=['A'..'z']-Special;

 CyrLetter=['А'..'я'];

 Digits   =['!'..'@'];

 

type

 TToken=(toEnd, toUpIndex, toDownIndex, toMacros, toOpenBraces,

         toCloseBraces, toString);

 

function GetToken(var Str, SubStr:string; var StPos, EnPos:integer):TToken;

begin

 SubStr:='';

 if Str[StPos]=#0 then begin Result:=toEnd; Exit; end;

 while Str[StPos] in Blank do Inc(StPos);

 EnPos:=StPos;

 case Str[EnPos] of

  '_',

  '^':begin

       if Str[EnPos]='_' then Result:=toDownIndex else Result:=toUpIndex;

       Inc(EnPos);

       while Str[EnPos] in LatLetter+CyrLetter+Digits do Inc(EnPos);

       SubStr:=Copy(Str, StPos+1, EnPos-(StPos+1));

      end;

  '\':begin

       Inc(EnPos); Result:=toMacros;

       if Str[EnPos] in Blank then begin SubStr:=' '; Inc(EnPos);Exit; end;

       if Str[EnPos] in Special then begin SubStr:=Str[EnPos]; Inc(EnPos);Exit; end;

       while Str[EnPos] in LatLetter+CyrLetter+Digits do Inc(EnPos);

       SubStr:=Copy(Str, StPos+1, EnPos-(StPos+1));

      end;

  '{':begin Inc(EnPos); Result:=toOpenBraces; end;

  '}':begin Inc(EnPos); Result:=toCloseBraces; end;

  else

    begin

     if Str[EnPos] in Special then

      begin SubStr:=Copy(Str, StPos, EnPos-StPos); Result:=toString; Exit; end;

     while Str[EnPos] in LatLetter+CyrLetter+Digits do Inc(EnPos);

     SubStr:=Copy(Str, StPos, EnPos-StPos);

     Result:=toString;

    end;

 end;

end;

 

function IsMathSymbol(Name:string; var CodeSymbol:byte):boolean;

var M, N, K : integer;

begin

  M:=Ord(s__Delta); N:=Ord(s_zeta);

  while M<=N do

   begin

    K:=M+(N-M) div 2;

    if Name=ArrNameSymbol[K] then

     begin

      IsMathSymbol:=true;

      CodeSymbol:=ArrCodeCharSymbol[K];

      Exit

     end

     else if Name>ArrNameSymbol[K] then M:=K+1 else N:=K-1;

     end;

    IsMathSymbol:=false

end;

 

type

TRecFont=class

 HF:HFont;

 LF:TLogFont;

 Token:TToken;

 SubStr:string;  {подстрока выводимая с параметрами LF}

 S:TSize;        {размер прямоугольника ограничивающего подстроку}

 DBLine:integer; {Смещение по вертикали относительно базой линии строки}

end;

 

constructor TMathLabel.Create(AOwner:TComponent);

begin

 inherited Create(AOwner);

 FontList:=TList.Create;

 AutoSize:=false;

end;

 

destructor  TMathLabel.Destroy;

begin

 ClearFontList;

 FontList.Free;

 inherited Destroy;

end;

 

procedure TMathLabel.ClearFontList;

var RF:TRecFont;

begin

 while FontList.Count>0 do

  begin

   RF:=FontList.Items[0];

   DeleteObject(RF.HF);

   FontList.Delete(0);

  end;

end;

 

procedure TMathLabel.FillFontList;

const cBlank:PChar=' ';

var Text, SubStr: string;

    RecFont:TRecFont;

    Token:TToken;

    StPos, EnPos:integer;

    CodeSymbol:byte;

    LogFont:TLogFont;

    sBlank         : PChar absolute cBlank;

    DC:HDC;

 

    function HeightIndex(fnHeight:integer):integer;

    {высота Font-а для подсточных и надстрочных индексов}

     begin

      Result:=-Max(1, Round(0.6*Abs(fnHeight)));

     end;

 

    function UpShift(fnHeight:integer):integer;

    {вертикальный сдвиг отностительно базовой линии для надстрочного индекса}

     begin

      Result:=-Max(1, Round(0.2*Abs(fnHeight)));

     end;

 

    function DownShift(fnHeight:integer):integer;

    {вертикальный сдвиг отностительно базовой линии для подстрочного индекса}

     begin

      Result:=Max(1, Round(0.4*Abs(fnHeight)));

     end;

 

 

begin

 Text:=Caption+#0;  StPos:=1;

 DC:=Canvas.Handle;

 GetObject(Font.Handle, SizeOf(LogFont), @LogFont);

 ClearFontList;

 while true do

  begin

   Token:=GetToken(Text, SubStr, StPos, EnPos);

   if Token=toEnd then Break;

   case Token of

    toUpIndex,

    toDownIndex:

     begin

      RecFont:=TRecFont.Create;

      RecFont.LF:=LogFont;

      RecFont.LF.lfHeight:=HeightIndex(RecFont.LF.lfHeight);

      RecFont.HF:=CreateFontIndirect(RecFont.LF);

      RecFont.SubStr:=SubStr;

      if Token=toUpIndex then RecFont.DBLine:=UpShift(LogFont.lfHeight)

       else RecFont.DBLine:=DownShift(LogFont.lfHeight);

      SelectObject(DC, RecFont.HF);

      GetTextExtentPoint32(DC, PChar(SubStr), Length(SubStr), RecFont.S);

      FontList.Add(RecFont);

     end;

    toMacros:

     begin

      if IsMathSymbol(SubStr, CodeSymbol) then

       begin

        RecFont:=TRecFont.Create;

        RecFont.LF:=LogFont;

        RecFont.LF.lfFaceName:='Symbol';

        RecFont.HF:=CreateFontIndirect(RecFont.LF);

        RecFont.SubStr:=Char(CodeSymbol);

        SelectObject(DC, RecFont.HF);

        GetTextExtentPoint32(DC, @CodeSymbol, 1, RecFont.S);

        FontList.Add(RecFont);

       end

       else if (Length(SubStr)=1)and(SubStr[1] in ([' ']+Special)) then

        begin

         RecFont:=TRecFont.Create;

         RecFont.LF:=LogFont;

         RecFont.HF:=CreateFontIndirect(RecFont.LF);

         RecFont.DBLine:=DownShift(LogFont.lfHeight);

         RecFont.SubStr:=SubStr;

         SelectObject(DC, RecFont.HF);

         GetTextExtentPoint32(DC, sBlank, 1, RecFont.S);

         FontList.Add(RecFont);

        end

        else if SubStr='it' then LogFont.lfItalic:=1

        else if SubStr='bl' then LogFont.lfWeight:=700

        else if SubStr='st' then LogFont.lfStrikeOut:=1

        else if SubStr='ul' then LogFont.lfUnderline:=1

        else if SubStr='rm' then

         begin

          LogFont.lfWeight:=400;  LogFont.lfItalic:=0;

          LogFont.lfUnderline:=0; LogFont.lfStrikeOut:=0;

         end;

     end;

    toOpenBraces:;

    toCloseBraces:;

    toString:

     begin

      RecFont:=TRecFont.Create;

      RecFont.LF:=LogFont;

      RecFont.HF:=CreateFontIndirect(LogFont);

      RecFont.SubStr:=SubStr;

      SelectObject(DC, RecFont.HF);

      GetTextExtentPoint32(DC, PChar(SubStr), Length(SubStr), RecFont.S);

      FontList.Add(RecFont);

     end;

   end;

   StPos:=EnPos;

  end;

end;

 

procedure TMathLabel.SetAlignH(Value:TAlignH);

begin

  if FAlignH<>Value then

  begin FAlignH:=Value; Invalidate; end;

end;

 

procedure TMathLabel.SetAlignV(Value:TAlignV);

begin

  if FAlignV<>Value then

  begin FAlignV:=Value; Invalidate; end;

end;

 

procedure TMathLabel.PrepareDrawText;

var RecFont:TRecFont;

    I:integer;

begin

{ if FOldText<>Caption then}

  begin

   ClearFontList;

   FillFontList;

   FillChar(RectText, SizeOf(TRect), #0);

   for I:=0 to FontList.Count-1 do

    begin

     RecFont:=FontList.Items[I];

     RectText.Right:=RectText.Right+RecFont.S.cX;

     if RectText.Top<RecFont.S.cY then RectText.Top:=RecFont.S.cY;

     if RectText.Bottom>RecFont.DBLine then RectText.Bottom:=RecFont.DBLine;

    end;

  end;

 FOldText:=Caption;

end;

 

procedure TMathLabel.CMTextChanged(var Message: TMessage);

begin

 PrepareDrawText;

 Invalidate;

 {Realign;}

end;

 

procedure TMathLabel.CMFontChanged(var Message: TMessage);

begin

 PrepareDrawText;

 Invalidate;

{ Realign;}

end;

 

procedure TMathLabel.DoDrawText(var Rect: TRect; Flags: Longint);

var I, X, Y, YY:integer;

    RecFont:TRecFont;

    FAlig:Cardinal;

    DC:HDC;

begin

{ PrepareDrawText;}

 Canvas.Brush.Color:=Color;

 Rect:=ClientRect;

 DC:=Canvas.Handle;

 FAlig:=GetTextAlign(DC);

 SetTextAlign(DC, TA_NOUPDATECP);

 case FAlignV of

  taAutoV        :begin

                   Height:=RectText.Top; Rect.Bottom:=RectText.Bottom;

                   YY:=0;

                  end;

  taTopJustifyV:YY:=0;

  taDownJustifyV:YY:=Rect.Bottom-RectText.Top;

  taCenterV      :YY:=(Rect.Bottom-(RectText.Top-RectText.Bottom)) div 2;

 

 end;

 case FAlignH of

  taAutoH        :begin

                   Width:=RectText.Right; Rect.Right:=RectText.Right;

                  end;

  taLeftJustifyH :X:=0;

  taRightJustifyH:X:=Rect.Right-RectText.Right;

  taCenterH      :X:=(Rect.Right-RectText.Right) div 2;

 end;

 Canvas.FillRect(Rect);

 for I:=0 to FontList.Count-1 do

  begin

   RecFont:=FontList.Items[I];

   SelectObject(DC,RecFont.HF);

   Y:=YY+RecFont.DBLine;

   Windows.TextOut(DC, X, Y, PChar(RecFont.SubStr), Length(RecFont.SubStr));

   X:=X+RecFont.S.cX;

   Windows.MoveToEx(DC, X, Y, nil);

  end;

 SetTextAlign(DC, FAlig);

end;

 

end.


2009-12-05 • Просмотров [ 4060 ]