1  
   2  unit WavePlotter;
   3  
   4  interface
   5  
   6  uses
   7    forms, dialogs, SysUtils, Classes, Controls, Graphics;
   8  
   9  const
  10    PI2 = PI * 2;
  11  
  12  type
  13    TWaveType = ( wtSqr, wtPoly, wtSin );
  14  
  15    TWave = class( TPersistent )
  16    public
  17      waveType: TWaveType;
  18      color: TColor;
  19      offset: integer;
  20      frequency, amplitude, volts, interval, gain: extended;
  21  
  22      procedure AssignTo(Dest: TPersistent); override;
  23    end;
  24  
  25    TWaveShape = class( TGraphicControl )
  26    protected
  27      fWaves: TList;
  28      fBoxSize: integer;
  29      fLineColor: TColor;
  30  
  31      function getWave(const index: integer): TWave;
  32      procedure setBoxSize(const Value: integer);
  33  
  34      function getBackgroundColor: TColor;
  35      procedure setBackgroundColor(const Value: TColor);
  36      procedure setLineColor(const Value: TColor);
  37  
  38    public
  39      constructor create( AOwner: TComponent ); override;
  40      destructor destroy; override;
  41  
  42      procedure clear;
  43      procedure delete( const index: integer );
  44  
  45      function add: integer;
  46  
  47      property waves[ const index: integer]: TWave read GetWave;
  48  
  49    published
  50      procedure paint; override;
  51      property boxSize: integer read fBoxSize write setBoxSize;
  52      property backgroundColor: TColor read getBackgroundColor write setBackgroundColor;
  53      property lineColor: TColor read fLineColor write setLineColor;
  54  
  55      //inherited
  56      //property Canvas;
  57      property Align;
  58      property Anchors;
  59      property Constraints;
  60      property DragCursor;
  61      property DragKind;
  62      property DragMode;
  63      property Enabled;
  64      //property Font;
  65      property ParentColor;
  66      //property ParentFont;
  67      property ParentShowHint;
  68      property PopupMenu;
  69      property ShowHint;
  70      property Visible;
  71      property OnClick;
  72      property OnContextPopup;
  73      property OnDblClick;
  74      property OnDragDrop;
  75      property OnDragOver;
  76      property OnEndDock;
  77      property OnEndDrag;
  78      property OnMouseDown;
  79      property OnMouseMove;
  80      property OnMouseUp;
  81      property OnStartDock;
  82      property OnStartDrag;
  83    end;
  84  
  85  implementation
  86  
  87  function max( const a, b: integer ): integer;
  88  begin
  89    if a > b then
  90      result := a
  91    else
  92      result := b;
  93  end;
  94  
  95  { TWaveShape }
  96  
  97  function TWaveShape.add: integer;
  98  begin
  99    result := fWaves.add( TWave.Create );
 100  end;
 101  
 102  procedure TWaveShape.clear;
 103  begin
 104    while fWaves.count > 0 do begin
 105      TWave( fWaves[0] ).free;
 106      fWaves.delete( 0 );
 107    end;
 108  end;
 109  
 110  constructor TWaveShape.create(AOwner: TComponent);
 111  begin
 112    inherited;
 113    fWaves := TList.create;
 114    fLineColor := clGray;
 115    color := clBtnFace;
 116    fBoxSize := 50;
 117  end;
 118  
 119  procedure TWaveShape.delete(const index: integer);
 120  begin
 121    if ( index > -1 ) and ( index < fWaves.count ) then begin
 122      TWave( fWaves[index] ).free;
 123      fWaves.delete( index );
 124    end;
 125  end;
 126  
 127  destructor TWaveShape.destroy;
 128  begin
 129    fWaves.free;
 130    inherited;
 131  end;
 132  
 133  function TWaveShape.getBackgroundColor: TColor;
 134  begin
 135    result := color;
 136  end;
 137  
 138  function TWaveShape.getWave(const index: integer): TWave;
 139  begin
 140    result := nil;
 141    if ( index > -1 ) and ( index < fWaves.count ) then
 142      result := TWave( fWaves[ index ] );
 143  end;
 144  
 145  procedure TWaveShape.paint;
 146  var
 147    k, x: integer;
 148    lastX, lastY: array of integer;
 149    y: extended;
 150  begin
 151    if not enabled then
 152      exit;
 153    canvas.brush.color := color;
 154    canvas.fillRect( clientRect );
 155  
 156    setLength( lastY, fWaves.count );
 157    setLength( lastX, fWaves.count );
 158    for k := 0 to high( lastY ) do begin
 159      lastY[k] := clientHeight div 2 + waves[k].offset;
 160      lastX[k] := 0;
 161    end;
 162  
 163    for x := 0 to max( clientWidth, clientHeight ) do begin
 164      with canvas do begin
 165        pen.color := fLineColor;
 166        pen.width := 1;
 167        pen.style := psDot;
 168  
 169        if x mod fBoxSize = 0 then begin
 170          moveTo( 0, x + trunc( frac( clientHeight / 2 / fBoxSize ) * fBoxSize ) );
 171          lineTo( clientWidth, x + trunc( frac( clientHeight / 2 / fBoxSize ) * fBoxSize ) );
 172  
 173          moveTo( x, 0 );
 174          lineTo( x, clientHeight );
 175        end;
 176  
 177        for k := 0 to fWaves.count - 1 do begin
 178          with waves[k] do begin
 179            pen.color := color;
 180            pen.width := 1;
 181            pen.style := psSolid;
 182  
 183            y := pi*k + PI2 * x * interval / fBoxSize * frequency;
 184  
 185            case waveType of
 186              wtSin:
 187                y := sin( y );
 188              wtPoly: begin
 189                y := frac( y / PI2 );
 190                if y <= 0.25 then
 191                  y := y / 0.25
 192                else if y <= 0.75 then
 193                  y := ( -y + 0.5 ) / 0.25
 194                else
 195                  y := ( y - 1 ) / 0.25;
 196              end;
 197              wtSqr: begin
 198                if frac( y / PI2 ) <= 0.5 then
 199                  y := 1
 200                else
 201                  y := -1;
 202              end;
 203            end;
 204            y := ( y * ( fBoxSize / volts ) * amplitude * gain ) + clientHeight / 2 + offset;
 205            moveTo( lastX[k], lastY[k] );
 206            lastX[k] := x;
 207            lastY[k] := trunc( y );
 208            lineTo( x, lastY[k] );
 209          end;
 210        end;
 211      end;
 212    end;
 213  end;
 214  
 215  procedure TWaveShape.setBackgroundColor(const Value: TColor);
 216  begin
 217    color := Value;
 218    Invalidate;
 219  end;
 220  
 221  procedure TWaveShape.setBoxSize(const Value: integer);
 222  begin
 223    fBoxSize := Value;
 224    invalidate;
 225  end;
 226  
 227  
 228  procedure TWaveShape.setLineColor(const Value: TColor);
 229  begin
 230    fLineColor := Value;
 231    Invalidate;
 232  end;
 233  
 234  { TWave }
 235  
 236  procedure TWave.AssignTo(Dest: TPersistent);
 237  begin
 238    if Dest.ClassType <> TWave then
 239      inherited;
 240    with TWave( Dest ) do begin
 241      waveType := self.waveType;
 242      color := self.color;
 243      offset := self.offset;
 244      frequency := self.frequency;
 245      amplitude := self.amplitude;
 246      volts := self.volts;
 247      interval := self.interval;
 248      gain := self.gain;
 249    end;
 250  end;
 251  
 252  end.

   1  
   2  //+ Jonas Raoni Soares Silva
   3  //@ http://jsfromhell.com/math/closest-square-point [v1.0]
   4  
   5  closestSquarePoint = function( px, py, x, y, w, h ){
   6  	return { x: px < x ? x : px > x + w ? x + w : px, y: py < y ? y : py > y + h ? y + h : py };
   7  };