VPF::Не понял - Форум программистов

Антихрист

Дата 20.12.2004, 05:23 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Скачал программу, но не могу разобраться что делается в функциях и процедурах(делфи совсем плохо знаю) не поможете?

Код


nit Solver;

interface

uses
  Math, SysUtils;

type
  PStack = ^TStack;
  TStack = record
    Next, Prev: PStack;
    Token: Byte;
    Number: Extended;
    Func: String[20];
  end;

  TSolver = class(TObject)
  private
    FError: Byte;
    FStack: PStack;
    FTokenStackTail: PStack;
    FTokenStackHead: PStack;
    FPrevToken: Byte;
    FRPNText: String;
    FRPNResult: Extended;
    FInput: String;
    function PriorityToken(Token: Byte): Integer;
    procedure PushStack(Token: Byte);
    procedure PopStack;
    procedure PushToken;
    procedure PushTokenNumber(Value: Extended);
    procedure FreeStack;
    procedure FreeTokenStack;
    procedure Tokenize(const Value: String);
    procedure ProcessTokens;
  public
    function TokenToStr(P: PStack): String;
    procedure Solve(const Value: String);
    procedure SolveGraph(const Value: String; X: Extended);
    property Input: String read FInput;
    property RPNText: String read FRPNText;
    property RPNResult: Extended read FRPNResult;
    property Error: Byte read FError;
  end;

const
  E_NOERROR     = 0;    {No Error}
  E_EMPTY       = 1;    {Empty expression}
  E_EXPR        = 2;    {Error in expression}
  E_SOLVE       = 3;    {Could not solve}
  E_DIV_BY_ZERO = 4;    {Division by zero}
  E_FUNC        = 5;    {Error in function}
  E_FUNC_NOT_FOUND = 6; {There's no such function}

  function SolverErrorToStr(Solver: TSolver): String;
  function SolverErrorToStrRus(Solver: TSolver): String;

implementation

const
  TOKEN_UNKNOWN = Byte(-1);
  TOKEN_NUMBER  = 0;
  TOKEN_FUNC    = 1;
  TOKEN_BOPEN   = 2;
  TOKEN_BCLOSE  = 3;
  TOKEN_PLUS    = 4;
  TOKEN_MINUS   = 5;
  TOKEN_MUL     = 6;
  TOKEN_DIVR    = 7;
  TOKEN_POW     = 8;

function TSolver.PriorityToken(Token: Byte): Integer;
begin
  case Token of
    TOKEN_BOPEN:                Result := 0;
    TOKEN_BCLOSE:               Result := 1;
    TOKEN_PLUS, TOKEN_MINUS:    Result := 2;
    TOKEN_MUL, TOKEN_DIVR:      Result := 3;
    TOKEN_POW:                  Result := 4;
    TOKEN_FUNC:                 Result := 5;
  else
    Result := -1;
  end;
end;

procedure TSolver.PushStack(Token: Byte);
var
  P: PStack;
begin
  New(P);
  P.Next := FStack;
  P.Token := Token;
  FStack := P;
end;

procedure TSolver.PopStack;
var
  P: PStack;
begin
  P := FStack;
  FStack := FStack.Next;
  Dispose(P);
end;

procedure TSolver.PushToken;
begin
  if FTokenStackHead = nil then begin
    New(FTokenStackHead);
    FTokenStackTail := FTokenStackHead;
    FTokenStackTail.Prev := nil;
  end else begin
    New(FTokenStackTail.Next);
    FTokenStackTail.Next.Prev := FTokenStackTail;
    FTokenStackTail := FTokenStackTail.Next;
  end;
  FTokenStackTail.Next := nil;

  FTokenStackTail.Token := FStack.Token;
  if FStack.Token = TOKEN_FUNC then
    FTokenStackTail.Func := FStack.Func;
end;

procedure TSolver.PushTokenNumber(Value: Extended);
begin
  if FTokenStackHead = nil then begin
    New(FTokenStackHead);
    FTokenStackTail := FTokenStackHead;
    FTokenStackTail.Prev := nil;
  end else begin
    New(FTokenStackTail.Next);
    FTokenStackTail.Next.Prev := FTokenStackTail;
    FTokenStackTail := FTokenStackTail.Next;
  end;
  FTokenStackTail.Next := nil;

  FTokenStackTail.Token := TOKEN_NUMBER;
  FTokenStackTail.Number := Value;
end;

function TSolver.TokenToStr(P: PStack): String;
begin
  case P.Token of
    TOKEN_NUMBER:       Result := FloatToStr(P.Number);
    TOKEN_FUNC:         Result := P.Func;
    TOKEN_BOPEN:        Result := '(';
    TOKEN_BCLOSE:       Result := ')';
    TOKEN_PLUS:         Result := '+';
    TOKEN_MINUS:        Result := '-';
    TOKEN_MUL:          Result := '*';
    TOKEN_DIVR:         Result := '/';
    TOKEN_POW:          Result := '^';
  else
    Result := 'UNK';
  end;
  Result := Result + ' ';
end;

procedure TSolver.FreeStack;
var
  P: PStack;
begin
  while FStack <> nil do begin
    P := FStack.Next;
    Dispose(FStack);
    FStack := P;
  end;
end;

procedure TSolver.FreeTokenStack;
var
  P: PStack;
begin
  while FTokenStackHead <> nil do begin
    P := FTokenStackHead.Next;
    Dispose(FTokenStackHead);
    FTokenStackHead := P;
  end;
end;

procedure TSolver.Tokenize(const Value: String);
  procedure HandleToken(const Value: String);
  var
    Token: Byte;
  begin
    {Convert Value into Token}
    case Value[1] of
      '0'..'9',
      ',':      Token := TOKEN_NUMBER;
      '(':      Token := TOKEN_BOPEN;
      ')':      Token := TOKEN_BCLOSE;
      '+':      Token := TOKEN_PLUS;
      '-':      Token := TOKEN_MINUS;
      '*':      Token := TOKEN_MUL;
      '/':      Token := TOKEN_DIVR;
      '^':      Token := TOKEN_POW;
      ' ':      Exit;
      'a'..'z': Token := TOKEN_FUNC;
    else
      begin
        FError := E_EXPR;
        Exit;
      end;
    end;
    if Token <> TOKEN_NUMBER then begin
      if FStack = nil then begin
        if (Token = TOKEN_MINUS) and (FPrevToken <> TOKEN_NUMBER) and (FPrevToken <> TOKEN_BCLOSE) then
          PushTokenNumber(0.0);
        PushStack(Token);
        if Token = TOKEN_FUNC then
          FStack.Func := Value;
      end else
        case Token of
        TOKEN_BOPEN:
          PushStack(TOKEN_BOPEN);
        TOKEN_BCLOSE: begin
          while (FStack <> nil) and (FStack.Token <> TOKEN_BOPEN) do begin
            PushToken;
            PopStack;
          end;
          if (FStack <> nil) and (FStack.Token = TOKEN_BOPEN) then
            PopStack;
        end else begin
          if (FPrevToken = TOKEN_BOPEN) and (Token = TOKEN_MINUS) then
            PushTokenNumber(0.0);
          while (FStack <> nil) and (PriorityToken(FStack.Token) >= PriorityToken(Token)) do begin
            PushToken;
            PopStack;
          end;
          PushStack(Token);
          if Token = TOKEN_FUNC then
            FStack.Func := Value;
        end;
      end;
    end else
      PushTokenNumber(StrToFloat(Value));
    FPrevToken := Token;
  end;

  procedure HandleRemainder;
  begin
    while (FStack <> nil) do begin
      if (FStack.Token <> TOKEN_BCLOSE) and (FStack.Token <> TOKEN_BOPEN) then
        PushToken;
      PopStack;
    end;
  end;
var
  i, Operation, PrevOperation: Word;
  S: String;
begin
  Operation := $FFFF;
  FPrevToken := TOKEN_UNKNOWN;
  FTokenStackHead := nil; FTokenStackTail := nil; FStack := nil;
  S := '';
  for i := 1 to Length(Value) do begin
    PrevOperation := Operation;
    {Extract Numbers, Functions, Operators}
    case Value[i] of
      '0'..'9', ',': Operation := 0; {Numbers}
      'a'..'z':      Operation := 1; {Functions}
    else             Operation := 2; {Operators}
    end;
    if (PrevOperation = 0) and ((Value[i] = 'E') or (Value[i] = 'e'))  then Operation := 0;
    if ((PrevOperation <> Operation) and (PrevOperation <> $FFFF)) or (Operation = 2) then begin
      if Length(S) > 0 then begin
        HandleToken(S);
        if FError <> E_NOERROR then
          Exit;
      end;
      S := '';
    end;
    S := S + Value[i];
  end;
  if Length(S) > 0 then begin
    HandleToken(S);
    if FError <> E_NOERROR then Exit;
  end;
  HandleRemainder;
end;

procedure TSolver.ProcessTokens;
var
  P, P1, P2: PStack;
begin
  if FTokenStackHead = nil then begin
    FError := E_EMPTY;
    Exit;
  end;

  P := FTokenStackHead;
  while P <> nil do begin
    FRPNText := FRPNText + TokenToStr(P) + ' ';
    P := P.Next;
  end;

  P := FTokenStackHead;
  while FTokenStackHead.Next <> nil do begin
    if P = nil then begin
      FError := E_EXPR;
      Exit;
    end;
    case P.Token of
      TOKEN_NUMBER:
        P := P.Next;
      TOKEN_FUNC:
        begin
          P1 := P.Prev;  {a}
          if P1 = nil then begin
            FError := E_EXPR;
            Exit;
          end;
          if P.Func = 'sin' then
            P1.Number := sin(P1.Number)
          else if P.Func = 'cos' then
            P1.Number := cos(P1.Number)
          else if P.Func = 'abs' then
            P1.Number := abs(P1.Number)
          else if P.Func = 'sqr' then
            P1.Number := sqr(P1.Number)
          else if P.Func = 'tan' then begin
            if cos(P1.Number) = 0 then begin
              FError := E_FUNC;
              Exit;
            end else
              P1.Number := sin(P1.Number) / cos(P1.Number);
          end else if P.Func = 'sqrt' then begin
            if P1.Number < 0 then begin
              FError := E_FUNC;
              Exit;
            end else
              P1.Number := sqrt(P1.Number)
          end else begin
            FError := E_FUNC_NOT_FOUND;
            Exit;
          end;
          P1.Next := P.Next;
          if P.Next <> nil then
            P.Next.Prev := P.Prev;
          Dispose(P);
          P := P1;
        end;
      else
        begin
          P1 := P.Prev;  {b}
          if P1 = nil then begin
            FError := E_EXPR;
            Exit;
          end;
          P2 := P1.Prev; {a}
          if P2 = nil then begin
            FError := E_EXPR;
            Exit;
          end;
          case P.Token of
            TOKEN_PLUS:   P2.Number := P2.Number + P1.Number;
            TOKEN_MINUS:  P2.Number := P2.Number - P1.Number;
            TOKEN_MUL:    P2.Number := P2.Number * P1.Number;
            TOKEN_DIVR:
              if P1.Number = 0 then begin
                FError := E_DIV_BY_ZERO;
                Exit;
              end else
                P2.Number := P2.Number / P1.Number;
            TOKEN_POW:
              if (P2.Number = 0) and (P1.Number < 0) then begin
                FError := E_DIV_BY_ZERO;
                Exit;
              end else
              if (P2.Number < 0) and (Frac(P1.Number) <> 0) then begin
                FError := E_SOLVE;
                Exit;
              end else
                P2.Number := Power(P2.Number, P1.Number);
          end;
          P2.Next := P.Next;
          if P.Next <> nil then
            P.Next.Prev := P1.Prev;
          Dispose(P); Dispose(P1);
          P := P2;
        end;
    end;
  end;
  if FTokenStackHead.Token <> TOKEN_NUMBER then begin
    FError := E_EXPR;
    Exit;
  end;
  FRPNResult := FTokenStackHead.Number;
  Dispose(FTokenStackHead); FTokenStackHead := nil;
end;

procedure TSolver.Solve(const Value: String);
begin
  FRPNResult := 0; FRPNText := ''; FError := E_NOERROR;
  FInput := Value;
  if Length(Value) = 0 then begin
    FError := E_EMPTY;
    Exit;
  end;
  Tokenize(Value);
  if FError = E_NOERROR then begin
    ProcessTokens;
    if FError <> E_NOERROR then
      FreeTokenStack;
  end else begin
    FreeStack;
    FreeTokenStack;
  end;
end;

procedure TSolver.SolveGraph(const Value: String; X: Extended);
begin
  Solve(StringReplace(Value, 'x', '(' + FloatToStr(X) + ')', [rfReplaceAll]));
end;

function SolverErrorToStr(Solver: TSolver): String;
begin
  case Solver.Error of
    E_NOERROR:          Result := 'No error';
    E_EMPTY:            Result := 'Empty expression';
    E_EXPR:             Result := 'Error in expression';
    E_SOLVE:            Result := 'Could not solve expression';
    E_DIV_BY_ZERO:      Result := 'Division by zero';
    E_FUNC:             Result := 'Error in function';
    E_FUNC_NOT_FOUND:   Result := 'Function not found';
  else
    Result := 'Unknown error';
  end;
end;

function SolverErrorToStrRus(Solver: TSolver): String;
begin
  case Solver.Error of
    E_NOERROR:          Result := 'Нет ошибки';
    E_EMPTY:            Result := 'Пустое выражение';
    E_EXPR:             Result := 'Ошибка в выражении';
    E_SOLVE:            Result := 'Невозможно решить выражение';
    E_DIV_BY_ZERO:      Result := 'Деление на ноль';
    E_FUNC:             Result := 'Ошибка при вычислении функции';
    E_FUNC_NOT_FOUND:   Result := 'Функция не найдена';
  else
    Result := 'Неизвестная ошибка';
  end;
end;


end.

Guest

Дата 20.12.2004, 05:25 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Да и еще что делает комманда Byte(-1)?

Vladimir13

Дата 20.12.2004, 05:31 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 208
Регистрация: 8.12.2004
Где: Волгоград, Россия

Репутация: 1
Всего: 1

а зачем качать, если не знаешь что качаешь и не знаешь зачем качаешь? Если не знаешь Delphi, то начинай писать с легких программ, а не бери мудреные чьи то. И тебе понятнее будет.

--------------------

Лучший метод - метод тыкаобращаться по адресу: mvdr

Алкоголик

Дата 20.12.2004, 05:37 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

Я знаю что я качаю, знаю зачем я качаю и написать мне её надо... извини за немного грубый ответ, просто это курсач и у меня 8 утра, а спать я сегодня не ложился...

Алкоголик

Дата 20.12.2004, 06:24 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

Неужто некому помочь???

Bes

Дата 20.12.2004, 07:36 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 806
Регистрация: 8.12.2004

Репутация: 5
Всего: 7

Нууу.... брат, раз уж ты не хочешь говорить что это за прога - хоть скажи на какой процедуре ошибка выскакивает. брэкпоинты ставить умеешь?

Vladimir13

Дата 20.12.2004, 07:37 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 208
Регистрация: 8.12.2004
Где: Волгоград, Россия

Репутация: 1
Всего: 1

ты объясни: что это за программа, что она считает... всяко к ней было описание какое нибудь

--------------------

Лучший метод - метод тыкаобращаться по адресу: mvdr

Алкоголик

Дата 20.12.2004, 07:41 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

Это калькулятор на обратной польской записи(стековый), ошибки нету все работает просто я совсем плохо знаю делфи. вот прошу объяснить немного, что в какой функции делается...

Vit

Дата 20.12.2004, 07:45 (ссылка)

(нет голосов)

Загрузка ...

Vitaly Nevzorov

Профиль
Группа: Экс. модератор
Сообщений: 10964
Регистрация: 25.3.2002
Где: Chicago

Репутация: 48
Всего: 207

F7/F8 помогут тебе оттрассировать и посмотреть что каждая программа делать. На первый взгляд в основном идёт парсинг выражения... Конкретнее на такой код глядя мало чего скажешь, надо пошагово проходить и смотреть

--------------------

With the best wishes, Vit
I have done so much with so little for so long that I am now qualified to do anything with nothing
Самый большой Delphi FAQ на русском языке здесь: www.drkb.ru

Ddddddelphi

Дата 20.12.2004, 07:46 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 48
Регистрация: 1.12.2004

Репутация: нет
Всего: нет

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

Это сообщение отредактировал(а) Ddddddelphi - 20.12.2004, 07:48

Алкоголик

Дата 20.12.2004, 07:47 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

Вот здесь программа посмотрите плиз а то времени совсем мало остается...

Алкоголик

Дата 20.12.2004, 09:01 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

А что такое парсинг?

~FoX~

Дата 20.12.2004, 09:07 (ссылка)

(нет голосов)

Загрузка ...

НЕ рыжий!!!

Профиль
Группа: Участник Клуба
Сообщений: 2819
Регистрация: 8.10.2003
Где: Зеленоград

Репутация: 13
Всего: 68

Цитата

А что такое парсинг?

Разризание исходной строки.

--------------------

…множественность никогда не следует полагать без необходимости…

Алкоголик

Дата 20.12.2004, 09:34 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 187
Регистрация: 26.1.2004

Репутация: нет
Всего: нет

а я надеялся...ладно спасибо тем кто хоть как-то отреагировал...

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »