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

    −1

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    57. 57
    58. 58
    59. 59
    60. 60
    61. 61
    62. 62
    63. 63
    64. 64
    65. 65
    66. 66
    67. 67
    68. 68
    69. 69
    70. 70
    71. 71
    72. 72
    73. 73
    74. 74
    75. 75
    76. 76
    77. 77
    78. 78
    79. 79
    80. 80
    81. 81
    82. 82
    83. 83
    84. 84
    85. 85
    86. 86
    87. 87
    88. 88
    89. 89
    90. 90
    91. 91
    92. 92
    93. 93
    94. 94
    95. 95
    96. 96
    97. 97
    98. 98
    99. 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)
  2. Pascal / Говнокод #23334

    −9

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    6. 6
    7. 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)
  3. Pascal / Говнокод #23147

    −1

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 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)
  4. Pascal / Говнокод #23137

    0

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    57. 57
    58. 58
    59. 59
    60. 60
    61. 61
    62. 62
    63. 63
    64. 64
    65. 65
    66. 66
    67. 67
    68. 68
    69. 69
    70. 70
    71. 71
    72. 72
    73. 73
    74. 74
    75. 75
    76. 76
    77. 77
    78. 78
    79. 79
    80. 80
    81. 81
    82. 82
    83. 83
    84. 84
    85. 85
    86. 86
    87. 87
    88. 88
    89. 89
    90. 90
    91. 91
    92. 92
    93. 93
    94. 94
    95. 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)
  5. Pascal / Говнокод #23106

    −1

    1. 1
    2. 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)
  6. Pascal / Говнокод #23100

    0

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 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)
  7. Pascal / Говнокод #22991

    −1414

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 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

    Комментарии (21)
  8. Pascal / Говнокод #21288

    −77

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    6. 6
    7. 7
    8. 8
    program LeakMem;
    
    uses sysutils;
    
    var
       str:string;
    
    ...

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

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

    Комментарии (92)
  9. Pascal / Говнокод #21129

    +8

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 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)
  10. Pascal / Говнокод #20875

    +1871

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 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

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