unit Unit1;
{
  softline drawing project
}
interface

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

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    clearBtn: TButton;
    linesBtn: TButton;
    PaintBox2: TPaintBox;
    colorBtn: TButton;
    ellipseBtnButton1: TButton;
    HscrollBar: TScrollBar;
    vscrollbar: TScrollBar;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure clearBtnClick(Sender: TObject);
    procedure linesBtnClick(Sender: TObject);
    procedure colorBtnClick(Sender: TObject);
    procedure ellipseBtnButton1Click(Sender: TObject);
    procedure PaintBox2Paint(Sender: TObject);
    procedure HscrollBarChange(Sender: TObject);
    procedure Image1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type PDW = ^dword;
     TPendirection = (pdHorizontal,pdVertical);

const hpen : array[0..3] of word = ($8888,$4444,$2222,$1111);
      vpen : array[0..3] of word = ($f000,$0f00,$00f0,$000f);
      hmask: array[0..3] of word = ($ffff,$7777,$3333,$1111);
      vmask: array[0..3] of word = ($ffff,$0fff,$00ff,$000f);
      fblend : array[0..16] of single =
               (0.0, 0.0625, 0.125, 0.1875, 0.25, 0.3125, 0.375, 0.4375,
                0.5, 0.5625, 0.625, 0.6875, 0.75, 0.8125, 0.875, 0.9375, 1.0);
      blenderwidth = 601;
      blenderheight = 601;

var bm : Tbitmap;
    line0 : dword;
    LineStep : dword;
    blender : array[0..blenderwidth-1,0..blenderheight-1] of word;
    blendRect : Trect;
    pencolor : dword;
    pendirection : TPendirection;

procedure sort(var a,b : smallInt);
//sort small to large
var h : smallInt;
begin
 if a > b then
  begin
   h := a; a := b; b := h;
  end;
end;

function packrect(a,b,c,d : smallInt) : Trect;
begin
 sort(a,c);
 sort(b,d);
 with result do
  begin
   left := a;
   top := b;
   right := c+1;
   bottom := d+1;
  end;
end;

procedure copybmrect;
begin
 form1.PaintBox1.Canvas.CopyRect(blendRect,bm.Canvas,blendRect);
end;

function popcount(a : word) : byte;
//count nr of 1 bits in a
var i : byte;
begin
 result := 0;
 for i := 0 to 15 do
  begin
   result := result + (a and $1);
   a := a shr 1;
  end;
end;

procedure procblendRect;
//blend pixels in abmRect into bm bitmap
var x,y : word;
    px,py,col : dword;
    r,g,b,pop : byte;
    penR,penG,penB : byte;
    fact,fact1 : single;
begin
 penR := pencolor and $ff;
 penG := (pencolor shr 8) and $ff;
 penB := (pencolor shr 16) and $ff;
 for y := blendRect.top to blendRect.bottom-1 do
  begin
   py := line0 - y*lineStep;
   for x := blendRect.Left to blendRect.Right-1 do
    begin
     px := py + (x shl 2);
     if blender[x,y] > 0 then
      begin
       pop := popcount(blender[x,y]);
       fact := fblend[pop];
       fact1 := 1-fact;
       col := PDW(px)^;
       r := (col shr 16) and $ff;
       g := (col shr 8) and $ff;
       b := col and $ff;
       r := round(fact1*r + fact*penR);
       g := round(fact1*g + fact*penG);
       b := round(fact1*b + fact*penB);
       col := (r shl 16) or (g shl 8) or b;
       PDW(px)^ := col;
       blender[x,y] := 0;
      end;
    end;//x
  end;//y
end;

procedure Qpixel(x,y : single);
//x,y: pixel.quarter
//use array abm for blending
var h : smallInt;
    px,mpx,py,mpy : smallInt;
    pen : word;
begin
 h := round(x*4);
 px := h shr 2;
 mpx := h and $3;
 h := round(y*4);
 py := h shr 2;
 mpy := h and $3;
 case pendirection of
  pdHorizontal : begin
                  pen := hpen[mpx] and vmask[mpy];
                  blender[px,py] := blender[px,py] or pen;
                  pen := hpen[mpx] and (vmask[mpy] xor $ffff);
                  blender[px,py+1] := blender[px,py+1] or pen;
                 end;
  pdVertical : begin
                pen := vpen[mpy] and hmask[mpx];
                blender[px,py] := blender[px,py] or pen;
                pen := vpen[mpy] and (hmask[mpx] xor $ffff);
                blender[px+1,py] := blender[px+1,py] or pen;
               end;
 end;//case
end;

procedure tradeXY(var x1,y1,x2,y2 : smallInt);
var hx,hy : smallInt;
begin
 hx := x1;
 hy := y1;
 x1 := x2;
 y1 := y2;
 x2 := hx;
 y2 := hy;
end;

procedure tradeAB(var a,b : smallInt);
var h : smallInt;
begin
 h := a;
 a := b;
 b := h;
end;

procedure softLine(x1,y1,x2,y2 : smallInt);
//draw softline in array abm, blend into bitmap bm
//pen width = 1
//color = col
//set mod rect
var hor : boolean;
    steps : smallInt;
    absx,absy : smallInt;
    i : smallInt;
    x,y,dx,dy : single;
begin
 absx := abs(x1-x2);
 absy := abs(y1-y2);
 hor := absx >= absy;
 if hor then
  begin
   if x1 > x2 then tradeXY(x1,y1,x2,y2);
   steps := (absx shl 2) + 3;
   pendirection := pdHorizontal;
  end
  else
   begin
    if y1 > y2 then tradeXY(x1,y1,x2,y2);
    steps := (absy shl 2) + 3;
    pendirection := pdVertical;
   end;
 dx := (x2-x1)/steps;
 dy := (y2-y1)/steps;
 x := x1;
 y := y1;
 for i := 0 to steps do
  begin
   Qpixel(x,y);
   x := x + dx;
   y := y + dy;
  end;
 blendrect := packrect(x1,y1,x2,y2);
 procBlendrect;
end;

procedure SoftEllipse(x1,y1,x2,y2:smallInt);
//paint softline ellipse
var a,b,i,mx,my : smallInt;
    x,y,sx,sy,sqra,sqrb,sqrab,adivb,bdiva : single;
begin
 a := abs(x2-x1) shr 1;
 b := abs(y2-y1) shr 1;
 if (a < 2) or (b < 2) then exit;
//
 sqra := a*a;
 sqrb := b*b;
 mx := (x1 + x2) shr 1;
 my := (y1 + y2) shr 1;
 if x1 > x2 then tradeAB(x1,x2);
 if y1 > y2 then tradeAB(y1,y1);
 sqrab := sqrt(sqra + sqrb);
 sx := sqra / sqrab;
 sy := sqrb / sqrab;
 bdiva := ba;
 adivb := ab;
 pendirection := pdHorizontal;
 x := 0;
 for i := 0 to trunc(sx *4) + 1 do
  begin
   y := bdiva*sqrt(sqra - x*x);
   Qpixel(mx+x,my-y);
   Qpixel(mx-x,my-y);
   Qpixel(mx+x,my+y);
   Qpixel(mx-x,my+y);
   x := x + 0.25;
  end;
 pendirection := pdVertical;
 y := 0;
 for i := 0 to trunc(sy * 4) + 1 do
  begin
   x := adivb*sqrt(sqrb - y*y);
   Qpixel(mx+x,my-y);
   Qpixel(mx-x,my-y);
   Qpixel(mx+x,my+y);
   Qpixel(mx-x,my+y);
   y := y + 0.25;
  end;
 blendRect := packRect(x1,y1,x2,y2);
 procBlendrect;
end;

procedure UpdateBox2;
//expand box1 pixels
var i,j,sx,sy : word;
    color : dword;
    r : Trect;
begin
 sx := form1.hscrollbar.position*40;
 sy := form1.vscrollbar.position*40;
 with form1.PaintBox2.Canvas do
  begin
   brush.Style := bsSolid;
   for j := 0 to 39 do
    for i := 0 to 39 do
     begin
      color := bm.Canvas.pixels[sx+i,sy+j];
      r := rect(i*10+1,j*10+1,i*10+9,j*10+9);
      brush.color := color;
      fillrect(r);
     end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 bm := TBitmap.Create;
 with bm do
  begin
   width := 601;
   height := 601;
   pixelformat := pf32bit;
   line0 := dword(scanline[0]);
   LineStep := line0 - dword(scanline[1]);
  end; 
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 bm.Free;
end;

procedure paintboxEdges(box : TPaintbox);
//paint edges around painybox on form1 canvas
var x1,y1,x2,y2 : word;
    i : byte;
begin
 with box do
  begin
   x1 := left-2;
   x2 := left+width+1;
   y1 := top-2;
   y2 := top + height+1;
  end;
 with form1.canvas do
  begin
   pen.Width := 1;
   for i := 0 to 1 do
    begin
     pen.color := 0;
     moveto(x2-i,y1+i);
     lineto(x1+i,y1+i);
     lineto(x1+i,y2-i);
     pen.color := $a0a0a0;
     lineto(x2-i,y2-i);
     lineto(x2-i,y1+i);
    end;
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
//paint edge of paintbox on form canvas
begin
 paintboxEdges(paintbox1);
 paintboxEdges(paintbox2);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
 paintbox1.canvas.Draw(0,0,bm);
end;

procedure TForm1.clearBtnClick(Sender: TObject);
var i,j : smallInt;
    r : Trect;
begin
 for j := 0 to blenderheight-1 do
  for i := 0 to blenderwidth-1 do blender[i,j] := 0;
 with bm do with canvas do
  begin
   brush.color := $ffffff;
   brush.Style := bsSolid;
   r := rect(0,0,width,height);
   fillrect(r);
  end;
 paintbox1.Canvas.Draw(0,0,bm);
 with paintbox2 do with canvas do
  begin
   brush.Color := $ffffff;
   brush.Style := bsSolid;
   fillrect(rect(0,0,width,height));
  end;
 paintbox2.Invalidate;//repaint raster
 updateBox2; 
end;

procedure TForm1.linesBtnClick(Sender: TObject);
var x1,y1,x2,y2 : smallInt;
    i : word;
begin
 for i := 0 to 20 do
  begin
   x2 := 200 + round(180*cos(0.05*pi*i));
   y2 := 200 + round(180*sin(0.05*pi*i));
   x1 := 400 - x2;
   y1 := 400 - y2;
   softline(x1,y1,x2,y2);
  end;
 paintbox1.Canvas.draw(0,0,bm);
 UpdateBox2;
end;

procedure TForm1.ellipseBtnButton1Click(Sender: TObject);
begin
 softellipse(10,10,50,391);
 softellipse(10,10,390,51);
 softellipse(10,10,391,391);
 softellipse(20,20,381,381);
 blendRect := rect(0,0,400,400);
 paintbox1.Canvas.draw(0,0,bm);
 updateBox2;
end;

procedure TForm1.colorBtnClick(Sender: TObject);
//add color rectangles to bm
var i : byte;
    r: Trect;
begin
 with bm.Canvas do
  for i := 0 to 2 do
   begin
    r := rect(50,50+100*i,350,100+100*i);
    brush.Color := $ff shl (i shl 3);
    brush.Style := bsSolid;
    fillrect(r);
   end;
 paintbox1.Canvas.Draw(0,0,bm);
 updateBox2;
end;

procedure TForm1.PaintBox2Paint(Sender: TObject);
//paint raster 10*10
var i : word;
begin
 with paintbox2 do with canvas do
  begin
   brush.color := $ffffff;
   brush.style := bsSolid;
   fillrect(rect(0,0,width,height));
   pen.width := 1;
   pen.Color := $c0c0c0;
   i := 0;
   while i < width do
    begin
     moveto(i,0); lineto(i,height);
     inc(i,10);
    end;
   i := 0;
   while i < height do
    begin
     moveto(0,i); lineto(width,i);
     inc(i,10);
    end;
  end;
end;

procedure TForm1.HscrollBarChange(Sender: TObject);
begin
 updateBox2;
end;

procedure TForm1.Image1Click(Sender: TObject);
//davdata website elink
begin
 ShellExecute(0,'open','http://www.davdata.nl', nil, nil, SW_SHOWNORMAL);
end;

end.