{$mode tp} program Rain; uses Crt, Graph; type PTGraphObj = ^TGraphObj; TGraphObj = object Active : Boolean; Color : Integer; constructor Create (AColor : Integer); destructor Done; virtual; procedure Show; procedure Hide; function GetObjColor : Integer; procedure Draw; virtual; abstract; function TakeAction (DoIt : Boolean; P : PTGraphObj) : PTGraphObj; virtual; abstract; function Recalc : Boolean; virtual; abstract; end; constructor TGraphObj.Create(AColor : Integer); begin Color := AColor; Active := True; end; destructor TGraphObj.Done; begin end; function TGraphObj.GetObjColor : Integer; begin if Active then GetObjColor := Color else GetObjColor := GetBkColor; end; procedure TGraphObj.Show; begin if not Active then begin Active := True; Draw; end; end; procedure TGraphObj.Hide; begin if Active then begin Active := False; Draw; end; end; type PTDrop = ^TDrop; TDrop = object (TGraphObj) X, Y : Integer; constructor Create (pX, pY : Integer; AColor : Integer); procedure Draw; virtual; function Recalc : Boolean; virtual; function TakeAction (DoIt : Boolean; P : PTGraphObj) : PTGraphObj; virtual; private grnd : Integer; end; const Vx = 5; Vy = 3; MaxRadius = 100; type PTCircle = ^TCircle; TCircle = object (TGraphObj) X, Y : Integer; Rx, Ry : Integer; constructor Create (pX, pY : Integer; AColor : Integer); procedure Draw; virtual; function Recalc : Boolean; virtual; function TakeAction (DoIt : Boolean; P : PTGraphObj) : PTGraphObj; virtual; end; function CreateNewDrop (p : PTDrop) : PTGraphObj; begin if Assigned (p) then Dispose (p, Done); CreateNewDrop := new (PTDrop, Create (Random (GetMaxX), Random (GetMaxY div 2), LightBlue)); end; constructor TDrop.Create (pX, pY : Integer; AColor : Integer); var Deep : Integer; begin inherited Create (AColor); X := pX; Y := pY; Deep := Random (GetMaxY div 4); grnd := GetMaxY - Trunc (Deep * Sin (Pi / 4)); end; procedure TDrop.Draw; begin SetColor (GetObjColor); Circle (X, Y, 3); end; function TDrop.TakeAction (DoIt : Boolean; P : PTGraphObj) : PTGraphObj; begin if DoIt then begin TakeAction := new (PTCircle, Create (PTDrop (p)^.X, PTDrop (p)^.Y, LightBlue)); Dispose (p, Done); end else TakeAction := P; end; function TDrop.Recalc : Boolean; begin Hide; Y := Y + 3; X := X + 2; if Y > grnd then Recalc := True else begin Recalc := False; Show; end; end; constructor TCircle.Create (pX, pY : Integer; AColor : Integer); begin inherited Create (AColor); X := pX; Y := pY; Rx := Vx; Ry := Vy; end; procedure TCircle.Draw; begin SetColor (GetObjColor); Ellipse (X, Y, 0, 360, Rx, Ry); end; function TCircle.TakeAction (DoIt : Boolean; P : PTGraphObj) : PTGraphObj; begin if DoIt then begin TakeAction := CreateNewDrop (PTDrop (P)); end else TakeAction := P; end; function TCircle.Recalc : Boolean; begin Hide; Inc (Rx, Vx); Inc (Ry, Vy); if Rx > MaxRadius then Recalc := True else begin Recalc := False; Show; end; end; procedure InitGraphix; var grDriver, grMode, ErrCode : Integer; begin grDriver := Detect; InitGraph (grDriver, grMode, ''); ErrCode := GraphResult; if ErrCode <> grOk then begin Writeln ('BGI Error : ' + GraphErrorMsg (ErrCode)); Readln; Halt(1); end; end; procedure CloseGraphix; begin CloseGraph; end; const MaxObjs = 50; var i : integer; Objs : array [1 .. MaxObjs] of PTGraphObj; begin InitGraphix; for i := 1 to MaxObjs do Objs [i] := CreateNewDrop (nil); while not KeyPressed do begin for i := 1 to MaxObjs do with Objs [i]^ do Objs [i] := TakeAction (Recalc, Objs [i]); Delay (15); end; for i := 1 to MaxObjs do Dispose (Objs [i], Done); CloseGraphix; end.