smgrafd.pas

Yahoo Messenger for Mobile

unit smgrafd;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls,StdCtrls;

const
  pixmax=32768;


type
  pRGBArray=^TRGBArray;
  TRGBArray= ARRAY[0..pixmax-1] OF TRGBTriple;
  knoprec=record
    kx,ky,kw,kh:integer;
    knoprect:trect;
    tekst:string;
    active,pressed:boolean;
    pic:array[1..4] of tbitmap;
  end;
  palettetype=array[0..255,1..3] of byte;

function lightshade(x,y,gr,d:integer;wcanvas:Tcanvas):Tcolor;
function darkshade(x,y,gr,d:integer;wcanvas:Tcanvas):Tcolor;
procedure buitenrand(x1,y1,x2,y2,size:integer;wcanvas:tcanvas);
procedure binnenrand(x1,y1,x2,y2,size:integer;wcanvas:tcanvas);
procedure _buitenrand(x1,y1,x2,y2,size:integer;wbitmap:tbitmap);
procedure _binnenrand(x1,y1,x2,y2,size:integer;wbitmap:tbitmap);
procedure tegel(w1,h1,w2,h2:integer;canvas1,canvas2:tcanvas);
procedure makepal(mpal:palettetype;wbitmap:tbitmap);
function optimizecopy(source_bitmap,target_bitmap:tbitmap;precision:byte):boolean;
function knopover(x,y:integer;wknop:knoprec):boolean;
function mstr(getal,deler,eenheden,decimalen:longint;vuller:char):string;
function radius(x,y:real):real;
function sgn(i:longint):integer;
function fillstr(getal,lengte:integer;vuller:char):string;
procedure textspace(x,y:integer;n:string;space:integer;wcanvas:tcanvas);
procedure textfill(x,y:integer;n:string;fillwidth:integer;wcanvas:tcanvas);

var
  xpath:string;
  fontsize:integer;

implementation

function lightshade(x,y,gr,d:integer;wcanvas:Tcanvas):Tcolor;

var
  col:tcolor;
  r,g,b:byte;

begin
  col:=wcanvas.pixels[x,y];
  r:=getrvalue(col);
  r:=r+((255-r)*(d-gr)) div (d*2);
  g:=getgvalue(col);
  g:=g+((255-g)*(d-gr)) div (d*2);
  b:=getbvalue(col);
  b:=b+((255-b)*(d-gr)) div (d*2);
  lightshade:=rgb(r,g,b);
end;

function darkshade(x,y,gr,d:integer;wcanvas:Tcanvas):Tcolor;

var
  col:tcolor;
  r,g,b:integer;

begin
  col:=wcanvas.pixels[x,y];
  r:=(getrvalue(col)*(gr+d)) div (d*2);
  g:=(getgvalue(col)*(gr+d)) div (d*2);
  b:=(getbvalue(col)*(gr+d)) div (d*2);
  darkshade:=rgb(r,g,b);
end;

procedure buitenrand(x1,y1,x2,y2,size:integer;wcanvas:tcanvas);

var
  i,j,z:integer;

begin
  with wcanvas do
  for z:=0 to size do
  begin
    for i:=x1+z to x2-1-z do
      pixels[i,y1+z]:=lightshade(i,y1+z,z,size,wcanvas);
    for j:=y1+z+1 to y2-1-z do
      pixels[x1+z,j]:=lightshade(x1+z,j,z,size,wcanvas);
    for i:=x1+z+1 to x2-z do
      pixels[i,y2-z]:=darkshade(i,y2-z,z,size,wcanvas);
    for j:=y1+z+1 to y2-1-z do
      pixels[x2-z,j]:=darkshade(x2-z,j,z,size,wcanvas);
  end;
end;

procedure binnenrand(x1,y1,x2,y2,size:integer;wcanvas:tcanvas);

var
  i,j,z:integer;

begin
  with wcanvas do
  for z:=0 to size do
  begin
    for i:=x1-z to x2+z do
      pixels[i,y1-z]:=darkshade(i,y1-z,z,size,wcanvas);
    for j:=y1-z+1 to y2-1+z do
      pixels[x1-z,j]:=darkshade(x1-z,j,z,size,wcanvas);
    for i:=x1-z+1 to x2+z do
      pixels[i,y2+z]:=lightshade(i,y2+z,z,size,wcanvas);
    for j:=y1-z+1 to y2-1+z do
      pixels[x2+z,j]:=lightshade(x2+z,j,z,size,wcanvas);
  end;
end;

function lighter(b:byte;gr,d:integer):byte;

begin
  lighter:=b+((255-b)*(d-gr)) div (d*2);
end;

function darker(b:byte;gr,d:integer):byte;

begin
  darker:=b*(gr+d) div (d*2);
end;

procedure _buitenrand(x1,y1,x2,y2,size:integer;wbitmap:tbitmap);

var
  i,j,z:integer;
  l:prgbarray;

begin
  for z:=0 to size do
  begin
    if (y1+z>-1) and (y1+z<wbitmap.height) then
    for i:=x1+z to x2-1-z do if (i>-1) and (i<wbitmap.width) then
    begin
      l:=prgbarray(wbitmap.scanline[y1+z]);
      l[i].rgbTred:=lighter(l[i].rgbTred,z,size);
      l[i].rgbTgreen:=lighter(l[i].rgbTgreen,z,size);
      l[i].rgbTblue:=lighter(l[i].rgbTblue,z,size);
    end;
    if (x1+z>-1) and (x1+z<wbitmap.width) then
    for j:=y1+z+1 to y2-1-z do if (j>-1) and (j<wbitmap.height) then
    begin
      l:=prgbarray(wbitmap.scanline[j]);
      l[x1+z].rgbTred:=lighter(l[x1+z].rgbTred,z,size);
      l[x1+z].rgbTgreen:=lighter(l[x1+z].rgbTgreen,z,size);
      l[x1+z].rgbTblue:=lighter(l[x1+z].rgbTblue,z,size);
    end;
    if (y2-z>-1) and (y2-z<wbitmap.height) then
    for i:=x1+z+1 to x2-z do if (i>-1) and (i<wbitmap.width) then
    begin
      l:=prgbarray(wbitmap.scanline[y2-z]);
      l[i].rgbTred:=darker(l[i].rgbTred,z,size);
      l[i].rgbTgreen:=darker(l[i].rgbTgreen,z,size);
      l[i].rgbTblue:=darker(l[i].rgbTblue,z,size);
    end;
    if (x2-z>-1) and (x2-z<wbitmap.width) then
    for j:=y1+z+1 to y2-1-z do if (j>-1) and (j<wbitmap.height) then
    begin
      l:=prgbarray(wbitmap.scanline[j]);
      l[x2-z].rgbTred:=darker(l[x2-z].rgbTred,z,size);
      l[x2-z].rgbTgreen:=darker(l[x2-z].rgbTgreen,z,size);
      l[x2-z].rgbTblue:=darker(l[x2-z].rgbTblue,z,size);
    end;
  end;
end;

procedure _binnenrand(x1,y1,x2,y2,size:integer;wbitmap:tbitmap);

var
  i,j,z:integer;
  b:byte;
  l:prgbarray;

begin
  for z:=0 to size do
  begin
    if (y1-z>-1) and (y1-z<wbitmap.height) then
    for i:=x1-z to x2+z do if (i>-1) and (i<wbitmap.width) then
    begin
      l:=prgbarray(wbitmap.scanline[y1-z]);
      b:=l[i].rgbTred;
      l[i].rgbTred:=darker(b,z,size);
      b:=l[i].rgbTgreen;
      l[i].rgbTgreen:=darker(b,z,size);
      b:=l[i].rgbTblue;
      l[i].rgbTblue:=darker(b,z,size);
    end;
    if (x1-z>-1) and (x1-z<wbitmap.width) then
    for j:=y1-z+1 to y2-1+z do if (j>-1) and (j<wbitmap.height) then
    begin
      l:=prgbarray(wbitmap.scanline[j]);
      l[x1-z].rgbTred:=darker(l[x1-z].rgbTred,z,size);
      l[x1-z].rgbTgreen:=darker(l[x1-z].rgbTgreen,z,size);
      l[x1-z].rgbTblue:=darker(l[x1-z].rgbTblue,z,size);
    end;
    if (y2+z>-1) and (y2+z<wbitmap.height) then
    for i:=x1-z+1 to x2+z do if (i>-1) and (i<wbitmap.width) then
    begin
      l:=prgbarray(wbitmap.scanline[y2+z]);
      l[i].rgbTred:=lighter(l[i].rgbTred,z,size);
      l[i].rgbTgreen:=lighter(l[i].rgbTgreen,z,size);
      l[i].rgbTblue:=lighter(l[i].rgbTblue,z,size);
    end;
    if (x2+z>-1) and (x2+z<wbitmap.width) then
    for j:=y1-z+1 to y2-1+z do if (j>-1) and (j<wbitmap.height) then
    begin
      l:=prgbarray(wbitmap.scanline[j]);
      l[x2+z].rgbTred:=lighter(l[x2+z].rgbTred,z,size);
      l[x2+z].rgbTgreen:=lighter(l[x2+z].rgbTgreen,z,size);
      l[x2+z].rgbTblue:=lighter(l[x2+z].rgbTblue,z,size);
    end;
  end;
end;

procedure tegel;

var
  x,y,xmax,ymax:integer;

begin
  xmax:=w1 div w2;
  ymax:=h1 div h2;
  canvas1.copymode:=cmSrcCopy;
  for y:=0 to ymax do for x:=0 to xmax do
  canvas1.copyrect(rect(x*w2,y*h2,x*w2+w2,y*h2+h2),canvas2,rect(0,0,w2,h2));
end;

procedure makepal(mpal:palettetype;wbitmap:tbitmap);

var
  i:integer;
  pal: PLogPalette;
  hpal: HPALETTE;

begin
  pal := nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion := $300;
    pal.palNumEntries := 256;
    for i := 0 to 255 do
    begin
      pal.palPalEntry[i].peRed :=mpal[i,1];
      pal.palPalEntry[i].peGreen :=mpal[i,2];
      pal.palPalEntry[i].peBlue :=mpal[i,3];
    end;
    hpal := CreatePalette(pal^);
    if hpal <> 0 then
      wbitmap.Palette := hpal;
  finally
    FreeMem(pal);
  end;
end;

function optimizecopy;

var
  i,j,x,y,z:integer;
  dat:array[0..63,0..63,0..63] of word;
  col:tcolor;
  r,g,b:byte;
  pal: PLogPalette;
  hpal: HPALETTE;
  tmp:tbitmap;
  l:pRGBarray;
  v,w:byte;


begin
  v:=precision;
  if v=0 then v:=1;
  w:=v;
  if w<4 then w:=4;
  for x:=0 to 63 do for y:=0 to 63 do for z:=0 to 63 do dat[x,y,z]:=0;
  tmp:=tbitmap.create;
  tmp.pixelformat:=pf24bit;
  tmp.width:=target_bitmap.width;
  tmp.height:=target_bitmap.height;
  tmp.canvas.stretchdraw(rect(0,0,tmp.width,tmp.height),source_bitmap);
  with tmp.canvas do
  begin
    for j:=0 to (tmp.height-1) div v do
    begin
      l:=prgbarray(tmp.scanline[j*v]);
      for i:=0 to (tmp.width-1) div v do
      begin
        r:=l[i*v].rgbTred div w;
        g:=l[i*v].rgbTgreen div w;
        b:=l[i*v].rgbTblue div w;
        if dat[r,g,b]<60000 then inc(dat[r,g,b]);
      end;
    end;
  end;

  pal := nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion := $300;
    pal.palNumEntries := 256;

    for i:=0 to 255 do
    begin
      r:=0;
      g:=0;
      b:=0;
      for x:=0 to 63 do for y:=0 to 63 do for z:=0 to 63 do
      if dat[x,y,z]>dat[r,g,b] then
      begin
        r:=x;
        g:=y;
        b:=z;
      end;

      pal.palPalEntry[i].peRed:=r*w;
      pal.palPalEntry[i].peGreen:=g*w;
      pal.palPalEntry[i].peBlue:=b*w;

      dat[r,g,b]:=0;
      for x:=r-1 to r+1 do if x in [0..63] then
      for y:=g-1 to g+1 do if y in [0..63] then
      for z:=b-1 to b+1 do if z in [0..63] then
        dat[x,y,z]:=dat[x,y,z] div 2;
      for x:=r-3 to r+3 do if x in [0..63] then
      for y:=g-3 to g+3 do if y in [0..63] then
      for z:=b-3 to b+3 do if z in [0..63] then
        dat[x,y,z]:=dat[x,y,z] div 2;
    end;

    hpal := CreatePalette(pal^);
    if hpal <> 0 then
      target_bitmap.Palette := hpal;
  finally
    FreeMem(pal);
  end;
  target_bitmap.canvas.draw(0,0,tmp);

  tmp.free;
  optimizecopy:=true;
end;

function knopover;

begin
  with wknop do
  if (x>=kx) and (x<=kx+kw-1) and (y>=ky) and (y<=ky+kh-1) then
  knopover:=true else knopover:=false;
end;

function mstr(getal,deler,eenheden,decimalen:longint;vuller:char):string;

var
  m:string;
  i:integer;

begin
  str(getal/deler:eenheden:decimalen,m);
  repeat
    if length(m)<eenheden+decimalen+1 then m:=vuller+m;
  until length(m)>=eenheden+decimalen+1;
  for i:=1 to length(m) do if m[i]=' ' then m[i]:=vuller;
  mstr:=m;
end;

function radius(x,y:real):real;

var
  tmp:real;

begin
  tmp:=sqrt(x*x+y*y);
  radius:=tmp;
end;

function sgn(i:longint):integer;

begin
  if i<0 then sgn:=-1 else sgn:=1;
end;

function fillstr(getal,lengte:integer;vuller:char):string;

var
  s:string;

begin
  s:=inttostr(getal);
  while length(s)<lengte do s:=vuller+s;
  fillstr:=s;
end;

procedure textspace(x,y:integer;n:string;space:integer;wcanvas:tcanvas);

var
  i:integer;

begin
  with wcanvas do for i:=1 to length(n) do
  begin
    textout(x,y,n[i]);
    x:=x+textwidth(n[i])+space;
  end;
end;

procedure textfill(x,y:integer;n:string;fillwidth:integer;wcanvas:tcanvas);

var
  i:integer;
  xx,space:real;

begin
  xx:=x;
  if length(n)>1 then
  space:=(fillwidth-wcanvas.textwidth(n))/(length(n)-1)
  else space:=0;
  with wcanvas do
  for i:=1 to length(n) do
  begin
    x:=round(xx);
    textout(x,y,n[i]);
    xx:=xx+textwidth(n[i])+space;
  end;
end;

begin
  xPath := ExtractFilePath(Application.ExeName);
  fontsize:=screen.pixelsperinch;
end.