1 unit outline;
2
3 {$CODEPAGE cp437}
4
5 {***************************************************************************}
6 interface
7 {***************************************************************************}
8
9 uses drivers,objects,views;
10
11 type Pnode=^Tnode;
12 Tnode=record
13 next:Pnode;
14 text:Pstring;
15 childlist:Pnode;
16 expanded:boolean;
17 end;
18
19 Poutlineviewer=^Toutlineviewer;
20 Toutlineviewer=object(Tscroller)
21 foc:sw_integer;
22 constructor init(var bounds:Trect;
23 AHscrollbar,AVscrollbar:Pscrollbar);
24 procedure adjust(node:pointer;expand:boolean);virtual;
creategraphnull25 function creategraph(level:integer;lines:longint;
26 flags:word;levwidth,endwidth:integer;
27 const chars:string):string;
28 procedure draw;virtual;
29 procedure expandall(node:pointer);
firstthatnull30 function firstthat(test:codepointer):pointer;
31 procedure focused(i:sw_integer);virtual;
32 procedure foreach(action:codepointer);
getchildnull33 function getchild(node:pointer;i:sw_integer):pointer;virtual;
getgraphnull34 function getgraph(level:integer;lines:longint;flags:word):string;
getnodenull35 function getnode(i:sw_integer):pointer;virtual;
getnumchildrennull36 function getnumchildren(node:pointer):sw_integer;virtual;
getpalettenull37 function getpalette:Ppalette;virtual;
getrootnull38 function getroot:pointer;virtual;
gettextnull39 function gettext(node:pointer):string;virtual;
40 procedure handleevent(var event:Tevent);virtual;
haschildrennull41 function haschildren(node:pointer):boolean;virtual;
isexpandednull42 function isexpanded(node:pointer):boolean;virtual;
isselectednull43 function isselected(i:sw_integer):boolean;virtual;
44 procedure selected(i:sw_integer);virtual;
45 procedure setstate(Astate:word;enable:boolean);virtual;
46 procedure update;
47 private
48 procedure set_focus(Afocus:sw_integer);
do_recursenull49 function do_recurse(action:codepointer;callerframe:pointer;
50 stop_if_found:boolean):pointer;
51 end;
52
53 Poutline=^Toutline;
54 Toutline=object(Toutlineviewer)
55 root:Pnode;
56 constructor init(var bounds:Trect;
57 AHscrollbar,AVscrollbar:Pscrollbar;
58 Aroot:Pnode);
59 procedure adjust(node:pointer;expand:boolean);virtual;
getchildnull60 function getchild(node:pointer;i:sw_integer):pointer;virtual;
getnumchildrennull61 function getnumchildren(node:pointer):sw_integer;virtual;
getrootnull62 function getroot:pointer;virtual;
gettextnull63 function gettext(node:pointer):string;virtual;
haschildrennull64 function haschildren(node:pointer):boolean;virtual;
isexpandednull65 function isexpanded(node:pointer):boolean;virtual;
66 destructor done;virtual;
67 end;
68
69 const ovExpanded = $1;
70 ovChildren = $2;
71 ovLast = $4;
72
73 Coutlineviewer=Cscroller+#8#8;
74
newnodenull75 function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode;
76 procedure disposenode(node:Pnode);
77
78
79 {***************************************************************************}
80 implementation
81 {***************************************************************************}
82
EBPnull83 type TMyFunc = function(_EBP: Pointer; Cur: Pointer;
84 Level, Position: sw_integer; Lines: LongInt;
85 Flags: Word): Boolean;
86
87
newnodenull88 function newnode(const Atext:string;Achildren,Anext:Pnode):Pnode;
89
90 begin
91 newnode:=new(Pnode);
92 with newnode^ do
93 begin
94 next:=Anext;
95 text:=newstr(Atext);
96 childlist:=Achildren;
97 expanded:=true;
98 end;
99 end;
100
101 procedure disposenode(node:Pnode);
102
103 var next:Pnode;
104
105 begin
106 while node<>nil do
107 begin
108 disposenode(node^.childlist);
109 disposestr(node^.text);
110 next:=node^.next;
111 dispose(node);
112 node:=next;
113 end;
114 end;
115
116 {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
117 { Toutlineviewer object methods }
118 {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
119
120 constructor Toutlineviewer.init(var bounds:Trect;
121 AHscrollbar,AVscrollbar:Pscrollbar);
122
123 begin
124 inherited init(bounds,AHscrollbar,AVscrollbar);
125 foc:=0;
126 growmode:=gfGrowHiX+gfGrowHiY;
127 end;
128
129 procedure Toutlineviewer.adjust(node:pointer;expand:boolean);
130
131 begin
132 abstract;
133 end;
134
CreateGraphnull135 function TOutlineViewer.CreateGraph(Level: Integer; Lines: LongInt;
136 Flags: Word; LevWidth, EndWidth: Integer;
137 const Chars: String): String;
138 const
139 FillerOrBar = 0;
140 YorL = 2;
141 StraightOrTee= 4;
142 Retracted = 6;
143 var
144 Last, Children, Expanded: Boolean;
145 I , J : Byte;
146 Graph : String;
147
148 begin
149 { Load registers }
150 graph:=space(Level*LevWidth+EndWidth+1);
151
152 { Write bar characters }
153 J := 1;
154 while (Level > 0) do
155 begin
156 Inc(J);
157 if (Lines and 1) <> 0 then
158 Graph[J] := Chars[FillerOrBar+2]
159 else
160 Graph[J] := Chars[FillerOrBar+1];
161 for I := 1 to LevWidth - 1 do
162 Graph[I]:= Chars[FillerOrBar+1];
163 J := J + LevWidth - 1;
164 Dec(Level);
165 Lines := Lines shr 1;
166 end;
167
168 { Write end characters }
169 Dec(EndWidth);
170 if EndWidth > 0 then
171 begin
172 Inc(J);
173 if Flags and ovLast <> 0 then
174 Graph[J] := Chars[YorL+2]
175 else
176 Graph[J] := Chars[YorL+1];
177 Dec(EndWidth);
178 if EndWidth > 0 then
179 begin
180 Dec(EndWidth);
181 for I := 1 to EndWidth do
182 Graph[I]:= Chars[StraightOrTee+1];
183 J := J + EndWidth;
184 Inc(J);
185 if (Flags and ovChildren) <> 0 then
186 Graph[J] := Chars[StraightOrTee+2]
187 else
188 Graph[J] := Chars[StraightOrTee+1];
189 end;
190 Inc(J);
191 if Flags and ovExpanded <> 0 then
192 Graph[J] := Chars[Retracted+2]
193 else
194 Graph[J] := Chars[Retracted+1];
195 end;
196 Graph[0] := Char(J);
197
198 CreateGraph := Graph;
199 end;
200
Toutlineviewer.do_recursenull201 function Toutlineviewer.do_recurse(action:codepointer;callerframe:pointer;
202 stop_if_found:boolean):pointer;
203
204 var position:sw_integer;
205 r:pointer;
206
recursenull207 function recurse(cur:pointer;level:integer;lines:longint;lastchild:boolean):pointer;
208
209 var i,childcount:sw_integer;
210 child:pointer;
211 flags:word;
212 children,expanded,found:boolean;
213
214 begin
215 inc(position);
216 recurse:=nil;
217
218 children:=haschildren(cur);
219 expanded:=isexpanded(cur);
220
221 {Determine flags.}
222 flags:=0;
223 if not children or expanded then
224 inc(flags,ovExpanded);
225 if children and expanded then
226 inc(flags,ovChildren);
227 if lastchild then
228 inc(flags,ovLast);
229
230 {Call the function.}
231 found:=TMyFunc(action)(callerframe,cur,level,position,lines,flags);
232
233 if stop_if_found and found then
234 recurse:=cur
235 else if children and expanded then {Recurse children?}
236 begin
237 if not lastchild then
238 lines:=lines or (1 shl level);
239 {Iterate all childs.}
240 childcount:=getnumchildren(cur);
241 for i:=0 to childcount-1 do
242 begin
243 child:=getchild(cur,i);
244 if (child<>nil) and (level<31) then
245 recurse:=recurse(child,level+1,lines,i=childcount-1);
246 {Did we find a node?}
247 if recurse<>nil then
248 break;
249 end;
250 end;
251 end;
252
253 begin
254 position:=-1;
255 r:=getroot;
256 if r<>nil then
257 do_recurse:=recurse(r,0,0,true)
258 else
259 do_recurse:=nil;
260 end;
261
262 procedure Toutlineviewer.draw;
263
264 var c_normal,c_normal_x,c_select,c_focus:byte;
265 maxpos:sw_integer;
266 b:Tdrawbuffer;
267
draw_itemnull268 function draw_item(cur:pointer;level,position:sw_integer;
269 lines:longint;flags:word):boolean;
270
271 var c,i:byte;
272 s,t:string;
273
274 begin
275 draw_item:=position>=delta.y+size.y;
276 if (position<delta.y) or draw_item then
277 exit;
278
279 maxpos:=position;
280 s:=getgraph(level,lines,flags);
281 t:=gettext(cur);
282
283 {Determine text colour.}
284 if (foc=position) and (state and sffocused<>0) then
285 c:=c_focus
286 else if isselected(position) then
287 c:=c_select
288 else if flags and ovexpanded<>0 then
289 c:=c_normal_x
290 else
291 c:=c_normal;
292
293 {Fill drawbuffer with graph and text to draw.}
294 for i:=0 to size.x-1 do
295 begin
296 wordrec(b[i]).hi:=c;
297 if i+delta.x<length(s) then
298 wordrec(b[i]).lo:=byte(s[1+i+delta.x])
299 else if 1+i+delta.x-length(s)<=length(t) then
300 wordrec(b[i]).lo:=byte(t[1+i+delta.x-length(s)])
301 else
302 wordrec(b[i]).lo:=byte(' ');
303 end;
304
305 {Draw!}
306 writeline(0,position-delta.y,size.x,1,b);
307 end;
308
309 begin
310 c_normal:=getcolor(4);
311 c_normal_x:=getcolor(1);
312 c_focus:=getcolor(2);
313 c_select:=getcolor(3);
314 maxpos:=-1;
315 foreach(@draw_item);
316 movechar(b,' ',c_normal,size.x);
317 writeline(0,maxpos+1,size.x,size.y-(maxpos-delta.y),b);
318 end;
319
320 procedure Toutlineviewer.expandall(node:pointer);
321
322 var i:sw_integer;
323
324 begin
325 if haschildren(node) then
326 begin
327 for i:=0 to getnumchildren(node)-1 do
328 expandall(getchild(node,i));
329 adjust(node,true);
330 end;
331 end;
332
Toutlineviewer.firstthatnull333 function Toutlineviewer.firstthat(test:codepointer):pointer;
334
335 begin
336 firstthat:=do_recurse(test,
337 { On most systems, locals are accessed relative to base pointer,
338 but for MIPS cpu, they are accessed relative to stack pointer.
339 This needs adaptation for so low level routines,
340 like MethodPointerLocal and related objects unit functions. }
341 {$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE}
342 get_caller_frame(get_frame,get_pc_addr)
343 {$else}
344 get_frame
345 {$endif}
346 ,true);
347 end;
348
349 procedure Toutlineviewer.focused(i:sw_integer);
350
351 begin
352 foc:=i;
353 end;
354
355 procedure Toutlineviewer.foreach(action:codepointer);
356
357 begin
358 do_recurse(action,
359 { On most systems, locals are accessed relative to base pointer,
360 but for MIPS cpu, they are accessed relative to stack pointer.
361 This needs adaptation for so low level routines,
362 like MethodPointerLocal and related objects unit functions. }
363 {$ifndef FPC_LOCALS_ARE_STACK_REG_RELATIVE}
364 get_caller_frame(get_frame,get_pc_addr)
365 {$else}
366 get_frame
367 {$endif}
368 ,false);
369 end;
370
getchildnull371 function Toutlineviewer.getchild(node:pointer;i:sw_integer):pointer;
372
373 begin
374 abstract;
375 end;
376
getgraphnull377 function Toutlineviewer.getgraph(level:integer;lines:longint;
378 flags:word):string;
379
380 begin
381 getgraph:=creategraph(level,lines,flags,3,3,' �����+�');
382 end;
383
Toutlineviewer.getnodenull384 function Toutlineviewer.getnode(i:sw_integer):pointer;
385
test_positionnull386 function test_position(node:pointer;level,position:sw_integer;lines:longInt;
387 flags:word):boolean;
388
389 begin
390 test_position:=position=i;
391 end;
392
393 begin
394 getnode:=firstthat(@test_position);
395 end;
396
getnumchildrennull397 function Toutlineviewer.getnumchildren(node:pointer):sw_integer;
398
399 begin
400 abstract;
401 end;
402
getpalettenull403 function Toutlineviewer.getpalette:Ppalette;
404
405 const p:string[length(Coutlineviewer)]=Coutlineviewer;
406
407 begin
408 getpalette:=@p;
409 end;
410
Toutlineviewer.getrootnull411 function Toutlineviewer.getroot:pointer;
412
413 begin
414 abstract;
415 end;
416
gettextnull417 function Toutlineviewer.gettext(node:pointer):string;
418
419 begin
420 abstract;
421 end;
422
423 procedure Toutlineviewer.handleevent(var event:Tevent);
424
425 var mouse:Tpoint;
426 cur:pointer;
427 new_focus:sw_integer;
428 count:byte;
429 handled,m,mouse_drag:boolean;
430 graph:string;
431
graph_of_focusnull432 function graph_of_focus(var graph:string):pointer;
433
434 var _level:sw_integer;
435 _lines:longInt;
436 _flags:word;
437
find_focusednull438 function find_focused(cur:pointer;level,position:sw_integer;
439 lines:longint;flags:word):boolean;
440
441 begin
442 find_focused:=position=foc;
443 if find_focused then
444 begin
445 _level:=level;
446 _lines:=lines;
447 _flags:=flags;
448 end;
449 end;
450
451 begin
452 graph_of_focus:=firstthat(@find_focused);
453 graph:=getgraph(_level,_lines,_flags);
454 end;
455
456 const skip_mouse_events=3;
457
458 begin
459 inherited handleevent(event);
460 case event.what of
461 evKeyboard:
462 begin
463 new_focus:=foc;
464 handled:=true;
465 case ctrltoarrow(event.keycode) of
466 kbUp,kbLeft:
467 dec(new_focus);
468 kbDown,kbRight:
469 inc(new_focus);
470 kbPgDn:
471 inc(new_focus,size.y-1);
472 kbPgUp:
473 dec(new_focus,size.y-1);
474 kbCtrlPgUp:
475 new_focus:=0;
476 kbCtrlPgDn:
477 new_focus:=limit.y-1;
478 kbHome:
479 new_focus:=delta.y;
480 kbEnd:
481 new_focus:=delta.y+size.y-1;
482 kbCtrlEnter,kbEnter:
483 selected(new_focus);
484 else
485 case event.charcode of
486 '-','+':
487 begin
488 adjust(getnode(new_focus),event.charcode='+');
489 update;
490 end;
491 '*':
492 begin
493 expandall(getnode(new_focus));
494 update;
495 end;
496 else
497 handled:=false;
498 end;
499 end;
500 if new_focus<0 then
501 new_focus:=0;
502 if new_focus>=limit.y then
503 new_focus:=limit.y-1;
504 if foc<>new_focus then
505 set_focus(new_focus);
506 if handled then
507 clearevent(event);
508 end;
509 evMouseDown:
510 begin
511 count:=1;
512 mouse_drag:=false;
513 repeat
514 makelocal(event.where,mouse);
515 if mouseinview(event.where) then
516 new_focus:=delta.y+mouse.y
517 else
518 begin
519 inc(count,byte(event.what=evMouseAuto));
520 if count and skip_mouse_events=0 then
521 begin
522 if mouse.y<0 then
523 dec(new_focus);
524 if mouse.y>=size.y then
525 inc(new_focus);
526 end;
527 end;
528 if new_focus<0 then
529 new_focus:=0;
530 if new_focus>=limit.y then
531 new_focus:=limit.y-1;
532 if foc<>new_focus then
533 set_focus(new_focus);
534 m:=mouseevent(event,evMouseMove+evMouseAuto);
535 if m then
536 mouse_drag:=true;
537 until not m;
538 if event.double then
539 selected(foc)
540 else if not mouse_drag then
541 begin
542 cur:=graph_of_focus(graph);
543 if mouse.x<length(graph) then
544 begin
545 adjust(cur,not isexpanded(cur));
546 update;
547 end;
548 end;
549 end;
550 end;
551 end;
552
553
Toutlineviewer.haschildrennull554 function Toutlineviewer.haschildren(node:pointer):boolean;
555
556 begin
557 abstract;
558 end;
559
isexpandednull560 function Toutlineviewer.isexpanded(node:pointer):boolean;
561
562 begin
563 abstract;
564 end;
565
isselectednull566 function Toutlineviewer.isselected(i:sw_integer):boolean;
567
568 begin
569 isselected:=foc=i;
570 end;
571
572 procedure Toutlineviewer.selected(i:sw_integer);
573
574 begin
575 {Does nothing by default.}
576 end;
577
578 procedure Toutlineviewer.set_focus(Afocus:sw_integer);
579
580 begin
581 assert((Afocus>=0) and (Afocus<limit.y));
582 focused(Afocus);
583 if Afocus<delta.y then
584 scrollto(delta.x,Afocus)
585 else if Afocus-size.y>=delta.y then
586 scrollto(delta.x,Afocus-size.y+1);
587 drawview;
588 end;
589
590 procedure Toutlineviewer.setstate(Astate:word;enable:boolean);
591
592 begin
593 if Astate and sffocused<>0 then
594 drawview;
595 inherited setstate(Astate,enable);
596 end;
597
598 procedure Toutlineviewer.update;
599
600 var count:sw_integer;
601 maxwidth:byte;
602
603 procedure check_item(cur:pointer;level,position:sw_integer;
604 lines:longint;flags:word);
605
606 var width:word;
607
608 begin
609 inc(count);
610 width:=length(gettext(cur))+length(getgraph(level,lines,flags));
611 if width>maxwidth then
612 maxwidth:=width;
613 end;
614
615 begin
616 count:=0;
617 maxwidth:=0;
618 foreach(@check_item);
619 setlimit(maxwidth,count);
620 set_focus(foc);
621 end;
622
623 {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
624 { Toutline object methods }
625 {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
626
627 constructor Toutline.init(var bounds:Trect;
628 AHscrollbar,AVscrollbar:Pscrollbar;
629 Aroot:Pnode);
630
631 begin
632 inherited init(bounds,AHscrollbar,AVscrollbar);
633 root:=Aroot;
634 update;
635 end;
636
637 procedure Toutline.adjust(node:pointer;expand:boolean);
638
639 begin
640 assert(node<>nil);
641 Pnode(node)^.expanded:=expand;
642 end;
643
getnumchildrennull644 function Toutline.getnumchildren(node:pointer):sw_integer;
645
646 var p:Pnode;
647
648 begin
649 assert(node<>nil);
650 p:=Pnode(node)^.childlist;
651 getnumchildren:=0;
652 while p<>nil do
653 begin
654 inc(getnumchildren);
655 p:=p^.next;
656 end;
657 end;
658
getchildnull659 function Toutline.getchild(node:pointer;i:sw_integer):pointer;
660
661 begin
662 assert(node<>nil);
663 getchild:=Pnode(node)^.childlist;
664 while i<>0 do
665 begin
666 dec(i);
667 getchild:=Pnode(getchild)^.next;
668 end;
669 end;
670
Toutline.getrootnull671 function Toutline.getroot:pointer;
672
673 begin
674 getroot:=root;
675 end;
676
Toutline.gettextnull677 function Toutline.gettext(node:pointer):string;
678
679 begin
680 assert(node<>nil);
681 gettext:=Pnode(node)^.text^;
682 end;
683
haschildrennull684 function Toutline.haschildren(node:pointer):boolean;
685
686 begin
687 assert(node<>nil);
688 haschildren:=Pnode(node)^.childlist<>nil;
689 end;
690
Toutline.isexpandednull691 function Toutline.isexpanded(node:pointer):boolean;
692
693 begin
694 assert(node<>nil);
695 isexpanded:=Pnode(node)^.expanded;
696 end;
697
698 destructor Toutline.done;
699
700 begin
701 disposenode(root);
702 inherited done;
703 end;
704
705 end.
706