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

    −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
    program voynasharov;
    uses crt, graphABC;
    
    type shar = class
     col, x, y, r: integer;
     pm: byte;
     constructor Create (ccol, cx, cy, cr: integer);
      begin
      col:=ccol;
      x:=cx;
      y:=cy;
      r:=cr;
      end;
     procedure make;
      begin
      setbrushcolor (col);
      circle (x,y,r);
      end;
     procedure mov;
     begin
     pm:=random(5);
     case pm of
     1: x:=x+20;
     2: x:=x-20;
     3: y:=y-20;
     4: y:=y+20;
     end;
     end;
    end;
    
    var first, second:shar;
    
    begin
     setwindowsize(1280,720);
     first:=shar.Create(666,550,400,60);
     second:=shar.Create(1488,740,300,60);
     first.make;
     second.make;
     repeat
     //clrscr;
     first.mov;
     second.mov;
     first.make;
     second.make;
     delay(50);
     until first.x=70;
    end.

    Лёгкий способ наколдовать перекатывание кругов в паскале

    SewerSurfer, 09 Января 2018

    Комментарии (3)
  2. Pascal / Говнокод #23646

    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
    program sharokat;
    uses crt, graphABC;
    
    type shar = class
     col, x, y, r: integer;
     constructor Create (ccol, cx, cy, cr: integer);
      begin
      col:=ccol;
      x:=cx;
      y:=cy;
      r:=cr;
      end;
     procedure make;
      begin
      setbrushcolor (col);
      circle (x,y,r);
      end;
    end;
    
    var my:shar;
    
    begin
     my:=shar.Create(666,100,100,60);
     my.make;
    end.

    Лёгкий способ наколдовать круг в паскале

    SewerSurfer, 09 Января 2018

    Комментарии (41)
  3. 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)
  4. 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)
  5. 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)
  6. 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)
  7. 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)
  8. 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)
  9. 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

    Комментарии (56)
  10. 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)