Forum Index > Coș cu teme șterse > Soft > Всё что касается Turbo Pascal 7.0.

#0 by System at 2006-10-20 20:46:32 (916 săptămâni în urmă) - [Link]Top
Кто может скинуть учебники, стастьи, исходники....и т.д.?


Mesaj util ?   Da   0 puncte

1 2 3 4 5
<< Precedenta      Următoarea >>

#1 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-20 21:02:11 (916 săptămâni în urmă) - [Link]Top
uses
  Crt;
type
  screen = array [0..199, 0..319] of byte;
var
  real_scr  : screen absolute $a000:0;
  p,w       : ^screen;
  i,k,j,l,m : integer;
  flag      : boolean;
  count     : longint;
{}
procedure set_screen(mode:byte); assembler;
asm
  mov ah, 0
  mov al, mode
  int 10h
end;
{}
begin
  set_screen($13);
  New(p);
  New(w);
  for j:=0 to 199 do
    for i:=0 to 319 do
      p^[j,i]:=0;
  for i:=1 to 1000 do
    p^[random(200), random(320)]:=random(256);
  for i:=0 to 199 do
    p^[i,i]:=i;
  for k:=1 to 110 do
    begin
      for i:=0 to Round(k/sqrt(8)) do
        begin
          j:=Round(sqrt(sqr(k/2)-sqr(i)));
          l:=j*5 div 6;
          m:=i*5 div 6;
          p^[99+l,159+i]:=k;
          p^[99-l,159+i]:=k;
          p^[99+l,159-i]:=k;
          p^[99-l,159-i]:=k;
          p^[99+m,159+j]:=k;
          p^[99-m,159+j]:=k;
          p^[99+m,159-j]:=k;
          p^[99-m,159-j]:=k;
        end;
    end;
w^:=p^;
flag:=false;
count:=0;
repeat
for k:=0 to 99 do  begin
  if Keypressed and (readkey=#27) then begin flag:=true; break; end;
  for i:=k to 199-k do
    begin
      p^[i,k]:=k;
      p^[i,319-k]:=k;
    end;
  for j:=k to 319-k do
    begin
      p^[k,j]:=k;
      p^[199-k,j]:=k;
    end;
{    delay(10-(k div 10));}
    if odd(k) then real_scr:=p^;
  Inc(count);
end;
if flag then break;
for k:=99 downto 0 do  begin
  if Keypressed and (readkey=#27) then begin flag:=true; break; end;
  for i:=k to 199-k do
    begin
      p^[i,k]:=w^[i,k];
      p^[i,319-k]:=w^[i,319-k];
    end;
  for j:=k to 319-k do
    begin
      p^[k,j]:=w^[k,j];
      p^[199-k,j]:=w^[199-k,j];
    end;
{    delay(10-(k div 10));}
    if odd(k) then real_scr:=p^;
  Inc(count);
end;
until flag;
  real_scr:=p^;
  Dispose(p);
  Dispose(w);
  set_screen(3);
  WriteLn(count);
end.



Mesaj util ?   Da   0 puncte
#2 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-20 22:26:42 (916 săptămâni în urmă) - [Link]Top
jekader, mi-i lene sa ma vrubesc ce face programu. Cu atit mai mult mi-i lene sa-l copii sh sa-l compilez. Deam spune ce face. Amush arunc sh eu o joaca :)


Mesaj util ?   Da   0 puncte
#3 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-20 23:10:44 (916 săptămâni în urmă) - [Link]Top
#2 Capilleary, какая-то чушь :) рисует разноцветрные кружки и прямоугольники :lol:

причём, прошу заметить, в режиме 256 цветов, и без использования библиотеки graph


Mesaj util ?   Da   0 puncte
#4 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-20 23:14:32 (916 săptămâni în urmă) - [Link]Top
{$N+}
program cherviak;
uses crt, graph, windos;
type vierme=array[1..800,1..2] of integer;
var hit,bo,bor,boc:boolean;
    px,py,px1,py1,coun:integer;
procedure draw(x,y,col:integer);
begin
    setcolor(col);
    rectangle(x,y,x+8,y+8);
    rectangle(x,y,x+6,y+6);
    rectangle(x+2,y+2,x+6,y+6);
    rectangle(x+2,y+2,x+4,y+4);
    setcolor(white)
end;
procedure move(var cher:vierme; x,y:longint; var l:longint);
var a,b,c,d:integer;
begin
    hit:=(cher[1,1]+x=px) and (cher[1,2]+y=py);
    if not hit then draw(cher[l,1],cher[l,2],16)
    else begin
          l:=l+1;
          if ((l-2) mod 3)=0 then
          coun:=1;
    end;

    for a:=l downto 2 do begin
        cher[a,1]:=cher[a-1,1];
        cher[a,2]:=cher[a-1,2];
    end;
    cher[1,1]:=cher[1,1]+x;
    cher[1,2]:=cher[1,2]+y;
end;
procedure config(var t:longint);
var h,m,s,h1,sec100,mem1,mem2:word;
begin
    writeln('Loading...' );
    write('Configuring game speed according to CPU clock speed...' );
    t:=0;
    gettime(h,m,s,sec100);
    mem1:=s;
    mem2:=sec100;
    delay(32000);
    gettime(h,m,s,sec100);
    if s<mem1 then s:=60-mem1+s;
    if s>mem1 then s:=s-mem1;
    if s=mem1 then s:=0;
    s:=s*100;
    if sec100<mem2 then sec100:=100-mem2+sec100;
    if sec100>mem2 then sec100:=sec100-mem2;
    if sec100=mem2 then sec100:=0;
    s:=s+sec100;
    t:=round(3000000/s);
    writeln('done' );
    write('Randomizing game scenario...' );
    for h1:=1 to h*m*s*sec100 do begin
        px:=random(600);
        py:=random(600);
        px1:=random(600);
        py1:=random(600);
    end;
    writeln('done' );
end;
var a,b,x,y,l,sp,de,cr,sp1:longint;
    v,v1:vierme;
    a1,b1:integer;
label count;
begin
    clrscr;
    config(sp);
    sp:=sp*1;
    detectgraph(a1,b1);
    initgraph(a1,b1,'' );
    rectangle(8,8,630,470);
    v[1,1]:=320;
    v[1,2]:=240;
    v[2,1]:=320;
    v[2,2]:=230;
    l:=2;
    x:=0;
    y:=-10;
    hit:=false;
    sp1:=sp div 4;
    repeat
          px:=random(62)*10+10;
          py:=random(46)*10+10;
          bo:=false;
          for b:=1 to l do
              if (px=v[b,1]) and (py=v[b,2]) then bo:=true;
              if getpixel(px,py)=red then bo:=true;
    until not bo;
    draw(px,py,lightgreen);
    bor:=false;
    repeat
          sp:=sp1-(sp1 div 300)*l;
          a:=0;
          repeat
count:          inc(a);
                delay(1);
          until (a=sp) or keypressed;
          if keypressed then
              case readkey of
                  '4':begin
                            if x=0 then begin
                              x:=-10; y:=0;
                            end;
                            if x=10 then goto count;
                  end;
                  '8':begin
                            if y=0 then begin
                              x:=0; y:=-10;
                            end;
                            if y=10 then goto count;
                  end;
                  '6':begin
                            if x=0 then begin
                              x:=10; y:=0;
                            end;
                            if x=-10 then goto count;
                  end;
                  'p','P':readkey;
                  '2':begin
                            if y=0 then begin
                              x:=0; y:=10;
                            end;
                            if y=-10 then goto count;
                  end;
                  'q','Q',' ',#13,#27:begin closegraph; halt(1); end;
              end;
          if getpixel(v[1,1]+x,v[1,2]+y)=red then bor:=true;
          move(v,x,y,l);
          if coun=1 then begin
              repeat
                    boc:=false;
                    px1:=random(62)*10+10;
                    py1:=random(46)*10+10;
                    for cr:=1 to l do
                        if (px1=v[cr,1]) and (py1=v[cr,2]) then boc:=true;
              until not boc;
              draw(px1,py1,red);
              coun:=0;
          end;
          if not bor then
          for b:=2 to l do
              if (v[b,1]=v[1,1]) and (v[b,2]=v[1,2]) then begin
                  if l-b > l div 2 then bor:=true
                  else begin
                  for de:=b to l do draw(v[de,1],v[de,2],16);
                  l:=b-1;
                  end;
              end;
          if hit then begin
              hit:=false;
              repeat
                    px:=random(62)*10+10;
                    py:=random(46)*10+10;
                    bo:=false;
                    for b:=1 to l do
                        if (px=v[b,1]) and (py=v[b,2]) then bo:=true;
              until not bo;
              draw(px,py,lightgreen);
          end;
          for b:=2 to l do draw(v[b,1],v[b,2],white);
          draw(v[1,1],v[1,2],lightgray);
    until (l=500) or bor or (v[1,1]<1) or (v[1,1]>620) or (v[1,2]<1) or (v[1,2]>460);
    repeat
          repeat until keypressed;
    until readkey=' ';
    closegraph;
    clrscr;
    writeln('Score: ',l-2);
    repeat
          repeat until keypressed;
    until readkey=' ';
    clrscr;
end.


Caietzelul sh pixul sh foiala! La informatica o sa va jucatzi sh voua 10 o sa va puna pentru asta :whistle:


Mesaj util ?   Da   0 puncte
#5 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-20 23:33:26 (916 săptămâni în urmă) - [Link]Top
am dat de nishte capodopere din anii liceului. Ehhhh, nostalgie.


program satelit;
uses graph,crt;
const k=0.0003;
Type obiect=record
            m:real;
            r:real;
            exist:boolean;
            x,y,vx,vy,xp,yp:real;
    end;
    obiecte=array[1..20] of obiect;
function dis(c1,c2:obiect):real;
begin
    dis:=sqr(c1.x-c2.x) + sqr(c1.y-c2.y);
end;
function putere(a,b:real):real;
begin
    if a>0 then
    putere:=exp(b*ln(a));
end;
procedure create(var c:obiect; m1,r1,x1,y1,vx1,vy1:real);
begin
    with c do begin
          m:=m1;
          r:=r1;
          x:=x1;
          y:=y1;
          vx:=vx1;
          vy:=vy1;
          exist:=true;
    end;
end;
procedure join(var c1,c2:obiect);
var a:real;
begin
    if c1.r<c2.r then begin
        c1.x:=c2.x;
        c1.y:=c2.y;
        c1.vx:=(c1.vx*c1.m+c2.vx*c2.m)/(c1.m+c2.m);
        c1.vy:=(c1.vy*c1.m+c2.vy*c2.m)/(c1.m+c2.m);
    end;
    c1.m:=c1.m+c2.m;
    a:=c1.r;
    c1.r:=putere(putere(c1.r,1/3)+putere(c2.r,1/3),3);
    setcolor(16);
    c2.exist:=false;
    circle(round(c1.xp),round(c1.yp),round(a));
    circle(round(c2.xp),round(c2.yp),round(c2.r));
    setcolor(white);
end;
procedure protz(var c1,c2:obiect);
begin
    if dis(c1,c2)<=sqr(c1.r+c2.r) then begin
        if ((c1.vx+c2.vx)<(c1.vx*c2.vx)) or ((c1.vy+c2.vy)<(c1.vy*c2.vy))
        then begin
            if abs(c1.m-c2.m)>(c1.m+c2.m-abs(c1.m-c2.m)) then
                if c1.m<c2.m then join(c2,c1) else join(c1,c2)
            else begin
                  c1.exist:=false;
                  c2.exist:=false;
                  setcolor(16);
                  circle(round(c1.xp),round(c1.yp),round(c1.r));
                  circle(round(c2.xp),round(c2.yp),round(c2.r));
                  setcolor(white);
            end;
        end;
    end;
end;
procedure mem(var c:obiecte; pina:integer);
var nr:integer;
begin
    for nr:=1 to pina do
        with c[nr] do begin
              xp:=x;
              yp:=y;
        end;
end;
procedure protz0(var c1,c2:obiect);
var c,d,e,f:real;
begin
    c:=c1.x-c2.x;
    d:=c1.y-c2.y;
    e:=c+d;
    f:=dis(c1,c2);
    c1.vx:=c1.vx-c2.m*k/f*c;
    c1.vy:=c1.vy-c2.m*k/f*d;
    c2.vx:=c2.vx+c1.m*k/f*c;
    c2.vy:=c2.vy+c1.m*k/f*d;
    c1.x:=c1.x+c1.vx;
    c1.y:=c1.y+c1.vy;
    c2.x:=c2.x+c2.vx;
    c2.y:=c2.y+c2.vy;
    if abs(c1.x-c2.x)<c1.r+c2.r then
        if abs(c1.y-c2.y)<c1.r+c2.r then protz(c1,c2);
end;
procedure move(var c:obiecte; dela,pina:integer; dx,dy,dvx,dvy:real);
var nr:integer;
begin
    for nr:=dela to pina do begin
        with c[nr] do begin
              x:=x+dx;
              y:=y+dy;
              vx:=vx+dvx;
              vy:=vy+dvy;
        end;
    end;
end;
procedure des(c:obiect);
begin
    setcolor(16);
    with c do begin
          circle(round(xp),round(yp),round(r));
          setcolor(white);
          circle(round(x),round(y),round(r));
    end;
end;
var a,b,lava:integer;
    o:obiecte;
begin
    detectgraph(a,b);
    initgraph(a,b,'' );
    lava:=30;
    create(o[1],1,1,110,100,0.1,-0.1);
    create(o[2],1,1,101,100,0.1,-0.1);
    create(o[3],1,1,20,101,0.1,-0.1);
    create(o[4],4,2,30,101,0.1,-0.1);
    create(o[5],1,1,40,101,0.1,-0.1);
    create(o[6],1,1,50,101,0.1,-0.1);
    create(o[7],1,1,60,102,0.1,-0.1);
    create(o[8],1,1,70,102,0.1,-0.1);
    create(o[9],1,1,80,102,0.1,-0.1);
    create(o[10],1,1,120,102,0.1,-0.1);
    create(o[11],1,1,130,103,0.1,-0.1);
    create(o[12],1,1,141,103,0.1,-0.1);
    create(o[13],1000,10,320,240,0,0);
    repeat
          mem(o,13);
          for a:=1 to 12 do
              for b:=a+1 to 13 do
                  if o[a].exist and o[b].exist then
                  protz0(o[a],o[b]);
          if keypressed then
              case readkey of
                  '4':move(o,1,12,0,0,-0.01,0);
                  '6':move(o,1,12,0,0,0.01,0);
                  '8':move(o,1,12,0,0,0,-0.01);
                  '2':move(o,1,12,0,0,0,0.01);
                  'q','Q':halt(1);
                  '3':move(o,1,13,0,10,0,0);
                  '.':move(o,1,13,0,-10,0,0);
                  '7':move(o,1,13,10,0,0,0);
                  '9':move(o,1,13,-10,0,0,0);
              end;
          for a:=1 to 13 do
              if o[a].exist then
              des(o[a]);
          delay(200);
    until lava<20;
    readkey;
    closegraph;
end.


Mesaj util ?   Da   0 puncte
#6 by Poker Donor (ydirtgouisdhgvj) (1 mesaje) at 2006-10-20 23:45:08 (916 săptămâni în urmă) - [Link]Top
i hate it...


Mesaj util ?   Da   0 puncte
#7 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-20 23:47:01 (916 săptămâni în urmă) - [Link]Top
Poker, de acord, e un limbaj greoi, neflexibil... Dar de la el am inceput :)


Mesaj util ?   Da   0 puncte
#8 by CLONE (User) (0 mesaje) at 2006-10-21 13:14:47 (916 săptămâni în urmă) - [Link]Top
Он по идее и сейчас в школах преподается(сам учу) :&#039;-(


Mesaj util ?   Da   0 puncte
#9 by viktorash ([DT]Member) (0 mesaje) at 2006-10-21 17:22:50 (916 săptămâni în urmă) - [Link]Top
ujasnah! Blin îmi mănîncă zilele Pascalu ista, şi încă am teză la Informatică :suicide:


Mesaj util ?   Da   0 puncte
#10 by kuett Fotbalist (VIP) (0 mesaje) at 2006-10-21 17:35:59 (916 săptămâni în urmă) - [Link]Top
#5 Capilleary, :w00t: :w00t: :w00t:


Mesaj util ?   Da   0 puncte
#11 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-21 17:50:10 (916 săptămâni în urmă) - [Link]Top
#10 kuett, попробовал скомпиллить - просто чёрный экранчик :(


Mesaj util ?   Da   0 puncte
#12 by ZendeN (Uploader) (0 mesaje) at 2006-10-21 18:04:49 (916 săptămâni în urmă) - [Link]Top
#11 jekader, у меня тоже...


Mesaj util ?   Da   0 puncte
#13 by DatarDisabled (Uploader) (0 mesaje) at 2006-10-21 18:18:12 (916 săptămâni în urmă) - [Link]Top
ВОт вам и пример ПО распространяемого с исходным кодом. Исходный код есть, а что лень изучить что он делает и как работает?


Mesaj util ?   Da   0 puncte
#14 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-21 18:21:01 (916 săptămâni în urmă) - [Link]Top
#13 Datar, я не собирался его изучать. Но, что я знаю, так это, что у меня - нелады с шестнадцатибитной подсистемой...

Сейчас кину исходники, которые у меня пашут :) 3D - движок 8-)


Mesaj util ?   Da   0 puncte
#15 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-21 18:31:14 (916 săptămâni în urmă) - [Link]Top
:lol:
karo4 nu mai tzin minte anume ce tre sa faca proga din #5, dar am schimbat delay-ul din 200 in 20000 (proga era facuta matink sa mearga pe IBM 286 :whistle: ) sh deam este ceva. Da iaka nu chiar ceea la ce ma ashteptam.

OOPS :blush:
asta nu eu am facut-o. Am vazut ca nu e stilul meu de a scrie matink. Deshi intzeleg fiecare secventza de cod pentru ce a fost scrisa, ce shi cum, dar eu pe atunci nu prea scriam atitea subprograme sh dupa asta sa le chem in programu principal. Mai ales procedura Move... Eu nu tzin minte sa fi facut asha ceva. Ciclu "for x:=dela to pina" :lol:. Karo4. Proga a fost scrisa nu de altcineva decit eviX, in clasa 10 matink. Proga e facuta ca sa ruleze normal la Pentium MMX 166 MHz.

Editat de către Capilleary la 2006-10-21 18:39:30




Mesaj util ?   Da   0 puncte
#16 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-21 18:39:14 (916 săptămâni în urmă) - [Link]Top
Мега-3D движок 8-) управление стрелочками. Модуля Graph - снова нет. Надеюсь, Библиотека Mode13h - из стандартных :whistle: 

program game3d;
uses
  mode13h;
const
  x1 : longint = 500;
  y1 : longint = -300;
  x2 : longint = 1000;
  y2 : longint = 300;
  d  : longint = 160;
var
  angle          : extended;
  i, j,
  deltax, deltay,
  ndx, ndy       : longint;
  bitmap         : array[0..15,0..15] of byte;
{}
procedure rotate(x,y:longint; alfa:extended; var nx,ny:longint);
begin
  nx:=Round(x*cos(alfa)-y*sin(alfa));
  ny:=Round(y*cos(alfa)+x*sin(alfa));
end;
{}
function min(a,b:longint):longint;
begin
  if a<b then
    min:=a
  else
    min:=b;
end;
{}
function max(a,b:longint):longint;
begin
  if a>b then
    max:=a
  else
    max:=b;
end;
{}
procedure render(dx, dy :longint; alfa:extended);
var
  xs, h, z, i, j, u, v,
  nx1, ny1, nx2, ny2    : longint;
  t, xi, yi             : extended;
begin
  clear;
  rotate(x1,y1,alfa,nx1,ny1);
  rotate(x2,y2,alfa,nx2,ny2);
  Inc(nx1, dx);
  Inc(nx2, dx);
  Inc(ny1, dy);
  Inc(ny2, dy);
  for i:=0 to 319 do
    begin
      xs:=i - 159;
      z:=xs*(nx2-nx1)-d*(ny2-ny1);
      if z<>0 then
        begin
          u:=ny1*(nx2-nx1)-nx1*(ny2-ny1);
          yi:=xs*u/z;
          xi:=d*u/z;
          if xi>0 then begin
          if nx1<>nx2 then
            t:=(xi-nx1)/(nx2-nx1)
          else
            t:=(yi-ny1)/(ny2-ny1);
          if (t>=0) and (t<=1) then
           begin
             u := Trunc(t*15.5);
             h := Round(200*d/xi);
             for j:=max(0,100-h) to min(199,100+h) do
               begin
                 v := Trunc(15.5*((j-100+h)/(2*h)));
                 buf1^[j,i]:=bitmap[u,v];
               end;
           end;
          end;
        end;
    end;
  update;
end;
{}
begin
  asm
    mov ax, 0305h
    xor bx, bx
    int 16h
  end;
  Init13h;
  for i:=0 to 15 do
    for j:=0 to 15 do
      bitmap[i,j]:=15;
  for i:=7 to 8 do
    for j:=1 to 14 do
      bitmap[i,j]:=10;
  bitmap[1,1]:=10;
  bitmap[1,2]:=10;
  bitmap[2,3]:=10;
  bitmap[3,3]:=10;
  bitmap[3,4]:=10;
  bitmap[2,4]:=10;
  bitmap[4,5]:=10;
  bitmap[5,5]:=10;
  bitmap[5,6]:=10;
  bitmap[4,6]:=10;
  bitmap[6,7]:=10;
  bitmap[1,15-1]:=10;
  bitmap[1,15-2]:=10;
  bitmap[2,15-3]:=10;
  bitmap[3,15-3]:=10;
  bitmap[3,15-4]:=10;
  bitmap[2,15-4]:=10;
  bitmap[4,15-5]:=10;
  bitmap[5,15-5]:=10;
  bitmap[5,15-6]:=10;
  bitmap[4,15-6]:=10;
  bitmap[6,15-7]:=10;
  bitmap[15-1,1]:=10;
  bitmap[15-1,2]:=10;
  bitmap[15-2,3]:=10;
  bitmap[15-3,3]:=10;
  bitmap[15-3,4]:=10;
  bitmap[15-2,4]:=10;
  bitmap[15-4,5]:=10;
  bitmap[15-5,5]:=10;
  bitmap[15-5,6]:=10;
  bitmap[15-4,6]:=10;
  bitmap[15-6,7]:=10;
  bitmap[15-1,15-1]:=10;
  bitmap[15-1,15-2]:=10;
  bitmap[15-2,15-3]:=10;
  bitmap[15-3,15-3]:=10;
  bitmap[15-3,15-4]:=10;
  bitmap[15-2,15-4]:=10;
  bitmap[15-4,15-5]:=10;
  bitmap[15-5,15-5]:=10;
  bitmap[15-5,15-6]:=10;
  bitmap[15-4,15-6]:=10;
  bitmap[15-6,15-7]:=10;
  angle:=0;
  deltax:=0;
  deltay:=0;
  repeat
    render(deltax, deltay, angle);
    case read_key_word of
      kUpArrow    : Dec(deltax,10);
      kDownArrow  : Inc(deltax,10);
      kX          : Dec(deltay,20);
      kZ          : Inc(deltay,20);
      kLeftArrow  : begin
                      angle:=angle+2*pi/36;
                      rotate(deltax,deltay,2*pi/36,ndx,ndy);
                      deltax:=ndx; deltay:=ndy;
                    end;
      kRightArrow : begin
                      angle:=angle-2*pi/36;
                      rotate(deltax,deltay,-2*pi/36,ndx,ndy);
                      deltax:=ndx; deltay:=ndy;
                    end;
      kEsc        : break;
    end;
  until false;
  Done13h;
end.



Mesaj util ?   Da   0 puncte
#17 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-21 18:41:22 (916 săptămâni în urmă) - [Link]Top
#16 jekader, daca imi mai dai sh fishieru pe nume mode13h.tpu sau codul-sursa ap vashe ar fi super :)


Mesaj util ?   Da   0 puncte
#18 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-21 18:43:07 (916 săptămâni în urmă) - [Link]Top
#17 Capilleary, ох йомайо :)  Вот Mein Lehrer наделал дел :)

unit mode13h;
interface
const

  g320x200x256 = $13;
  t80x25x16 = $3;

  kEsc = $011b;
  kSpace = $3920;
  kEnter = $1c0d;

  kUpArrow    = $4800;
  kLeftArrow  = $4b00;
  kRightArrow = $4d00;
  kDownArrow  = $5000;
  kHome      = $4700;
  kEnd        = $4f00;
  kPgUp      = $4900;
  kPgDn      = $5100;
  kInsert    = $5200;
  kDelete    = $5300;

  kZ          = $2c7a;
  kX          = $2d78;
type
  screen  = array [0..199,0..319] of byte ;
  pscreen = ^screen;
  ch_im  = array[0..7] of byte;
  font    = array [#0..#255] of ch_im;
  pfont  = ^font;

var
  scr : screen absolute $a000:0;
  buf1 : pscreen;
procedure set_mode(mode:byte);
function key_pressed:boolean;
function read_key_word:word;
function get_font:pfont;
procedure put_image(x,y:integer;col:byte;var c : ch_im);
procedure clear;
procedure update;
procedure Init13h;
procedure Done13h;
{НННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННН}

implementation
var
  buf2 : pscreen;

{НННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННННН}
procedure set_mode(mode:byte);assembler;
asm
  mov al, mode
  mov ah, 0
  int 10h
end;
{ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД}
function key_pressed:boolean;assembler;
asm
  mov ah,1
  int 16h
  mov al, 0
  jz  @@not_pressed
  dec al
@@not_pressed:
end;
{ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД}
function read_key_word:word;assembler;
asm
  mov ah,0
  int 16h
end;
{ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД}
function get_font:pfont;assembler;
asm
  mov ax, 1130h
  mov bh, 3
  int 10h
  mov ax, bp
  mov dx, es
end;
{ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД}
procedure put_image(x,y:integer;col:byte;var c : ch_im); assembler;
asm
  push es
  push ds
  les ax, buf1
  mov ax, 320
  imul y
  add ax, x
  mov di, ax
  lds si, c
  mov cx, 8
  mov ah, col
  mov bx, x
  cld
@@ext:
  lodsb
  mov dl, 80h
  push bx
  push di
@@int:
  cmp bx, 320
  jnc @@no_out
  test al, dl
  jz @@sk
  mov es:[di], ah
@@sk:
@@no_out:
  inc di
  inc bx
  ror dl, 1
  jnc @@int
  pop di
  pop bx
  add di, 320
  loop @@ext
  pop ds
  pop es
end;
{ДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДДД}
procedure update;assembler;
asm
  push ds
  push es
  mov di, word ptr buf2
  mov dx, word ptr buf2+2
  mov es, dx
  lds si, buf1
  mov cx, 64000
  cld
@@find_next:
  rep cmpsb
  je @@just_dec
@@real_copy:
  mov bx, 0a000h
  mov es, bx
  mov bx, di
  dec si
  mov di, si
  movsb
  mov di, bx
  mov es, dx
@@just_dec:
  or cx,cx
  jne @@find_next
@@done:
  pop es
  pop ds
  push ds
  push es
  les di, buf2
  lds si, buf1
  mov cx, 32000
rep movsw
  pop es
  pop ds
end;
{}
procedure clear; assembler;
asm
  les di, buf1
  xor ax, ax
  mov cx, 32000
  cld
  rep stosw
end;
{}
procedure Init13h;
var
  i, j : integer;
begin
  set_mode(g320x200x256);
  New(buf1);
  New(buf2);
  for i:=0 to 199 do for j:=0 to 319 do buf1^[i,j]:=0;
  buf2^:=buf1^;
end;
{}
procedure Done13h;
begin
  Dispose(buf2);
  Dispose(buf1);
  set_mode(t80x25x16);
end;
{}
begin
end.


Mesaj util ?   Da   0 puncte
#19 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-21 18:47:18 (916 săptămâni în urmă) - [Link]Top
:rofl:
nafeg vashe Pascal? Programeaza deam tot in Assembler :lol:

prikolinaia programa, numa k la mine fara directiva {$N+} nu a mers :(


Mesaj util ?   Da   0 puncte
#20 by mdcool (Power User) (0 mesaje) at 2006-10-21 20:08:49 (916 săptămâni în urmă) - [Link]Top
#16 jekader, выложи куданибудь mode13g.tpu


Mesaj util ?   Da   0 puncte
#21 by jekader Donor (Besatzungsarmee) (0 mesaje) at 2006-10-21 20:21:12 (916 săptămâni în urmă) - [Link]Top
#20 mdcool, да оставь впокое... вон, наверху исходники этой библиотеки... Поверь мне, результат не стоит усилий по выкладыванию библиотеки.. движок - отстой :)


Mesaj util ?   Da   0 puncte
#22 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-21 20:22:07 (916 săptămâni în urmă) - [Link]Top
mdcool, el a pus source-code-ul, acum doar copie-l sh compileaza, tre sa apara mode13g.tpu in mapa cu compilatzii.


Mesaj util ?   Da   0 puncte
#23 by mdcool (Power User) (0 mesaje) at 2006-10-21 20:44:52 (916 săptămâni în urmă) - [Link]Top
#21 jekader, нащет движка - сагласен но это блин прекрасная и весьма простая основа для обучению образного и модульного мышления. если ПОЛНОСТЬЮ освоинь это гавно, то потом до с++ рукой подать

Editat de către mdcool la 2006-10-21 20:50:18




Mesaj util ?   Da   0 puncte
#24 by mdcool (Power User) (0 mesaje) at 2006-10-21 20:45:35 (916 săptămâni în urmă) - [Link]Top
#21 jekader, #22 Capilleary, да у меня pascal 7.1, он скотина глюченный какойто,сорс-код который вы дали не выполняется видите ли cannot run a unit. а 7,0 на моем проце выдает i/o error при любой версии ХРеновины. лучше сразу файл

и по поводу программ выше - первую выполняет без вопросов, а вторую и третью - ошибка, че-то связанное с InitGraph


Mesaj util ?   Da   0 puncte
#25 by Capilleary Donor (Патлатый) (0 mesaje) at 2006-10-21 20:49:00 (916 săptămâni în urmă) - [Link]Top
MODE13H.TPU


Mesaj util ?   Da   0 puncte

1 2 3 4 5
<< Precedenta      Următoarea >>

Forum Index > Coș cu teme șterse > Soft > Всё что касается Turbo Pascal 7.0.

You are not permitted to post in this forum.


Navigare rapidă:


Comunitatea digitală din Moldova. Să adunăm și să organizăm conținutul autohton de pe întreg internet pe un singur site web.