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

    +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
    program bio;
    uses crt, graphABC;
    const y1=200; r1=20;
    var
    x2,x3,r:real;
    
    procedure del (x1,x11:integer);
    begin
    circle (x1,y1,r1); 
    sleep(1000); 
    ClearWindow();
    r:=r1/2;
    x2:=x1-(r);
    circle (Trunc(x2),y1,Trunc(r));
    x3:=x11+(r);
    circle (Trunc(x3),y1,Trunc(r));
    sleep(1000); 
    r:=r*2;
    x2:=x1-(r);
    circle (Trunc(x2),y1,Trunc(r));
    x3:=x11+(r);
    circle (Trunc(x3),y1,Trunc(r));
    del(Trunc(x2),Trunc(x3));
    end;
    
    
    begin
    SetWindowSize(600,400);
    setBrushColor(clGreen);
    del(300,300);
    end.

    Симулятор деления клеток на паскале, который не работает.

    SewerSurfer, 17 Марта 2018

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

    +10

    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
    var
     DPen: TGPPen;
     Drawer: TGPGraphics;
     DBrush: TGPSolidBrush;
     DFntFam: TGPFontFamily;
     DPath: TGPGraphicsPath;
     IC,BC:Integer;
     ICL, BCL:TGPColor;
     W:WideString;
     si:TGPRectF;
     rt:TGPRectF;
     GP:TGPPoint;
    begin
      W:=FWaterMark.Text;
      IC:=ColortoRGB(FWaterMark.Font.Color);
      BC:=ColorToRGB(FWaterMark.CircuitColor);
      ICl:=MakeColor(GetRValue(IC), GetGValue(IC), GetBValue(IC));
      BCL:=MakeColor(GetRValue(BC), GetGValue(BC), GetBValue(BC));
      Drawer:=TGPGraphics.Create(FBitMap.Canvas.Handle);
      Drawer.SetCompositingQuality(CompositingQualityHighQuality);
      Drawer.SetSmoothingMode(SmoothingModeAntiAlias);
      Drawer.SetTextRenderingHint(TextRenderingHintAntiAlias);
      DPath:=TGPGraphicsPath.Create;
      DPen:=TGPPen.Create(BCL, FWaterMark.FCircuitWidth);
      DBrush:=TGPSolidBrush.Create(ICL);
      DFntFam:=TGPFontFamily.Create(FWaterMark.Font.Name);
    
      RT.X:=0;
      RT.Y:=0;
      RT.Width:=FBitMap.Width;
      RT.Height:=FBitMap.Height;
      
      DPath.AddString(W, Length(W), DFntFam, FontStyleBold, FWaterMark.Font.Size, GP, TGPStringFormat.Create()); 
      DPath.GetBounds(RT, nil, DPen);
      DPath.Reset; 
    
    //В общем, хз, как узнать ширину и высоту нарисованного.
    //MeasureString/MeasureCharacterRanges не подходят,а в доке такая муть, что я чуть не спился.

    Нежнейший аромат...

    Exception, 04 Марта 2018

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