uses
  Math;
 
type
  TRGBColor=record
    r,g,b:byte;
  end;
  THSLColor=record
    h,s,l:double;
  end;
 
function RGB2HSL(v: TRGBColor): THSLColor;
var
  mx,mn: double;
begin
  mx:=max(max(v.r,v.g),v.b);
  mn:=min(min(v.r,v.g),v.b);
  Result.l:=(mx+mn)/510; //510=2*255
  if (Result.l=0) or (mx=mn) then
    Result.s:=0
  else if Result.l<=0.5 then
    Result.s:=(mx-mn)/(mx+mn)
  else if Result.l<>1 then
    Result.s:=(mx-mn)/(510-mx-mn)
  else
    Result.s:=1;
  if mx=mn then
    Result.h:=0
  else if mx=v.r then
    Result.h:=60*(v.g-v.b)/(mx-mn)+IfThen(v.g<v.b,360,0)
  else if mx=v.g then
    Result.h:=60*(v.b-v.r)/(mx-mn)+120
  else
    Result.h:=60*(v.r-v.g)/(mx-mn)+240
end;
 
function HSL2RGB(v: THSLColor): TRGBColor;
var
  q,p,h: double;
  t,c: array[1..3] of double;
  i: integer;
begin
  if v.l<0.5 then
    q:=v.l*(1+v.s)
  else
    q:=v.l+v.s-(v.l*v.s);
  p:=2*v.l-q;
  h:=v.h/360;
  t[1]:=h+1/3;
  t[2]:=h;
  t[3]:=h-1/3;
  for i:=1 to 3 do
    if t[i]<0 then
      t[i]:=t[i]+1
    else if t[i]>1 then
      t[i]:=t[i]-1;
  for i:=1 to 3 do
    if t[i]<1/6 then
      c[i]:=(q-p)*6*t[i]+p
    else if InRange(t[i],1/6,0.5) then
      c[i]:=q
    else if InRange(t[i],0.5,2/3) then
      c[i]:=(q-p)*(2/3-t[i])*6+p
    else
      c[i]:=p;
  Result.r:=round(c[1]*255);
  Result.g:=round(c[2]*255);
  Result.b:=round(c[3]*255);
end;

Cache:=TCache<byte,UInt64>.Create(6);//создание (6 элементов) 
for i:=6 downto 1 do //заполнение
  Cache[i]:=i;
if Cache.HasItem(2) then //если есть элемент с ключом «2», то вывести его
  WriteLn(Cache[2]);

Res3:=Cache[3];//получить значение элемента с ключом «3»

Cache[7]:=7;//добавить элемент с ключом «7»

program CallExponent;
{программа вычисляет значение константы e путём
 решения дифференциального уравнения y'=y, y(0)=1}
uses
  RungeKutta;
 
function Equation(x,y:extended):extended;
begin
  Result:=y
end;
 
begin
  WriteLn(GetSolutionAtPoint(1,0.001,0,1,Equation)) 
  // 2.71828182845902
  // погрешность в 14-ом знаке после запятой
end.

unit RungeKutta;
 
interface
 
{.$DEFINE Cache}
 
uses
  System.SysUtils, System.Math{$IFDEF Cache}, CacheUnit{$ENDIF};
 
type
  TRKEquation=reference to function(x,y:extended):extended;
 
  /// <summary>
  /// Решение ОДУ методом Рунге-Кутты
  /// </summary>
  IRungeKutta=interface
    /// <summary>
    /// Собственно решение
    /// </summary>
    function y(x:extended):extended;
  end;
 
/// <summary>
/// Создание интерфейса <see cref="ACod.Math.RungeKutta.IRungeKutta"/>
/// </summary>
function InitialRK(h,x0,y0:extended; RKEquation:TRKEquation
  {$IFDEF Cache}; Cache:TCacheLimit=0{$ENDIF}):IRungeKutta;
/// <summary>
/// Получение решения уравнения в точке X с шагом H
/// </summary>
function GetSolutionAtPoint(x,h,x0,y0:extended; RKEquation:TRKEquation)
  :extended;
 
implementation
 
type
  TRungeKutta=class(TInterfacedObject,IRungeKutta)
  private
    FH:extended;
    FX0:extended;
    FY0:extended;
    FRKEquation:TRKEquation;
    FYN,FXN:extended;
    FStepCount:UInt64;
    {$IFDEF Cache}
    FCache:boolean;
    FCacheMass:TCache<extended,extended>;
    {$ENDIF}
    procedure SetH(const Value:extended);
    procedure SetRKEquation(const Value:TRKEquation);
    procedure SetX0(const Value:extended);
    procedure SetY0(const Value:extended);
    procedure Step(dx:extended);
  public
    constructor Create{$IFDEF Cache}(Cache:TCacheLimit){$ENDIF};
    destructor Free;
    property RKEquation:TRKEquation read FRKEquation write SetRKEquation;
    property x0:extended read FX0 write SetX0;
    property y0:extended read FY0 write SetY0;
    property h:extended read FH write SetH;
    function y(x:extended):extended;
  end;
 
{ TRungeKutta }
 
constructor TRungeKutta.Create{$IFDEF Cache}(Cache:TCacheLimit){$ENDIF};
begin
  {$IFDEF Cache}
  FCache:=Cache>0;
  if FCache then
    FCacheMass:=TCache<extended,extended>.Create(Cache);
  {$ENDIF}
end;
 
destructor TRungeKutta.Free;
begin
  {$IFDEF Cache}
  if FCache then
    FCacheMass.Free;
  {$ENDIF}
end;
 
procedure TRungeKutta.SetH(const Value:extended);
begin
  FH:=Value;
end;
 
procedure TRungeKutta.SetRKEquation(const Value:TRKEquation);
begin
  FRKEquation:=Value;
end;
 
procedure TRungeKutta.SetX0(const Value:extended);
begin
  FX0:=Value;
end;
 
procedure TRungeKutta.SetY0(const Value:extended);
begin
  FY0:=Value;
end;
 
procedure TRungeKutta.Step(dx:extended);
var
  k1,k2,k3,k4:extended;
begin
  k1:=dx*RKEquation(FXN,FYN);
  k2:=dx*RKEquation(FXN+dx/2,FYN+k1/2);
  k3:=dx*RKEquation(FXN+dx/2,FYN+k2/2);
  k4:=dx*RKEquation(FXN+dx,FYN+k3);
  FYN:=FYN+(k1+2*k2+2*k3+k4)/6;
  FXN:=FXN+dx;
end;
 
function TRungeKutta.y(x:extended):extended;
var
  tmp:UInt64;
  pls:boolean;
begin
  Result:=NaN;
  if IsNaN(x)or IsInfinite(x) then
    raise Exception.CreateFmt('Неподходящее для вычислений значение x=%f',[x]);
  {$IFDEF Cache}
  if FCache then
    if FCacheMass.HasItem(x) then
      Exit(FCacheMass[x]);
  {$ENDIF}
  FXN:=FX0;
  FYN:=FY0;
  FStepCount:=round(abs(x-FX0)/FH);
  pls:=x<FX0;
  if pls then
    FH:=-FH;
  tmp:=0;
  while tmp<(FStepCount-1) do
    begin
      Step(FH);
      inc(tmp);
    end;
  {new:23.08.2012 10:37}
  Step(x-(FH*(FStepCount-1)+FX0));
  {/new}
  Result:=FYN;
  if pls then
    FH:=-FH;
  {$IFDEF Cache}
  if FCache then
    FCacheMass[x]:=FYN;
  {$ENDIF}
end;
 
{ Funtions }
 
function InitialRK(h,x0,y0:extended; RKEquation:TRKEquation{$IFDEF Cache}; Cache:TCacheLimit{$ENDIF})
  :IRungeKutta;
var
  tmp:TRungeKutta;
begin
  if CompareValue(h,0)<=0 then
    raise Exception.CreateFmt('Величина шага (%f) должна быть больше 0!',[h]);
  tmp:=TRungeKutta.Create{$IFDEF Cache}(Cache){$ENDIF};
  tmp.h:=h;
  tmp.x0:=x0;
  tmp.y0:=y0;
  tmp.RKEquation:=RKEquation;
  Result:=tmp;
end;
 
function GetSolutionAtPoint(x,h,x0,y0:extended; RKEquation:TRKEquation)
  :extended;
begin
  Result:=InitialRK(h,x0,y0,RKEquation{$IFDEF Cache},0{$ENDIF}).y(x);
end;

xml:=TXmlPathDoc.Create('c:\file.xml');//из файла
xml:=TXmlPathDoc.Create(stream,false);//из потока, если true, то конструктор освободит поток
xml:=TXmlPathDoc.CreateXml('<root><element v="1"/></root>')//из строки

v:=xml.GetData('root\element.v');
v:=xml.ExecQuery('root\element.v');

xml.SetData('root\element.v',1);
xml.ExecQuery('root\element.v:="1"');

xml.SaveToFile('c:\file.xml');
xml.SaveToStream(stream);

xml.DeleteElement('root\element');

xml.Document;//IXmlDocument
xml.Root;//IXmlNode,=xml.Document.DocumentElement;
xml.GetNode('root\element');//IXmlNode

uses
  System.Math, Generics.Collections;
 
function PassQuantity(s:string):Real;
var
  i,len:integer;
  rep:TDictionary<char,integer>;
  difRegCount:integer;
  simbCount:integer;
  copySb:Integer;
  Info:TList<string>;
begin
  len:=length(s); 
  if len<=1 then//дабы избежать проблем с логарифмами
    Exit(0);
  Rep:=TDictionary<char, integer>.Create;
  info:=TList<string>.Create;
  simbCount:=0;
  for i:=1 to len do
    begin
      case s[i] of
        'A'..'Z','А'..'Я','Ё':info.Add('lu');//letter,upCase
        'a'..'z','а'..'я','ё':info.Add('ll');//letter,lowCase
        '0'..'9':info.Add('dn');//digit,nonCase
      else
        info.Add('sn');//simbol,nonCase
        inc(simbCount);
      end;
      if not Rep.ContainsKey(s[i]) then
        Rep.Add(s[i], 1)
      else
        Rep[s[i]]:=Rep[s[i]]+1;//rep[n]=число повторений символа n
    end;
  copySb:=0;
  difRegCount:=0;
  for i:=1 to info.Count-1 do
    begin
      if info[i][2]<>info[i-1][2] then
        inc(difRegCount);//различный регистр
      if info[i][1]=info[i-1][1] then
        inc(copySb);//различный тип
    end;
  info.Free;
  Result:=logN(len, rep.Count)*(len+sqrt(0.5*simbCount+difRegCount)-sqrt(copySb));
  Rep.Free;
end;

GetScPref(0.00017,0,'Ф');//=170 мкФ
GetScPref(1e20,0,'Дж');//=100 ЭДж
GetScPref(0.19856,2,'г');//=198,56 мг
GetScPref(0.19856,1,'г');//=198,6 мг
{-----------------}
GetCompPref(100000000,2);//=95,37 МиБ
GetCompPref(1000,2);//=0,98 КиБ

uses
  Math, SysUtils;
 
function GetScPref(v:extended;n:byte;meas:string):string;
var
  t:integer;
const
  pref:array[-8..8] of string=
         ('и','з','а','ф','п','н','мк','м','','к','М','Г','Т','П','Э','З','И');
begin
  t:=EnsureRange(trunc(logN(990,abs(v)))+(sign(ln(abs(v)))-1) div 2,-8,8);
  Result:=FloatToStr(RoundTo(v*power(10,-min(max(t*3,-24),24)),-n))+' '+pref[t]+meas;
end;
 
function GetCompPref(v:int64;n:byte):string;
var
  t:integer;
const
  pref:array[0..8] of string=('','Ки','Ми','Ги','Ти','Пи','Эи','Зи','Йи');
begin
  t:=EnsureRange(trunc(logN(990,abs(v))),0,8);
  Result:=FloatToStr(RoundTo(v*power(2,-min(t*10,80)),-n))+' '+pref[t]+'Б';
end;

unit BynaryFind;
 
{Будьте внимательны при использовании границ поиска по умолчанию, поскольку
использованы максимальное и минимальное возможные значения переменной типа
Extended, и если для некоторых х выполняется: f(x)>x, то программа может
вылететь с печальной ошибкой "Floating point overflow".
Так же стоит учесть, что проверки на монотонность функция не производит.}
 
interface
 
uses
  Math;
 
type
  ///   <summary>
  ///     Монотонная функция
  ///   </summary>
  TMonoFunc=function(x:extended):extended;
 
  ///   <summary>
  ///     Результат поиска
  ///   </summary>
  TResult=record
    /// <summary>
    ///   Значение аргумента
    /// </summary>
    argument:extended;
    /// <summary>
    ///   Точность поиска
    /// </summary>
    epsilon:extended;
    /// <summary>
    ///   Найден ли аргумет (если <c>false</c>, то возвращается ближайшее значение из
    ///   интервала поиска)
    /// </summary>
    isFinded:boolean;
  end;
 
/// <summary>
///   Функция бинарного поиска аргумента по известному значению. Работает
///   только для монотонных и непрерывных на [a,b] функций.
/// </summary>
function FindArgument(func:TMonoFunc; y:extended; a:extended=-MaxExtended;
                      b:extended=MaxExtended; eps:extended=1e-18):TResult;
 
/// <summary>
///   Функция бинарного поиска индекса элемента в массиве. Работает только
///   в отсортированных массивов.
/// </summary>
function FindIndex(arr:TArray<extended>; v:extended):integer;
 
implementation
 
var
  tmp,staticA,staticB,tY,tA,tB,tEps:extended;
  tFunc:TMonoFunc;
  tflg:boolean;
  compareMod:ShortInt;
 
function FindArgumentRec:extended;
begin
  tmp:=(tA+tB)/2; //середина отрезка
  if IsZero(tFunc(ta)-tFunc(tb),teps) then //если длина отрезка меньше эпсилон
    begin                                  //то возвращаем середину хитрым путем
      tflg:=tmp>((staticA+staticB)/2);
      if tflg then
        Exit(-staticA+tmp)
      else
        Exit(-staticB+tmp)
    end;
  //проверяем середину отрезка на соответствие
  //домножение на compareMod позволяет работать с функцией как с возрастающей
  case compareMod*CompareValue(tfunc(tmp),ty,teps) of
    0:Result:=tmp;//если f(tmp)=y, то его и возвращаем
    -1: //если f(tmp)<y, ищем правее
    begin
      tA:=tmp;
      Result:=FindArgumentRec
    end;
    1: //если f(tmp)>y, ищем левее
    begin
      tB:=tmp;
      Result:=FindArgumentRec
    end
  end
end;
 
function FindArgument(func:TMonoFunc; y,a,b,eps:extended):TResult;
begin
  staticA:=a;  //запись исходных границ поиска
  staticB:=b;
  tFunc:=func; //и прочих нужных вещей в глобальные
  tA:=a;       //переменные, дабы не засорять стек
  tB:=b;
  tY:=y;
  tEps:=eps;
  Result.epsilon:=eps;
  //определение вида функции: возрастает(1) она или убывает(-1)
  //если compareMod=0, то функция либо постоянна, либо не монотонна
  compareMod:=CompareValue(func(b),func(a),eps);
  if compareMod=0 then
    with Result do
      begin
        argument:=(b+a)/2;
        isFinded:=func(argument)=y;
        Exit;
      end;
  with Result do
    begin
      argument:=FindArgumentRec;//собственно поиск
      //проверка, найдено ли значение, и нахождение ближайшей границы области
      isFinded:=((-argument>a) and tflg) or ((-argument<b) and not tflg);
      if not isFinded then
        begin
          if tflg then
            argument:=argument+a
          else
            argument:=argument+b
        end
    end
end;
 
var
  tarr:TArray<extended>;
  tv:extended;
  a,b,t:integer;
 
function FindIndexRec:integer;
begin
  t:=(a+b) div 2;
  if (a=b) then
    Exit(-1);
  case compareMod*CompareValue(tarr[t],tv) of
    0:Result:=t;
    -1:
    begin
      a:=t;
      Result:=FindIndexRec
    end;
    1:
    begin
      b:=t;
      Result:=FindIndexRec
    end
  end
end;
 
function FindIndex(arr:TArray<extended>; v:extended):integer;
begin
  tv:=v;
  a:=0;
  b:=length(arr)-1;
  if b<0 then//в пустом массиве искомого элемента точно нет
    Exit(-1);
  tarr:=arr;
  compareMod:=CompareValue(arr[b],arr[a]);
  if compareMod=0 then//если массив постоянен
    Exit(IfThen(arr[a]=v,a,-1));
  Result:=FindIndexRec;
end;
 
end.

function Mut(c1,c2:Char):Char;inline;
begin
  Result:=chr((Word(c1) shl (SizeOf(Char)*4)) or (Word(c2) shr (SizeOf(Char)*4)))
  {если
     c1=$1234
     c2=$abcd
   то
     Result=$34ab}
end;
 
function EnCrypt(text:string):string;
var
  i:Integer;
begin
  Result:='';
  for i:=2 to length(text) do
    Result:=Result+Mut(text[i-1],text[i]);
  Result:=Result+Mut(text[length(text)],text[1])
end;
 
function DeCrypt(text:string):string;
var
  i:Integer;
begin
  Result:='';
  for i:=2 to length(text) do
    Result:=Result+Mut(text[i-1],text[i]);
  Result:=Mut(text[length(text)],text[1])+Result
end;

unit SubRosa;
 
{
+----------------------+
|Примеры использования:|
+----------------------+------------------------+
|...                                            |
|  Write('Введите старый пароль: ');            |
|  ReadLn(pass);                                |
|  Write('Введите новый пароль: ');             |
|  ReadLn(newpass);                             |
|  if bTesseraMuto('pass.bin',pass,newpass) then|
|    WriteLn('Пароль успешно изменён!');        |
|...                                            |
+------------------------------------------+----+
|...                                       |
|  Write('Введите пароль: ');              |
|  ReadLn(pass);                           |
|  if bTesseraComparo('pass.bin',pass) then|
|    begin                                 |
|      WriteLn('Пароль принят!');          |
|...                                       |
+------------------------------------------+
}
 
interface
 
type
  dtString=WideString;
  dtChar=WideChar;
 
///     <summary>
///       Процедура записи сигнатуры ключа в файл
///     </summary>
///     <param name="sThesaurum">
///       Имя файла хранилища
///     </param>
///     <param name="sTessera">
///        Ключ
///     </param>
procedure vTesseraHabio(sThesaurum, sTessera:dtString);
///     <summary>
///       Функция сравнения сигнатуры ключа с сигнатурой из*хранилища
///     </summary>
///     <param name="sThesaurum">
///       Имя файла хранилища
///     </param>
///     <param name="sTessera">
///       Ключ
///     </param>
///     <returns>
///       Возвращает истину, если сигнатуры совпадают
///     </returns>
function bTesseraComparo(sThesaurum, sTessera:dtString):Boolean;
///     <summary>
///       Функция перезаписи сигнатуры хранилища
///     </summary>
///     <param name="sThesaurum">
///       Имя файла хранилища
///     </param>
///     <param name="sPriscusTessera">
///       Старый ключ
///     </param>
///     <param name="sNovusTessera">
///       Новый ключ
///     </param>
///     <returns>
///       Возвращает истину, если сигнатура была перезаписана
///     </returns>
function bTesseraMuto(sThesaurum, sPriscusTessera, sNovusTessera:dtString):Boolean;
///     <summary>
///       Функция вычисления сигнатуры строки
///     </summary>
///     <param name="sVersus">
///       Строка для вычисления сигнатуры
///     </param>
///     <returns>
///       $65daec1d8e6f466 - сигнатура пустой строки
///     </returns>
function lliVerificatus(sVersus:dtString):Int64;
 
implementation
 
uses
  SysUtils,
  Classes;
 
const
  lliUnificatus:Int64=$65daec1d8e6f466;  //если честно, выбрано случайно
  lliUMultiplicator:Int64=lliUnificatus div $f8;
  lliUAdditor:Int64=lliUnificatus div $1e3;
 
var
  lliMultiplicator:Int64;
  lliAdditor:Int64;
 
type
  Mass8=array[1..8] of Byte;
 
procedure vTesseraHabio(sThesaurum, sTessera:dtString);
var
  oPlica:TFileStream;
  lliSignificatio:Int64;
  m8AliusSignificatio:Mass8 absolute lliSignificatio;
begin
  if not DirectoryExists(ExtractFilePath(sThesaurum)) then
    ForceDirectories(ExtractFilePath(sThesaurum));
  try
    oPlica:=TFileStream.Create(sThesaurum, fmCreate);
    lliSignificatio:=lliVerificatus(sTessera);
    oPlica.Write(m8AliusSignificatio, 8)
  finally
    if oPlica<>nil then
      oPlica.Free
  end
end;
 
function bTesseraComparo(sThesaurum, sTessera:dtString):Boolean;
var
  oPlica:TFileStream;
  lliSignificatio:Int64;
  m8AliusSignificatio:Mass8 absolute lliSignificatio;
begin
  Result:=false;
  if not FileExists(sThesaurum) then
    Exit;
  try
    oPlica:=TFileStream.Create(sThesaurum, fmOpenRead);
    oPlica.Read(m8AliusSignificatio, 8);
    Result:=lliSignificatio=lliVerificatus(sTessera)
  finally
    if oPlica<>nil then
      oPlica.Free
  end
end;
 
function bTesseraMuto(sThesaurum, sPriscusTessera, sNovusTessera:dtString):Boolean;
var
  oPlica:TFileStream;
  lliSignificatio:Int64;
  m8AliusSignificatio:Mass8 absolute lliSignificatio;
begin
  if not FileExists(sThesaurum) then
    begin
      Result:=sPriscusTessera='';
      if Result then
        vTesseraHabio(sThesaurum, sNovusTessera);
      Exit
    end;
  if sPriscusTessera=sNovusTessera then
    Exit(bTesseraComparo(sThesaurum, sPriscusTessera));
  try
    oPlica:=TFileStream.Create(sThesaurum, fmOpenReadWrite);
    oPlica.Read(m8AliusSignificatio,8);
    Result:=lliSignificatio=lliVerificatus(sPriscusTessera);
    if Result then
      begin
        oPlica.Seek(0,soBeginning);
        oPlica.Write(Mass8(lliVerificatus(sNovusTessera)), 8)
      end
  finally
    if oPlica<>nil then
      oPlica.Free
  end
end;
 
function lliAccidentalis(cSignum:dtChar):Int64;inline;
begin
  Result:=Ord(cSignum)*lliMultiplicator+lliAdditor
end;
 
function lliPermutatio(lliPrimus, lliSecundus:Int64):Int64;inline;
begin
  Result:=((lliPrimus shl 16) or (lliSecundus shr 48)) xor
  ((lliPrimus shr 48) or (lliSecundus shl 16))
end;
 
function lliVerificatus(sVersus:dtString):Int64;
var
  iOrigo, iIndex:Integer;
begin
  Result:=lliUnificatus;
  if sVersus='' then
    Exit;
  iOrigo:=Length(sVersus);
  lliAdditor:=lliAccidentalis(chr(iOrigo))+1;
  lliMultiplicator:=lliAccidentalis(chr(iOrigo))-1;
  if lliMultiplicator=0 then
    lliMultiplicator:=lliUMultiplicator;
  for iIndex:=1 to iOrigo do
    Result:=lliPermutatio(Result+iIndex, lliAccidentalis(sVersus[iIndex]));
  lliMultiplicator:=lliUMultiplicator;
  lliAdditor:=lliUAdditor
end;
 
initialization
  lliMultiplicator:=lliUMultiplicator;
  lliAdditor:=lliUAdditor
end.

unit ZipCode;
 
interface
 
uses
  Math, Graphics;
 
/// <summary>
///   Вывод на канву почтового индекса
/// </summary>
/// <param name="Canvas:TCanvas">
///   Указатель на экземпляр класса TCanvas, на котором будет производится
///   вывод кода
/// </param>
/// <param name="x:Integer">
///   Абсцисса левого верхнего угла кода
/// </param>
/// <param name="y:Integer">
///   Ордината левого верхнего угла кода
/// </param>
/// <param name="ZipCode:Integer">
///   Собственно код
/// </param>
/// <param name="WidthSimbol:Integer">
///   Ширина каждого символа
/// </param>
/// <param name="SimbolCount:Integer">
///   Количество символов (0 - автоматически)
/// </param>
/// <param name="SpaceWidth:Extended">
///   Отношение ширины пробела между символами к ширине символа
/// </param>
/// <param name="SimbolHeight:Extended">
///   Отношение высоты символа к ширине символа
/// </param>
/// <param name="LineWidth:Integer">
///   Толщина линий символов
/// </param>
/// <returns>
///   Возвращает истину, если вывод был произведён без ошибок
/// </returns>
function GraphZipCode(Canvas:TCanvas;x,y,ZipCode,WidthSimbol:Integer;SimbolCount:Integer=8;
             SpaceWidth:Extended=0.33;SimbolHeight:Extended=2;LineWidth:Integer=3):boolean;
 
implementation
 
function GraphZipCode;
var
  tx,ty,dx,dy,dxw,i,tnb,lenc:Integer;
  tmp:array of integer;
 
  function OneZip(n:Integer):boolean;//рисование цифры
  begin
    case n of
    0:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx+dx,ty);
      LineTo(tx+dx,ty+dy);
      LineTo(tx,ty+dy);
      LineTo(tx,ty)
    end;
    1:with Canvas do
    begin
      MoveTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty);
      LineTo(tx+dx,ty+dy)
    end;
    2:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx+dx,ty);
      LineTo(tx+dx,ty+(dy div 2));
      LineTo(tx,ty+dy);
      lineTo(tx+dx,ty+dy)
    end;
    3:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx+dx,ty);
      LineTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty+(dy div 2));
      LineTo(tx,ty+dy)
    end;
    4:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty+(dy div 2));
      MoveTo(tx+dx,ty);
      LineTo(tx+dx,ty+dy)
    end;
    5:with Canvas do
    begin
      MoveTo(tx+dx,ty);
      LineTo(tx,ty);
      LineTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty+(dy div 2));
      LineTo(tx+dx,ty+dy);
      LineTo(tx,ty+dy)
    end;
    6:with Canvas do
    begin
      MoveTo(tx+dx,ty);
      LineTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty+(dy div 2));
      LineTo(tx+dx,ty+dy);
      LineTo(tx,ty+dy);
      LineTo(tx,ty+(dy div 2))
    end;
    7:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx+dx,ty);
      LineTo(tx,ty+(dy div 2));
      LineTo(tx,ty+dy)
    end;
    8:with Canvas do
    begin
      MoveTo(tx,ty);
      LineTo(tx,ty+dy);
      LineTo(tx+dx,ty+dy);
      LineTo(tx+dx,ty);
      LineTo(tx,ty);
      MoveTo(tx,ty+(dy div 2));
      LineTo(tx+dx,ty+(dy div 2))
    end;
    9:with Canvas do
    begin
      MoveTo(tx+dx,ty+(dy div 2));
      LineTo(tx,ty+(dy div 2));
      LineTo(tx,ty);
      LineTo(tx+dx,ty);
      LineTo(tx+dx,ty+(dy div 2));
      LineTo(tx,ty+dy)
    end
    else
      Exit(false)
    end;
    Result:=true
  end;
 
begin
try
  tx:=x;
  ty:=y;  //точка начала рисования
  dx:=WidthSimbol;  //ширина символа
  dy:=round(WidthSimbol*SimbolHeight);  //высота символа
  dxw:=round(dx*(1+SpaceWidth));  //ширина символа с пробелом после него
  if ZipCode<>0 then
    lenc:=trunc(Log10(Abs(ZipCode)*10))  //число цифр в коде
  else
    lenc:=1;
  if SimbolCount=0 then
    SimbolCount:=lenc;  //число цифр, которые будут выведены
  if lenc>SimbolCount then
    Exit(false);
  Canvas.Pen.Width:=LineWidth;  //ширина пера
  SetLength(tmp,SimbolCount);
  tnb:=abs(ZipCode);
  for i:=SimbolCount-1 downto 0 do
    begin  //заполнение массива цифрами кода
      tmp[i]:=tnb mod 10;
      tnb:=tnb div 10
    end;
  for i:=0 to SimbolCount-1 do
    begin
      if not OneZip(tmp[i]) then  //собственно вывод цифры
        Exit(false);
      tx:=tx+dxw  //сдвиг позиции
    end;
  Result:=true //если истина, то всё хорошо
except
  Result:=false
end
end;
 
end.