{Procedura di risacaltura Buffer reali di Leonardo Maffi}


function Riscala(b:buffer; tipo:integer; mx,my:indiceBuffer):buffer;
  { Tipo di interpolazione  1)A blocchi 2)Bilineare 3)Bicubica }

  function Ingrandisci(b:buffer; tipo:integer; newx,newy:long):buffer;
    var mulx,muly: real;

    function Lineare(x:real; y:long):real;
      var
        mx,my,x0: IndiceBuffer;
        y0: real;

      Function Leggi(x,y:indiceBuffer):real;
        var pr: ^real;
        begin
          if x<0 then
                   x:= 0
                 else
                   if x>mx then x:= mx;
          if y<=0 then
                    pr:= Ptr(vb[b].pb+ x*4)
                  else if y>=my then
                                  pr:= Ptr(vb[b].pb+ (my*vb[b].nx+x)*4)
                                else
                                  pr:= Ptr(vb[b].pb+ (y*vb[b].nx+x)*4);
          Leggi:= pr^;
        end;

      begin
        mx:= vb[b].nx-1;
        my:= vb[b].ny-1;
        x:= x-0.5+(0.5/mulx);
        x0:= floor(x);
        x:= x-x0;
        y0:= leggi(x0, y);
        Lineare:= y0 + x*(leggi(succ(x0), y)-y0);
      end;


    function Bilineare(x,y:real):real;
      var
        mx,my,tx,ty: IndiceBuffer;

      Function Leggi(x,y:indiceBuffer):real;
        var pr: ^real;
        begin
          if x<0 then
                   x:= 0
                 else
                   if x>mx then x:= mx;
          if y<=0 then
                    pr:= Ptr(vb[b].pb+ x*4)
                  else if y>=my then
                                  pr:= Ptr(vb[b].pb+ (my*vb[b].nx+x)*4)
                                else
                                  pr:= Ptr(vb[b].pb+ (y*vb[b].nx+x)*4);
          Leggi:= pr^;
        end;

      begin
        mx:= vb[b].nx-1;
        my:= vb[b].ny-1;
        x:= x-0.5+(0.5/mulx);
        y:= y-0.5+(0.5/muly);
        tx:= floor(x);
        ty:= floor(y);
        x:= x-tx;
        y:= y-ty;
        Bilineare:= (1-y)*((1-x)*leggi(tx, ty) + x*leggi(succ(tx), ty)) +
                    y*((1-x)*leggi(tx, succ(ty)) + x*leggi(succ(tx), succ(ty)));
      end;

    function Cubica(x:real; y:long):real;
      var
        y0,y1,y2: real;
        x0,mx,my: IndiceBuffer;

      Function Leggi(x,y:indiceBuffer):real;
        var pr: ^real;
        begin
          if x<0 then
                   x:= 0
                 else
                   if x>mx then x:= mx;
          if y<=0 then
                    pr:= Ptr(vb[b].pb+ x*4)
                  else if y>=my then
                                  pr:= Ptr(vb[b].pb+ (my*vb[b].nx+x)*4)
                                else
                                  pr:= Ptr(vb[b].pb+ (y*vb[b].nx+x)*4);
          Leggi:= pr^;
        end;

      begin
        mx:= vb[b].nx-1;
        my:= vb[b].ny-1;
        x:= x-0.5+(0.5/mulx);
        x0:= floor(x)-1;
        x:= x-x0;
        y0:= leggi(x0, y);
        y1:= leggi(succ(x0), y);
        y2:= leggi(x0+2, y);
        Cubica:= y0 + x*(y1-y0) + x*(x-1)*(y0-2*y1+y2)/2 +
                 x*(x-1)*(x-2)*(-y0+3*y1-3*y2+leggi(x0+3, y))/6;
      end;

    function Bicubica(x,y:real):real;
      var
        mx,my,tx,ty: IndiceBuffer;
        z: array[0..3,0..3] of real;
        c: array[0..3] of real;
        i,j: integer;

      Function Leggi(x,y:indiceBuffer):real;
        var pr: ^real;
        begin
          if x<0 then
                   x:= 0
                 else
                   if x>mx then x:= mx;
          if y<=0 then
                    pr:= Ptr(vb[b].pb+ x*4)
                  else if y>=my then
                                  pr:= Ptr(vb[b].pb+ (my*vb[b].nx+x)*4)
                                else
                                  pr:= Ptr(vb[b].pb+ (y*vb[b].nx+x)*4);
          Leggi:= pr^;
        end;

      begin
        mx:= vb[b].nx-1;
        my:= vb[b].ny-1;
        x:= x-0.5+(0.5/mulx);
        y:= y-0.5+(0.5/muly);
        tx:= floor(x)-1;
        ty:= floor(y)-1;
        x:= x-tx;
        y:= y-ty;
        for i:= 0 to 3 do
          for j:= 0 to 3 do
            z[i,j]:= leggib(b, tx+i, ty+j);
        for i:= 0 to 3 do
          c[i]:= z[0,i] + x*(z[1,i]-z[0,i]) + x*(x-1)*(z[0,i]-2*z[1,i]+z[2,i])/2 +
                 x*(x-1)*(x-2)*(-z[0,i]+3*z[1,i]-3*z[2,i]+z[3,i])/6;
        Bicubica:= c[0] + y*(c[1]-c[0]) + y*(y-1)*(c[0]-2*c[1]+c[2])/2 +
                 y*(y-1)*(y-2)*(-c[0]+3*c[1]-3*c[2]+c[3])/6;
      end;

    var
      auxyi,nxb,nxb2,x,y,mx,my,pos1,AuxY: long;
      v1,v2: ^array[0..2000000] of real;
      auxyr,DivX,DivY,SumX,SumY: real;
      b2: buffer;
    begin
      Ingrandisci:= 0;
      if controlla(b) and (tipo>=1) and (tipo<=3) and (newx>0) and (newy>0) then
        if (vb[b].nx*vb[b].ny>1) and (((vb[b].nx<=newx) and (vb[b].ny<=newy)) or (tipo=1)) then begin
          mulx:= newx/vb[b].nx;
          muly:= newy/vb[b].ny;
          mx:= newx; my:= newy;
          if (mx=Vb[b].nx) and (my=Vb[b].ny)
            then Ingrandisci:= DuplicaBuffer(b)
            else begin
              b2:= creaBuffer(vb[b].nome+" Riscalato",mx,my);
              if controlla(b2) then begin
                Ingrandisci:= b2;
                v1:= ptr(vb[b].pb);
                v2:= ptr(vb[b2].pb);
                nxb:= vb[b].nx;
                nxb2:= vb[b2].nx;
                case tipo of
                  1: begin {N.B: Si puo' fare con l'algoritmo per righe }
                       pos1:= 0;
                       DivX:= vb[b].nx/NewX;
                       DivY:= vb[b].ny/NewY;
                       SumY:= 0;
                       For y:= 0 to my-1 do begin
                         auxy:= nxb * trunc(SumY);
                         SumX:= 0;
                         for x:= 0 to mx-1 do begin
                           v2^[pos1]:= v1^[trunc(SumX)+auxy];
                           SumX:= SumX + DivX;
                           pos1:= succ(pos1);
                         end;
                         SumY:= SumY + DivY;
                       end;
                     end;
                  2: begin
                       auxyi:= 0;
                       if muly=1
                         then
                           for y:= 0 to my-1 do begin
                             for x:= 0 to mx-1 do
                               v2^[x+auxyi]:= Lineare(x/mulx,y)
                             auxyi:= auxyi + nxb2;
                           end
                       else
                         for y:= 0 to my-1 do begin
                           auxyr:= y/muly;
                           for x:= 0 to mx-1 do
                             v2^[x+auxyi]:= Bilineare(x/mulx,auxyr);
                           auxyi:= auxyi + nxb2;
                         end;
                     end;
                  3: if muly=1
                       then
                         for x:= 0 to mx-1 do
                           for y:= 0 to my-1 do
                             v2^[x+y*nxb2]:= Cubica(x/mulx,y)
                       else begin
                         for x:= 0 to mx-1 do begin
                           v2^[x]:= Bilineare(x/mulx,0);
                           v2^[x+pred(my)*nxb2]:= Bilineare(x/mulx,pred(my)/muly);
                         end;
                         for y:= 0 to my-1 do begin
                           v2^[y*nxb2]:= Bilineare(0,y/muly);
                           v2^[pred(mx)+y*nxb2]:= Bilineare(pred(mx)/mulx,y/muly);
                         end;
                         for x:= 1 to mx-2 do
                           for y:= 1 to my-2 do
                             v2^[x+y*nxb2]:= Bicubica(x/mulx,y/muly);
                       end;
                  otherwise;
                end;
              end;
            end;
        end;
    end;



  function Riduci(b:buffer; newx,newy:long):buffer;
    var
      mulx,muly: real;
      mx,my,nxb,nxb2: indicebuffer;
      b2,b3: buffer;
      v1,v2,v3: ^array[0..2000000] of real;
      ok: boolean;

    procedure RiduzioneX;
      var a1,a2,ip,x,i,j,d,d1,d2,incE,incNE: long;
      begin
        a1:= 0;
        a2:= 0;
        for j:= 0 to vb[b].ny-1 do begin
          d1:= vb[b].nx-1;
          d2:= mx-1;
          d:= d2+d2-d1;
          incE:= d2+d2;
          incNE:= (d2-d1)+(d2-d1);
          x:= 0;
          i:= 0;
          ip:= 0;
          v2^[a1]:= v2^[a1]+v1^[a2];
          for i:= 1 to d1 do begin
            if d<=0 then d:= d + incE
                    else begin
                           d:= d + incNE;
                           v2^[x+a1]:= v2^[x+a1]/(i-ip);
                           ip:= i;
                           x:= succ(x);
                         end;
            v2^[x+a1]:= v2^[x+a1]+v1^[i+a2];
          end;
          v2^[x+a1]:= v2^[x+a1]/(i-ip);
          a1:= a1 + nxb2;
          a2:= a2 + nxb;
        end;
      end; {RiduzioneX}


    procedure Riduzione;
      var a2,a1,ip,k,x,y,i,j,d,d1,d2,incE,incNE,yd,yd1,yd2,yincE,yincNE: long;
      begin
        yd1:= vb[b].ny-1;
        yd2:= my-1;
        yd:= yd2+yd2-yd1;
        yincE:= yd2+yd2;
        yincNE:= (yd2-yd1)+(yd2-yd1);
        y:= 0;
        j:= 0;
        for k:= 0 to mx-1 do
          v3^[k]:= 0;
        d1:= vb[b].nx-1;
        d2:= mx-1;
        d:= d2+d2-d1;
        incE:= d2+d2;
        incNE:= (d2-d1)+(d2-d1);
        x:= 0;
        i:= 0;
        v3^[x]:= 1;
        v2^[0]:= v1^[0];
        for i:= 1 to d1 do begin
          if d<=0 then d:= d + incE
                  else begin
                         d:= d + incNE;
                         x:= succ(x);
                       end;
          v3^[x]:= v3^[x]+1;
          v2^[x]:= v2^[x]+v1^[i];
        end;
        a1:= 0;
        a2:= 0;
        for j:= 1 to yd1 do begin
          a2:= a2 + nxb;
          if yd<=0 then yd:= yd + yincE
                   else begin
                          yd:= yd + yincNE;
                          for k:= 0 to mx-1 do begin
                            v2^[k+a1]:= v2^[k+a1]/v3^[k];
                            v3^[k]:= 0;
                          end;
                          y:= succ(y);
                          a1:= a1 + nxb2;
                        end;
          d:= d2+d2-d1;
          x:= 0;
          i:= 0;
          v3^[x]:= v3^[x]+1;
          v2^[x+a1]:= v2^[x+a1]+v1^[i+a2];
          ip:= 1;
          for i:= 1 to d1 do begin
            if d<=0 then d:= d + incE
                    else begin
                           d:= d + incNE;
                           v3^[x]:= v3^[x]+i-ip;
                           ip:= i;
                           x:= succ(x);
                         end;
            v2^[x+a1]:= v2^[x+a1]+v1^[i+a2];
          end;
          v3^[x]:= v3^[x]+i-ip;
        end;
        a1:= (my-1)*nxb2;
        for k:= 0 to mx-1 do
          v2^[k+a1]:= v2^[k+a1]/v3^[k];
      end; {Riduzione}


    begin {riduci}
      Riduci:= 0;
      if controlla(b) and (newx>0) and (newy>0) then
        if (vb[b].nx*vb[b].ny>1) and (vb[b].nx>=newx) and (vb[b].ny>=newy) then begin
          mulx:= newx/vb[b].nx;
          muly:= newy/vb[b].ny;
          mx:= newx; my:= newy;
          if (mx=Vb[b].nx) and (my=Vb[b].ny)
            then Riduci:= DuplicaBuffer(b)
            else begin
              b2:= creaBuffer(vb[b].nome+" Riscalato",mx,my);
              ok:= assegnar(b2,0);
              if my=vb[b].ny
                then begin
                       if ok and controlla(b2) then begin
                         Riduci:= b2;
                         v1:= ptr(vb[b].pb);
                         v2:= ptr(vb[b2].pb);
                         nxb:= vb[b].nx;
                         nxb2:= vb[b2].nx;
                         riduzioneX;
                       end
                       else ok:= rimuovibuffer(b2);
                     end
                else begin
                       b3:= creaBuffer("Temp",mx,1);
                       if ok and controlla(b2) and controlla(b3) then begin
                         Riduci:= b2;
                         v1:= ptr(vb[b].pb);
                         v2:= ptr(vb[b2].pb);
                         v3:= ptr(vb[b3].pb);
                         nxb:= vb[b].nx;
                         nxb2:= vb[b2].nx;
                         riduzione;
                       end
                       else ok:= rimuovibuffer(b2);
                       ok:= rimuovibuffer(b3);
                     end;
            end;
        end;
    end;

  function Sgn(x,y:long):integer;
    begin
      if x=y then sgn:= 0
             else if x<y then sgn:= -1
                         else sgn:= 1;
    end;

  var
    b2,b3: buffer;
    ok: boolean;
  begin
    Riscala:= 0;
    if controlla(b) and (tipo>0) and (tipo<4) then begin
      if tipo=1 then b3:= Ingrandisci(b,tipo,mx,my)
        else
          case sgn(mx,vb[b].nx) of
            -1: case sgn(my,vb[b].ny) of
                 -1: b3:= Riduci(b,mx,my);
                  0: b3:= Riduci(b,mx,my);
                  1: begin
                       b2:= Riduci(b,mx,vb[b].ny)
                       b3:= Ingrandisci(b2,tipo,mx,my);
                       ok:= rimuovibuffer(b2);
                     end;
                end;
             0: case sgn(my,vb[b].ny) of
                 -1: b3:= Riduci(b,mx,my);
                  0: b3:= DuplicaBuffer(b);
                  1: b3:= Ingrandisci(b,tipo,mx,my);
                end;
             1: case sgn(my,vb[b].ny) of
                 -1: begin
                       b2:= Riduci(b,vb[b].nx,my)
                       b3:= Ingrandisci(b2,tipo,mx,my);
                       ok:= rimuovibuffer(b2);
                     end;
                  0: b3:= Ingrandisci(b,tipo,mx,my);
                  1: b3:= Ingrandisci(b,tipo,mx,my);
                end;
          end;
      if controlla(b3) then begin
        vb[b3].nome:= vb[b].nome+" Riscalato";
        Riscala:= b3;
      end;
    end;
  end;

procedure ChiamaRiscala;
  var
    b,b2: buffer;
    tipo: integer;
    nx,ny: indicebuffer;
  begin
    writeln("Riscalatura dimensioni buffer.");
    writeln("Attenzione: questa procedura e' molto imprecisa.");
    b:= ScegliBuffer("Buffer da riscalare",true);
    write("Nuovo numero punti asse x: "); readln(nx);
    write("Nuovo numero punti asse y: "); readln(ny);
    write("Che Tipo di interpolazione  1)A blocchi 2)Bilineare 3)Bicubica ? ");
    readln(Tipo);
    b2:= Riscala(b,tipo,nx,ny);
    if controlla(b2)
      then writeln("Riscalatura buffer ",b," riversata nel buffer ",b2,".")
      else writeln("Nessuna riscalatura effettuata.");
  end;