Introducción
Galería teleplástica
Instrucciones
Psicoplás Gold
Descargar
Código Fuente
Enlaces
Generando psicoplastias en su ordenador desde julio del 2005
Código Fuente.
El programa está hecho con Borland Delphi 6.0. Los archivos del código fuente se pueden descargar desde este enlace. Si solo te apetece comprobar los algoritmos de dibujo, el código de los mismos se expone a continuación.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
Image2: TImage;
Label1: TLabel;
Button3: TButton;
Label2: TLabel;
SaveDialog1: TSaveDialog;
MainMenu1: TMainMenu;
Archivo1: TMenuItem;
Grabarloseta1: TMenuItem;
Grabarzoomyretoques1: TMenuItem;
procedure Button1Click(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button3Click(Sender: TObject);
procedure Image2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Grabarzoomyretoques1Click(Sender: TObject);
procedure Grabarloseta1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
const grises = 16;
colorea : array [1..grises] of integer=($40,$4C,$58,$64,$70,$7C,$88,$94,
$A0,$AC,$B8,$C4,$D0,$DC,$E8,$F4);
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var x,y : integer;
gris,base : integer;
mat : array [0..399, 0..399] of integer;
begin
randomize;
for y:=0 to 399 do
for x:=0 to 399 do
begin
if (x<1) and (y<1) then {Primer punto}
base:= random (grises)
else if (x>0) and (y<1) then {primera fila}
base:= mat [x-1,y]
else if (x<1) and (y>0) then {primera columna}
base:= round ((mat [x,y-1]+ mat[x+1,y-1])/2)
else if (x>398) then {ultima columna}
base:=round ((mat[x-1,y-1]+mat[x,y-1]+mat[x-1,y])/3)
else {Cualquier otra cosa}
base:=round ((mat[x-1,y-1]+mat[x,y-1]+mat[x+1,y-1]+mat[x-1,y])/4);
gris:=base + random (3)-1;
if gris<1 then gris:=1;
if gris>grises then gris:=grises;
mat[x,y]:=gris;
end;
for y:=0 to 399 do
for x:=1 to 399 do
begin
gris:=RGB(colorea[mat[x,y]],colorea[mat[x,y]],colorea[mat[x,y]]);
image1.Canvas.Pixels[x,y]:=gris;
end;
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var i,j,k,l,col:integer;
begin
if (x>50) and (x<350) and (y>50) and (y<350) then
for i:=0 to 99 do
for j:=0 to 99 do
begin
col:=image1.Canvas.Pixels[x+i-50,y+j-50];
for k:=0 to 3 do
for l:=0 to 3 do
image2.Canvas.Pixels[4*i+k,4*j+l]:=col;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var i : integer;
x,y : integer;
base,gris : integer;
mat : array [0..399, 0..399] of integer;
const pasadas = 10;
begin
randomize;
for x:=0 to 399 do
for y:=0 to 399 do
mat[x,y]:=7;
for i:=1 to pasadas do
for x:=1 to 398 do
for y:=1 to 398 do
begin
base:=round ((mat[x-1,y-1]+mat[x,y-1]+mat[x+1,y-1]+
mat[x-1,y] +mat[x+1,y] +
mat[x-1,y+1]+mat[x,y+1]+mat[x+1,y+1])/8);
gris:=base + random (5)-2;
if gris<1 then gris:=1;
if gris>grises then gris:=grises;
mat[x,y]:=gris;
end;
for y:=0 to 399 do
for x:=1 to 399 do
begin
gris:=RGB(colorea[mat[x,y]],colorea[mat[x,y]],colorea[mat[x,y]]);
image1.Canvas.Pixels[x,y]:=gris;
end;
end;
procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var col : Tcolor;
i,j : integer;
r : byte; {Usamos un byte para almacenar los 8 bits menos signif. }
begin
if (x>6) and (x<394) and (y>6) and (y<394) then
for i:=-8 to 8 do
for j:=-8 to 8 do
if (i*i+j*j)<64 then {La esponja es redondita}
begin
r:=image2.canvas.Pixels [x+i,y+j];
if r>12 then r:=r-12;
image2.canvas.pixels [x+i,y+j]:=RGB (r,r,r);
end;
end;
procedure TForm1.Grabarzoomyretoques1Click(Sender: TObject);
begin
if savedialog1.execute then
image2.Picture.SaveToFile(savedialog1.filename);
end;
procedure TForm1.Grabarloseta1Click(Sender: TObject);
begin
if savedialog1.execute then
image1.Picture.SaveToFile(savedialog1.filename);
end;
end.
Me apetecía ponerlo, que pasa.