I'm working on a project where I need to calculate the spearman's rank of some data, Currently my program can calculate the spearmans rank as long as their are no tied rankings. I would use an existing unit but I need to display the ranked values in a string grid, alongside their rank, not just the Spearmans value itself. I'm having trouble coming up with a solution that allows the tied values ranks to be averaged to allow the test to be calculated when there is tied data.
Thanks you for your time.
here is the Spearmans rank
This is the code I have so far, this only sorts and ranks the values, the actual spearmans value is calculated in another procedure
type Tspearman = record
x : string;
y : string;
xrank : string;
yrank : string;
d : string;
d2 : string;
end;
procedure TForm1.SortRank();
var
s:string;
P2, P2plus1,q : single;
Position_1, Position_2,i: Integer;
Temporary : TSpearman;
t:string;
begin
for Position_1 := 1 to ListBoxSP.Items.Count-1 do //Length(data) - 1 do
begin
for Position_2 := 1 to ListBoxSP.Items.Count-2 do //( Length( data ) - 2 ) do
begin
P2 := StrToFloat(data[ Position_2 ].x);
P2plus1 := StrToFloat(data[ Position_2 + 1 ].x );
if P2 > P2plus1 then // ascending
then
begin
Temporary := data[ Position_2 ];
data[ Position_2 ] := data[ Position_2 + 1 ];
data[ Position_2 + 1 ] := Temporary;
end;
end;
end;
For i :=1 to ListBoxSP.Items.Count
do
begin
data[i].xrank := IntToStr(i);
end;
for Position_1 := 1 to ListBoxSP.Items.Count-1 do //Length(data) - 1 do
begin
for Position_2 := 1 to ListBoxSP.Items.Count-2 do //( Length( data ) - 2 ) do
begin
P2 := StrToFloat(data[ Position_2 ].y);
P2plus1 := StrToFloat(data[ Position_2 + 1 ].y );
if P2 > P2plus1 then // ascending
begin
Temporary := data[ Position_2 ];
data[ Position_2 ] := data[ Position_2 + 1 ];
data[ Position_2 + 1 ] := Temporary;
end;
end;
end;
For i :=1 to ListBoxSP.Items.Count
do
begin
data[i].yrank := IntToStr(i);
end;
For i:=1 to ListBoxSP.Items.Count //This calculates the d values
do
begin
data[i].d := FloatToStr(StrToFloat(data[i].xrank)-StrToFloat(data[i].yrank));
end;
For i:=1 to ListBoxSP.Items.Count
do
begin
data[i].d2 := data[i].d;
q:= sqr(StrToFloat(data[i].d2));
data[i].d2 := FloatToStr(q);
end;
end;
Related
I have a task to print each number from the input alternately, firstly numbers with even indexes, then numbers with odd indexes. I have solved it, but only for one line of numbers, but I have to read n lines of numbers.
Expected input:
2
3 5 7 2
4 2 1 4 3
Expected output:
7 5 2
1 3 2 4
Where 2 is number of lines, 3 and 4 are numbers of numbers, 5, 7, 2 and 2, 1 , 4, 3 are these numbers.
Program numbers;
Uses crt;
var k,n,x,i,j: integer;
var tab : Array[1..1000] of integer;
var tab1 : Array[1..1000] of integer;
var tab2 : Array[1..1000] of integer;
begin
clrscr;
readln(k);
for i:=1 to k do
begin
read(n);
for j:=1 to n do
begin
read(tab[j]);
if(j mod 2 = 0) then
tab1[j]:=tab[j]
else
begin
tab2[j]:=tab[j];
end;
end;
end;
for j:=1 to n do
if tab1[j]<>0 then write(tab1[j], ' ');
for j:=1 to n do
if tab2[j]<>0 then write(tab2[j], ' ');
end.
Let's clean up the formatting, and use a record to keep track of each "line" of input.
program numbers;
uses
crt;
type
TLine = record
count : integer;
numbers : array[1..1000] of integer
end;
var
numLines, i, j : integer;
lines : Array[1..1000] of TLine;
begin
clrscr;
readln(numLines);
for i := 1 to numLines do
begin
read(lines[i].count);
for j := 1 to lines[i].count do
read(lines[i].numbers[j])
end
end.
We can read each line in. Now, how do we print the odd and even indices together? Well, we could do math on each index, or we could just increment by 2 instead of 1 using a while loop.
program numbers;
uses
crt;
type
TLine = record
count : integer;
numbers : array[1..1000] of integer
end;
var
numLines, i, j : integer;
lines : Array[1..1000] of TLine;
begin
clrscr;
readln(numLines);
// Read in lines.
for i := 1 to numLines do
begin
read(lines[i].count);
for j := 1 to lines[i].count do
read(lines[i].numbers[j])
end;
// Print out lines.
for i := 1 to numLines do
begin
j := 1;
while j <= lines[i].count do
begin
write(lines[i].numbers[j], ' ');
j := j + 2
end;
j := 2;
while j <= lines[i].count do
begin
write(lines[i].numbers[j], ' ');
j := j + 2
end;
writeln
end
end.
Now if we run this:
2
3 4 5 6
4 6 2 4 1
4 6 5
6 4 2 1
One thing we can note is that the following loop is the same for both odd and even indexes, except for the start index.
while j <= lines[i].count do
begin
write(lines[i].numbers[j], ' ');
j := j + 2
end;
This is a perfect place to use a procedure. Let's call it PrintEveryOther and have it take an index to start from and a line to print.
program numbers;
uses
crt;
type
TLine = record
count : integer;
numbers : array[1..1000] of integer
end;
var
numLines, i, j : integer;
lines : Array[1..1000] of TLine;
procedure PrintEveryOther(start : integer; line :TLine);
var
i : integer;
begin
i := start;
while i <= line.count do
begin
write(line.numbers[i], ' ');
i := i + 2
end
end;
begin
clrscr;
readln(numLines);
for i := 1 to numLines do
begin
read(lines[i].count);
for j := 1 to lines[i].count do
read(lines[i].numbers[j])
end;
for i := 1 to numLines do
begin
PrintEveryOther(1, lines[i]);
PrintEveryOther(2, lines[i]);
writeln
end
end.
This program is supposed to find the difference between two dates but it has a bug and I can't find it.
It keeps returning a big number - please help
Program tp4;
Type
dt = Record
jour : Integer;
mois : Integer;
annee : Integer;
End;
Var
date : dt ;
y,x,i,s : Integer;
Begin
x := 0;
s := 0;
For y:=1 To 2 Do
//2 dates
Begin
Writeln('Entrez un date : jour mois année ');
Readln( date.jour, date.mois, date.annee);
While ((date.jour<=0) Or (date.jour>31) Or (date.mois>12) Or (date.annee<=0) ) Do
//verfication loop
Begin
Writeln('Entrez une date valide : jour mois année ');
Readln(date.jour ,date.mois ,date.annee);
End;
s := s+date.jour ;
For i:= 1 To date.mois-1 Do
Case i Of
3,5,7,8,10,12,1 : s := s+31;
4,6,9,11 : s := s +30;
2 : If ((date.annee Mod 100)=0) And ((date.annee Mod 400) = 0 ) Then //convert months to days
s := s+29
Else If date.annee Mod 4 = 0 Then
s := s+29
Else s := s+28;
End; //Convert years to days
For i:= 1 To date.annee Do
If (i Mod 100 = 0) And (i Mod 400 = 0) Then s := s+366
Else If (i Mod 4 =0) Then s := s+366
Else s := s+365;
x:=s-x ;
End;
If (x)<=0 Then
Writeln('la difference est :',-x)
Else Writeln('la difference est :',x);
Readln;
End.
**input**
12 03 2019
13 03 2019
**output**
737510
I think the error was somewhere in s and x (x:=s-x; etc.), I did refactoring:
Program tp4;
Type dt = Record
jour : Integer;
mois : Integer;
annee : Integer;
End;
Type
arrayDate = array[1..2] of dt;
Var
y,i,f,s : Integer;
arrDate: arrayDate;
function Leap (Y : Word): Boolean;
Begin
If (Y Mod 4) <> 0 Then Leap := FALSE
Else If (Y Mod 100) <> 0 Then Leap := TRUE
Else Leap := (Y Mod 400) = 0;
End;
function Lenght (date: dt) : Integer;
Begin
Lenght := 0;
Lenght := Lenght + date.jour;
For i := 1 To date.mois Do
Case i Of
3, 5, 7, 8, 10, 12, 1 : Lenght := Lenght + 31;
4, 6, 9, 11 : Lenght := Lenght + 30;
2 : If Leap (date.annee) Then Lenght := Lenght + 29 Else Lenght:= Lenght + 28;
End;
For i := 1 To date.annee Do //Convert years to days
If Leap (i) Then Lenght := Lenght + 366 Else Lenght := Lenght + 365;
End;
Begin
For y := 1 To 2 Do //2 dates
Begin Writeln ('Entrez un date : jour mois année ');
Readln (arrDate[y].jour, arrDate[y].mois, arrDate[y].annee);
While ((arrDate[y].jour <= 0)
Or (arrDate[y].jour > 31)
Or (arrDate[y].mois > 12)
Or (arrDate[y].annee <= 0)) Do //verfication loop
Begin
Writeln ('Entrez une date valide : jour mois année ');
Readln (arrDate[y].jour, arrDate[y].mois, arrDate[y].annee);
End;
End;
f := Lenght(arrDate[1]);
s := Lenght(arrDate[2]);
Writeln ('la difference est :', Abs(s - f)); // absolute |s-f|
Readln;
End.
You are using the For y ... loop to request input and to calculate number of days for each input. Within the loop, the s variable is the days counter.
The error you do is that you zero s bfore the For y ... loop and not at the beginning of the loop. Therefore, the second time you request a date, s still has the value from the first date, on top of which you then start to calculate the days for the second date.
The correction is of course to move s := 0; to the beginning of the For y ... loop,
or change the first assignment of s from
s := s + date.jour;
to
s := date.jour;
Finding the difference between two dates 6,000 years apart in a loop? And (ab)using the name of a standard function "Length"? Ouch!
Try this:
//----------------------------------------------------------------------
// Convert a date to its Julian Day Number
//----------------------------------------------------------------------
procedure cj(dd, mm, yyyy: longint; var jdn, dow: longint);
var
cj_y,
cj_c,
cj_x,
cj_y: double;
begin
if dd = 0 then
begin
jdn:= -1
dow:= -1;
end
else
begin
cj_y:= yyyy + (mm - 2.85) / 12;
cj_c:= 0.75 * trunc(cj_y * 0.01);
cj_x:= frac(cj_y);
cj_y:= trunc(cj_y);
jdn:= trunc(
trunc(
trunc(367 * cj_x) + 367 * (cj_y) -
1.75 * cj_y + dd) - cj_c) +
1721115.0;
dow:= jdn mod 7;
end;
end; {cj}
Formula as given is valid for days after 1582-10-15, a small tweak will allow dates going back to 0000-03-01.
Follow the link in https://groups.google.com/g/comp.lang.pascal.borland/c/itwgcfYpLEU which I posted in August 1998 in comp.lang.pascal.borland for explanations.
I'm learning algorithms and I'm trying to make an algorithm that extracts numbers lets say n in [1..100] from a string. Hopefully I get an easier algorithm.
I tried the following :
procedure ReadQuery(var t : tab); // t is an array of Integer.
var
x,v,e : Integer;
inputs : String;
begin
//readln(inputs);
inputs:='1 2 3';
j:= 1;
// make sure that there is one space between two integers
repeat
x:= pos(' ', inputs); // position of the space
delete(inputs, x, 1)
until (x = 0);
x:= pos(' ', inputs); // position of the space
while x <> 0 do
begin
x:= pos(' ', inputs); //(1) '1_2_3' (2) '2_3'
val(copy(inputs, 1, x-1), v, e); // v = value | e = error pos
t[j]:=v;
delete(inputs, 1, x); //(1) '2_3' (2) '3'
j:=j+1; //(1) j = 2 (2) j = 3
//writeln(v);
end;
//j:=j+1; // <--- The mistake were simply here.
val(inputs, v, e);
t[j]:=v;
//writeln(v);
end;
I get this result ( resolved ) :
1
2
0
3
expected :
1
2
3
PS : I'm not very advanced, so excuse me for reducing you to basics.
Thanks for everyone who is trying to share knowledge.
Your code is rather inefficient and it also doesn't work for strings containing numbers in general.
A standard and performant approach would be like this:
type
TIntArr = array of Integer;
function GetNumbers(const S: string): TIntArr;
const
AllocStep = 1024;
Digits = ['0'..'9'];
var
i: Integer;
InNumber: Boolean;
NumStartPos: Integer;
NumCount: Integer;
procedure Add(Value: Integer);
begin
if NumCount = Length(Result) then
SetLength(Result, Length(Result) + AllocStep);
Result[NumCount] := Value;
Inc(NumCount);
end;
begin
InNumber := False;
NumCount := 0;
for i := 1 to S.Length do
if not InNumber then
begin
if S[i] in Digits then
begin
NumStartPos := i;
InNumber := True;
end;
end
else
begin
if not (S[i] in Digits) then
begin
Add(StrToInt(Copy(S, NumStartPos, i - NumStartPos)));
InNumber := False;
end;
end;
if InNumber then
Add(StrToInt(Copy(S, NumStartPos)));
SetLength(Result, NumCount);
end;
This code is intentionally written in a somewhat old-fashioned Pascal way. If you are using a modern version of Delphi, you wouldn't write it like this. (Instead, you'd use a TList<Integer> and make a few other adjustments.)
Try with the following inputs:
521 cats, 432 dogs, and 1487 rabbits
1 2 3 4 5000 star 6000
alpha1beta2gamma3delta
a1024b2048cdef32
a1b2c3
32h50s
5020
012 123!
horses
(empty string)
Make sure you fully understand the algorithm! Run it on paper a few times, line by line.
Input String : “a4b4c2d9d9c2e6e6b4s2o1o1s2a4w2r8r8k3g5g5k3w2”
I tried this code as first step:
declare
word varchar2(50) := 'a4b4c2d9d9c2e6e6b4s2o1o1s2a4w2r8r8k2g5g5k2w2';
num number := length(word)/2;
name_array dbms_sql.varchar2_table;
begin
dbms_output.put_line(word);
FOR i IN 1..num LOOP
name_array(i) := substr(word, -2*i, 2);
END LOOP;
FOR i IN name_array.FIRST .. name_array.LAST LOOP
dbms_output.put_line(name_array(i));
END LOOP;
end;
This code creates only an array of string. Not xml format. I need this output:
Which SQL functions,conditional clauses... do I need to use?
Oracle Setup:
CREATE OR REPLACE TYPE CHARS_TABLE IS TABLE OF CHAR(2);
/
CREATE OR REPLACE TYPE INTEGERS_TABLE IS TABLE OF INTEGER;
/
PL/SQL:
This assumes a well-formed set of character pairs and just indents each pair to the appropriate level:
DECLARE
word VARCHAR2(50) := 'a4b4c2d9d9c2e6e6b4s2o1o1s2a4w2r8r8k2g5g5k2w2';
num PLS_INTEGER := LENGTH( word ) / 2;
name_array CHARS_TABLE := CHARS_TABLE();
depth_array INTEGERS_TABLE := INTEGERS_TABLE();
open_array INTEGERS_TABLE := INTEGERS_TABLE();
BEGIN
name_array.EXTEND( num );
depth_array.EXTEND( num );
open_array.EXTEND( num );
name_array(1) := SUBSTR( word, 1, 2 );
depth_array(1) := 1;
open_array(1) := 1;
FOR i IN 2 .. num LOOP
name_array(i) := SUBSTR( word, 2*i - 1, 2 );
open_array(i) := 1;
FOR j IN 1 .. i-1 LOOP
IF name_array(j) = name_array(i) THEN
open_array(i) := -open_array(i);
END IF;
END LOOP;
depth_array(i) := depth_array(i-1) + open_array(i);
END LOOP;
FOR i IN 1 .. num LOOP
FOR j IN 2 .. depth_array(i) + CASE open_array(i) WHEN 1 THEN 0 ELSE 1 END LOOP
DBMS_OUTPUT.PUT( ' ' );
END LOOP;
DBMS_OUTPUT.PUT_LINE( name_array(i) );
END LOOP;
END;
/
Output:
a4
b4
c2
d9
d9
c2
e6
e6
b4
s2
o1
o1
s2
a4
w2
r8
r8
k2
g5
g5
k2
w2
Update - Simpler Stack-Based Version:
DECLARE
word CONSTANT VARCHAR2(50) := 'a4b4c2d9d9c2e6e6b4s2o1o1s2a4w2r8r8k2g5g5k2w2';
num CONSTANT PLS_INTEGER := LENGTH( word ) / 2;
name_array CHARS_TABLE := CHARS_TABLE();
depth PLS_INTEGER := 0;
name CHAR(2);
PROCEDURE indent( depth PLS_INTEGER, name CHAR )
IS
BEGIN
FOR j IN 2 .. depth LOOP
DBMS_OUTPUT.PUT( ' ' );
END LOOP;
DBMS_OUTPUT.PUT_LINE( name );
END;
BEGIN
name_array.EXTEND( num );
FOR i IN 1 .. num LOOP
name := SUBSTR( word, 2*i - 1, 2 );
IF depth > 0 AND name = name_array(depth) THEN
indent(depth,name);
depth := depth - 1;
ELSE
depth := depth - 1;
name_array(depth) := name;
indent(depth,name);
END IF;
END LOOP;
END;
/
DECLARE
vs_CurrentChar VARCHAR2(1);
vs_NextChar VARCHAR2(1);
vs_TempText VARCHAR2(100);
vs_InputText VARCHAR2(100) := 'abcdffdcba';
vn_LengthOfText NUMBER := 1;
vn_WhileIndex NUMBER := 1;
vs_Spaces VARCHAR(100);
BEGIN
vs_TempText := NULL;
vs_CurrentChar := substr(vs_InputText, vn_WhileIndex, vn_LengthOfText);
dbms_output.put_line(vs_CurrentChar);
WHILE vn_WhileIndex < length(vs_InputText) - 1 LOOP
vs_NextChar := substr(vs_InputText, vn_WhileIndex + 1, vn_LengthOfText);
EXIT WHEN vs_CurrentChar = vs_NextChar;
vs_TempText := vs_TempText || vs_CurrentChar;
vs_CurrentChar := vs_NextChar;
vs_Spaces := NULL;
FOR i IN 1 .. vn_WhileIndex LOOP
vs_Spaces := vs_Spaces || chr(9); --'*';
END LOOP;
dbms_output.put_line(vs_Spaces || vs_CurrentChar);
vn_WhileIndex := vn_WhileIndex + 1;
END LOOP;
dbms_output.put_line(vs_Spaces || vs_CurrentChar);
FOR i IN 1 .. length(vs_TempText) LOOP
vs_Spaces := substr(vs_Spaces, vn_LengthOfText, length(vs_Spaces) - 1);
vs_CurrentChar := substr(vs_TempText, -i, vn_LengthOfText);
dbms_output.put_line(vs_Spaces || vs_CurrentChar);
END LOOP;
END;
/
And output:
a
b
c
d
f
f
d
c
b
a
even, if you put '*'; instead of chr(9); then output will look like as:
a
*b
**c
***d
****f
****f
***d
**c
*b
a
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.