UNSAFE MODULE-------------------------------------------------------------- raw data ---ShowNew EXPORTSMain ; IMPORT Stdio, Rd, Wr, Thread, Word, Text, (*ViewportVBT,*) Trestle; IMPORT VBT, PaintOp, TrestleComm, Color, Region, Rect, Point; IMPORT AnchorBtnVBT, TextVBT, BorderedVBT, MenuBtnVBT, Split, HVSplit; IMPORT ButtonVBT, Axis, Font, VBTClass, Fmt, Process, HVBar; IMPORT ZIO; CONST (* Copied from RTHeapInfo.i3 due to version skew... *) SENDING_TYPES = -23; SENDING_COUNTS = -24; TYPE Vector = REF ARRAY OF INTEGER; CONST ControlNames = ARRAY [0..9] OF TEXT { "start", NIL, "new object count", "new byte size", "total object count", "total byte size", "lap object count", "lap byte size", NIL, "quit" }; TYPE CompareProc = PROCEDURE (a, b: INTEGER): INTEGER; CONST CompareProcs = ARRAY [0..5] OF CompareProc { CompareCnts, CompareBytes, CompareTotalCnts, CompareTotalBytes, CompareLapCnts, CompareLapBytes }; CONST Titles = ARRAY [0..5] OF TEXT { " new object counts ", " new byte sizes ", " total object counts ", " total byte sizes ", " lap object counts ", " lap byte sizes " };
VAR n_types : INTEGER := 0; type_names : REF ARRAY OF TEXT; type_sizes : Vector; cur_cnts : Vector; cur_bytes : Vector; total_cnts : Vector; total_bytes : Vector; lap_cnts : Vector; lap_bytes : Vector; sort_map : Vector; root : VBT.T; title : TextVBT.T; lap_title : TextVBT.T; display : BarGraphVBT; max_value : INTEGER := 10; max_stat : INTEGER := 0; disp_stat : INTEGER := 0; compare : CompareProc := CompareCnts; colors : REF ARRAY OF PaintOp.T; started : BOOLEAN := FALSE; lap_running : BOOLEAN := FALSE;-------------------------------------------------------- build the VBTs ---
PROCEDURESetupVBT () = <*FATAL TrestleComm.Failure*> VAR control, start, menu_bar, viewport: VBT.T; BEGIN control := BuildMenu ("control...", ControlNames, SetControl); lap_title := TextVBT.New ("lap start"); start := BorderedVBT.New (MenuBtnVBT.New (lap_title, StartPress, NIL)); title := TextVBT.New (Titles[disp_stat]); menu_bar := ButtonVBT.MenuBar (control, start, title); display := NEW (BarGraphVBT);
viewport := NEW (ViewportVBT.T).init (display, scrollStyle := ViewportVBT.ScrollStyle.Auto); viewport := BorderedVBT.New (display);
viewport := display; root := HVSplit.Cons (Axis.T.Ver, menu_bar, viewport); (* VBT.NewShape (display); *) Trestle.Install (root); END SetupVBT;----------------------------------------------------------------- menus ---
TYPE MenuProc = PROCEDURE (i: INTEGER); MenuClosure = REF RECORD id : INTEGER; tag : TEXT; proc : MenuProc; END; PROCEDURE---------------------------------------------------------------- colors ---BuildMenu (name: TEXT; READONLY tags: ARRAY OF TEXT; p: MenuProc): VBT.T = VAR menu: VBT.T; m: MenuClosure; id := 0; BEGIN menu := HVSplit.New (Axis.T.Ver); FOR i := 0 TO LAST (tags) DO IF tags[i] # NIL THEN m := NEW (MenuClosure, id := id, tag := tags[i], proc := p); INC (id); Split.AddChild (menu, MenuBtnVBT.TextItem (tags[i], MenuPress, m)); ELSE Split.AddChild (menu, HVBar.New (size := 1.0)); END; END; RETURN BorderedVBT.New ( AnchorBtnVBT.New ( TextVBT.New (name), BorderedVBT.New (menu), 99999)); END BuildMenu; PROCEDUREMenuPress (v: ButtonVBT.T; <*UNUSED*>READONLY cd: VBT.MouseRec) = VAR m: MenuClosure := VBT.GetProp (v, TYPECODE (MenuClosure)); BEGIN m.proc (m.id); END MenuPress; PROCEDUREStartPress (<*UNUSED*> v: ButtonVBT.T; <*UNUSED*>READONLY cd: VBT.MouseRec) = BEGIN IF NOT started THEN RETURN END; LOCK display DO IF (lap_running) THEN (* capture the final lap values *) FOR i := 0 TO n_types-1 DO lap_cnts[i] := total_cnts[i] - lap_cnts[i]; lap_bytes[i] := total_bytes[i] - lap_bytes[i]; END; lap_running := FALSE; TextVBT.Put (lap_title, "lap start"); ELSE (* capture the initial lap values *) lap_cnts^ := total_cnts^; lap_bytes^ := total_bytes^; lap_running := TRUE; TextVBT.Put (lap_title, "lap stop"); END; END; lap_title.redisplay (); IF (disp_stat = 4) OR (disp_stat = 5) THEN display.redisplay (); END; END StartPress; PROCEDURESetControl (i: INTEGER) = BEGIN IF (i = 0) THEN Go (); ELSIF (i <= 6) THEN disp_stat := i - 1; compare := CompareProcs [disp_stat]; TextVBT.Put (title, Titles[disp_stat]); UpdateMax (); Sort (); display.redisplay (); ELSE Process.Exit (0); END; END SetControl;
PROCEDURE------------------------------------------------------------- bar graph ---CreateColors () = (* LL=display *) VAR j: INTEGER := 0; BEGIN colors := NEW (REF ARRAY OF PaintOp.T, n_types); FOR i := 0 TO n_types-1 BY 2 DO colors[i] := NewColor (j); INC (j); END; FOR i := 1 TO n_types-1 BY 2 DO colors[i] := NewColor (j); INC (j); END; END CreateColors; PROCEDURENewColor (i: INTEGER): PaintOp.T = (* LL=display *) VAR rgb: Color.T; hsv: Color.HSV; BEGIN hsv.h := FLOAT (i) / FLOAT (n_types); hsv.s := 1.0; hsv.v := 1.0; rgb := Color.FromHSV (hsv); RETURN PaintOp.FromRGB (rgb.r, rgb.g, rgb.b); END NewColor;
CONST Vertical_gap = 15; (* pixel height of the bars *) Vertical_base = 17; (* veritcal offset of the first row *) Tag_base = 5; (* horizontal offset of the labels *) Bar_base = 150; (* horizontal offset of the bottom of the bars *) Num_width = 25; (* pixels to leave for the numbers *) Min_bar_length = 150; VAR bar_length := 250; (* length in pixels of a full bar *) TYPE BarGraphVBT = VBT.Leaf OBJECT rect: Rect.T; OVERRIDES repaint := RepaintBarGraph; reshape := ReshapeBarGraph; shape := ShapeBarGraph; END; PROCEDURE---------------------------------------------------------------------------ShapeBarGraph (<*UNUSED*> self: BarGraphVBT; ax : Axis.T; <*UNUSED*> n : CARDINAL ): VBT.SizeRange = VAR sz: INTEGER; BEGIN IF (ax = Axis.T.Hor) THEN sz := 2 * Tag_base + Bar_base + Min_bar_length + Num_width; ELSE sz := Vertical_base + 4 * Vertical_gap; END; RETURN VBT.SizeRange {lo := sz, pref := sz, hi := 100000}; END ShapeBarGraph; PROCEDUREReshapeBarGraph (self: BarGraphVBT; READONLY cd: VBT.ReshapeRec) = CONST Used = Bar_base + 2 * Tag_base + Num_width; BEGIN self.rect := cd.new; bar_length := (cd.new.east - cd.new.west) - Used; RepaintBarGraph (self, Region.T{r := cd.new}); END ReshapeBarGraph; PROCEDURERepaintBarGraph (self: BarGraphVBT; <*UNUSED*> READONLY rgn : Region.T ) = VAR x, y: INTEGER; name: TEXT; value: INTEGER; BEGIN (** VBT.PaintTint (self, self.rect, PaintOp.Bg); **) EraseBar (-2); y := -2; (* repaint the ruler *) EraseBar (-1); y := -1; PaintRuler (); (* repaint each of the bars *) FOR i := 0 TO n_types-1 DO EraseBar (i); y := i; IF (VPos (i) >= self.rect.south) THEN EXIT; END; x := sort_map [i]; name := type_names[x]; value := GetStat (x); IF (value > 0) THEN VBT.PaintTint (self, GetBar (i, value), colors[x]); VBT.PaintText (self, Rect.Full, TagBase (i), Font.BuiltIn, name); VBT.PaintText (self, Rect.Full, NumBase (name, value, i), Font.BuiltIn, Fmt.Int (value)); END; END; (* finish erasing *) WHILE (VPos (y) <= self.rect.south) DO EraseBar (y); INC (y); END; END RepaintBarGraph; PROCEDUREEraseBar (ver: INTEGER) = VAR r: Rect.T; BEGIN r.west := display.rect.west; r.east := display.rect.east; r.north := VPos (ver); r.south := r.north + Vertical_gap; VBT.PaintTint (display, r, PaintOp.Bg); END EraseBar; PROCEDUREGetBar (ver, value: INTEGER): Rect.T = VAR r: Rect.T; BEGIN r.north := VPos (ver); r.south := r.north + Vertical_gap; r.west := display.rect.west + Bar_base; (*== HPos(0) *) r.east := HPos (value); RETURN r; END GetBar; PROCEDURETagBase (ver: INTEGER): Point.T = VAR p: Point.T; BEGIN p.h := display.rect.west + Tag_base; p.v := VPos (ver+1) - 1; RETURN p; END TagBase; PROCEDURENumBase (name: TEXT; value, ver: INTEGER): Point.T = VAR p := TagBase (ver); BEGIN p.h := MAX (p.h + TWidth (name) + 6, HPos (value) + 2); RETURN p; END NumBase; PROCEDUREVPos (row: INTEGER): INTEGER = BEGIN RETURN display.rect.north + Vertical_base + Vertical_gap * row; END VPos; PROCEDUREHPos (value: INTEGER): INTEGER = VAR len := FLOAT(value) / FLOAT (max_value) * FLOAT(bar_length); BEGIN RETURN display.rect.west + Bar_base + ROUND (len); END HPos; PROCEDUREPaintRuler () = VAR pt: Point.T; n, wid: INTEGER; txt: TEXT; BEGIN pt.v := VPos (0) - 1; pt.h := HPos (0); VBT.PaintText (display, Rect.Full, pt, Font.BuiltIn, "0"); n := max_value DIV 2; txt := Fmt.Int (n); wid := TWidth (txt); pt.h := HPos (n) - wid DIV 2; VBT.PaintText (display, Rect.Full, pt, Font.BuiltIn, txt); n := max_value; txt := Fmt.Int (n); wid := TWidth (txt); pt.h := HPos (n) - wid; VBT.PaintText (display, Rect.Full, pt, Font.BuiltIn, Fmt.Int (max_value)); END PaintRuler; PROCEDURETWidth (txt: TEXT): INTEGER = BEGIN RETURN VBT.TextWidth (display, txt, Font.BuiltIn); END TWidth;
PROCEDURE----------------------------------------------------- type descriptions ---Run () = VAR cmd: INTEGER; BEGIN TRY LOOP cmd := ZIO.GetInt (); IF (cmd = SENDING_COUNTS) THEN GetData (); ELSIF (cmd = SENDING_TYPES) THEN GetTypes (); ELSE (* the data stream is out of synch, just ignore the data... *) END; END; EXCEPT | Rd.EndOfFile => END; END Run;
PROCEDURE----------------------------------------------------------- sample data ---GetTypes () RAISES {Rd.EndOfFile} = VAR n_new : INTEGER; new_n_types : INTEGER; new_type_names : REF ARRAY OF TEXT; new_type_sizes : Vector; new_cur_cnts : Vector; new_cur_bytes : Vector; new_total_cnts : Vector; new_total_bytes : Vector; new_lap_cnts : Vector; new_lap_bytes : Vector; new_sort_map : Vector; BEGIN n_new := ZIO.GetInt (); new_n_types := n_types + n_new; new_type_names := NEW (REF ARRAY OF TEXT, new_n_types); new_type_sizes := NewVec (new_n_types); new_cur_cnts := NewVec (new_n_types); new_cur_bytes := NewVec (new_n_types); new_total_cnts := NewVec (new_n_types); new_total_bytes := NewVec (new_n_types); new_lap_cnts := NewVec (new_n_types); new_lap_bytes := NewVec (new_n_types); new_sort_map := NewVec (new_n_types); IF (n_types > 0) THEN (* preserve the old data *) SUBARRAY (new_type_names^, 0, n_types) := type_names^; SUBARRAY (new_type_sizes^, 0, n_types) := type_sizes^; SUBARRAY (new_cur_cnts^, 0, n_types) := cur_cnts^; SUBARRAY (new_cur_bytes^, 0, n_types) := cur_bytes^; SUBARRAY (new_total_cnts^, 0, n_types) := total_cnts^; SUBARRAY (new_total_bytes^, 0, n_types) := total_bytes^; SUBARRAY (new_lap_cnts^, 0, n_types) := lap_cnts^; SUBARRAY (new_lap_bytes^, 0, n_types) := lap_bytes^; END; (* read the new type descriptors *) FOR i := n_types TO new_n_types-1 DO new_type_sizes[i] := ZIO.GetInt (); new_type_names[i] := FixName (ZIO.GetText ()); END; FOR i := 0 TO new_n_types-1 DO new_sort_map[i] := i; END; (* finally, fix up the globals *) LOCK display DO type_names := new_type_names; type_sizes := new_type_sizes; cur_cnts := new_cur_cnts; cur_bytes := new_cur_bytes; total_cnts := new_total_cnts; total_bytes := new_total_bytes; lap_cnts := new_lap_cnts; lap_bytes := new_lap_bytes; sort_map := new_sort_map; n_types := new_n_types; CreateColors (); Sort (); END; END GetTypes; PROCEDUREFixName (t: TEXT): TEXT = VAR i: INTEGER; len := Text.Length (t); BEGIN IF len > 3 AND Text.GetChar (t, 0) = 'T' AND Text.GetChar (t, 1) = 'C' AND Text.GetChar (t, 2) = '=' THEN i := 3; WHILE (i < len) AND (Text.GetChar (t, i) # ' ') DO INC (i) END; IF (i < len) THEN t := Text.Sub (t, i+1); END; END; RETURN t; END FixName;
PROCEDURE--------------------------------------------------------------- sorting ---GetData () RAISES {Rd.EndOfFile} = VAR n_elts, n, cnt, size: INTEGER; cnts, bytes: Vector; BEGIN cnts := NewVec (n_types); bytes := NewVec (n_types); (* read the sample *) n_elts := ZIO.GetInt (); FOR i := 0 TO n_elts-1 DO n := ZIO.GetInt (); cnt := ZIO.GetInt (); size := type_sizes [n]; IF size >= 0 THEN size := size * cnt; ELSE size := ZIO.GetInt (); END; cnts [n] := cnt; bytes [n] := size; END; (* update the globals *) LOCK display DO cur_cnts := cnts; cur_bytes := bytes; FOR i := 0 TO n_types-1 DO total_cnts[i] := Word.Plus (total_cnts[i], cnts[i]); total_bytes[i] := Word.Plus (total_bytes[i], bytes[i]); END; UpdateMax (); Sort (); END; display.redisplay (); END GetData; PROCEDUREGetStat (i: INTEGER): INTEGER = VAR v: INTEGER; BEGIN IF (disp_stat = 0) THEN v := cur_cnts[i]; ELSIF (disp_stat = 1) THEN v := cur_bytes[i]; ELSIF (disp_stat = 2) THEN v := total_cnts[i]; ELSIF (disp_stat = 3) THEN v := total_bytes[i]; ELSIF (disp_stat = 4) THEN IF lap_running THEN v := total_cnts[i] - lap_cnts[i]; ELSE v := lap_cnts[i]; END; ELSE (*disp_stat = 5*) IF lap_running THEN v := total_bytes[i] - lap_bytes[i]; ELSE v := lap_bytes[i]; END; END; RETURN v; END GetStat; PROCEDUREUpdateMax () = VAR max := 0; BEGIN FOR i := 0 TO n_types-1 DO max := MAX (max, GetStat (i)); END; IF (disp_stat # max_stat) THEN (* we've changed stats since the last update *) max_value := (3 * max + 1) DIV 2; max_stat := disp_stat; ELSIF (max > max_value) THEN (* make it bigger *) max_value := (3 * max + 1) DIV 2; ELSIF (3 * max < 2 * max_value) AND (max > 5) THEN (* make is smaller *) max_value := MAX (max, 5); END; END UpdateMax;
PROCEDURE******** PROCEDURE CompareTypecodes (a, b: INTEGER): INTEGER = BEGIN RETURN a - b; END CompareTypecodes;Sort () = BEGIN DoSort (compare); END Sort;
PROCEDURE CompareName (a, b: INTEGER): INTEGER = BEGIN RETURN Text.Compare (type_names[a], type_names[b]); END CompareName; *********
PROCEDURE--------------------------------------------------- low-level utilities ---CompareCnts (a, b: INTEGER): INTEGER = VAR aa := cur_cnts [a]; VAR bb := cur_cnts [b]; VAR x := bb - aa; BEGIN IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareCnts; PROCEDURECompareBytes (a, b: INTEGER): INTEGER = VAR aa := cur_bytes [a]; VAR bb := cur_bytes [b]; VAR x := bb - aa; BEGIN IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareBytes; PROCEDURECompareTotalCnts (a, b: INTEGER): INTEGER = VAR aa := total_cnts [a]; VAR bb := total_cnts [b]; VAR x := bb - aa; BEGIN IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareTotalCnts; PROCEDURECompareTotalBytes (a, b: INTEGER): INTEGER = VAR aa := total_bytes [a]; VAR bb := total_bytes [b]; VAR x := bb - aa; BEGIN IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareTotalBytes; PROCEDURECompareLapCnts (a, b: INTEGER): INTEGER = VAR aa := lap_cnts [a]; VAR bb := lap_cnts [b]; VAR x := bb - aa; BEGIN IF lap_running THEN aa := total_cnts[a] - aa; bb := total_cnts[b] - bb; x := bb - aa; END; IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareLapCnts; PROCEDURECompareLapBytes (a, b: INTEGER): INTEGER = VAR aa := lap_bytes [a]; VAR bb := lap_bytes [b]; VAR x := bb - aa; BEGIN IF lap_running THEN aa := total_bytes[a] - aa; bb := total_bytes[b] - bb; x := bb - aa; END; IF (x = 0) AND (aa > 0) THEN x := Text.Compare (type_names[a], type_names[b]); END; RETURN x; END CompareLapBytes; PROCEDUREDoSort (cmp: CompareProc) = BEGIN IF (sort_map = NIL) THEN RETURN END; QuickSort (sort_map^, 0, NUMBER (sort_map^), cmp); InsertionSort (sort_map^, 0, NUMBER (sort_map^), cmp); END DoSort; PROCEDUREQuickSort (VAR a: ARRAY OF INTEGER; lo, hi: INTEGER; cmp: CompareProc) = CONST CutOff = 9; VAR i, j: INTEGER; key, tmp: INTEGER; BEGIN WHILE (hi - lo > CutOff) DO (* sort a[lo..hi) *) (* use median-of-3 to select a key *) i := (hi + lo) DIV 2; IF cmp (a[lo], a[i]) < 0 THEN IF cmp (a[i], a[hi-1]) < 0 THEN key := a[i]; ELSIF cmp (a[lo], a[hi-1]) < 0 THEN key := a[hi-1]; a[hi-1] := a[i]; a[i] := key; ELSE key := a[lo]; a[lo] := a[hi-1]; a[hi-1] := a[i]; a[i] := key; END; ELSE (* a[lo] >= a[i] *) IF cmp (a[hi-1], a[i]) < 0 THEN key := a[i]; tmp := a[hi-1]; a[hi-1] := a[lo]; a[lo] := tmp; ELSIF cmp (a[lo], a[hi-1]) < 0 THEN key := a[lo]; a[lo] := a[i]; a[i] := key; ELSE key := a[hi-1]; a[hi-1] := a[lo]; a[lo] := a[i]; a[i] := key; END; END; (* partition the array *) i := lo+1; j := hi-2; (* find the first hole *) WHILE cmp (a[j], key) > 0 DO DEC (j) END; tmp := a[j]; DEC (j); LOOP IF (i > j) THEN EXIT END; WHILE cmp (a[i], key) < 0 DO INC (i) END; IF (i > j) THEN EXIT END; a[j+1] := a[i]; INC (i); WHILE cmp (a[j], key) > 0 DO DEC (j) END; IF (i > j) THEN IF (j = i-1) THEN DEC (j) END; EXIT END; a[i-1] := a[j]; DEC (j); END; (* fill in the last hole *) a[j+1] := tmp; i := j+2; (* then, recursively sort the smaller subfile *) IF (i - lo < hi - i) THEN QuickSort (a, lo, i-1, cmp); lo := i; ELSE QuickSort (a, i, hi, cmp); hi := i-1; END; END; (* WHILE (hi-lo > CutOff) *) END QuickSort; PROCEDUREInsertionSort (VAR a: ARRAY OF INTEGER; lo, hi: INTEGER; cmp: CompareProc) = VAR j: INTEGER; key: INTEGER; BEGIN FOR i := lo+1 TO hi-1 DO key := a[i]; j := i-1; WHILE (j >= lo) AND cmp (key, a[j]) < 0 DO a[j+1] := a[j]; DEC (j); END; a[j+1] := key; END; END InsertionSort;
PROCEDUREGo () = <*FATAL Wr.Failure, Thread.Alerted*> BEGIN IF NOT started THEN (* let the application begin *) started := TRUE; Wr.PutChar (Stdio.stdout, 'g'); Wr.Flush (Stdio.stdout); END; END Go; PROCEDURENewVec (n: INTEGER): Vector = BEGIN RETURN NEW (Vector, n); END NewVec; BEGIN SetupVBT (); Run (); Trestle.AwaitDelete (root); END ShowNew.