Pascal — Говнокод.ру

Pascal / Говнокод #23616

−1

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99

uses crt;
var
n, c, d:text;//текстовые переменный сохранений
name:string;//имя игрока
namet, cot, dit:string;//имена файлов 
co,di:real;//переменные в игре
cdi:integer;//переменные с курсом
dif:string;//комманды
pm:byte;//+-курс
col:integer;//выбор количества для продажи
procedure cur; //вывод курса
begin
writeln ('Курс алмаза - ',cdi,' монет(ы)');
end;
procedure newr; //изменение курса
begin
pm:=random(2);//курс алмазов +- в промежутке 5,10
if pm=1 then cdi:=cdi+random(5)+5 else cdi:=cdi-(random(5)+5); 
cur();
end;
procedure buyco;
begin
write ('Сколько алмазов вы обменяете на монеты: ');
readln (col);
if col>di then 
 begin
 writeln ('У вас нет такого количества алмазов, введите меньше');
 write ('Сколько алмазов вы обменяете на монеты: ');
 col:=0;  readln (col);
 end 
 else 
  begin
  co:=co+(di*cdi);  di:=di-col;
  writeln ('Монет: ',co);  writeln ('Алмазов: ',di);
  end;
end;
procedure buydi;
begin
write ('Сколько монет вы обменяете на алмазы: ');
readln (col);
if col>co then 
 begin
 writeln ('У вас нет такого количества монет, введите меньше');
 write ('Сколько монет вы обменяете на алмазы: ');
 col:=0;
 readln (col);
 end 
 else 
  begin
  di:=di+((col*co)/cdi); co:=co-col;  
  writeln ('Монет: ',co); writeln ('Алмазов: ',di);  
  end;
end;
procedure buy;
begin
Writeln ('Введиде "co", если хотите купить монеты'); Writeln ('Введиде "di", если хотите купить алмазы');
Write ('Ввод: '); Readln (dif);
if dif = 'co' then buyco(); if dif = 'di' then buydi();
end;
procedure save;
begin
   assign(n, namet);
   rewrite (n);//cоздаём имена файлов   
   cot:=concat(name,'co.txt');
   dit:=concat(name,'di.txt');   
   {создаём сохранения}assign (c, cot); rewrite(c); co:=5; write(c,co);
   assign (d, dit); rewrite(d); di:=1; write(d,di);
   writeln ('Монет: ',co); writeln ('Алмазов: ',di); writeln ('Игра ',name,' сохранена');      
end;
begin
cdi:=random(20)+10; //Задаём начальный курс
write ('Введите ваше имя: '); readln (name); 
namet:=concat(name,'.txt');
if FileExists(namet) then
  begin
     writeln ('Сохранение ',name,' обнаружено');
     writeln ('Загружается сохранение...');
     assign (n, namet);
     reset(n);     
     cot:=concat(name,'co.txt');
     dit:=concat(name,'di.txt');//"вспомиаем" имена файлов     
     assign (c, cot); reset(c); read(c,co);
     assign (d, dit); reset(d); read(d,di);//загрузка сохранений     
     writeln ('Монет: ',co);
     writeln ('Алмазов: ',di);  //вывод данных из сохранений
  end  
  else 
   begin
   //создаём файл с именем игрока
   writeln ('Сохранение ',name,' не обнаружено'); writeln ('Создаётся сохранение...');   
   save();
   end;
   repeat //бесконечный репит
   write('Введите комманду: ');
   readln(dif);
     case dif of
    'new' : newr(); 'cur' : cur(); 'buy' : buy();'save' : save();   
    else Writeln ('Такой команды нет'); end;  
   until dif='end'; close(n);close(c);close(d);

Ну вот. Одна из моих первых программ на паскале. Про переводы из одной валюты в другую с учётом курса. Есть даже сохранения.
Чёрт ногу сломит, я сам уже не понимаю, что тут написал.

SewerSurfer, 24 Декабря 2017

Комментарии (2)

Pascal / Говнокод #23334

−9

1
2
3
4
5
6
7

{получить I}
function getSafeItoDBID(TEmployer e):Integer;
begin
  if (e<>nil) and (e.getIdentificator()<>nil) and (e.getIdentificator().getID()<>nil) and (e.getIdentificator().getID().getID()<>nil)
    then result:= e.getIdentificator().getID().getID().getValue().i;
    else result:= 0;
end;

Получить без ERROR ID для записи в MySQL

AlCodel, 07 Сентября 2017

Комментарии (0)

Pascal / Говнокод #23147

−1

01
02
03
04
05
06
07
08
09
10

TServerThread = class(TThread)
  private
    procedure DoReadData;
  protected
    ThreadOwner: TIPCServer;
    procedure Execute; override;
    constructor Create(AThreadOwner: TIPCServer);
    destructor Destroy; override;
  public
  end;

Мы кодили, кодили и наконец накодили!

antipattern, 27 Июня 2017

Комментарии (3)

Pascal / Говнокод #23137

0

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95

procedure TForm1.ProcListAdvancedCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
var
  TP:TprocessInfo;
  xColor: TColor;
  xRect: TRect;
  xBitmap: TBitmap;
  I, L, R: Integer;
begin
  DefaultDraw:=False;
  TP:=TProcessInfo(Item.SubItems.Objects[0]);
  if (Item.Selected) then
  begin
    if Sender.Focused then
    begin
      if (FItemAtCursor <> -1) and (Item.Index = FItemAtCursor) then
        xColor:=clNavy
      else
        xColor:=$00C56A31;
    end
    else
      xColor:=$00D8E9EC
  end
  else
  begin
    if (TP.New<2) or (TP.Terminated<2) or (TP.Hidden) then
    begin

      if ShowDangerousProcesses then
      if TP.Hidden then
      xColor:=$00DBDBDB;

      if ShowNewProcesses then
      if TP.New <2 then
      xColor:=$001DEB2D;

      if ShowTerminatedProcesses then
      if TP.Terminated < 2 then
      xColor:=$001D2DEB;
    end
    else

    if (Item.Index mod 2 = 1) then
    xColor:=RGB(245,245,255)
    else
    xColor:=clWindow;
  end;
  Sender.Canvas.Brush.Color:=xColor;
  DefaultDraw:=True;

  if (Item.Selected) and Sender.Focused
  then Sender.Canvas.Font.Color:=clWindow
  else Sender.Canvas.Font.Color:=clWindowText;
  Sender.Canvas.FillRect(Item.DisplayRect(drLabel));
  DefaultDraw:=True;

  Exit; 

  xRect:=Item.DisplayRect(drLabel);
  Sender.Canvas.TextRect(xRect,xRect.Left+2,xRect.Top,Item.Caption);

  for I:=0 to TListView(Sender).Columns.Count-1 do
  begin
    if TListView(Sender).Columns[TListView(Sender).Columns[I].ID].Width<=0 then Continue;
    if (I=0) and (TListView(Sender).Columns[I].ID <> 0) then
    begin
      xRect.Left:=0;
      xRect.Right:=xRect.Left+TListView(Sender).Columns.Items[TListView(Sender).Columns[I].ID].Width-1;
      Sender.Canvas.FillRect(xRect);
      Sender.Canvas.TextRect(xRect,xRect.Left+2,xRect.Top,Item.SubItems[TListView(Sender).Columns[I].ID-1]);
    end
    else
    begin
    if I>0 then
    begin
      xRect.Left:=xRect.Right+1;
      xRect.Right:=xRect.Left+TListView(Sender).Columns.Items[TListView(Sender).Columns[I].ID].Width-1;
      Sender.Canvas.FillRect(xRect);
      if TListView(Sender).Columns[I].ID >0 then
      Sender.Canvas.TextRect(xRect,xRect.Left+5,xRect.Top,Item.SubItems[Pred(TListView(Sender).Columns[I].ID)])
      else
      begin
        L:=(Item.DisplayRect(drIcon).Right-Item.DisplayRect(drIcon).Left)+6;
      Sender.Canvas.TextRect(xRect,xRect.Left+L,xRect.Top, Item.Caption)
    end;
    end;

    end;
  end;
  Sender.Canvas.Brush.Color:=clWindow;
  Sender.Canvas.FillRect(Item.DisplayRect(drIcon));
  if Item.ImageIndex=-1 then Exit;
  xBitmap:=TBitmap.Create;
  TListView(Sender).SmallImages.GetBitmap(Item.ImageIndex,xBitmap);

ListView - великий и ужасный! - в режиме OwnerDraw.
Писал диспетчер процессов. Когда я разрешил прятать столбцы и включил свойство FullDrag, моя жизнь круто изменилась.

antipattern, 19 Июня 2017

Комментарии (3)

Pascal / Говнокод #23106

−1

1
2

(багрепорт)
http://www.alphaskins.com/forum/index.php?app=core&module=attach&section=attach&attach_rel_module=post&attach_id=8330Сергох Гончаров с AlphaSkins.com шалит )

Сергох Гончаров с AlphaSkins.com шалит )

antipattern, 06 Июня 2017

Комментарии (0)

Pascal / Говнокод #23100

0

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

function IsExecutablePacked(FileName: WideString): Boolean;
var
i: Cardinal;
CompressionRatio: Double;
Count: Cardinal;
MathX: array [0 .. 255] of Integer;
FileStream: TFileStream;
Buffer: PAnsiChar;
FileHandle: THandle;
begin
Result := False;
try
FileHandle := 0;
FileHandle := CreateFileW(PWideChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_DELETE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (FileHandle <> 0) and FileExists(FileName) then
begin
try
FileStream := TFileStream.Create(FileHandle);
Count := FileStream.Seek(0, soFromEnd);
try
GetMem(Buffer, Count);
FileStream.Seek(0, soFromBeginning);
FileStream.Read(Buffer^, Count);
CompressionRatio := 0;
FillChar(MathX, Sizeof(MathX), 0);
for i := 0 to Count - 1 do
Inc(MathX[Windows.PByte(DWORD(Buffer) + (i))^]);
for i := 0 to 255 do
if MathX > 0 then
CompressionRatio := CompressionRatio - Log2(MathX / Count) * MathX;
finally
FreeMem(Buffer, Count);
end;
CompressionRatio := (Count * 8) / CompressionRatio;
CompressionRatio := 100 / CompressionRatio;
if CompressionRatio > 97 then
Result := True;
finally
FileStream.Free;
end;
end;
finally
end;
end;

"Ис Эксекутабле Пуцкед" - форматирование сохранено.

antipattern, 04 Июня 2017

Комментарии (0)

Pascal / Говнокод #22991

−1414

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

function Unescape(const s: AnsiString): widestring;
var
  i: Integer;
  j: Integer;
  c: Integer;
begin
  // Make result at least large enough. This prevents too many reallocs
  SetLength(Result, Length(s));
  i := 1;
  j := 1;
  while i <= Length(s) do begin
    if s[i] = '\' then begin
      if i < Length(s) then begin
        // escaped backslash?
        if s[i + 1] = '\' then begin
          Result[j] := '\';
          inc(i, 2);
        end
        // convert hex number to WideChar
        else if (s[i + 1] = 'u') and (i + 1 + 4 <= Length(s))
                and TryStrToInt('$' + string(Copy(s, i + 2, 4)), c) then begin
          inc(i, 6);
          Result[j] := WideChar(c);
        end else begin
          raise Exception.CreateFmt('Invalid code at position %d', [i]);
        end;
      end else begin
        raise Exception.Create('Unexpected end of string');
      end;
    end else begin
      Result[j] := WideChar(s[i]);
      inc(i);
    end;
    inc(j);
  end;

  // Trim result in case we reserved too much space
  SetLength(Result, j - 1);
end;

Это не вирус. Просто в Delphi 7 не завезли JSon.

doctor_stertor, 07 Мая 2017

Комментарии (57)

Pascal / Говнокод #21288

−77

1
2
3
4
5
6
7
8

program LeakMem;

uses sysutils;

var
   str:string;

...

В седьмой делфе утекает память.

voodoodal16, 28 Сентября 2016

Комментарии (94)

Pascal / Говнокод #21129

+8

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

Program L_121;
uses crt;
Var N : integer;
b,z : string;
f1 : text;

Begin
     assign(f1,'Единица измерения.txt');
     writeln('1 Соотношение конкретной единицы измерения длины');
     writeln('2 Соотношение единиц измерения длины');
     writeln('3 Обозначение единиц измерения длины');
     writeln('4 Назначение единиц измерения длины');
     read(N);clrscr;
     reset(f1);
     case N of
     
     1:begin
            write('Введите единицу измерения : ');
            read(b);clrscr;
            readln(f1,z);writeln(z);
            if b='миллиметр' then begin readln(f1,z);writeln(z); end;
            if b='сантиметр' then begin readln(f1,z);readln(f1,z);writeln(z); end;
            if b='дециметр'  then begin readln(f1,z);readln(f1,z);readln(f1,z);writeln(z);end;
            if b='метр'      then begin readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);writeln(z);end;
            if b='километр'  then begin readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);writeln(z); end;
       end;
     2:begin
            readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     3:begin
            readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);
            writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     4:begin
            readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);
            readln(f1,z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     end;
End.

4 года назад я так писал код)

Genome, 07 Сентября 2016

Комментарии (20)

Pascal / Говнокод #20875

+1873

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

function translate_a_name_of_the_winter_to_the_foreign_language(language: String): String;
  begin
    if      language = 'авестийский'    Result := 'zimō'
    else if language = 'белорусский'    Result := 'зіма'
    else if language = 'болгарский'     Result := 'зима'
    else if language = 'верхнелужицкий' Result := 'zyma'
    else if language = 'греческий'      Result := 'χειμώνας'
    else if language = 'древнепрусский' Result := 'semo'
    else if language = 'латинский'      Result := 'hiems'
    else if language = 'латышский'      Result := 'ziema'
    else if language = 'литовский'      Result := 'žiema'
    else if language = 'македонский'    Result := 'зима'
    else if language = 'нижнелужицкий'  Result := 'zyma'
    else if language = 'осетинский'     Result := 'зымӕг'
    else if language = 'польский'       Result := 'zima'
    else if language = 'русский'        Result := 'зима'
    else if language = 'санскрит'       Result := 'hima'
    else if language = 'сербский'       Result := 'зима'
    else if language = 'словацкий'      Result := 'zima'
    else if language = 'словенский'     Result := 'zima'
    else if language = 'талышский'      Result := 'зымыстон'
    else if language = 'таджикский'     Result := 'зимистон'
    else if language = 'украинский'     Result := 'зима'
    else if language = 'хорватский'     Result := 'zima'
    else if language = 'чешский'        Result := 'zima'
  end;

Из одного очень серьёзного проекта.

Amayak_Akopyan, 20 Августа 2016

Комментарии (70)

Говнокод: по колено в коде.

Pascal / Говнокод #23616

Pascal / Говнокод #23334

Pascal / Говнокод #23147

Pascal / Говнокод #23137

Pascal / Говнокод #23106

Pascal / Говнокод #23100

Pascal / Говнокод #22991

Pascal / Говнокод #21288

Pascal / Говнокод #21129

Pascal / Говнокод #20875