Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DRAWER.ZIP/CANVAS.PAS

Pascal/Delphi Source File | 1993-01-04 | 7.6 KB | 374 lines

{$L-,D-}

unit Canvass;

interface

uses
    Shape;

const

    MAXCANVASSHAPES = 50;

type

    Canvas =     object
                    x1, y1, x2, y2 : word;
                    NumShapes : word;
                    Shapes : array[1..MAXCANVASSHAPES] of Shape;
                    procedure Initialize( x1, y1, x2, y2 : word);
                    function  PtInRegion( x, y : word) : boolean;
                    function  AddShape( s : shape) : boolean;
                    procedure Delete;
                    procedure Copy;
                    function  ObjectAt( x, y : word) : Shape;
                    procedure SelectObject( s : Shape );
                    procedure Lasso( lx1, ly1, lx2, ly2 : word);
                    procedure Move( dx, dy : integer);
                    procedure Size( dx, dy : integer);
                    Procedure ChangeColor( newcolor : word);
                    procedure GetRange( var rx1, ry1, rx2, ry2 : word);
                    function  PtInSelection( x, y : word) : boolean;
                    procedure UnSelectObject( s : Shape );
                    procedure SelectAllObjects;
                    procedure UnSelectAllObjects;
                    function  SelectedObject( s : Shape ) : Shape;
                    function  OnHandle( px, py : word) : boolean;
                    procedure Draw;
                    procedure Erase;
                    procedure Save( fn : string);
                    procedure Load( fn : string);
                end;

implementation

uses MSGraph, Utility;

const
    CANVASSTAMP : word = $0160;

procedure Canvas.Initialize( x1, y1, x2, y2 : word);
begin
    self.x1 := x1;
    self.y1 := y1;
    self.x2 := x2;
    self.y2 := y2;
    self.NumShapes := 0;
end;

function Canvas.PtInRegion( x, y : word) : boolean;
begin
    with self do
        PtInRegion := (x>=x1) and (x<=x2) and (y>=y1) and (y<=y2);
end;

function Canvas.AddShape( s : shape ) : boolean;
begin
    if self.NumShapes < MAXCANVASSHAPES then begin
        inc(self.NumShapes);
        self.Shapes[self.NumShapes] := s;
        AddShape := TRUE;
        end
    else
        AddShape := FALSE;
end;

procedure Canvas.Delete;
var
    n : word;

    procedure MoveUp;
    var
        n2 : word;
    begin
        for n2 := n+1 to self.NumShapes do
            self.Shapes[n2-1] := self.Shapes[n2];
    end;

begin
    with self do begin
        n := 1;
        while n <= NumShapes do
            if self.Shapes[n].Selected then begin
                self.Shapes[n].Erase;
                Dispose( self.Shapes[n] );
                MoveUp;
                Dec(NumShapes);
                end
            else
                inc(n);
        end;
end;

procedure Canvas.Copy;
var
    n : word;
    s : shape;
begin
    for n := 1 to self.NumShapes do
        if self.Shapes[n].Selected then begin
            s := self.Shapes[n].clone;
            s.Move( 4, 4);
            self.Shapes[n].UnSelect;
            s.Select;
            if not self.AddShape(s) then Dispose(s);
            end;
end;

procedure Canvas.Draw;
var
    n : word;
begin
    for n := 1 to self.NumShapes do
        self.Shapes[n].Draw;
end;

procedure Canvas.Erase;
begin
    _SetColor(0);
    with self do _Rectangle( _GFILLINTERIOR, x1, y1, x2, y2);
end;

function Canvas.SelectedObject( s : shape) : Shape;
var
    n : word;
begin
    { if s=NIL, find first selected object.  Else, find the
      one selected after s (if any) }
    for n := 1 to self.NumShapes do
        if self.Shapes[n].Selected then
            if s=NIL then begin
                SelectedObject := self.Shapes[n];
                exit;
                end
            else if self.Shapes[n]=s then s := NIL;

    SelectedObject := NIL;

end;

function Canvas.ObjectAt( x, y : word) : Shape;
var
    n : word;
begin
    with self do for n := 1 to NumShapes do
        if Shapes[n].PtInRegion( x, y ) then begin
            ObjectAt := Shapes[n];
            exit;
            end;
    ObjectAt := NIL;
end;

procedure Canvas.SelectObject( s : Shape);
begin
    s.Select;
end;

procedure Canvas.Lasso( lx1, ly1, lx2, ly2 : word);
const
    PICKRECTANGLE = 10;
var
    n : word;

    function InRange( x, y : word) : boolean;
    begin
        InRange := (x>=lx1) and (x<=lx2) and (y>=ly1) and (y<=ly2);
    end;

begin
    { if the selection is very small, treat as a pick }
    if (abs(lx2-lx1)+abs(ly2-ly1))<PICKRECTANGLE then with self do
        for n := 1 to NumShapes do
            if Shapes[n].PtInRegion(lx2, ly2) then begin
                Shapes[n].Select;
                exit;
                end;

    { selection is big, do a group pick }
    with self do
        for n := 1 to NumShapes do with Shapes[n] do
            if InRange( x, y) and InRange( x+xe, y+ye ) then Select;

end;

procedure Canvas.Move( dx, dy : integer);
var
    n : word;
begin
    for n := 1 to self.NumShapes do with self.Shapes[n] do
        if Selected then Move( dx, dy);
end;

procedure Canvas.Size( dx, dy : integer);
var
    n : word;
begin
    for n := 1 to self.NumShapes do with self.Shapes[n] do
        if Selected then Size( dx, dy);
end;

procedure Canvas.ChangeColor( newcolor : word );
var
    n : word;
begin
    for n := 1 to self.NumShapes do with self.Shapes[n] do
        if Selected then color := newcolor;
end;

procedure Canvas.UnSelectObject( s : Shape);
begin
    s.UnSelect;
end;

procedure Canvas.SelectAllObjects;
var
    n : word;
begin
    with self do
        for n := 1 to NumShapes do
            Shapes[n].Select;
end;

procedure Canvas.UnSelectAllObjects;
var
    n : word;
begin
    with self do
        for n := 1 to NumShapes do
            Shapes[n].UnSelect;
end;

function Canvas.PtInSelection( x, y : word) : boolean;
var
    rx1, ry1, rx2, ry2 : word;
begin
    self.GetRange( rx1, ry1, rx2, ry2);
    with self do
        PtInSelection :=    ((x+HITPOINTTOLERANCE)>rx1) and
                            ((x-HITPOINTTOLERANCE)<rx2) and
                            ((y+HITPOINTTOLERANCE)>ry1) and
                            ((y-HITPOINTTOLERANCE)<ry2);
end;

procedure Canvas.GetRange( var rx1, ry1, rx2, ry2 : word);
var
    n : word;
begin
    rx1 := 65535;
    ry1 := 65535;
    rx2 := 0;
    ry2 := 0;
    for n := 1 to self.NumShapes do with self.Shapes[n] do
        if Selected then begin
                rx1 := min( x, min( rx1, x+xe) );
                ry1 := min( y, min( ry1, y+ye) );
                rx2 := max( x, max( rx2, x+xe) );
                ry2 := max( y, max( ry2, y+ye) );
                end;
end;

function Canvas.OnHandle( px, py : word) : boolean;
var
    n : word;
    ax, ay : word;
begin
    with self do for n := 1 to NumShapes do
        if Shapes[n].OnHandle( px, py, ax, ay) then begin
            OnHandle := TRUE;
            exit;
            end;
    OnHandle := FALSE;
end;

procedure Canvas.Save( fn : string);
var
    f : file;
    n : word;
    nw : word;
begin
{$I-}
    assign(f, fn);
    rewrite(f, 1);
{$I+}
    if IoResult<>0 then exit;
    BlockWrite( f, CANVASSTAMP, sizeof(CANVASSTAMP), nw);
    with self do begin
        BlockWrite( f, NumShapes, sizeof(NumShapes), nw);
        for n := 1 to NumShapes do
            Shapes[n].Save(f);
        end;
    close(f);
end;

procedure Canvas.Load( fn : string);
var
    f : file;
    n : word;
    ns : word;
    s : word;
    nr : word;
    t  : ShapeTypes;

    re : rectangle;
    fr : FRectangle;
    el : Ellipse;
    fe : FEllipse;
    gt : GText;
    li : Line;

begin
{$I-}
    assign(f, fn);
    reset(f, 1);
{$I+}
    if IOResult<>0 then exit;

    BlockRead( f, s, sizeof(s), nr);
    if (IOResult=0) and (s=CANVASSTAMP) then with self do begin
        BlockRead( f, ns, sizeof(ns), nr);
        for n := 1 to ns do begin
            BlockRead( f, t, sizeof(t), nr);
            case t of
                sRectangle :    begin
                                    new(re);
                                    Re.Load( f);
                                    if not self.AddShape(re) then Dispose(re);
                                end;
                sFRectangle :    begin
                                    new(fr);
                                    fr.Load( f);
                                    if not self.AddShape(fr) then Dispose(fr);
                                end;
                sEllipse :         begin
                                    new(el);
                                    el.Load( f);
                                    if not self.AddShape(el) then Dispose(el);
                                end;
                sFEllipse :        begin
                                    new(fe);
                                    fe.Load( f);
                                    if not self.AddShape(fe) then Dispose(fe);
                                end;
                sGText :         begin
                                    new(gt);
                                    gt.Load( f);
                                    if not self.AddShape(gt) then Dispose(gt);
                                end;
                sLine :         begin
                                    new(li);
                                    li.Load( f);
                                    if not self.AddShape(li) then Dispose(li);
                                end;
                else    RunError(191);
                end; { case }
            end; { for n := 1 to ns }
            self.Erase;
            self.Draw;
        end; { if stamp = }
    close(f);
end;

begin
end.