• Главная
• В избранное
• Наш E-MAIL
• Добавить материал
• Нашёл ошибку
• Вниз

var

 i: integer;

 s: string;

begin

 s:= '$' + ThatHexString;

 i:= StrToInt(a);

end;

CONST HEX: ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);

VAR str : String;

 Int, i: integer;

BEGIN

 READLN(str);

 Int:= 0;

 FOR i:= 1 TO length(str) DO

  IF str[i] < 'a' THEN Int:= Int * 16 + ord(str[i]) – 48

  ELSE Int:= Int * 16 + hex[str[i]];

 WRITELN(Int);

 READLN;

END.

Самое простое преобразование – через строку.

HexString:= Format('%0x', DecValue);

Строка представляет собой массив байтов в виде ASCII-символов. Необходимо организовать преобразование типов по аналогии с Delphi-функциями Ord и Chr.

Функция BytesToHexStr преобразует, к примеру, набор байтов [0,1,1,0] в строку '30313130', HexStrToBytes выполнит обратное преобразование.

unit Hexstr;

interface

uses String16, SysUtils;

Type

 PByte = ^BYTE;

procedure BytesToHexstr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

implementation

procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);

Const

 HexChars : Array[0..15] of char = '0123456789ABCDEF';

var

 i, j: WORD;

begin

 SetLength(hHexStr, (InputLength * 2));

 FillChar(hHexStr, sizeof(hHexStr), #0);

 j:= 1;

 for i := 1 to InputLength  do begin

  hHexStr[j]:= Char(HexChars[pbyteArray^ shr  4]); inc(j);

  hHexStr[j]:= Char(HexChars[pbyteArray^ and 15]); inc(j);

  inc(pbyteArray);

 end;

end;

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

var

 i: WORD;

 c: byte;

begin

 SetLength(Response, InputLength);

 FillChar(Response, SizeOf(Response), #0);

 for i:= 0 to (InputLength – 1) do begin

  c:= BYTE(HexBytes[i]) And BYTE($f);

  if c > 9 then Inc(c, $37)

  else Inc(c, $30);

  Response[i + 1]:= char(c);

 end;{for}

end;

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);

{pbyteArray указывает на область памяти, хранящей результаты}

var

 i, j: WORD;

 tempPtr: PChar;

 twoDigits: String[2];

begin

 tempPtr:= pbyteArray;

 j:= 1;

 for i:= 1 to (Length(hHexStr) DIV 2) do begin

  twoDigits:= Copy(hHexStr, j, 2); Inc(j, 2);

  PByte(tempPtr)^:= StrToInt('$' + twoDigits); Inc(tempPtr);

 end;{for}

end;

end.

UNIT string16.

interface

{$IFNDEF Win32}

procedure SetLength(var S: string; Len: Integer);

procedure SetString(var Dst: string; Src: PChar; Len: Integer);

{$ENDIF}

implementation

{$IFNDEF Win32}

procedure SetLength(var S: string; Len: Integer);

begin

 if len > 255 then S[0]:= Chr(255)

 else S[0]:= Chr(Len)

end;

procedure SetString(var Dst: string; Src: PChar; Len: Integer);

begin

 if Len > 255 then Move(Src^, Dst[1], 255)

 else Move(Src^, Dst[1], Len);

 SetLength(Dst, Len);

end;

{$ENDIF}

end.

Может ли кто-нибудь дать мне идею простого преобразования двоичного кода (base2) в десятичный (base10)?

/////////////////////////////////////////////////////////////////////////

// преобразование 32-битного base2 в 32-битный base10                  //

// максимальное число = 99 999 999, возвращает –1 при большем значении //

/////////////////////////////////////////////////////////////////////////

function base10(base2:integer) : integer; assembler;

asm

 cmp        eax,100000000        // проверка максимального значения

 jb         @1                   // значение в пределах допустимого

 mov        eax,-1               // флаг ошибки

 jmp        @exit                // выход если –1

@1:

 push       ebx                  // сохранение регистров

 push       esi

 xor        esi,esi              // результат = 0

 mov        ebx,10               // вычисление десятичного логарифма

 mov        ecx,8                // преобразование по формуле 10^8-1

@2:

 mov        edx,0                // удаление разницы

 div        ebx                  // eax – целочисленное деление на 10, edx – остаток от деления на 10

 add        esi,edx              // результат = результат + разность[I]

 ror        esi,4                // перемещение разряда

 loop       @2                   // цикл для всех 8 разрядов

 mov        eax,esi              // результат функции

 pop        esi                  // восстанавление регистров

 pop        ebx

@exit:

end;

function IntToBin(Value: Longint; Size: Integer): String;

var

 i: Integer;

begin

 Result :='';

 for i:= Size downto 0 do begin

  if value and (1 shl i)<>0 then begin

   Result:= Result+'1';

  end else begin

   Result:= Result+'0';

  end;

 end;

end;

Function BinToInt(Value: String): Longint;

var

 i,Size: Integer;

begin

 Result:= 0;

 Size:= Length(Value);

 for i:=Size downto 0 do begin

  if copy(value,i,1) = '1' then begin

   Result:= Result + (1 shl i);

  end;

 end;

end;

Следующая функция получает в качестве параметра Base (1..16) любую десятичную величину и возвращает результат в виде строки, содержащей точное значение BaseX. Вы можете использовать данный алгоритм для преобразования арабских чисел в римские (смотри ниже).

function DecToBase(Decimal: Longint; const Base: Byte): String;

const Symbols: String[16] = '0123456789ABCDEF';

var

 scratch: String;

 remainder: Byte;

begin

 scratch:= '';

 repeat

  remainder:= Decimal mod base;

  scratch:= Symbols[remainder + 1] + scratch;

  Decimal:= Decimal div base;

 until (decimal = 0);

 Result:= scratch;

end;

Передайте данной функции любую десятичную величину (1…3999), и она возвратит строку, содержащую точное значение в римской транскрипции.

function DecToRoman(Decimal: Longint ): String;

const Romans: Array[1..13] of String = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');

 Arabics: Array[1..13] of integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var

 i: Integer;

 scratch: String;

begin

 scratch:= '';

 for i := 13 downto 1 do

  while (decimal >= arabics[i]) do begin

   Decimal:= Decimal – Arabics[i];

   scratch:= scratch + Romans[i];

  end;

 Result:= scratch;

end;

Попробуйте:

var

 Icon: TIcon;

 Bitmap: TBitmap;

begin

 Icon:= TIcon.Create;

 Bitmap:= TBitmap.Create;

 Icon.LoadFromFile('c:\picture.ico');

 Bitmap.Width:= Icon.Width;

 Bitmap.Height:= Icon.Height;

 Bitmap.Canvas.Draw(0, 0, Icon);

 Bitmap.SaveToFile('c:\picture.bmp');

 Icon.Free;

 Bitmap.Free;

end;

Способ преобразования изображения размером 32×32 в иконку.

unit main;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,Dialogs,ExtCtrls, StdCtrls;

type TForm1 = class(TForm)

 Button1: TButton;

 Image1: TImage;

 Image2: TImage;

 procedure Button1Click(Sender: Tobject);

 procedure FormCreate(Sender: Tobject);

private

 { Private declarations }

public

 { Public declarations }

end;

var

 Form1: TForm1;

implementation

{$R *.DFM}

Procedure Tform1.Button1Click(Sender: Tobject);

 var winDC, srcdc, destdc : HDC;

 oldBitmap : HBitmap;

 iinfo : TICONINFO;

begin

 GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

 WinDC:= getDC(handle);

 srcDC:= CreateCompatibleDC(WinDC);

 destDC:= CreateCompatibleDC(WinDC);

 oldBitmap:= SelectObject(destDC, iinfo.hbmColor);

 oldBitmap:= SelectObject(srcDC, iinfo.hbmMask);

 BitBlt(destdc, 0, 0, Image1.picture.icon.width, Image1.picture.icon.height, srcdc, 0, 0, SRCPAINT);

 Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);

 DeleteDC(destDC);

 DeleteDC(srcDC);

 DeleteDC(WinDC);

 image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName) + 'myfile.bmp');

end;

Procedure Tform1.FormCreate(Sender: Tobject);

begin

 image1.picture.icon.loadfromfile('c:\myicon.ico');

end;

end.

Данный модуль позволяет читать и записывать файлы формата Unix.

unit StreamFile;

interface

Uses SysUtils;

Procedure AssignStreamFile(var f: text; FileName: String);

implementation

Const BufferSize = 128;

Type

 TStreamBuffer = Array[1..High(Integer)] of Char;

 TStreamBufferPointer = ^TStreamBuffer;

 TStreamFileRecord = Record

  Case Integer Of

  1: (

   Filehandle: Integer;

   Buffer: TStreamBufferPointer;

   BufferOffset: Integer;

   ReadCount: Integer;

  );

  2: (

   Dummy : Array[1..32] Of Char

  )

  End;

Function StreamFileOpen(var f : TTextRec): Integer;

Var

 Status: Integer;

Begin

 With TStreamFileRecord (F.UserData) Do Begin

  GetMem(Buffer, BufferSize);

  Case F.Mode Of

  fmInput:

   FileHandle:= FileOpen(StrPas(F.Name), fmShareDenyNone);

  fmOutput:

   FileHandle:= FileCreate(StrPas(F.Name));

  fmInOut:

  Begin

   FileHandle:= FileOpen(StrPas(F.Name), fmShareDenyNone Or fmOpenWrite or fmOpenRead);

   If FileHandle <> -1 Then status:= FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }

   F.Mode:= fmOutput;

  End;

  End;

  BufferOffset:= 0;

  ReadCount:= 0;

  F.BufEnd:= 0;  { В этом месте подразумеваем что мы достигли конца файла (eof). }

  If FileHandle = -1 Then Result := -1

  Else Result:= 0;

 End;

End;

Function StreamFileInOut(var F: TTextRec): Integer;

 Procedure Read(var Data: TStreamFileRecord);

  Procedure CopyData;

  Begin

  While (F.BufEnd < Sizeof(F.Buffer) - 2) And (Data.BufferOffset <= Data.ReadCount) And (Data.Buffer [Data.BufferOffset] <> #10) Do Begin

    F.Buffer[F.BufEnd]:= Data.Buffer^[Data.BufferOffset];

    Inc(Data.BufferOffset);

    Inc(F.BufEnd);

   End;

   If Data.Buffer [Data.BufferOffset] = #10 Then Begin

    F.Buffer[F.BufEnd]:= #13;

    Inc(F.BufEnd);

    F.Buffer[F.BufEnd]:= #10;

    Inc(F.BufEnd);

    Inc(Data.BufferOffset);

   End;

  End;

 Begin

  F.BufEnd:= 0;

  F.BufPos:= 0;

  F.Buffer:= '';

  Repeat Begin

   If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then Begin

    Data.BufferOffset:= 1;

    Data.ReadCount:= FileRead(Data.FileHandle, Data.Buffer^, BufferSize);

   End;

   CopyData;

  End Until (Data.ReadCount = 0) Or (F.BufEnd >= Sizeof (F.Buffer) - 2);

  Result:= 0;

 End;

 Procedure Write(var Data: TStreamFileRecord);

 Var

  Status: Integer;

  Destination: Integer;

  II: Integer;

 Begin

  With TStreamFileRecord(F.UserData) Do Begin

   Destination:= 0;

   For II:= 0 To F.BufPos - 1 Do Begin

    If F.Buffer[II] <> #13 Then Begin

     Inc(Destination);

     Buffer^[Destination]:= F.Buffer[II];

    End;

   End;

   Status:= FileWrite(FileHandle, Buffer^, Destination);

   F.BufPos:= 0;

   Result:= 0;

  End;

 End;

Begin

 Case F.Mode Of

 fmInput:

  Read(TStreamFileRecord(F.UserData));

 fmOutput:

  Write(TStreamFileRecord(F.UserData));

 End;

End;

Function StreamFileFlush(var F: TTextRec): Integer;

Begin

 Result:= 0;

End;

Function StreamFileClose(var F : TTextRec): Integer;

Begin

 With TStreamFileRecord(F.UserData) Do Begin

  FreeMem(Buffer);

  FileClose(FileHandle);

 End;

 Result:= 0;

End;

Procedure AssignStreamFile(var F: Text; Filename: String);

Begin

 With TTextRec(F) Do Begin

  Mode:= fmClosed;

  BufPtr:= @Buffer;

  BufSize:= Sizeof(Buffer);

  OpenFunc:= @StreamFileOpen;

  InOutFunc:= @StreamFileInOut;

  FlushFunc:= @StreamFileFlush;

  CloseFunc:= @StreamFileClose;

  StrPLCopy(Name, FileName, Sizeof(Name) - 1);

 End;

End;

end.

Используя Delphi 3, как мне сохранить BMP-изображение в JPEG-файле?

Допустим, Image1 – компонент TImage, содержащий растровое изображение. Используйте следующий фрагмент кода для конвертации вашего изображения в JPEG-файл:

var

 MyJpeg: TJpegImage;

 Image1: TImage;

begin

 Image1:= TImage.Create;

 MyJpeg:= TJpegImage.Create;

 Image1.LoadFromFile('TestImage.BMP');  // Чтение изображения из файла

 MyJpeg.Assign(Image1.Picture.Bitmap);  // Назначание изображения объекту MyJpeg

 MyJpeg.SaveToFile('MyJPEGImage.JPG');  // Сохранение на диске изображения в формате JPEG

end;

Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

unit LinearSystem;

interface

{============== Тип, описывающий формат WAV ==================}

type wavheader = record

 nChannels       : Word;

 nBitsPerSample  : LongInt;

 nSamplesPerSec  : LongInt;

 nAvgBytesPerSec : LongInt;

 RIFFSize        : LongInt;

 fmtSize         : LongInt;

 formatTag       : Word;

 nBlockAlign     : LongInt;

 DataSize        : LongInt;

end;

{============== Поток данных сэмпла ========================}

const MaxN = 300;  { максимальное значение величины сэмпла }

type SampleIndex = 0..MaxN+3;

type DataStream = array[SampleIndex] of Real;

var N: SampleIndex;

{============== Переменные сопровождения ======================}

type Observation = record

 Name       : String[40];  {Имя данного сопровождения}

 yyy        : DataStream;  {Массив указателей на данные}

 WAV        : WAVHeader;   {Спецификация WAV для сопровождения}

 Last       : SampleIndex; {Последний доступный индекс yyy}

 MinO, MaxO : Real;        {Диапазон значений yyy}

end;

var K0R, K1R, K2R, K3R: Observation;

 K0B, K1B, K2B, K3B : Observation;

{================== Переменные имени файла ===================}

var StandardDatabase: String[80];

 BaseFileName: String[80];

 StandardOutput: String[80];

 StandardInput: String[80];

{=============== Объявления процедур ==================}

procedure ReadWAVFile(var Ki, Kj : Observation);

procedure WriteWAVFile(var Ki, Kj : Observation);

procedure ScaleData(var Kk: Observation);

procedure InitallSignals;

procedure InitLinearSystem;

implementation

{$R *.DFM}

uses VarGraph, SysUtils;

{================== Стандартный формат WAV-файла ===================}

const MaxDataSize : LongInt = (MaxN+1)*2*2;

const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;

const StandardWAV : WAVHeader = (

 nChannels       : Word(2);

 nBitsPerSample  : LongInt(16);

 nSamplesPerSec  : LongInt(8000);

 nAvgBytesPerSec : LongInt(32000);

 RIFFSize        : LongInt((MaxN+1)*2*2+36);

 fmtSize         : LongInt(16);

 formatTag       : Word(1);

 nBlockAlign     : LongInt(4);

 DataSize        : LongInt((MaxN+1)*2*2)

);

{================== Сканирование переменных сопровождения ===================}

procedure ScaleData(var Kk : Observation);

var I : SampleIndex;

begin

 {Инициализация переменных сканирования}

 Kk.MaxO:= Kk.yyy[0];

 Kk.MinO:= Kk.yyy[0];

 {Сканирование для получения максимального и минимального значения}

 for I:= 1 to Kk.Last do begin

  if kk.maxo < kk.yyy[i] then kk.maxo:= kk.yyy[i];

  if kk.mino > kk.yyy[i] then kk.mino:= kk.yyy[i];

 end;

end; { scaledata }

procedure ScaleAllData;

begin

 ScaleData(K0R);

 ScaleData(K0B);

 ScaleData(K1R);

 ScaleData(K1B);

 ScaleData(K2R);

 ScaleData(K2B);

 ScaleData(K3R);

 ScaleData(K3B);

end; {scalealldata}

{================== Считывание/запись WAV-данных ===================}

VAR InFile, OutFile: file of Byte;

type Tag = (F0, T1, M1);

type FudgeNum = record

 case X:Tag of

 F0 : (chrs : array[0..3] of byte);

 T1 : (lint : LongInt);

 M1 : (up,dn: Integer);

end;

var ChunkSize  : FudgeNum;

procedure WriteChunkName(Name: String);

var i: Integer;

 MM: Byte;

begin

 for i:= 1 to 4 do begin

  MM:= ord(Name[i]);

  write(OutFile, MM);

 end;

end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);

var I: integer;

begin

 ChunkSize.x:=T1;

 ChunkSize.lint:=LL;

 ChunkSize.x:=F0;

 for I:= 0 to 3 do Write(OutFile,ChunkSize.chrs[I]);

end;

procedure WriteChunkWord(WW: Word);

var I: integer;

begin

 ChunkSize.x:=T1;

 ChunkSize.up:=WW;

 ChunkSize.x:=M1;

 for I:= 0 to 1 do Write(OutFile,ChunkSize.chrs[I]);

end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);

var I: Integer

begin

 ChunkSize.x:=M1;

 with Ki.WAV do begin

  case nChannels of

  1:

   if nBitsPerSample=16 then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}

    ChunkSize.up = trunc(Ki.yyy[N]+0.5);

    if N<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);

    N:= N+2;

   end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

    for I:=0 to 3 do ChunkSize.chrs[I]:= trunc(Ki.yyy[N+I]+0.5);

    N:= N+4;

   end;

  2:

   if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

    ChunkSize.dn:= trunc(Ki.yyy[N]+0.5);

    ChunkSize.up := trunc(Kj.yyy[N]+0.5);

    N:= N+1;

   end else begin {4 Двухканальный 8-битный сэмпл}

    ChunkSize.chrs[1]:= trunc(Ki.yyy[N]+0.5);

    ChunkSize.chrs[3]:= trunc(Ki.yyy[N+1]+0.5);

    ChunkSize.chrs[0]:= trunc(Kj.yyy[N]+0.5);

    ChunkSize.chrs[2]:= trunc(Kj.yyy[N+1]+0.5);

    N:= N+2;

   end;

  end; {with wav do begin..}

 end; {четырехбайтовая переменная "chunksize" теперь заполнена}

 ChunkSize.x:=T1;

 WriteChunkSize(ChunkSize.lint);{помещаем 4 байта данных}

end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);

var MM: Byte;

 I: Integer;

 OK: Boolean;

begin

 {Приготовления для записи файла данных}

 AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }

 ReWrite(OutFile);

 With ki.wav do begin

  DataSize:= nChannels*(nBitsPerSample div 8)*(Ki.Last+1);

  RIFFSize:= DataSize+36;

  fmtSize:= 16;

 end;

 {Записываем ChunkName "RIFF"}

 WriteChunkName('RIFF');

 {Записываем ChunkSize}

 WriteChunkSize(Ki.WAV.RIFFSize);

 {Записываем ChunkName "WAVE"}

 WriteChunkName('WAVE');

 {Записываем tag "fmt_"}

 WriteChunkName('fmt ');

 {Записываем ChunkSize}

 Ki.WAV.fmtSize:= 16;  {должно быть 16-18}

 WriteChunkSize(Ki.WAV.fmtSize);

 {Записываем  formatTag, nChannels}

 WriteChunkWord(Ki.WAV.formatTag);

 WriteChunkWord(Ki.WAV.nChannels);

 {Записываем  nSamplesPerSec}

 WriteChunkSize(Ki.WAV.nSamplesPerSec);

 {Записываем  nAvgBytesPerSec}

 WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

 {Записываем  nBlockAlign, nBitsPerSample}

 WriteChunkWord(Ki.WAV.nBlockAlign);

 WriteChunkWord(Ki.WAV.nBitsPerSample);

 {Записываем метку блока данных "data"}

 WriteChunkName('data');

 {Записываем DataSize}

 WriteChunkSize(Ki.WAV.DataSize);

 N:=0; {первая запись-позиция}

 while N<=Ki.Last do WriteOneDataBlock(Ki,Kj);{помещаем 4 байта и увеличиваем счетчик n}

 {Освобождаем буфер файла}

 CloseFile(OutFile);

end; {WriteWAVFile}

procedure InitSpecs;

begin

end; { InitSpecs }

procedure InitSignals(var Kk : Observation);

var J: Integer;

begin

 for  J:= 0 to MaxN do Kk.yyy[J]:= 0.0;

 Kk.MinO:= 0.0;

 Kk.MaxO:= 0.0;

 Kk.Last:= MaxN;

end; {InitSignals}

procedure InitAllSignals;

begin

 InitSignals(K0R);

 InitSignals(K0B);

 InitSignals(K1R);

 InitSignals(K1B);

 InitSignals(K2R);

 InitSignals(K2B);

 InitSignals(K3R);

 InitSignals(K3B);

end; {InitAllSignals}

var chunkname: string[4];

procedure ReadChunkName;

var I : integer;

 MM : Byte;

begin

 ChunkName[0]:= chr(4);

 for i := 1 to 4 do begin

  Read(InFile, MM);

  ChunkName[I]:=chr(MM);

 end;

end; {ReadChunkName}

procedure ReadChunkSize;

var I: integer;

 MM : Byte;

begin

 ChunkSize.x:= F0;

 ChunkSize.lint := 0;

 for i:= 0 to 3 do begin

  Read(InFile, MM);

  ChunkSize.chrs[I]:= MM;

 end;

 ChunkSize.x:= T1;

end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);

var I: Integer;

begin

 if n<=maxn then begin

  ReadChunkSize; {получаем 4 байта данных}

  ChunkSize.x:=M1;

  with Ki.WAV do case nChannels of

  1:

   if nBitsPerSample=16 then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}

    Ki.yyy[N]:=1.0*ChunkSize.up;

    if N<MaxN then Ki.yyy[N+1]:=1.0*ChunkSize.dn;

    N:= N+2;

   end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

    for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];

    N := N+4;

   end;

  2:

   if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

    Ki.yyy[N]:=1.0*ChunkSize.dn;

    Kj.yyy[N]:=1.0*ChunkSize.up;

    N:= N+1;

   end else begin {4 Двухканальный 8-битный сэмпл}

    Ki.yyy[N]:=1.0*ChunkSize.chrs[1];

    Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];

    Kj.yyy[N]:=1.0*ChunkSize.chrs[0];

    Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];

    N:= N+2;

   end;

  end;

  if N<=MaxN then begin {LastN:= N;}

   Ki.Last:= N;

   if Ki.WAV.nChannels=2 then Kj.Last := N;

  end else begin {lastn    := maxn;}

   Ki.Last:= MaxN;

   if Ki.WAV.nChannels=2 then Kj.Last := MaxN;

  end;

 end;

end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, K : Observation);

var MM: Byte;

 I: Integer;

 OK: Boolean;

 NoDataYet: Boolean;

 DataYet: Boolean;

 nDataBytes: LongInt;

begin

 if FileExists(StandardInput)then with Ki.WAV do begin  { Вызов диалога открытия файла }

  OK:= True; {если не изменится где-нибудь ниже}

  {Приготовления для чтения файла данных}

  AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }

  Reset(InFile);

  {Считываем ChunkName "RIFF"}

  ReadChunkName;

  if ChunkName<>'RIFF' then OK:= False;

   {Считываем ChunkSize}

   ReadChunkSize;

   RIFFSize:= ChunkSize.lint; {должно быть 18,678}

   {Считываем ChunkName "WAVE"}

   ReadChunkName;

   if ChunkName<>'WAVE' then OK:= False;

   {Считываем ChunkName "fmt_"}

   ReadChunkName;

   if ChunkName<>'fmt ' then OK:= False;

   {Считываем ChunkSize}

   ReadChunkSize;

   fmtSize:= ChunkSize.lint;  {должно быть 18}

   {Считываем  formatTag, nChannels}

   ReadChunkSize;

   ChunkSize.x:= M1;

   formatTag:= ChunkSize.up;

   nChannels:= ChunkSize.dn;

   {Считываем  nSamplesPerSec}

   ReadChunkSize;

   nSamplesPerSec := ChunkSize.lint;

   {Считываем  nAvgBytesPerSec}

   ReadChunkSize;

   nAvgBytesPerSec:= ChunkSize.lint;

   {Считываем  nBlockAlign}

   ChunkSize.x:= F0;

   ChunkSize.lint:= 0;

   for i:= 0 to 3 do begin

    Read(InFile, MM);

    ChunkSize.chrs[I]:= MM;

   end;

   ChunkSize.x:= M1;

   nBlockAlign:= ChunkSize.up;

   {Считываем  nBitsPerSample}

   nBitsPerSample:= ChunkSize.dn;

   for I:= 17 to fmtSize do Read(InFile,MM);

   NoDataYet:= True;

   while NoDataYet do begin

    {Считываем метку блока данных "data"}

    ReadChunkName;

    {Считываем DataSize}

    ReadChunkSize;

    DataSize:= ChunkSize.lint;

    if ChunkName <> 'data' then begin

     for I:= 1 to DataSize do  {пропуск данных, не относящихся к набору звуковых данных}

      Read(InFile, MM);

    end else NoDataYet:= False;

   end;

   nDataBytes:= DataSize;

   {Наконец, начинаем считывать данные для байтов nDataBytes}

   if nDataBytes>0 then DataYet:= True;

   N:=0; {чтение с первой позиции}

   while DataYet do begin

    ReadOneDataBlock(Ki,Kj); {получаем 4 байта}

    nDataBytes:= nDataBytes-4;

    if nDataBytes<=4 then DataYet:= False;

   end;

   ScaleData(Ki);

   if Ki.WAV.nChannels=2 then begin Kj.WAV:= Ki.WAV;

   ScaleData(Kj);

  end;

  {Освобождаем буфер файла}

  CloseFile(InFile);

 end else begin

  InitSpecs;{файл не существует}

  InitSignals(Ki);{обнуляем массив "Ki"}

  InitSignals(Kj);{обнуляем массив "Kj"}

 end;

end; { ReadWAVFile}

{================= Операции с набором данных ====================}

const MaxNumberOfDataBaseItems = 360;

type  SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;

VAR DataBaseFile: file of Observation;

LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}

ItemNameS: array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem(Kk : Observation; N : LongInt);

begin

 if N<MaxNumberOfDataBaseItems then begin

  Seek(DataBaseFile, N);

  Read(DataBaseFile, Kk);

 end else InitSignals(Kk);

end; {GetDatabaseItem}

procedure PutDatabaseItem(Kk : Observation; N : LongInt);

begin

 if  N<MaxNumberOfDataBaseItems then if N<=LastDataBaseItem then begin

  Seek(DataBaseFile, N);

  Write(DataBaseFile, Kk);

  LastDataBaseItem:= LastDataBaseItem+1;

 end else while lastdatabaseitem<=n do begin

  Seek(DataBaseFile, LastDataBaseItem);

  Write(DataBaseFile, Kk);

  LastDataBaseItem:= LastDataBaseItem+1;

 end else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}

end; {PutDatabaseItem}

procedure InitDataBase;

begin

 LastDataBaseItem:= 0;

 if FileExists(StandardDataBase) then begin

  Assign(DataBaseFile,StandardDataBase);

  Reset(DataBaseFile);

  while not EOF(DataBaseFile) do begin

   GetDataBaseItem(K0R, LastDataBaseItem);

   ItemNameS[LastDataBaseItem]:= K0R.Name;

   LastDataBaseItem:= LastDataBaseItem+1;

  end;

  if EOF(DataBaseFile) then if LastDataBaseItem>0 then LastDataBaseItem:= LastDataBaseItem-1;

 end;

end; {InitDataBase}

function FindDataBaseName(Nstg: String): LongInt;

var ThisOne : LongInt;

begin

 ThisOne:= 0;

 FindDataBaseName:= –1;

 while ThisOne<LastDataBaseItem do begin

  if Nstg = ItemNameS[ThisOne] then begin

   FindDataBaseName:= ThisOne;

   Exit;

  end;

  ThisOne:= ThisOne+1;

 end;

end; {FindDataBaseName}

{======================= Инициализация модуля ========================}

procedure InitLinearSystem;

begin

 BaseFileName:= '\PROGRA~1\SIGNAL~1\';

 StandardOutput:= BaseFileName + 'K0.wav';

 StandardInput:= BaseFileName + 'K0.wav';

 StandardDataBase:= BaseFileName + 'Radar.sdb';

 InitAllSignals;

 InitDataBase;

 ReadWAVFile(K0R,K0B);

 ScaleAllData;

end; {InitLinearSystem}

begin {инициализируемый модулем код}

 InitLinearSystem;

end. {Unit LinearSystem}

function TtheCalendar.CalcEaster:String;

var B,D,E,Q:Integer;

 GF:String;

begin

 B:= 225-11*(Year Mod 19);

 D:= ((B-21)Mod 30)+21;

 If d>48 then Dec(D);

 E:= (Year+(Year Div 4)+d+1) Mod 7;

 Q:= D+7-E;

 If q<32 then begin

  If ShortDateFormat[1]='d' then Result:= IntToStr(Q)+'/3/'+IntToStr(Year)

  else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

 end else begin

  If ShortDateFormat[1]='d' then Result:= IntToStr(Q-31)+'/4/'+IntToStr(Year)

  else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

 end;

 {вычисление страстной пятницы}

 If Q<32 then begin

  If ShortDateFormat[1]='d' then GF:= IntToStr(Q-2)+'/3/'+IntToStr(Year)

  else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year);

 end else begin

  If ShortDateFormat[1]='d' then GF:= IntToStr(Q-31-2)+'/4/'+IntToStr(Year)

  else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year);

 end;

end;

Кто-нибудь пробовал написать функцию, возвращающую для определенной даты день недели?

Моя функция как раз этим и занимается.

unit datefunc;

interface

function checkdate(date : string): boolean;

function Date2julian(date : string): longint;

function Julian2date(julian : longint): string;

function DayOfTheWeek(date: string): string;

function idag: string;

implementation

uses sysutils;

function idag() : string;

{Получает текущую дату и возвращает ее в формате YYYYMMDD для использования

другими функциями данного модуля.}

var

 Year, Month, Day: Word;

begin

 DecodeDate(Now, Year, Month, Day);

 result:= IntToStr(year)+ IntToStr(Month) +IntToStr(day);

end;

function Date2julian(date : string) : longint;

{Получает дату в формате YYYYMMDD.

Если у вас другой формат, в первую очередь преобразуйте его.}

var

 month, day, year:integer;

 ta, tb, tc : longint;

begin

 month:= strtoint(copy(date,5,2));

 day:= strtoint(copy(date,7,2));

 year:= strtoint(copy(date,1,4));

 if month > 2 then month:= month – 3

 else begin

  month:= month + 9;

  year:= year – 1;

 end;

 ta:= 146097 * (year div 100) div 4;

 tb:= 1461 * (year MOD 100) div 4;

 tc:= (153 * month + 2) div 5 + day + 1721119;

 result:= ta + tb + tc

end;

function mdy2date(month, day, year : integer): string;

var

 y, m, d : string;

begin

 y:= '000'+inttostr(year);

 y:= copy(y,length(y)-3,4);

 m:= '0'+inttostr(month);

 m:= copy(m,length(m)-1,2);

 d:= '0'+inttostr(day);

 d:= copy(d,length(d)-1,2);

 result:= y+m+d;

end;

function Julian2date(julian : longint): string;

 {Получает значение и возвращает дату в формате YYYYMMDD}

var

 x,y,d,m : longint;

 month,day,year : integer;

begin

 x:= 4 * julian – 6884477;

 y:= (x div 146097) * 100;

 d:= (x MOD 146097) div 4;

 x:= 4 * d + 3;

 y:= (x div 1461) + y;

 d:= (x MOD 1461) div 4 + 1;

 x:= 5 * d – 3;

 m:= x div 153 + 1;

 d:= (x MOD 153) div 5 + 1;

 if m < 11 then month:= m + 2

 else month:= m – 10;

 day:= d;

 year:= y + m div 11;

 result:= mdy2date(month, day, year);

end;

function checkdate(date : string): boolean;

{Дата должна быть в формате YYYYMMDD.}

var

 julian: longint;

 test: string;

begin

 {Сначала преобразовываем строку в юлианский формат даты.

  Это позволит получить необходимое значение.}

 julian:= Date2julian(date);

 {Затем преобразовываем полученную величину в дату.

  Это всегда будет правильной датой. Для проверки делаем обратное преобразование.

  Результат проверки передаем как выходной параметр функции.}

 test:= Julian2date(julian);

 if date = test then result:= true

 else result:= false;

end;

function DayOfTheWeek(date : string): string;

 {Получаем дату в формате YYYYMMDD и возвращаем день недели.}

var

 julian: longint;

begin

 julian:= (Date2julian(date)) MOD 7;

 case julian of

 0: result:= 'Понедельник';

 1: result := 'Вторник';

 2: result:= 'Среда';

 3: result:= 'Четверг';

 4: result:= 'Пятница';

 5: result:= 'Суббота';

 6: result:= 'Воскресенье';

 end;

end;

end.

У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.

Некоторое время назад я делал простой шифратор/дешифратор дат, проверяющий достоверность даты. Код приведен ниже.

function CheckDateFormat(SDate: string): string;

var

 IDateChar: string;

 x,y: integer;

begin

 IDateChar:='.,\/';

 for y:=1 to length(IDateChar) do begin

  x:= pos(IDateChar[y],SDate);

  while x>0 do begin

   Delete(SDate,x,1);

   Insert('-',SDate,x);

   x:= pos(IDateChar[y],SDate);

  end;

 end;

 CheckDateFormat:= SDate;

end;

function DateEncode(SDate:string):longint;

var

 year, month, day: longint;

 wy, wm, wd: longint;

 Dummy: TDateTime;

 Check: integer;

begin

 DateEncode:= -1;

 SDate:= CheckDateFormat(SDate);

 Val(Copy(SDate,1,pos('-',SDate)-1),day,check);

 Delete(Sdate,1,pos('-',SDate));

 Val(Copy(SDate,1,pos('-',SDate)-1),month,check);

 Delete(SDate,1,pos('-',SDate));

 Val(SDate,year,check);

 wy:= year;

 wm:= month;

 wd:= day;

 try

  Dummy:= EncodeDate(wy,wm,wd);

 except

  year:= 0;

  month:= 0;

  day:= 0;

 end;

 DateEncode:= (year*10000)+(month*100)+day;

end;

Привет, я хочу в качестве совета поделиться функцией DateSer, которую я написал перед этим на VB. Данная функция весьма полезна но, к сожалению, ее нет в Delphi. Применяется она так:

DecodeDate(Date,y,m,d);

NewDate:= DateSer(y-4,m+254,d+1234);

или приблизительно так….

function DateSer(y,m,d: Integer): TDateTime;

const

 mj: array[1..12] of integer=(31,28,31,30,31,30,31,31,30,31,30,31);

var

 add: Integer;

begin

 while (true) do begin

  y:=y+(m-1) div 12;

  m:= (m-1) mod 12 +1;

  if m<=0 then begin

   Inc(m,12);

   Dec(y);

  end;

  if ((y mod 4 = 0) and ((y mod 100<>0) or (y mod 400=0))) and (m=2) then add:=1 //дополнительный день в феврале

  else add:=0;

  if (d>0) and (d<=(mj[m]+add)) then break;

  if d>0 then begin Dec(d,mj[m]+add); Inc(m); end

  else begin Inc(d,mj[m]+add); Dec(m); end;

  end;

 Result:=EncodeDate(y,m,d);

end;

"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.

type

 THanoiBin = 0..2;

 THanoiLevel = 0..9;

procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

//  Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.

//  Диск окажется наверху (естественно, выше него дисков не будет)

Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды – наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.

procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

begin

 if HanoiLevel <= High(THanoiLevel) then begin

  MoveTower(FromPin, 3 – FromPin – ToPin, Level + 1);

  MoveDisc(FromPin, ToPin, Level);

  MoveTower(3 – FromPin – ToPin, ToPin, Level + 1);

 end;

end;

Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:

MoveTower(0, 1, Low(THanoiLevel));

Я нашел алгоритм, написанный на BASIC и вычисляющий восход-заход солнца и восход-заход луны. Может кто-нибудь сможет перенести это на Pascal?

(в случае чего сообщите мне по адресу st_evil@mail.ru)

10 ' Восход-заход солнца

20 GOSUB 300

30 INPUT "Долгота (град)";B5,L5

40 INPUT "Часовая зона (час)";H

50 L5=L5/360: Z0=H/24

60 GOSUB 1170: T=(J-2451545)+F

70 TT=T/36525+1: ' TT = столетия,

80 ' начиная с 1900.0

90 GOSUB 410: T=T+Z0

100 '

110 ' Получаем положение солнца

120 GOSUB 910: A(1)=A5: D(1)=D5

130 T=T+1

140 GOSUB 910: A(2)=A5: D(2)=D5

150 IF A(2)<A(1) THEN A(2)=A(2)+P2

160 Z1=DR*90.833: ' Вычисление зенита

170 S=SIN(B5*DR): C=COS(B5*DR)

180 Z=COS(Z1): M8=0: W8=0: PRINT

190 A0=A(1): D0=D(1)

200 DA=A(2)-A(1): DD=D(2)-D(1)

210 FOR C0=0 TO 23

220 P=(C0+1)/24

230 A2=A(1)+P*DA: D2=D(1)+P*DD

240 GOSUB 490

250 A0=A2: D0=D2: V0=V2

260 NEXT

270 GOSUB 820: ' Вывод информации?

280 END

290 '

300 ' Константы

310 DIM A(2),D(2)

320 P1=3.14159265: P2=2*P1

330 DR=P1/180: K1=15*DR*1.0027379

340 S$="Заход солнца в "

350 R$="Восход солнца в "

360 M1$="В этот день солнце не восходит"

370 M2$="В этот день солнце не заходит"

380 M3$="Солнце заходит весь день"

390 M4$="Солнце восходит весь день"

400 RETURN

410 ' Получение часового пояса

420 T0=T/36525

430 S=24110.5+8640184.813*T0

440 S=S+86636.6*Z0+86400*L5

450 S=S/86400: S=S-INT(S)

460 T0=S*360*DR

470 RETURN

480 '

490 ' Просматриваем возможные события на полученный час

500 L0=T0+C0*K1: L2=L0+K1

510 H0=L0-A0: H2=L2-A2

520 H1=(H2+H0)/2: ' Часовой угол,

530 D1=(D2+D0)/2: ' наклон в

540 ' получасе

550 IF C0>0 THEN 570

560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z

570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z

580 IF SGN(V0)=SGN(V2) THEN 800

590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z

600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2

610 D=B*B-4*A*V0: IF D<0 THEN 800

620 D=SQR(D)

630 IF V0<0 AND V2>0 THEN PRINT R$;

640 IF V0<0 AND V2>0 THEN M8=1

650 IF V0>0 AND V2<0 THEN PRINT S$;

660 IF V0>0 AND V2<0 THEN W8=1

670 E=(-B+D)/(2*A)

680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A)

690 T3=C0+E+1/120: ' Округление

700 H3=INT(T3): M3=INT((T3-H3)*60)

710 PRINT USING "##:##";H3;M3;

720 H7=H0+E*(H2-H0)

730 N7=-COS(D1)*SIN(H7)

740 D7=C*SIN(D1)-S*COS(D1)*COS(H7)

750 AZ=ATN(N7/D7)/DR

760 IF D7<0 THEN AZ=AZ+180

770 IF AZ<0 THEN AZ=AZ+360

780 IF AZ>360 THEN AZ=AZ-360

790 PRINT USING ", азимут ###.#";AZ

800 RETURN

810 '

820 ' Процедура вывода информации

830 IF M8=0 AND W8=0 THEN 870

840 IF M8=0 THEN PRINT M1$

850 IF W8=0 THEN PRINT M2$

860 GOTO 890

870 IF V2<0 THEN PRINT M3$

880 IF V2>0 THEN PRINT M4$

890 RETURN

900 '

910 ' Фундаментальные константы

920 ' (Van Flandern &

930 ' Pulkkinen, 1979)

940 L=.779072+.00273790931*T

950 G=.993126+.0027377785*T

960 L=L-INT(L): G=G-INT(G)

970 L=L*P2: G=G*P2

980 V=.39785*SIN(L)

990 V=V-.01000*SIN(L-G)

1000 V=V+.00333*SIN(L+G)

1010 V=V-.00021*TT*SIN(L)

1020 U=1-.03349*COS(G)

1030 U=U-.00014*COS(2*L)

1040 U=U+.00008*COS(L)

1050 W=-.00010-.04129*SIN(2*L)

1060 W=W+.03211*SIN(G)

1070 W=W+.00104*SIN(2*L-G)

1080 W=W-.00035*SIN(2*L+G)

1090 W=W-.00008*TT*SIN(G)

1100 '

1110 ' Вычисление солнечных координат

1120 S=W/SQR(U-V*V)

1130 A5=L+ATN(S/SQR(1-S*S))

1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S))

1150 R5=1.00021*SQR(U)

1160 RETURN

1165 '

1170 ' Календарь –> JD

1180 INPUT "Год, Месяц, День";Y,M,D

1190 G=1: IF Y<1583 THEN G=0

1200 D1=INT(D): F=D-D1-.5

1210 J=-INT(7*(INT((M+9)/12)+Y)/4)

1220 IF G=0 THEN 1260

1230 S=SGN(M-9): A=ABS(M-9)

1240 J3=INT(Y+S*INT(A/7))

1250 J3=-INT((INT(J3/100)+1)*3/4)

1260 J=J+INT(275*M/9)+D1+G*J3

1270 J=J+1721027+2*G+367*Y

1280 IF F>=0 THEN 1300

1290 F=F+1: J=J-1

1300 RETURN

1310 '

1320 ' Программа вычисляет время восхода и захода

1330 ' солнца по дате (с точностью до минуты) в пределах

1340 ' нескольких текущих столетий. Производит корректировку, если географическая

1350 ' точка находится в арктичиском или антарктическом регионе, где заход или восход солнца

1360 ' на текущую дату может не состояться. Вводимые данные: положительная северная широта и

1370 ' отрицательная западная долгота. Часовой пояс указывается относительно Гринвича

1380 ' (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в

1390 ' "Sky & Telescope" за август 1994, страница 84.

PROCEDURE TForm1.Edit1Exit(Sender: TObject);

BEGIN

 IF Edit1.Text<>'' THEN BEGIN

  TRY

    StrToDate(Edit1.Text);

   EXCEPT

    Edit1.SetFocus;

    MessageBeep(0);

    raise Exception.Create('"'+Edit1.Text + '&quot – некорректная дата');

   END {try};

   Edit1.Text:= DateToStr(StrToDate(Edit1.Text));

 END{if};

END;