this slowpoke moves

Draw Animated Pixel Graphic

Unit Graphic.pas 
unit Graphic;

interface

type
  vector = array [1..3] of real;
  projection = array [1..2] of vector;
 procedure NormLine(x0,y0,x1,y1,color: integer);
 procedure CDP(alpha: real; var P: Projection);
 procedure Project(const P: Projection; const x,y,z: real; const u0,v0: integer; var u,v: integer);
 procedure DrawSurf;
 procedure FindCoord(var x,y: real; var xp,yp: integer);
 function  Fun(x,y: real):real;

implementation

uses Unit1, Graphics;

procedure NormLine(x0,y0,x1,y1,color: integer);
begin
  b.Canvas.Pen.Color:=color;
  b.Canvas.MoveTo(sx+x0,sy-y0);
  b.Canvas.LineTo(sx+x1,sy-y1);
end;

procedure CDP(alpha: real; var P: Projection);
var
 t: real;
begin
 alpha:= pi*alpha/180.0;
 P[1,1]:=-1.0/sqrt(2.0);
 P[1,2]:=-P[1,1];
 P[1,3]:=0.0;
 t:=sin(alpha)/cos(alpha);
 P[2,1]:=t*P[1,1];
 P[2,2]:=P[2,1];
 P[2,3]:=sqrt(1.0-sqr(t));
end;

procedure Project(const P: Projection; const x,y,z: real; const u0,v0: integer; var u,v: integer);
begin
 u:= u0+round(P[1,1]*x+P[1,2]*y+P[1,3]*z);
 v:= v0+round(P[2,1]*x+P[2,2]*y+P[2,3]*z);
end;

function Fun(x,y: real):real;
begin
 Fun:=cos(sqrt(x*x*a+y*y*a));
end;

procedure FindCoord(var x,y: real; var xp,yp: integer);
begin
 z:= 10*Fun(0.1*x,0.1*y);
 project(P,x,y,z,0,0,xnew,ynew);
end;

procedure DrawSurf;
var
 i,j: integer;
begin
 for i:= 1 to 50 do
  begin
  x:=-100+i*4;
  y:=-100;
  FindCoord(x,y,xnew,ynew);
  xold:=xnew;
  yold:=ynew;
  for j:= 1 to 50 do
    begin
    y:=-100+j*4;
    FindCoord(x,y,xnew,ynew);
    NormLine(xnew,ynew,xold,yold,clLime);
    xold:=xnew;
    yold:=ynew;
    end;
  end;
 for i:= 1 to 50 do
  begin
  y:=-100+i*4;
  x:=-100;
  FindCoord(x,y,xnew,ynew);
  xold:=xnew;
  yold:=ynew;
  for j:= 1 to 50 do
    begin
    x:=-100+j*4;
    FindCoord(x,y,xnew,ynew);
    NormLine(xnew,ynew,xold,yold,clLime);
    xold:=xnew;
    yold:=ynew;
    end;
 end;
end;

end.
Unit 1 : 
uses Graphic

var
  Form1: TForm1;
  b: TBitmap;
  needexit: boolean = false;
  pm: boolean = true;
  sint,cost: array [0..360] of real;
  started: boolean = false;
  secondScene: integer = 0;
  sx,sy: integer;
  P: Projection;
  xnew,ynew,xold,yold: integer;
  x,y,z,a: real;
  pma: boolean = true; 
  logfont: TLogFont;
  fonth: THandle;
  
//

function AngleToPi(x: integer): real;
begin
  AngleToPi:=(Pi*x)/180;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
 i: integer;
begin
  b := TBitMap.Create;
  b.pixelformat := pf24bit;
  b.width := Clientwidth;
  b.height := Clientheight;
  for i:= 0 to 360 do
    begin
    sint[i]:=sin(AngleToPi(i));
    cost[i]:=cos(AngleToPi(i));
    end;
  sx:=Form1.ClientWidth div 2;
  sy:=Form1.ClientHeight div 2-30;
  Randomize;
end;

procedure DrawLine(x,y,rad,ang,color: integer);
var
 curX,curY: integer;
begin
  curX:=x+Round(rad*cost[ang]);
  curY:=y+Round(rad*sint[ang]);
  b.Canvas.Pen.Color:=color;
  b.Canvas.MoveTo(x,y);
  b.Canvas.LineTo(curX,curY);
end;

procedure DrawPixel(x,y,rad,ang,color: integer);
var curX,curY: integer;
begin
  curX:=x+Round(rad*cost[ang]);
  curY:=y+Round(rad*sint[ang]);
  b.Canvas.Pixels[CurX,CurY]:=color;
end;

procedure TForm1.Draw;
var
  x,y,r,i,tmpAng: integer;
  angle: integer;
  ang2: integer;  
  ang3: integer;  
  spAng: integer; 
  CurColor: integer; 
  iteration: integer; 
  tp,xp,yp,pp: real;
  kp: Longint;
  rp: integer;

Procedure FillScreen(FillEllipse: boolean);
begin
b.Canvas.Pen.Color:=clBlack;
b.Canvas.Ellipse(x-52,y+52,x+52,y-52);
if FillEllipse then b.Canvas.FillRect(Rect(b.Width div 2-151,b.Height div 2-170,b.Width div 2+151,b.Height div 2+71));
end;
begin
started:=true;
ang3:=0;
ang2:=MaxInt-360;              
angle:=0;
spAng:=0;                    
r:=50;
x:=51;
y:=b.Height-51;
a:=0.01;
pma:=true;
CurColor:=0;
logFont.lfheight := 30;
logfont.lfwidth := 15;
FontH := createfontindirect(logfont);
SelectObject(b.canvas.handle, FontH);
b.Canvas.Brush.Color:=clBlack;
b.Canvas.FillRect(Rect(0,0,b.Width,b.Height));
Form1.canvas.draw(0, 0, b);
while not needexit do
  begin
  case SecondScene of
  0:begin
    FillScreen(true);
    for i:= 1 to 36 do
      begin
      tmpAng:=(ang3+10*i) mod 360;
      if Odd(i) then
      DrawLine(b.Width div 2+Round(50*cost[tmpAng]),b.Height div 2-50+Round(50*sint[tmpAng]),20,tmpAng,clYellow)
      else
        begin
        DrawLine(b.Width div 2+Round(50*cost[tmpAng]),b.Height div 2-50+Round(50*sint[tmpAng]),50,tmpAng,clYellow);
        b.Canvas.Pen.Color:=RGB(255,0,0);
        b.Canvas.Ellipse(b.Width div 2+Round(100*cost[tmpAng])-5,b.Height div 2-50+Round(100*sint[tmpAng])-5,b.Width div 2+Round(100*cost[tmpAng])+5,b.Height div 2-50+Round(100*sint[tmpAng])+5);
        end;
      end;
    b.Canvas.Pen.Color:=RGB(0,200,0);
    b.Canvas.Ellipse(b.Width div 2-50,b.Height div 2,b.Width div 2+50,b.Height div 2-100);
    for i:= 1 to 18 do              
      begin
      tmpAng:=(ang2+20*i) mod 360;
      DrawLine(b.Width div 2+Round(10*cost[tmpAng]),b.Height div 2-50+Round(10*sint[tmpAng]),30,tmpAng,clAqua);
      end;
    end;
  1:begin
    FillScreen(true);
    cdp(30,P);
    drawsurf;
    if pma then a:=a+0.01 else a:=a-0.01;
    if a>=2.4 then pma:= not pma;
    if a<=0.01 then pma:= not pma;
    end;
  2:begin
    FillScreen(false);
    rp:=25;
    xp:=1.0;
    yp:=0.0;
    for kp:= 1 to 15 do
      begin
      pp:= random;
      tp:=xp;
      if pp<=0.85 then
        begin
        xp:=0.85*xp+0.04*yp;
        yp:=-0.04*tp+0.85*yp+1.6;
        end
      else
      if pp<=0.92 then
        begin
        xp:=0.20*xp-0.26*yp;
        yp:=0.23*tp+0.22*yp+1.6;
        end
      else
      if pp<=0.99 then
        begin
        xp:=-0.15*xp+0.28*yp;
        yp:=0.26*tp+0.24*yp+0.44;
        end
      else
        begin
        xp:=0.0;
        yp:=0.16*yp;
        end;
      b.Canvas.Pixels[b.Width div 2 +round(rp*xp),b.Height div 2+70 -round(rp*yp)]:=clGreen;
      end;
    end;
  end;
  b.Canvas.Pen.Color:=clWhite;             
  b.Canvas.Ellipse(x-50,y+50,x+50,y-50);
  DrawLine(x,y,r,angle mod 360,clLime);
  DrawLine(x,y,r,(angle+120) mod 360,clLime);
  DrawLine(x,y,r,(angle+240) mod 360,clLime);
  SelectObject(b.canvas.handle, FontH);
  SetTextColor(b.canvas.handle, rgb(ang2,ang2,ang2));
  b.Canvas.TextOut(b.Width div 2-180, 0, 'Press space to next scene');
  case CurColor of
  0:begin
    DrawPixel(70,150,spAng div 20,spAng mod 360,Rgb(spAng,0,0));   
    DrawPixel(b.Width-70,150,spAng div 20,(1260-spAng) mod 360,Rgb(spAng,0,0));
    end;
  2:begin
    DrawPixel(70,150,spAng div 20,spAng mod 360,Rgb(0,spAng,0));   
    DrawPixel(b.Width-70,150,spAng div 20,(1260-spAng) mod 360,Rgb(0,spAng,0));
    end;
  1:begin
    DrawPixel(70,150,spAng div 20,spAng mod 360,Rgb(0,0,spAng));   
    DrawPixel(b.Width-70,150,spAng div 20,(1260-spAng) mod 360,Rgb(0,0,spAng));
    end;
  end;
  Form1.canvas.draw(0, 0, b);
  Application.ProcessMessages;
  if x=Form1.ClientWidth-50 then pm:= not pm;
  if x=50 then pm:= not pm;
  if pm then begin inc(x); inc(angle); end else begin dec(x); dec(angle); end;
  dec(ang2);                  
  inc(ang3);
  Inc(spAng);
  if spAng=1250 then
    begin                        
    spAng:=0;
    CurColor:=(CurColor+1) mod 3;
    end;
  end;
DeleteObject(FontH);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
 b.free;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
 needexit:=true;
end;
procedure TForm1.FormClick(Sender: TObject);
begin
 Draw;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
if started then exit;
logFont.lfheight := 100;
logfont.lfwidth := 30;
logfont.lfweight := 750;
logFont.lfEscapement := -0;
logfont.lfcharset := 1;
logfont.lfoutprecision := out_tt_precis;
logfont.lfquality := draft_quality;
logfont.lfpitchandfamily := FF_Modern;
logfont.lfStrikeOut := 0;
logfont.lfUnderline := 0;
FontH := createfontindirect(logfont);
SelectObject(Form1.canvas.handle, FontH);
SetTextColor(Form1.canvas.handle, rgb(250, 0, 0));
SetBKmode(Form1.canvas.handle, transparent);
Form1.Canvas.TextOut(0, b.Height div 2-50, 'Click me to start!!!');
DeleteObject(FontH);
logFont.lfheight := 16;
logfont.lfwidth := 8;
fonth := createfontindirect(logfont);
SelectObject(Form1.canvas.handle, fonth);
SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
DeleteObject(FontH);
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key=' ' then SecondScene:= (SecondScene+1) mod 3;
  b.Canvas.Pen.Color:=clBlack;
  b.Canvas.FillRect(Rect(b.Width
                    div 2-151,b.Height
                    div 2-170,b.Width
                    div 2+151,b.Height
                    div 2+71));
end;

Keine Kommentare:

Kommentar veröffentlichen

Abonnieren Posts (Atom)

Beliebte Posts

  • Network Source Code Update
    Network Source Code Update Source Code Network Update :  https://asciigen.blogspot.com/p/network.html Send Message 1.0 Source Server Client ...
  • Windows Key Sniffer
      Windows Key Sniffer  0.82 - Update 08/2024 Der Windows Key Sniffer hat mir im Laufe der Zeit viel Arbeit erspart und unterstützt, viele Wi...
  • Windows Defender Bypass
      Windows Defender Bypass  Version 0.75 - Update 11/2024 Den Windows 10-eigenen Virenschutz Defender kann man auf mehreren Wegen abschalten,...
  • ASCii Gif Animator
     ASCii GIF Animator Update Version 0.68 (32 bit) - 11/2024 Bei dieser überarbeiteten Version ist die Kompatibilität zu den verschiedenen GIF...
  • MD5 Hacker
      MD5 Hacker v.0.26 - Update 08.2024 MD5 Hashs sollten eigentlich nicht entschlüsselt werden können. Jedoch gibt es Tools, mit welchen auch ...
  • Host Editor
    Host Editor Version 0.64 - Update 11/2024 Hosts File Editor allows for the easy editing of host files and backup creation. Create your own h...
  • Dir Sniffer
        Dir Sniffer Version 0.08 - Update 08/2024 Dir Sniffer ist ein kleines aber nützliches Tool um herauszufinden, was ihr Programm auf ihrem...
  • Oldskool Font Generator
        Oldskool Font Generator v.0.29 - Update 11/2023 Das Tool stell 508 Bitmap Fonts zu Verfügung. Eigene Fonts können integriert werden, sie...
  • ASCii Text Creator
     ASCii Text Creator v.0.24 - Update 11.2023 * Add BugFix Gui Move Message Send * Add 447 Figlet Font Pack * Fixed Invert Unicode Function * ...

Translate