burada eskiden hazırlamış olduğum bazı programları paylaşabilirim sizinle. umarım bu işi öğrenmek isteyenlere de faydası olur.
ayrıca hemen şunu da belirteyim ki burada yazdığım tüm kodlar tamamen herkese açıktır isteyen istediği gibi kullanabilme, değiştirebilme, ve geliştirme hakkına sahiptir. burdaki tek amacım insanlara faydalı olmak, inşallah bi katkımız olur.
son olarak satır başlarında "." kullanmamın nedeni boşluğa bu forumda izin verilmemesidir. bu .ları teker teker silmek istemiyosanız not defterine kopyaladıktan sonra Ctrl-H ye basın we aranan yerine "..", yeni değer yerine de " " yazın. " ları yazmayın. tümünü değişire basın we 1-2 noktayı fazladan yada eksik silmiş olabilir onları da siz düzeltirsiniz artık
bide şunu söyliycem: kodların arasında {} işaretleri görüyosunuz. onları kaldırırsanız programda değişiklikler farkedeceksiniz, çünkü onların koyulma nedeni benim hoşuma gitmiş olması. yani program {} arasındaki kodlar olsa da çalışır, olmasa da çalışır. sadece zewk meselesi biraz, size kalmış istediğiniz gibi oynayın kodlarla.
kodlarla ilgili kafanıza takılan bişey olursa herzaman sorularınıza açığım elimden geldiğince yardım etmeye çalışırım.
Konu salelltd tarafından (27/05/07 Saat 20:42 ) değiştirilmiştir..
uses crt,graph;
const max=40;maxnkt=20;dusmeivmesi=0.005;tolasilik=5;x1= 0;y1=0;x2=640;y2=440;
......dizi:array[1..15] of integer=(40,80,120,160,200,240,280,320,360,400,440 ,480,520,560,600);
type xy=record x,y:real;end;
.......havaifisek=record
........................k,h:xy;
........................p:boolean;
........................t1,tp,t:integer;
........................nn,r:byte;
........................nkt:array[1..maxnkt] of record k,h:xy;r:byte;end;
......................end;
var ht:array[1..max] of havaifisek;n,tt:byte;tick0,tick1,tickn,carpsay:lon gint;c:char;
procedure hfolustur(t,tp:integer;x,y,hx,hy:real;r:byte);
begin
..if n>=max then exit;n:=n+1;tickn:=tickn+1;
..ht[n].k.x:=x;ht[n].k.y:=y;
..ht[n].h.x:=hx;ht[n].h.y:=hy;
..ht[n].t:=t;ht[n].t1:=0;
..ht[n].p:=false;ht[n].nn:=0;
..ht[n].r:=r;ht[n].tp:=tp;
end;
function rndhx:real;
var k:shortint;
begin
..k:=2*random(2)-1;rndhx:=k*random(150)/200;
end;
function rndhy:real;
begin
..rndhy:=0.1+random(200)/300;
end;
procedure rhfolustur;
var u:byte;
begin
..u:=tickn mod 15+1;
..hfolustur(50+random(100),random(10)+random(15),d izi[u],y2-40,rndhx,rndhy,random(15)+1);
end;
procedure init;
procedure gr;
var gd,gm:integer;i:byte;
begin
..randomize;gd:=detect;initgraph(gd,gm,'');if graphresult<>0 then halt;
{..for i:=1 to 15 do outtextxy(dizi[i],445,chr(i+64));}
end;
var i:byte;
begin
..n:=0;tt:=0;tick0:=0;tick1:=0;tickn:=0;carpsay:=0 ;
..for i:=1 to 20 do
..begin
....hfolustur(300,20,95+i*10,400-i/5,0.15+(21-i)/125,0.8-i/125,15);
....hfolustur(300,20,505-i*10,400-i/5,-0.15-(21-i)/125,0.8-i/125,8);
..end;
..gr;
end;
procedure rline(x1,y1,x2,y2:real);
begin
..line(round(x1),round(y1),round(x2),round(y2));
end;
procedure rputpixel(x,y:real;r:byte);
begin
..putpixel(round(x),round(y),r);
end;
procedure patlat(i:byte);
var k,l:byte;m:shortint;
begin
..ht[i].nn:=maxnkt;
..for k:=1 to maxnkt do
..with ht[i].nkt[k] do
..begin
....k.x:=ht[i].k.x;k.y:=ht[i].k.y;
....m:=2*random(2)-1;h.x:=m*(1+random(10))/20;
....m:=2*random(2)-1;h.y:=m*(1+random(10))/20;
....r:=random(15)+1;
....setcolor(r);for l:=1 to 10 do rline(k.x+5*cos(l*pi/5),k.y-5*sin(l*pi/5),k.x+20*cos(l*pi/5),k.y-20*sin(l*pi/5));
....setcolor(0);for l:=1 to 10 do rline(k.x+5*cos(l*pi/5),k.y-5*sin(l*pi/5),k.x+20*cos(l*pi/5),k.y-20*sin(l*pi/5));
..end;
end;
procedure ayar;
var i,j:byte;
begin
..tt:=tt+1;
..if tt>5 then
..begin
....tt:=0;
....for i:=1 to n do for j:=i+1 to n do
....if (not ht[i].p) and (not ht[j].p) and (abs(ht[i].k.x-ht[j].k.x)<5) and (abs(ht[i].k.y-ht[j].k.y)<5) then
....begin
......ht[i].t1:=ht[i].t-1;ht[j].t1:=ht[j].t-1;carpsay:=carpsay+1;
....end;
....for i:=1 to n do
....begin
......ht[i].t1:=ht[i].t1+1;
......if (ht[i].t1>=ht[i].t) and (not ht[i].p) then
......begin
........ht[i].p:=true;patlat(i);
......end;
....end;
..end;
end;
procedure hfcizim(i:byte;b:boolean);
var u,s,c:real;j:byte;
begin
..u:=sqrt(sqr(ht[i].h.x)+sqr(ht[i].h.y));
..if u=0 then exit;
..c:=ht[i].h.x/sqrt(sqr(ht[i].h.x)+sqr(ht[i].h.y));
..s:=ht[i].h.y/sqrt(sqr(ht[i].h.x)+sqr(ht[i].h.y));
..if ht[i].p then
..begin
....for j:=1 to ht[i].nn do
....begin
......rputpixel(ht[i].nkt[j].k.x,ht[i].nkt[j].k.y,ht[i].nkt[j].r*ord(b));
....end;
..end else
..begin
....setcolor(ht[i].r*ord(b));
....rline(ht[i].k.x-1,ht[i].k.y,ht[i].k.x+5*c-1,ht[i].k.y-5*s);
....rline(ht[i].k.x,ht[i].k.y,ht[i].k.x+5*c,ht[i].k.y-5*s);
....rline(ht[i].k.x+1,ht[i].k.y,ht[i].k.x+5*c+1,ht[i].k.y-5*s);
....rline(ht[i].k.x-2*s,ht[i].k.y-2*c,ht[i].k.x+2*s,ht[i].k.y+2*c);
..end;
end;
procedure ciz(b:boolean);
var i:byte;
begin
..for i:=1 to n do hfcizim(i,b);
end;
procedure hareket;
var i,j,k,l,x:byte;
begin
..x:=n;
..for i:=1 to x do
..if ht[i].p then
..begin
....for j:=1 to ht[i].nn do
....begin
......ht[i].nkt[j].k.x:=ht[i].nkt[j].k.x+ht[i].nkt[j].h.x;
......ht[i].nkt[j].k.y:=ht[i].nkt[j].k.y-ht[i].nkt[j].h.y;
......ht[i].nkt[j].h.y:=ht[i].nkt[j].h.y-dusmeivmesi;
....end;
....k:=ht[i].nn;
....for j:=1 to k do
....if (ht[i].nkt[j].k.x>x2) or (ht[i].nkt[j].k.y>y2) or
.......(ht[i].nkt[j].k.x<x1) or (ht[i].nkt[j].k.y<y1) then
....begin
......for l:=j to k-1 do
......begin
........ht[i].nkt[l]:=ht[i].nkt[l+1];
......end;
......ht[i].nn:=ht[i].nn-1;
....end;
....if (k=0) or ((ht[i].tp<>-1) and (ht[i].t1-ht[i].t>ht[i].tp)) then
....begin
......for l:=i+1 to n do
......begin
........ht[l-1]:=ht[l];
......end;
......n:=n-1;
....end;
..end else
..begin
....ht[i].k.x:=ht[i].k.x+ht[i].h.x;
....ht[i].k.y:=ht[i].k.y-ht[i].h.y;
....ht[i].h.y:=ht[i].h.y-dusmeivmesi/8;
....if (ht[i].k.x>x2) or (ht[i].k.y>y2) or
.......(ht[i].k.x<x1) or (ht[i].k.y<y1) then
....begin
......for l:=i+1 to n do
......begin
........ht[l-1]:=ht[l];
......end;
......n:=n-1;
....end;
..end;
end;
procedure tickdeg;
begin
..tick0:=tick0+1;if tick0>500000 then begin tick0:=0;tick1:=tick1+1;end;
end;
procedure yazilar(b:boolean);
var s:string;
begin
..setcolor(ord(b)*15);
..str(tick0,s);
..outtextxy(0,y2+15,'Sm='+s);
..str(tick1,s);
..outtextxy(100,y2+15,'Sd='+s);
..str(tickn,s);
..outtextxy(200,y2+15,'Toplam='+s);
..str(n,s);
..outtextxy(300,y2+15,'Suanki='+s);
..str(carpsay,s);
..outtextxy(400,y2+15,'Carpisma='+s);
end;
begin
..init;
..repeat
....ciz(true);
....c:=#1;if keypressed then c:=readkey;
....case c of
......'a'..'o','A'..'O':hfolustur(100,20,dizi[ord(upcase(c))-64],y2-40,rndhx,rndhy,random(15)+1);
......#13:readkey;
....end;
....{yazilar(true);}delay(4);ciz(false);{yazilar(f alse);}
....if random(tolasilik)=0 then rhfolustur;
....ayar;hareket;tickdeg;
..until c=#27;
..closegraph;
end.
uses graph,crt;
const maxz=500;ux=20;uy=20;uz=20;oux=150;ouy=150;ouz=0;k nkt=25;tknkt=knkt*knkt;
type xyz=record
...........x,y,z:real;
.........end;
.....xy=record
..........x,y:real;
........end;
.....cizgi=record
.............n1,n2:xyz;
...........end;
.....dortgen=array[1..4] of cizgi;
.....cisim=array[1..4] of dortgen;
.....kure=array[1..tknkt] of xyz;
var gd,gm,ox,oy:integer;cis:array[1..50] of cisim;c:char;sil:boolean;say:byte;ku:kure;
procedure kureyap(x,y,z,r:real;var k:kure);
var i,j,xx:integer;
begin
..xx:=0;
..for i:=1 to knkt do
..for j:=1 to knkt do
..begin
....inc(xx);
....k[xx].x:=x+r*cos(j*2*pi/knkt)*cos(i*2*pi/knkt);
....k[xx].y:=y-r*cos(j*2*pi/knkt)*sin(i*2*pi/knkt);
....k[xx].z:=z-r*sin(j*2*pi/knkt);
..end;
end;
procedure otele(var c:cisim;x,y,z:real);
var i,j:byte;
begin
..for i:=1 to 4 do
..for j:=1 to 4 do
..with c[i,j] do
..begin
....n1.x:=n1.x+x;n1.y:=n1.y+y;n1.z:=n1.z+z;
....n2.x:=n2.x+x;n2.y:=n2.y+y;n2.z:=n2.z+z;
..end;
end;
procedure kureotele(var k:kure;x,y,z:real);
var i:integer;
begin
..for i:=1 to tknkt do begin k[i].x:=k[i].x+x;k[i].y:=k[i].y+y;k[i].z:=k[i].z+z;end;
end;
procedure cevir(a:xyz;var b:xy);
begin
..b.x:=ox+a.x*(1-a.z/maxz);b.y:=oy-a.y*(1-a.z/maxz);
end;
procedure cizgic(c:cizgi);
var c1,c2:xy;
begin
..cevir(c.n1,c1);cevir(c.n2,c2);line(round(c1.x),r ound(c1.y),round(c2.x),round(c2.y));
end;
procedure karec(c:dortgen);
var c1,c2:xy;i:byte;
begin
..for i:=1 to 4 do
..begin
....cevir(c[i].n1,c1);cevir(c[i].n2,c2);
....line(round(c1.x),round(c1.y),round(c2.x),round (c2.y));
..end;
end;
procedure ciz(c:cisim;r:byte);
var i:byte;
begin
..setcolor(r);for i:=1 to 4 do karec(c[i]);
end;
procedure kureciz(k:kure;r:byte);
var i:integer;kk:xy;
begin
..for i:=1 to tknkt do
..begin
....cevir(k[i],kk);putpixel(round(kk.x),round(kk.y),r);
..end;
end;
procedure don(var a,b:real;aci:real);
var c:real;
begin
..c:=a;
..a:=c*cos(aci*pi/180)-b*sin(aci*pi/180);
..b:=b*cos(aci*pi/180)+c*sin(aci*pi/180);
end;
procedure donc(var k:xyz;axy,ayz,axz:real);
begin
..don(k.x,k.y,axy);
..don(k.y,k.z,ayz);
..don(k.z,k.x,axz);
end;
procedure donkure(var k:kure;axy,ayz,axz:real);
var i:integer;
begin
..for i:=1 to tknkt do donc(k[i],axy,ayz,axz);
end;
procedure doncizgi(var c:cizgi;a1,a2,a3:real);
begin
..donc(c.n1,a1,a2,a3);
..donc(c.n2,a1,a2,a3);
end;
procedure donk(var c:dortgen;a1,a2,a3:real);
var i:byte;
begin
..for i:=1 to 4 do doncizgi(c[i],a1,a2,a3);
end;
procedure dondur(var d:cisim;xy,xz,yz:real);
var i:byte;
begin
..for i:=1 to 4 do begin donk(d[i],xy,yz,xz);donk(d[i],xy,yz,xz);end;
end;
procedure cizgiol(var c:cizgi;n1,n2:xyz);
begin
..c.n1:=n1;c.n2:=n2;
end;
procedure dortgenolustur(var k:dortgen;n1,n2,n3,n4:xyz);
begin
..cizgiol(k[1],n1,n2);
..cizgiol(k[2],n2,n3);
..cizgiol(k[3],n3,n4);
..cizgiol(k[4],n4,n1);
end;
procedure cisimolustur(var c:cisim;n1,n2,n3,n4,n5,n6,n7,n8:xyz);
begin
..dortgenolustur(c[1],n1,n2,n3,n4);
..dortgenolustur(c[2],n1,n2,n7,n6);
..dortgenolustur(c[3],n4,n3,n8,n5);
..dortgenolustur(c[4],n7,n6,n5,n8);
end;
procedure ck(var c:cisim;x,y,z,ux,uy,uz:real);
var n1,n2,n3,n4,n5,n6,n7,n8:xyz;
begin
..n1.x:=x;n1.y:=y;n1.z:=z;
..n2.x:=x;n2.y:=y+uy;n2.z:=z;
..n3.x:=x+ux;n3.y:=y+uy;n3.z:=z;
..n4.x:=x+ux;n4.y:=y;n4.z:=z;
..n5.x:=x+ux;n5.y:=y;n5.z:=uz;
..n6.x:=x;n6.y:=y;n6.z:=uz;
..n7.x:=x;n7.y:=y+uy;n7.z:=uz;
..n8.x:=x+ux;n8.y:=y+uy;n8.z:=uz;
..cisimolustur(c,n1,n2,n3,n4,n5,n6,n7,n8);
end;
procedure init;
var i,j,k,l,m:byte;
begin
{..say:=27;for i:=1 to say do ck(cis[i],i*50-say*25-50,0,0,50,50,50);}
{..say:=27;for i:=1 to say do ck(cis[i],cos(i*pi/18)*oux,sin(i*pi/18)*ouy,ouz,ux,uy,uz);}
{..say:=27;m:=20;l:=0;for i:=0 to 2 do for j:=0 to 2 do for k:=0 to 2 do begin inc(l);ck(cis[l],i*m-m,j*m-m,-k*m,m,m,m);end;}
{..say:=1;ck(cis[1],40,0,0,45,70,50);}
..kureyap(0,0,0,50,ku);
..ox:=320;oy:=240;
end;
procedure cizim(b:byte);
var i:byte;
begin
..for i:=1 to say do ciz(cis[i],b);
end;
procedure cdondur(x,y,z:real);
var i:byte;
begin
..for i:=1 to say do dondur(cis[i],x,y,z);
end;
var k:byte;x,y,z,vx,vy,vz:real;
begin
..gd:=detect;initgraph(gd,gm,'');if graphresult<>0 then halt;init;x:=0;y:=0;z:=0;k:=1;vx:=0;vy:=0;vz:=0;si l:=true;
..repeat
....kureciz(ku,15);
....{cizim(15);}delay(10);{if sil then cizim(0);}kureciz(ku,0);
....if keypressed then
....begin
......c:=upcase(readkey);
......case c of
........'T':vx:=vx+0.2;
........'G':vx:=vx-0.2;
........'Y':vy:=vy+0.2;
........'H':vy:=vy-0.2;
........'U':vz:=vz+0.2;
........'J':vz:=vz-0.2;
........'B':begin vx:=0;vy:=0;vz:=0;end;
........'+':if k<27 then inc(k);
........'-':if k>1 then dec(k);
........'A':x:=x+0.2;
........'Q':x:=x-0.2;
........'W':y:=y+0.2;
........'S':y:=y-0.2;
........'E':z:=z+0.2;
........'D':z:=z-0.2;
........'X':begin x:=0;y:=0;z:=0;end;
........'C':cleardevice;
........#32:sil:=not sil;
......end;
....end;
....donkure(ku,x,y,z);kureotele(ku,vx,vy,vz);
{....cdondur(x,y,z);otele(cis[k],vx,vy,vz);}
..until c=#27;
..closegraph;
end.
65520 basamaklı sayılarla dört işlem(bölmeyi de siz yapın benim çok kafam karıştığı için bırakmıştım eskiden şimdi de canım hiç uğraşmak istemiyo)
uses crt;
const buyukN=65520;
type sayi=record s:array[1..buyukN] of char;n:word;end;
.....psayi=^sayi;
procedure birlestir(n:word;a,b: psayi;var c: psayi);{b'yi a'nın n'inci yerine ekle}
var i:word;
begin
..if (a=nil) or (b=nil) or ((n>a^.n) and (a^.n>1)) or (n=0) then exit;
..for i:=1 to n-1 do c^.s[i]:=a^.s[i];
..for i:=1 to b^.n do if i+n>buyukN then begin c^.n:=i+n-1;exit;end else c^.s[i+n-1]:=b^.s[i];
..for i:=n to a^.n do if i+b^.n>buyukN then begin c^.n:=i+b^.n-1;exit;end else c^.s[i+b^.n]:=a^.s[i];
..c^.n:=a^.n+b^.n;
end;
procedure sil(a: psayi;n,k:word;var b: psayi);{a'nın n'inci harfinden başlayarak k harf sil}
var i:word;
begin
..if a=nil then exit;
..if n>a^.n then begin b^.n:=0;exit;end;
..for i:=1 to n-1 do b^.s[i]:=a^.s[i];
..if n+k>a^.n then begin b^.n:=n-1;exit;end;
..for i:=n+k to a^.n do b^.s[i-k]:=a^.s[i];
..b^.n:=a^.n-k;
end;
function buyuk(a,b: psayi):shortint;{-1:hata ,0:eşit, 1:a büyük, 2:b büyük}
var i:byte;bul,n:boolean;
begin
..if (a=nil) or (b=nil) then begin buyuk:=-1;exit;end;n:=false;
..if (a^.s[1]='-') and (b^.s[1]='-') then n:=true;
..if (a^.s[1]='-') and (b^.s[1]<>'-') then buyuk:=2 else if (a^.s[1]<>'-') and (b^.s[1]='-') then buyuk:=1 else
..begin
....bul:=false;
....if a^.n>b^.n then begin bul:=true;if n then buyuk:=2 else buyuk:=1;end else
....if b^.n>a^.n then begin bul:=true;if n then buyuk:=1 else buyuk:=2;end else
....begin
......for i:=1 to a^.n do
......if ord(a^.s[i])>ord(b^.s[i]) then begin if n then buyuk:=2 else buyuk:=1;bul:=true;break;end else
......if ord(b^.s[i])>ord(a^.s[i]) then begin if n then buyuk:=1 else buyuk:=2;bul:=true;break;end;
......if not bul then buyuk:=0;
....end;
..end;
end;
procedure carpim(a,b: psayi;var carpilan: psayi);forward;
function katbul(a,b: psayi):char;
var i:byte;k,l: psayi;bs:shortint;
begin
..new(k);new(l);
..for i:=1 to 10 do
..begin
....k^.n:=1;k^.s[1]:=chr(i+48);carpim(k,a,l);bs:=buyuk(l,b);if (bs=1) or (bs=0) then break;
..end;
..katbul:=chr(i+47);
..dispose(k);dispose(l);
end;
procedure toplam(a,b: psayi;var toplanan: psayi);
var tmp,tmp2: psayi;an,bn,x:longint;c:byte;af:boolean;y:word;
begin
..af:=false;new(tmp);new(tmp2);new(toplanan);topla nan^.n:=0;
..an:=a^.n;bn:=b^.n;x:=an-bn;
..if x<>0 then
..begin
....tmp^.n:=abs(x);for y:=1 to abs(x) do tmp^.s[y]:='0';
....if x>0 then begin birlestir(1,tmp,b,tmp2);b^.s:=tmp2^.s;b^.n:=tmp2^. n;end else
....if x<0 then begin birlestir(1,tmp,a,tmp2);a^.s:=tmp2^.s;a^.n:=tmp2^. n;end;
..end;
..for x:=a^.n downto 1 do
..begin
....if not ((ord(a^.s[x])-48 in [0..9]) and (ord(b^.s[x])-48 in [0..9])) then break;
....c:=ord(a^.s[x])-48+ord(b^.s[x])-48+ord(af);af:=false;
....if c>9 then begin c:=c-10;af:=true;end;
....tmp2^.n:=1;tmp2^.s[1]:=chr(c+48);
....birlestir(1,toplanan,tmp2,tmp);toplanan^.s:=tm p^.s;toplanan^.n:=tmp^.n;
..end;
..if af then
..begin
....tmp2^.n:=1;tmp2^.s[1]:='1';birlestir(1,toplanan,tmp2,tmp);toplanan^.s:= tmp^.s;toplanan^.n:=tmp^.n;
..end;
..dispose(tmp);dispose(tmp2);
end;
procedure carpim(a,b: psayi;var carpilan: psayi);
var s,tmp,tmp2: psayi;x,y,z,k,l:byte;
begin
..new(carpilan);new(s);new(tmp);new(tmp2);
..carpilan^.s[1]:='0';carpilan^.n:=1;
..if a^.n<b^.n then
..begin
....s^.n:=a^.n;s^.s:=a^.s;
....a^.n:=b^.n;a^.s:=b^.s;
....b^.n:=s^.n;b^.s:=s^.s;
..end;
..l:=0;
..for x:=b^.n downto 1 do
..begin
....s^.n:=0;k:=0;
....for y:=a^.n downto 1 do
....begin
......if not ((ord(a^.s[y])-48 in [0..9]) and (ord(b^.s[x])-48 in [0..9])) then break;
......z:=(ord(b^.s[x])-48)*(ord(a^.s[y])-48)+k;k:=0;if z>9 then k:=z div 10;
......tmp^.n:=1;tmp^.s[1]:=chr(z mod 10+48);
......birlestir(1,s,tmp,tmp2);s^.n:=tmp2^.n;s^.s:= tmp2^.s;
....end;
....if k>0 then
....begin
......tmp^.n:=1;tmp^.s[1]:=chr(k+48);
......birlestir(1,s,tmp,tmp2);s^.n:=tmp2^.n;s^.s:= tmp2^.s;
....end;
....tmp^.n:=x+l-1;for y:=1 to x+l-1 do tmp^.s[y]:='0';
....birlestir(1,s,tmp,tmp2);s^.n:=tmp2^.n;s^.s:=tm p2^.s;
....toplam(carpilan,s,tmp2);carpilan^.n:=tmp2^.n;c arpilan^.s:=tmp2^.s;
..end;
..while carpilan^.s[1]='0' do
..begin
....sil(carpilan,1,1,tmp);carpilan^.n:=tmp^.n;carp ilan^.s:=tmp^.s;if carpilan^.n=0 then break;
..end;
..dispose(tmp);dispose(tmp2);dispose(s);
end;
procedure yaz(p: psayi);
var i:word;
begin
..for i:=1 to p^.n do write(p^.s[i]);
end;
procedure oku(var p: psayi);
var i:word;c:char;
begin
..i:=1;new(p);
..repeat
....c:=readkey;
....case c of
......'0'..'9':begin
.................p^.s[i]:=c;i:=i+1;gotoxy(1,wherey);p^.n:=i-1;yaz(p);
.............. end;
......#8:if i>1 then
.........begin
...........i:=i-1;gotoxy(1,wherey);p^.n:=i-1;yaz(p);mem[$B800: (wherex-1)*2+(wherey-1)*160]:=32;
........ end;
......#27:halt;
....end;
..until (i>buyukN) or (c=#13);
..p^.n:=i-1;writeln;
end;
var a,b,c: psayi;
begin
..writeln('iki sayı giriniz:');oku(a);oku(b);
..writeln('çarpımı:');carpim(a,b,c);
{..writeln('Birleşimi:');birlestir(2,a,b,c);}
{..writeln('Toplamı:');toplam(a,b,c);}
..yaz(c);readln;
..dispose(a);dispose(b);dispose(c);
end.
Konu salelltd tarafından (27/05/07 Saat 20:45 ) değiştirilmiştir..
bunu bi kitaptan almıştım okadar faydası oldu ki bunu kullanan programlar da ekliycem de onun için weriorum.
(mouse63.pas olarak kaydedilip derlenecek)
unit mouse63;
interface
uses dos;
const LEFTPRESS=1;
......RIGHTPRESS=2;
......LEFTREL=4;
......RIGHTREL=8;
......CURPOS=16;
var Mouse_Reg:Registers;
....Mouse_Installed:Boolean;
....Mouse_Error:Word;
function InitMouse:Word;
Procedure ShowMouse;
Procedure HideMouse;
Function MousePosition(var Mou***,MouseY:Word):Word;
procedure SetMousePosition(mou***,mousey:Word);
Function MousePress(button:word;var count,lastx,lasty:word):word;
Function MouseRelease(button:word;var count,lastx,lasty:Word):Word;
procedure Setmou***y(x1,y1,x2,y2:Word);
procedure RestoreMou***Y;
procedure SetPixelToMickey(Horiz,Verti:Word);
implementation
function InitMouse:Word;
begin
..Mouse_Reg.Ax:=0;Intr($33,Mouse_Reg);InitMouse:=M ouse_Reg.Ax;
end;
procedure showmouse;
begin
..Mouse_Reg.Ax:=1;Intr($33,Mouse_Reg);
end;
procedure HideMouse;
begin
..Mouse_Reg.Ax:=2;Intr($33,Mouse_Reg);
end;
function MousePosition(var mou***,mousey:word):word;
begin
..Mouse_Reg.Ax:=3;Intr($33,Mouse_Reg);
..with mouse_reg do begin mou***:=succ(cx div 8);mousey:=succ(dx div 8);mouseposition:=bx;end;
end;
procedure setmouseposition(mou***,mousey:word);
begin
..Mouse_Reg.Ax:=4;Mouse_Reg.cx:=pred(mou****8);mou se_reg.dx:=pred(mousey*8);Intr($33,Mouse_Reg);
end;
function mousepress(button:word;var count,lastx,lasty:word):word;
begin
..Mouse_Reg.Ax:=5;Mouse_Reg.bx:=button;Intr($33,Mo use_Reg);
..mousepress:=Mouse_Reg.ax;count:=mouse_reg.bx;las tx:=succ(mouse_reg.cx div 8);lasty:=succ(mouse_reg.dx div 8);
end;
function mouserelease(button:word;var count,lastx,lasty:word):word;
begin
..Mouse_Reg.Ax:=6;Mouse_Reg.bx:=button;Intr($33,Mo use_Reg);
..mouserelease:=Mouse_Reg.ax;count:=mouse_reg.bx;l astx:=succ(mouse_reg.cx div 8);lasty:=succ(mouse_reg.dx div 8);
end;
procedure setmou***y(x1,y1,x2,y2:word);
begin
..Mouse_Reg.ax:=7;Mouse_Reg.cx:=pred(x1*8);mouse_R eg.dx:=pred(y1*8);intr($33,mouse_reg);
..Mouse_Reg.ax:=8;mouse_Reg.cx:=pred(x2*8);mouse_R eg.dx:=pred(y2*8);intr($33,mouse_Reg);
end;
procedure restoremou***y;
begin
..Mouse_Reg.ax:=7;Mouse_Reg.cx:=0;mouse_Reg.dx:=63 9;intr($33,mouse_reg);
..Mouse_Reg.ax:=8;mouse_Reg.cx:=0;mouse_Reg.dx:=19 9;intr($33,mouse_Reg);
end;
procedure SetPixelToMickey(Horiz,Verti:Word);
begin
..Mouse_Reg.ax:=15;Mouse_Reg.cx:=Horiz;Mouse_Reg.D x:=Verti;intr($33,Mouse_Reg);
end;
begin
..Mouse_Error:=InitMouse;Mouse_Installed:=Mouse_Er ror=65535;
end.
Konu salelltd tarafından (27/05/07 Saat 20:46 ) değiştirilmiştir..
topu düşürmeden yukardaki taşları kırmaya çalışıyosunuz.(bilmeyen warmı ki )
uses graph,crt,mouse63;
type resim=record w:word;p: pointer;end;
.....top=record x,y,hx,hy:real;end;
var dizi:array[1..30,1..20] of Byte;
....resimler:array[1..2] of resim;{1:top,2:imle‡}
....mp,mx,my:word;
....t:top;
function acibul(p1x,p1y,p2x,p2y:real):real;
var t,lx,ly,d:real;
begin
..lx:=p2x-p1x;ly:=p2y-p1y;
..if ((lx=0) and (ly=0)) then d:=0 else
..begin
....if lx=0 then
....begin
......if ly>=0 then t:=90 else t:=270;
....end
....else t:=arctan(ly/lx)*180/pi;
....if lx<0 then t:=t+180;if((lx>=0)and(ly<0))then t:=t+360;d:=abs(t);
..end;
..acibul:=d;
end;
procedure sekillericiz;
var i,j:byte;
begin
..for i:=1 to 30 do for j:=1 to 20 do begin setfillstyle(1,dizi[i,j]);bar(20*i+2,j*18-13,20*i+18,j*18-5);end;
end;
procedure arabirim;
begin
..setcolor(15);line(0,430,639,430);sekillericiz;
end;
procedure init;
procedure dosyaacma;
var t:text;i,j:byte;c:char;
begin
..assign(t,'ARK.DAT');{$I-}reset(t);{$I+}if ioresult<>0 then halt;
..for i:=1 to 30 do begin for j:=1 to 20 do read(t,c,dizi[i,j]);readln(t);end;close(t);
end;
procedure gr;
var gd,gm:integer;
begin
..gd:=VGA;gm:=VGAHi;initgraph(gd,gm,'');if graphresult<>0 then halt;
end;
procedure m;
begin
..setmou***y(30,609,420,420);setpixeltomickey(5,4) ;setmouseposition(320,420);
end;
procedure resimayari;
const pat:fillpatterntype=(32,4,32,4,32,4,32,4);
begin
..setfillstyle(1,15);fillellipse(2,2,2,2);
..resimler[1].w:=imagesize(0,0,4,4);
..getmem(resimler[1].p,resimler[1].w);
..getimage(0,0,4,4,resimler[1].p^);
..cleardevice;
..setcolor(15);moveto(3,0);lineto(57,0);lineto(60, 2);lineto(60,4);lineto(57,6);lineto(3,6);lineto(0, 4);lineto(0,2);lineto(3,0);
..setfillpattern(pat,15);floodfill(15,3,15);
..resimler[2].w:=imagesize(0,0,60,6);
..getmem(resimler[2].p,resimler[2].w);
..getimage(0,0,60,6,resimler[2].p^);
..cleardevice;
end;
begin
..if not mouse_installed then halt;
..dosyaacma;gr;m;resimayari;arabirim;mp:=mouseposi tion(mx,my);
..t.x:=320;t.y:=400;t.hx:=1/sqrt(2);t.hy:=-1/sqrt(2);
end;
procedure deinit;
var i:byte;
begin
..for i:=1 to 2 do freemem(resimler[i].p,resimler[i].w);
..closegraph;setmou***y(1,79,1,25);setmousepositio n(1,1);setpixeltomickey(40,30);
end;
procedure oldu;
var s:real;
begin
..if abs(t.x-mx)>30 then
..begin
....t.x:=320;t.y:=400;t.hx:=0;t.hy:=-1;
..end
..else
..begin
....s:=(t.x-mx)/30;
....t.hx:=s;t.hy:=-t.hy;
..end;
end;
procedure hareket;
var i,j:byte;kx,ky:real;
begin
..t.x:=t.x+t.hx;t.y:=t.y+t.hy;
..if t.x>610 then begin t.x:=610;t.hx:=-t.hx;end;
..if t.x<30 then begin t.x:=30;t.hx:=-t.hx;end;
..if t.y>420 then oldu;
..if t.y<10 then begin t.y:=10;t.hy:=-t.hy;end;
..for i:=1 to 30 do for j:=1 to 20 do
..if dizi[i,j]=0 then continue else
..if (t.x>i*20) and (t.x<(i+1)*20) and (t.y>j*18-13) and (t.y<j*18-5) then
..begin
....kx:=abs(t.x-(i*20+10))/16;ky:=abs(t.y-(j*18-9))/8;
....if kx>ky then t.hx:=-t.hx else if ky>kx then t.hy:=-t.hy else begin t.hx:=-t.hx;t.hy:=-t.hy;end;
....setfillstyle(1,0);bar(i*20+2,j*18-13,i*20+18,j*18-5);dizi[i,j]:=0;
..end;
end;
begin
..init;
..repeat
....putimage(round(t.x),round(t.y),resimler[1].p^,XORPUT);putimage(mx-30,my,resimler[2].p^,XORPUT);delay(5);
....putimage(round(t.x),round(t.y),resimler[1].p^,XORPUT);putimage(mx-30,my,resimler[2].p^,XORPUT);
....mp:=mouseposition(mx,my);
....hareket;
..until keypressed;
..deinit;
end.
bu da bunun editörü:
uses graph,crt,mouse63;
var gd,gm:integer;dizi:array[1..30,1..20] of byte;c:char;p,x,y:word;imlecx,imlecy,k:byte;
procedure Sekillericiz;
var i,j:byte;
begin
..for i:=1 to 30 do for j:=1 to 20 do begin setfillstyle(1,dizi[i,j]);bar(20*i+2,(j-1)*18+5,20*(i+1)-2,j*18-5);end;
end;
procedure imlecciz;
begin
..setcolor(15);setwritemode(xorput);rectangle(imle cx*20,(imlecy-1)*18+4,(imlecx+1)*20,imlecy*18-4);setwritemode(normalput);
end;
procedure imlec2ciz;
begin
..setcolor(15);setwritemode(xorput);line(x-5,y,x+5,y);line(x,y-5,x,y+5);setwritemode(normalput);
end;
procedure ekran;
begin
..setcolor(15);
..for gd:=0 to 15 do
..begin
....setfillstyle(1,gd);
....rectangle(gd*10+15+(1-gd div 8)*80,(gd div 8+1)*20+380,gd*10+24+(1-gd div 8)*80,(gd div 8+1)*20+400);
....bar(gd*10+16+(1-gd div 8)*80,(gd div 8+1)*20+381,gd*10+23+(1-gd div 8)*80,(gd div 8+1)*20+399);
..end;
..sekillericiz;
end;
procedure dosyayayaz;
var t:text;i,j:byte;
begin
..assign(t,'ARK.DAT');rewrite(t);for i:=1 to 30 do begin for j:=1 to 20 do write(t,' ',dizi[i,j]);writeln(t);end;close(t);
end;
procedure dosyaacma;
var t:text;i,j:byte;c:char;
begin
..assign(t,'ARK.DAT');{$I-}reset(t);{$I+}if ioresult<>0 then begin rewrite(t);close(t);reset(t);end;
..for i:=1 to 30 do begin for j:=1 to 20 do read(t,c,dizi[i,j]);readln(t);end;close(t);
end;
begin
..gd:=VGA;gm:=VGAHi;initgraph(gd,gm,'');if graphresult<>0 then halt;dosyaacma;
..setmou***y(1,640,1,480);setmouseposition(320,240 );setpixeltomickey(1,1);ekran;
..repeat
....p:=mouseposition(x,y);imlecx:=x div 20+1;imlecy:=y div 18+1;
....if (y<360) and (x<600) then begin imlecciz;delay(10);imlecciz;end else begin imlec2ciz;delay(10);imlec2ciz;end;
....if p=leftpress then
....begin
......if (y<360) and (x<600) then
......begin
........dizi[imlecx,imlecy]:=k;setfillstyle(1,k);bar(imlecx*20+2,imlecy*18-13,imlecx*20+18,imlecy*18-5);
......end
......else
......begin
........if (x>94) and (x<175) and (y>400) and (y<440) then k:=((y-400) div 20)*8+(x-95) div 10;
......end;
....end;
....if keypressed then c:=readkey;
..until c=#27;
..closegraph;
..dosyayayaz;
end.
Konu salelltd tarafından (27/05/07 Saat 20:31 ) değiştirilmiştir..
eskiler
tümünü değişire basın we 1-2 noktayı fazladan yada eksik silmiş olabilir onları da siz düzeltirsiniz artık 
şimdi de canım hiç uğraşmak istemiyo)
Normal
