1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:

unit Unit1;
 
interface  
 
uses  
  Windows, Graphics, Forms, StdCtrls, Classes, Controls, ExtCtrls, SysUtils;
 
type  
  TPointPair = array[0..1] of TPoint;  
  PPointPair = ^TPointPair;  
  TVisPair = record  
    W: Extended;  
    Flag: Boolean;  
    Line: PPointPair;  
  end;  
  TInterval = record  
    FromW, ToW: Extended;  
    Line: PPointPair;  
    LineSegment: TPointPair;  
  end;  

  TForm1 = class(TForm)  
    Image1: TImage;
    procedure FormCreate(Sender: TObject);  
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;  
      Shift: TShiftState; X, Y: Integer);  
  private  
    { Private declarations }  
  public  
    { Public declarations }  
    Lines: array of TPointPair;  
    procedure Redraw;  
    procedure DefLine(X1, Y1, X2, Y2: Integer);  
  end;  

var  
  Form1: TForm1;  

implementation  

uses Math, Contnrs;  
 
{$R *.dfm}  
 
procedure TForm1.DefLine(X1, Y1, X2, Y2: Integer);  
var  
 IndL: Integer;  
begin  
  IndL := Length(Lines);  
  SetLength(Lines, IndL+1);  
  Lines[IndL][0] := Point(X1,Y1);  
  Lines[IndL][1] := Point(X2,Y2);  
end;  
 
procedure TForm1.FormCreate(Sender: TObject);  
begin  
  DefLine(240,42,397,306);  DefLine(397,306,23,345);  DefLine(23,345,240,42);
  DefLine(147,233,194,297); DefLine(194,297,207,214); DefLine(207,214,147,233);
  DefLine(243,155,269,238); DefLine(269,238,292,179); DefLine(292,179,243,155);
  DefLine(307,281,314,260); DefLine(314,260,327,283); DefLine(327,283,307,281);
  Redraw;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
 Visible: array of TVisPair;
 Intervals: array of TInterval;
 TempVisible: TVisPair;  
 I, J, Ind, Index: Integer;  
 Min, CurrW, LastW, FirstW: Extended;  
 Init: Boolean;  
 LList: TList;
 TempLine: Pointer;
function ProcessList(W: Extended; LList: TList): Integer;
var
 D, MinD: Extended;
 K, L: Integer;
 P1, P2: TPoint;
begin
  MinD := infinite;  
  L := 0;  
  for K := 0 to LList.Count-1 do
  begin  
   P1 := PPointPair(LList[K])^[0];  
   P2 := PPointPair(LList[K])^[1];  
   D := ((P2.Y-Y)*(P1.X-X)-(P2.X-X)*(P1.Y-Y))/(cos(W)*(P2.Y-P1.Y)-sin(W)*(P2.X-P1.X));  
   if D < MinD then  
   begin  
    MinD := D;  
    L := K;  
   end;  
  end;  
  Result := L;
end;  
procedure ProcessLine(IndL: integer);
var  
 W1, W2, W: Extended;  
 IndV: Integer;  
begin  
  W1 := ArcTan2(Lines[IndL][0].Y-Y,Lines[IndL][0].X-X);  
  W2 := ArcTan2(Lines[IndL][1].Y-Y,Lines[IndL][1].X-X);  
  if W1=W2 then  
   exit;
  IndV := Length(Visible);
  SetLength(Visible, IndV+2);  
  if (abs(W1-W2)>pi) xor (W1>W2) then  
  begin  
   W := W1;
   W1 := W2;
   W2 := W;
  end;
  if abs(W1-W2)>pi then
   LList.Add(@Lines[IndL]);
  Visible[IndV].W := W1;
  Visible[IndV].Flag := True;
  Visible[IndV].Line := @Lines[IndL];
  Visible[IndV+1].W := W2;
  Visible[IndV+1].Flag := False;
  Visible[IndV+1].Line := @Lines[IndL];
end;
procedure CalcLineSegment(var Interval: TInterval);  
var  
 P1, P2: TPoint;  
 rx, ry, I1, I2: Extended;  
begin  
  P1 := Interval.Line[0];  
  P2 := Interval.Line[1];  
  SinCos(Interval.FromW, ry, rx);  
  I1 := (rx*(P2.y-Y)-ry*(P2.x-X))/(rx*(P2.y-P1.y)-ry*(P2.x-P1.x));  
  SinCos(Interval.ToW, ry, rx);  
  I2 := (rx*(P2.y-Y)-ry*(P2.x-X))/(rx*(P2.y-P1.y)-ry*(P2.x-P1.x));  
  Interval.LineSegment[0] := Point(Round(I1*P1.X+(1-I1)*P2.X),Round(I1*P1.Y+(1-I1)*P2.Y));  
  Interval.LineSegment[1] := Point(Round(I2*P1.X+(1-I2)*P2.X),Round(I2*P1.Y+(1-I2)*P2.Y));  
end;
begin
  if Length(Lines) = 0 then
   exit;  
  Image1.Picture := nil;  
  LList := TList.Create;
  try
   for I := 0 to Length(Lines)-1 do  
    ProcessLine(I);  
   for I := 0 to Length(Visible)-1 do
   begin  
    Min := Visible[I].W;
    Ind := I;  
    for J := I+1 to Length(Visible)-1 do  
     if Visible[J].W<Min then  
     begin  
      Min := Visible[J].W;  
      Ind := J;  
     end;  
    if Ind <> I then  
    begin  
      TempVisible := Visible[I];
      Visible[I] := Visible[Ind];
      Visible[Ind] := TempVisible;
    end;  
   end;  
   I := 0;  
   LastW := 0;  
   FirstW := 0;  
   Init := True;  
   repeat  
     CurrW := Visible[I].W;  
     if Init then  
     begin  
      Init := False;  
      FirstW := CurrW;  
     end else  
     begin  
      if LList.Count > 0 then
      begin
       Index := Length(Intervals);
       TempLine := LList[ProcessList((LastW+CurrW)/2, LList)];
       if (Index > 0) and (Intervals[Index-1].Line = TempLine) and
          (Intervals[Index-1].ToW = LastW) then
         Intervals[Index-1].ToW := CurrW
       else begin
        SetLength(Intervals, Index+1);
        Intervals[Index].FromW := LastW;
        Intervals[Index].ToW := CurrW;
        Intervals[Index].Line := TempLine;
       end;
      end;
     end;
     repeat
      if Visible[I].Flag then
       LList.Add(Pointer(Visible[I].Line)) else
       LList.Delete(LList.IndexOf(Pointer(Visible[I].Line)));
      inc(I);
     until (I=length(Visible)) or (Visible[I].W <> CurrW);
     if I=length(Visible) then
      break;
     LastW := CurrW;
   until false;
   if not Init and (LList.Count > 0) then
   begin
    Index := Length(Intervals);
    TempLine := LList[ProcessList((FirstW+2*pi+CurrW)/2, LList)];
    if (Index > 0) and (Intervals[Index-1].Line = TempLine) and
       (Intervals[Index-1].ToW = CurrW) then
     Intervals[Index-1].ToW := FirstW
    else begin
     SetLength(Intervals, Index+1);
     Intervals[Index].FromW := CurrW;
     Intervals[Index].ToW := FirstW;
     Intervals[Index].Line := TempLine;
    end;
   end;
   Index := Length(Intervals);
   if (Index > 0) and (Intervals[0].Line = Intervals[Index-1].Line) and
      (Intervals[0].FromW = Intervals[Index-1].ToW) then
   begin
    Intervals[0].FromW := Intervals[Index-1].FromW;
    SetLength(Intervals, Index-1);
   end;
   Image1.Canvas.Pen.Width := 1;
   Image1.Canvas.Brush.Color := clRed;
   Image1.Canvas.Pen.Color := clBlack;
   for I := 0 to length(Intervals)-1 do  
   begin  
    CalcLineSegment(Intervals[I]);  
    Image1.Canvas.Polygon([Point(X,Y),  
                           Point(Intervals[I].LineSegment[0].X, Intervals[I].LineSegment[0].Y),  
                           Point(Intervals[I].LineSegment[1].X, Intervals[I].LineSegment[1].Y)]);  
   end;  
  finally  
   LList.Free;  
  end;  
  Redraw;  
end;  

procedure TForm1.Redraw;  
var  
 I: Integer;  
begin  
  Image1.Canvas.Pen.Color := clBlack;  
  Image1.Canvas.Pen.Width := 3;  
  for I := 0 to Length(Lines)-1 do  
  begin  
    with Lines[I][0] do  
     Image1.Canvas.MoveTo(X,Y);  
    with Lines[I][1] do  
     Image1.Canvas.LineTo(X,Y);  
  end;  
end;  
end.