uses GraphABC;
var
x, y: integer;
procedure kv(x, y: integer; color: system.Drawing.Color);
begin
Rectangle(x, y, x + 20, y - 50);
FloodFill(x + 10, y - 10, color);
end;
procedure radpiramid;
begin
x := 80;
while x < 640 do
begin
SetPenColor(clBlack);
kv(x - 40, 50, clGreen);
y := 100;
for var i := 1 to 3 do
kv(x - 20 * i, y, clOrange);
y := 150;
for var i := 1 to 5 do
kv(x + 40 - 20 * (i + 1), y, clRed);
x := x + 105;
end
end;
begin
while y <= windowHeight do
begin
radpiramid;
end;
end.
How to extend a series of pyramids to the entire window? I enter the values of x and y in the last block, but this does not affect anything.
Inside the radpiramid procedure and kv procedure you using a fixed value of y.
procedure kv(x, y: integer; color: system.Drawing.Color);
...
Rectangle(x, y, x + 20, y - 50); <----------------
...
procedure radpiramid;
...
kv(x - 40, 50, clGreen);
y := 100; <--------------------
for var i := 1 to 3 do
kv(x - 20 * i, y, clOrange);
y := 150; <-----------------------
for var i := 1 to 5 do
kv(x + 40 - 20 * (i + 1), y, clRed);
...
You must increase this value of y to get pyramids to appear at different heights of the window.
Related
There are 2 codes in Delphi 7. I need to make forms for them so that all variables are written to the form by the crawler himself, and not by the programmer through the code.
I tried to create a form from scratch. I tried to build it on a ready-made code. Unfortunately, my knowledge of programming in Delphi 7 is too small to understand the documentation for forms written in a rather complex language.
FIRST:
program p1;
{$APPTYPE CONSOLE}
uses
SysUtils, Math, Windows;
var
x, z: integer;
var
RES,s, sp, p, ps, y: real;
begin
SetConsoleCP(1251);
SetConsoleOutputCP(1251);
x := 1;
y := 2.25;
z := 3;
ps := 1;
for x := 1 to 7 do
begin
sp := 0;
for z := 3 to 10 do
begin
s := Arctan(y / z + x / y) / power(abs(y - x - z), 1 / 3);
sp := sp + s;
//Writeln('Сумма ', sp:0:3);
end;
p := (power(2.3, 4 / x) * abs(y - x)) / (sqrt(sqr(x) + sqr(y) + 1.5)) + sp;
ps := ps * p;
//Writeln('Произведение ', ps:0:3);
end;
RES := ps;
Writeln(RES:0:3);
Readln;
end.
SECOND:
program p2;
{$APPTYPE CONSOLE}
uses
SysUtils, Math, Windows;
const
H = 0.4;
Xmin = -3;
Xmax = 2.9;
var
x, y, W: real;
begin
SetConsoleCP(1251);
SetConsoleOutputCP(1251);
x := Xmin;
while (x < Xmax) do
begin
if (x > 0.1) and (x < 2) then begin
W := power(x, 1 / 3) + ln(x);
y := ((ln(sqr(W) + W + 1)) * cos(4 * x)) / (exp(-2) + 2);
end
else if (x <= 0.1) then begin
W := sqr(sin(x)) + 4 * x;
y := ((ln(sqr(W) + W + 1)) * cos(4 * x)) / (exp(-2) + 2);
end
else begin
W := 2.6 * sqr(x) - 3.7;
y := ((ln(sqr(W) + W + 1)) * cos(4 * x)) / (exp(-2) + 2);
end;
x := x + H;
Write('X= ', x:0:3);
Write(' ');
Writeln('Y= ', y:0:3);
end;
Readln;
end.
File > New > Forms Application
That will create a new GUI (not Console) project with a blank Form. Design the Form with UI controls and event handlers as needed, and then copy/paste your code above into the generated code as needed.
My code is doing strange thing when MoveMessage procedure takes max values(ScreenWidth and ScreenHeight). So the "Hello, world" string moves to the right down corner and doing strange thing, but the max and min values are set correctly.
Can someone tell me where is my mistake.
program HelloCrt;
uses crt;
const
Message = 'Hello, world!';
procedure GetKey(var code: integer);
var
c: char;
begin
c := Readkey;
if c = #0 then
begin
c := Readkey;
code := -ord(c);
end
else
code := ord(c);
end;
procedure ShowMessage(x, y: integer; msg: string);
begin
GotoXY(x, y);
write(msg);
GotoXY(1, 1);
end;
procedure HideMessage(x, y: integer; msg: string);
var
len, i: integer;
begin
len := Length(msg);
GotoXY(x, y);
for i := 1 to len do
write(' ');
GotoXY(1, 1);
end;
procedure MoveMessage(var x, y: integer; msg: string; dx, dy: integer);
begin
HideMessage(x, y, msg);
x := x + dx;
y := y + dy;
if x > (ScreenWidth - length(msg)) then
x := (ScreenWidth - length(msg) + 1);
if x < 1 then
x := 1;
if y > ScreenHeight then
y := ScreenHeight;
if y < 1 then
y := 1;
ShowMessage(x, y, msg);
end;
var
CurX, CurY: integer;
c: integer;
begin
clrscr;
CurX := (ScreenWidth - length(Message)) div 2;
CurY := ScreenHeight div 2;
ShowMessage(CurX, CurY, Message);
while true do
begin
Getkey(c);
if c > 0 then
break;
case c of
-75:
MoveMessage(CurX, CurY, Message, -1, 0);
-77:
MoveMessage(CurX, CurY, Message, 1, 0);
-72:
MoveMessage(CurX, CurY, Message, 0, -1);
-80:
MoveMessage(CurX, CurY, Message, 0, 1);
end
end;
clrscr;
end.
program CircleMoving;
uses SwinGame, sgTypes;
procedure Main();
var
x, y, CIRCLE_RADIUS: Single; screenColour: Color;
begin
OpenGraphicsWindow('Character Moving', 800, 600);
Delay(5000);
x := 400;
y := 300;
CIRCLE_RADIUS := 150;
screenColour := ColorWhite;
repeat
clearScreen(screenColour);
fillCircle(ColorGreen, x, y, CIRCLE_RADIUS);
RefreshScreen(60);
Processevents();
if KeyDown(LeftKey) and (x - CIRCLE_RADIUS < ScreenWidth()) then
begin
x := x - 1;
end;
if KeyDown(RightKey) and (x + CIRCLE_RADIUS < ScreenWidth()) then
begin
x := x + 1;
end;
if KeyDown(UpKey) and (y - CIRCLE_RADIUS < ScreenHeight()) then
begin
y := y - 1;
end;
if KeyDown(DownKey) and (y + CIRCLE_RADIUS < ScreenHeight()) then
begin
y := y + 1;
end;
until WindowCloseRequested();
end;
begin
Main();
end.
At the moment when I run the code it works other then when I move the circle to the left and up it goes off the window, I do not want this to happen. I want it to be restricted so the circle will stop and wont go any further once it hits the edge. I want it to be the same on all side so when I move the circle in any direction it will stop at the edge of the window. Moving the circle to the right and down works but left and up does not. I believe the problem is at the if statements starting at line 22. How do I change my code to fix this?
OK, I just installed a Tortoise git in my PC. And I'm quiet amuse about the water effect from its about page.
try to move your mouse cursor on the turtle picture from tortoise GIT - About
its more like we are playing out finger on a water.
Does anyone know how to do make that kind of water effect in Delphi ?
See Leonel Togniolli's "Water Effects" at efg's lab.
The ripple effect is based on 2D Water Effects in December 1999 Game Developer Magazine Article
.
The algorithm is described in here 2D Water, as mentioned by François and as a reference in the source code.
Leonel's implementation is partly based on the gamedev article the-water-effect-explained by Roy Willemse. Here is also pascal code.
There is one more Delphi example at efg's called "Ripple Project", a screen shot is shown below.
Please do the following :
01. Create a Delphi Unit named "WaterEffect.pas" and paste the following codes:
unit WaterEffect;
interface
uses
Winapi.Windows, System.SysUtils, Vcl.Graphics, Math;
const
DampingConstant = 15;
type
PIntArray = ^TIntArray;
TIntArray = array[0..16777215] of Integer;
PPIntArray = ^TPIntArray;
TPIntArray = array[0..16777215] of PIntArray;
PRGBArray = ^TRGBArray;
TRGBArray = array[0..16777215] of TRGBTriple;
PPRGBArray = ^TPRGBArray;
TPRGBArray = array[0..16777215] of PRGBArray;
TWaterDamping = 1..99;
TWaterEffect = class(TObject)
private
{ Private declarations }
FrameWidth: Integer;
FrameHeight: Integer;
FrameBuffer01: Pointer;
FrameBuffer02: Pointer;
FrameLightModifier: Integer;
FrameScanLine01: PPIntArray;
FrameScanLine02: PPIntArray;
FrameScanLineScreen: PPRGBArray;
FrameDamping: TWaterDamping;
procedure SetDamping(Value: TWaterDamping);
protected
{ Protected declarations }
procedure CalculateWater;
procedure DrawWater(ALightModifier: Integer; Screen, Distance: TBitmap);
public
{ Public declarations }
constructor Create;
destructor Destroy; override;
procedure ClearWater;
procedure SetSize(EffectBackgroundWidth, EffectBackgroundHeight: Integer);
procedure Render(Screen, Distance: TBitmap);
procedure Bubble(X, Y: Integer; BubbleRadius, EffectBackgroundHeight: Integer);
property Damping: TWaterDamping read FrameDamping write SetDamping;
end;
implementation
{ TWaterEffect }
const
RandomConstant = $7FFF;
procedure TWaterEffect.Bubble(X, Y: Integer; BubbleRadius, EffectBackgroundHeight: Integer);
var
Rquad: Integer;
CX, CY, CYQ: Integer;
Left, Top, Right, Bottom: Integer;
begin
if (X < 0) or (X > FrameWidth - 1) then X := 1 + BubbleRadius + Random(RandomConstant) mod (FrameWidth - 2 * BubbleRadius - 1);
if (Y < 0) or (Y > FrameHeight - 1) then Y := 1 + BubbleRadius + Random(RandomConstant) mod (FrameHeight - 2 * BubbleRadius - 1);
Left := -Min(X, BubbleRadius);
Right := Min(FrameWidth - 1 - X, BubbleRadius);
Top := -Min(Y, BubbleRadius);
Bottom := Min(FrameHeight - 1 - Y, BubbleRadius);
Rquad := BubbleRadius * BubbleRadius;
for CY := Top to Bottom do
begin
CYQ := CY * CY;
for CX := Left to Right do
begin
if (CX * CX + CYQ <= Rquad) then
begin
Inc(FrameScanLine01[CY + Y][CX + X], EffectBackgroundHeight);
end;
end;
end;
end;
procedure TWaterEffect.CalculateWater;
var
X, Y, XL, XR: Integer;
NewH: Integer;
P1, P2, P3, P4: PIntArray;
PT: Pointer;
Rate: Integer;
begin
Rate := (100 - FrameDamping) * 256 div 100;
for Y := 0 to FrameHeight - 1 do
begin
P1 := FrameScanLine02[Y];
P2 := FrameScanLine01[Max(Y - 1, 0)];
P3 := FrameScanLine01[Y];
P4 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
XL := Max(X - 1, 0);
XR := Min(X + 1, FrameWidth - 1);
NewH := (P2[XL] + P2[X] + P2[XR] + P3[XL] + P3[XR] + P4[XL] + P4[X] +
P4[XR]) div 4 - P1[X];
P1[X] := NewH * Rate div 256;
end;
end;
PT := FrameBuffer01;
FrameBuffer01 := FrameBuffer02;
FrameBuffer02 := PT;
PT := FrameScanLine01;
FrameScanLine01 := FrameScanLine02;
FrameScanLine02 := PT;
end;
procedure TWaterEffect.ClearWater;
begin
if FrameBuffer01 <> nil then ZeroMemory(FrameBuffer01, (FrameWidth * FrameHeight) * SizeOf(Integer));
if FrameBuffer02 <> nil then ZeroMemory(FrameBuffer02, (FrameWidth * FrameHeight) * SizeOf(Integer));
end;
constructor TWaterEffect.Create;
begin
inherited;
FrameLightModifier := 10;
FrameDamping := DampingConstant;
end;
destructor TWaterEffect.Destroy;
begin
if FrameBuffer01 <> nil then FreeMem(FrameBuffer01);
if FrameBuffer02 <> nil then FreeMem(FrameBuffer02);
if FrameScanLine01 <> nil then FreeMem(FrameScanLine01);
if FrameScanLine02 <> nil then FreeMem(FrameScanLine02);
if FrameScanLineScreen <> nil then FreeMem(FrameScanLineScreen);
inherited;
end;
procedure TWaterEffect.DrawWater(ALightModifier: Integer; Screen, Distance:
TBitmap);
var
DX, DY: Integer;
I, C, X, Y: Integer;
P1, P2, P3: PIntArray;
PScreen, PDistance: PRGBArray;
PScreenDot, PDistanceDot: PRGBTriple;
BytesPerLine1, BytesPerLine2: Integer;
begin
Screen.PixelFormat := pf24bit;
Distance.PixelFormat := pf24bit;
FrameScanLineScreen[0] := Screen.ScanLine[0];
BytesPerLine1 := Integer(Screen.ScanLine[1]) - Integer(FrameScanLineScreen[0]);
for I := 1 to FrameHeight - 1 do FrameScanLineScreen[i] := PRGBArray(Integer(FrameScanLineScreen[i - 1]) + BytesPerLine1);
begin
PDistance := Distance.ScanLine[0];
BytesPerLine2 := Integer(Distance.ScanLine[1]) - Integer(PDistance);
for Y := 0 to FrameHeight - 1 do
begin
PScreen := FrameScanLineScreen[Y];
P1 := FrameScanLine01[Max(Y - 1, 0)];
P2 := FrameScanLine01[Y];
P3 := FrameScanLine01[Min(Y + 1, FrameHeight - 1)];
for X := 0 to FrameWidth - 1 do
begin
DX := P2[Max(X - 1, 0)] - P2[Min(X + 1, FrameWidth - 1)];
DY := P1[X] - P3[X];
if (X + DX >= 0) and (X + DX < FrameWidth) and (Y + DY >= 0) and (Y + DY < FrameHeight) then
begin
PScreenDot := #FrameScanLineScreen[Y + DY][X + DX];
PDistanceDot := #PDistance[X];
C := PScreenDot.rgbtBlue - DX;
if C < 0 then PDistanceDot.rgbtBlue := 0 else if C > 255 then PDistanceDot.rgbtBlue := 255 else
begin
PDistanceDot.rgbtBlue := C;
C := PScreenDot.rgbtGreen - DX;
end;
if C < 0 then PDistanceDot.rgbtGreen := 0 else if C > 255 then PDistanceDot.rgbtGreen := 255 else
begin
PDistanceDot.rgbtGreen := C;
C := PScreenDot.rgbtRed - DX;
end;
if C < 0 then PDistanceDot.rgbtRed := 0 else if C > 255 then PDistanceDot.rgbtRed := 255 else
begin
PDistanceDot.rgbtRed := C;
end;
end
else
begin
PDistance[X] := PScreen[X];
end;
end;
PDistance := PRGBArray(Integer(PDistance) + BytesPerLine2);
end;
end;
end;
procedure TWaterEffect.Render(Screen, Distance: TBitmap);
begin
CalculateWater;
DrawWater(FrameLightModifier, Screen, Distance);
end;
procedure TWaterEffect.SetDamping(Value: TWaterDamping);
begin
if (Value >= Low(TWaterDamping)) and (Value <= High(TWaterDamping)) then FrameDamping := Value;
end;
procedure TWaterEffect.SetSize(EffectBackgroundWidth, EffectBackgroundHeight: Integer);
var
I: Integer;
begin
if (EffectBackgroundWidth <= 0) or (EffectBackgroundHeight <= 0) then
begin
EffectBackgroundWidth := 0;
EffectBackgroundHeight := 0;
end;
FrameWidth := EffectBackgroundWidth;
FrameHeight := EffectBackgroundHeight;
ReallocMem(FrameBuffer01, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameBuffer02, FrameWidth * FrameHeight * SizeOf(Integer));
ReallocMem(FrameScanLine01, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLine02, FrameHeight * SizeOf(PIntArray));
ReallocMem(FrameScanLineScreen, FrameHeight * SizeOf(PRGBArray));
ClearWater;
if FrameHeight > 0 then
begin
FrameScanLine01[0] := FrameBuffer01;
FrameScanLine02[0] := FrameBuffer02;
for I := 1 to FrameHeight - 1 do
begin
FrameScanLine01[I] := #FrameScanLine01[I - 1][FrameWidth];
FrameScanLine02[I] := #FrameScanLine02[I - 1][FrameWidth];
end;
end;
end;
end.
In "uses" add "WaterEffect".
Add a "Timer" with "Enable" property and "Interval=25".
In "Private Declaration" add "Water: TWaterEffect;" and "FrameBackground: TBitmap;".
Define "var X:Integer;"
Define the following
procedure TMainForm.FormCreate(Sender: TObject);
begin
Timer01.Enabled := true;
FrameBackground := TBitmap.Create;
FrameBackground.Assign(Image01.Picture.Graphic);
Image01.Picture.Graphic := nil;
Image01.Picture.Bitmap.Height := FrameBackground.Height;
Image01.Picture.Bitmap.Width := FrameBackground.Width;
Water := TWaterEffect.Create;
Water.SetSize(FrameBackground.Width,FrameBackground.Height);
X:=Image01.Height;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
FrameBackground.Free;
Water.Free;
end;
procedure TMainForm.Image01MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Water.Bubble(X,Y,1,100);
end;
procedure TMainForm.Image01MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Water.Bubble(X,Y,1,100);
end;
procedure TMainForm.Timer01Timer(Sender: TObject);
begin
if Random(8)= 1 then
Water.Bubble(-1,-1,Random(1)+1,Random(500)+50);
Water.Render(FrameBackground,Image01.Picture.Bitmap);
with Image01.Canvas do
begin
Brush.Style:=bsClear;
font.size:=12;
Font.Style:=[];
Font.Name := 'Comic Sans MS';
font.color:=$e4e4e4;
Textout(190, 30, DateTimeToStr(Now));
end;
end;
Now Compile. I think you will get the required effect.
That effect is generated by applying certain numerical transformations to the image. They're defined in the CWaterEffect class, which you can inspect for yourself in the WaterEffect.cpp source file.
I have a procedure to auto-resize a column in a grid to accommodate for the largest string in that column. However when there's over 2,000 records in the grid, it takes a little too much time. Any tips on speeding this up?
//lstSKU = grid
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M: Integer;
X: Integer;
S: String;
R: TRect;
begin
M:= 20;
lstSKU.Canvas.Font.Assign(lstSKU.Font);
for X:= 1 to lstSKU.RowCount - 1 do begin
S:= lstSKU.Cells[ACol, X];
R:= Rect(0, 0, 20, 20);
DrawText(lstSKU.Canvas.Handle, PChar(S), Length(S), R,
DT_LEFT or DT_VCENTER or DT_CALCRECT);
if R.Right > M then
M:= R.Right;
end;
M:= M + 15;
lstSKU.ColWidths[ACol]:= M;
end;
Is this a standard TStringGrid/TDrawGrid?
You can iterate through using Canvas.TextWidth(S) instead to measure the content width of each cell, save the largest, add any padding, and then set the Grid.ColWidths[Col] := M;. This will trigger a single redraw if needed. (Basically what you're doing, without repeating the drawing operation 2001 times.)
procedure TfrmExcel.ResizeCol(const ACol: Integer);
var
M, T: Integer;
X: Integer;
S: String;
begin
M := 20;
for X := 1 to lstSKU.RowCount - 1 do
begin
S:= lstSKU.Cells[ACol, X];
T := lstSKU.Canvas.TextWidth(S);
if T > M then
M := T;
end;
M := M + 15;
lstSKU.ColWidths[ACol] := M;
end;
If you want to set both width and height of the cell to accomodate larger fonts or something, use TextExtent instead of TextWidth; TextExtent returns a TSize, from which you can read Width and Height.
Although already answered, I'm posting the final code, which you can use with any string grid (TStringGrid). It resized 3,000 records with 27 columns in 2.3 seconds, as opposed to the prior 6.4 average.
//AGrid = Grid containing column to be resized
//ACol = Column index of grid to be resized
//AMin = Minimum column width
procedure ResizeCol(AGrid: TStringGrid; const ACol, AMin: Integer);
var
M, T: Integer; //M=Maximum Width; T=Current Text
X: Integer; //X=Loop Counter
begin
M:= AMin; //Begin with minimum width
AGrid.Canvas.Font.Assign(AGrid.Font);
for X:= 1 to AGrid.RowCount - 1 do begin
T:= AGrid.Canvas.TextWidth(AGrid.Cells[ACol, X]);
if T > M then M:= T;
end;
AGrid.ColWidths[ACol]:= M + AMin;
end;