Carousel Volume 2 #1/carousel.iso/mactosh/tech/protocol.hqx/ProtocolSources.pit/UProtocolchart.inc1.p

Text File | 1986-02-04 | 15.6 KB | 798 lines

{copyright 1986 by Herb Barad}
{Protocol is a program to produce a PICT representation of a class}
{hierarchy from a textual description.}
{parts from Flow MacApp sample - copyright 1986 by Apple Computer}

CONST
 maxKeyword = 32;

 picDwgBeg = 130;
 picDwgEnd = 131;
 picGrpBeg = 140;
 picGrpEnd = 141;
 picTxtBeg = 150;
 picTxtEnd = 151;

 nMdrwSizes = 8;


TYPE
 HTxtPicRec = ^PTxtPicRec;
 PTxtPicRec = ^TTxtPicRec;
 TTxtPicRec = PACKED RECORD
               tJus:   Byte;
               tFlip:  Byte;
               tRot:   Byte;
               tLine:  Byte;
               tXtra:  Byte;
               END;
 PByte = ^Byte;


 KWSpec = RECORD
           keyword:      KeyStr;
           itsShape:     KShape;
           itsAlignment: KAlignment;
           itsStyle:     Style;
           END;

 KWTable = ARRAY[0..maxKeyword] OF KWSpec;

VAR
 nKeywords:     INTEGER;
 keywordTable:    KWTable;
 commentHandle: Handle;

 mDrwSizes:     ARRAY[1..nMdrwSizes] OF INTEGER; {font sizes in MacDraw}


 PROCEDURE InitProtocolchart;
 BEGIN
  nKeyWords := 0;

  WITH keywordTable[0] DO
   BEGIN
    keyword := 'default';
    itsShape := shNone;
    itsAlignment := alMiddle;
    itsStyle := [];
   END;

  commentHandle := NewHandle(0);

  mDrwSizes[1] := 09;
  mDrwSizes[2] := 10;
  mDrwSizes[3] := 12;
  mDrwSizes[4] := 14;
  mDrwSizes[5] := 18;
  mDrwSizes[6] := 24;
  mDrwSizes[7] := 36;
  mDrwSizes[8] := 48;
 END;


 PROCEDURE AddKeyword(aKeyWord: KeyStr; aShape: KShape; anAlignment: KAlignment; aStyle: Style);
 BEGIN
  IF nKeywords < maxKeyword THEN
   BEGIN
   nKeywords := nKeyWords + 1;
   WITH keywordTable[nKeywords] DO
    BEGIN
    keyword := aKeyWord;
    itsShape := aShape;
    itsAlignment := anAlignment;
    itsStyle := aStyle;
    END;
   END;
 END;


 PROCEDURE TNode.INode(aTree: TTree;
         aCaption : String80;
         anAlignment : KAlignment;
         aStyle : Style;
         aShape : KShape;
         aNumber : NumStr);
  VAR
   gZeroRect: Rect;
 BEGIN
  fFirstChild := NIL;
  fNextChild := NIL;
  fTree := aTree;
  fCaption := aCaption;
  fAlignment := anAlignment;
  fFace := aStyle;
  fNumber := aNumber;

  IF aShape = shDRect THEN
   BEGIN
   aShape := shRect;
   fDoubled := TRUE;
   END
  ELSE
   fDoubled := FALSE;
  fShapeKind := aShape;

  SetRect(gZeroRect, 0, 0, 0, 0);
  fBounds := gZeroRect;
 END;


 PROCEDURE TNode.Free;
 BEGIN
  FreeObject(fFirstChild);
  FreeObject(fNextChild);
  INHERITED Free;
 END;


{$IFC qDebug}
{$IFC qTrace}{$D+}{$ENDC}
 PROCEDURE TNode.Inspect; OVERRIDE;
 BEGIN
  INHERITED Inspect;

  Writeln('"', fCaption, '"');

  Write('fFirstChild = ');
  WritePtr(fFirstChild);
  Write('  fNextChild = ');
  WritePtr(fNextChild);
  Write('  fBounds = ');
  WriteRect(fBounds);
  Writeln;

  Write('fAlignment = ',     ORD(fAlignment):1,
          '  fNumber = ', fNumber,
          '  fShapeKind = ', ORD(fShapeKind):1);
  IF fDoubled THEN
   Writeln('  doubled')
  ELSE
   Writeln;
 END;
{$IFC qTrace}{$D++}{$ENDC}
{$ENDC}


 PROCEDURE TNode.AddChild (child : TNode);
  VAR
   sib : TNode;
 BEGIN
  IF fFirstChild = NIL THEN
   fFirstChild := child
  ELSE
   BEGIN
    sib := fFirstChild;
    while sib.fNextChild <> NIL do
     sib := sib.fNextChild;
    sib.fNextChild := child;
   END;
 END;


 PROCEDURE TNode.AddLinkHeight (sib : TNode;
         VAR v : INTEGER);
 BEGIN
  WITH fTree do
   BEGIN
   IF (sib <> NIL) and (fShapeKind <> shNone) THEN
    v := v + 2 * fPenThickness + fSpacing
   ELSE IF fShapeKind = shOval THEN
    v := v + fPenThickness + fSpacing;

   IF fShapeKind <> shNone THEN
    v := v + fShadow;
   END;
 END;


 PROCEDURE TNode.Condense;
  VAR
   sib, child : TNode;
 BEGIN
  IF (fShapeKind = shRect) and (fFirstChild = NIL) THEN
   BEGIN
    sib := fNextChild;
    IF sib <> NIL THEN
     IF (sib.fFirstChild = NIL) and (sib.fShapeKind = shRect) THEN
      BEGIN
       fShapeKind := shRectNone;
       fNextChild := NIL;
       fFirstChild := sib;
       child := sib;
       while child <> NIL do
        IF (child.fFirstChild = NIL) and (child.fShapeKind = shRect) THEN
         BEGIN
          child.fShapeKind := shNone;
          sib := child;
          child := child.fNextChild;
         END
        ELSE
         BEGIN
          fNextChild := child;
          sib.fNextChild := NIL;
          child := NIL;
         END;
      END;
   END
  ELSE
   BEGIN
    child := fFirstChild;
    IF (child <> NIL) and (fAlignment <> alLeft) and (fShapeKind <> shNone) THEN
     fShapeKind := shRoundRect;
    while child <> NIL do
     BEGIN
      child.Condense;
      child := child.fNextChild;
     END;
   END;
 END;


 PROCEDURE TNode.Draw(area: Rect; forPicture: BOOLEAN);
  VAR
   ignore: Rect;
   endPt:  Point;
   intersect: BOOLEAN;

 BEGIN
  intersect := SectRect(area, fBounds, ignore);

  IF forPicture AND (fShapeKind <> shNone) THEN {don't group if there is no enclosure}
   PicComment(picGrpBeg, 0, NIL);

  DrawEnclosure(forPicture);
  DrawCaption(forPicture);
  endPt := thePort^.pnLoc;

  IF forPicture AND (fShapeKind <> shNone) THEN
   PicComment(picGrpEnd, 0, NIL);

  IF intersect THEN
   DrawChildren(area, forPicture);

  IF fNumber <> '' THEN
   DrawNumber(area, forPicture, endPt);
 END;


 PROCEDURE TNode.DrawCaption(forPicture: BOOLEAN);
  VAR
   w, h, v, ignore : INTEGER;
   s: String80;
 BEGIN
  MeasureText(v, ignore, w);
  v := fBounds.top + v;

  IF forPicture THEN
   BEGIN
   SetHandleSize(commentHandle, SIZEOF(TTxtPicRec));
   WITH HTxtPicRec(commentHandle)^^ DO
    BEGIN
    CASE fAlignment OF
     alLeft:   tJus := 1;
     alMiddle: tJus := 2;
     alRight:  tJus := 3;
     OTHERWISE tJus := 1;
     END;

    tFlip := 0;
    tRot := 0;
    tLine := 2;
    tXtra := 0
    END;

   PicComment(picTxtBeg, SIZEOF(TTxtPicRec), commentHandle);

   SetHandleSize(commentHandle, 0);
   END;

  case fAlignment OF
   alLeft :
    h := fBounds.left + fTree.fTypeSize;
   alMiddle :
    h := (fBounds.left + fBounds.right - w) div 2;
   alRight :
    h := fBounds.right - fTree.fTypeSize - w;
  END;

  MoveTo(h, v);
  s := fCaption; {In case of heap compaction}
  DrawString(s);

  IF forPicture THEN
   PicComment(picTxtEnd, 0, NIL);
 END;


 PROCEDURE TNode.DrawChildren(area: Rect; forPicture: BOOLEAN);
  VAR
   child : TNode;
 BEGIN
  child := fFirstChild;
  while child <> NIL do
   BEGIN
    child.Draw(area, forPicture);
    child.DrawLink(child.fNextChild, forPicture);
    child := child.fNextChild;
   END;
 END;


 PROCEDURE TNode.DrawEnclosure(forPicture: BOOLEAN);
  VAR
    thickness, roundness, shadowOffset: INTEGER;
    r: Rect;
    shadow: Rect;
 BEGIN
   WITH fTree do
    BEGIN
    thickness := fPenThickness;
    roundness := 3 * fTypeSize;
    r := fBounds;
    END;

   shadowOffset := fTree.fShadow;
   IF shadowOffset > 0 THEN
    BEGIN
    shadow := r;
    OffsetRect(shadow, shadowOffset, shadowOffset);
    END;

   IF forPicture THEN
    InsetRect(r, (thickness+1) DIV 2, (thickness+1) DIV 2);

   PenSize(thickness, thickness);

   case fShapeKind OF
    shRect, shRectNone :
     BEGIN
     IF shadowOffset > 0 THEN
      BEGIN
      FillRect(shadow, black);
      FillRect(r, white);
      END;
     FrameRect(r);

     IF fDoubled THEN
      BEGIN
      InsetRect(r, (3 * thickness) DIV 2 + 2, 0);
      FrameRect(r);
      END;
     END;

    shOval :
     BEGIN
     IF shadowOffset > 0 THEN
      BEGIN
      FillOval(shadow, black);
      FillOval(r, white);
      END;
     FrameOval(r);
     END;

    shRoundRect :
     BEGIN
     IF shadowOffset > 0 THEN
      BEGIN
      FillRoundRect(shadow, roundness, roundness, black);
      FillRoundRect(r, roundness, roundness, white);
      END;

     FrameRoundRect(r, roundness, roundness);
     END;

    shNone :
   END;
 END;


 PROCEDURE TNode.DrawLink(sib : TNode; forPicture: BOOLEAN);
  VAR
   h, v : INTEGER;
 BEGIN
 { do nothing, so that we have no links between sibling classes.
  IF (sib <> NIL) and (fShapeKind <> shNone) THEN
   BEGIN
    with fBounds do
     BEGIN
      h := (left + right) div 2;
      v := bottom;
     END;
    MoveTo(h, v);
    LineTo(h, sib.fBounds.top);
   END;
 }
 END;


 PROCEDURE TNode.DrawNumber(area: Rect; forPicture: BOOLEAN; endCaption: Point);
  VAR
    thickness: INTEGER;
    widHalf: INTEGER;
    htHalf: INTEGER;
    s: NumStr;
    r: Rect;
    f: FontInfo;
    x: INTEGER;
    dh: INTEGER;
    dv: INTEGER;

 BEGIN
  IF forPicture THEN
   PicComment(picGrpBeg, 0, NIL);

  thickness := fTree.fPenThickness * 2;
  IF thickness > 4 THEN
   thickness := 4;

  TextFont(fTree.fTypeFont);
  TextFace([bold]);
  TextSize(fTree.fTypeSize);
  GetFontInfo(f);
  PenSize(thickness, thickness);

  s := fNumber;
  widHalf := StringWidth(s) DIV 2 + 2 * thickness;
  htHalf := (f.ascent + f.descent + f.leading) DIV 2 + 2 * thickness;
  IF widHalf > htHalf THEN
   x := widHalf
  ELSE
   x := htHalf;

  endCaption.h := endCaption.h + htHalf * 3;

  SetRect(r, -x, -x, x, x);
  OffsetRect(r, endCaption.h + widHalf - 2 * thickness,
                endCaption.v + htHalf - f.ascent - f.leading - 2 * thickness);

  dh := 0;
  dv := 0;

  IF r.left < 0 THEN
   dh := -r.left
  ELSE IF r.right > fTree.fHead.fBounds.right THEN
   dh := fTree.fHead.fBounds.right - r.right;

  IF r.top < 0 THEN
   dv := -r.top
  ELSE IF r.bottom > fTree.fHead.fBounds.bottom THEN
   dv := fTree.fHead.fBounds.bottom - r.bottom;

  endCaption.h := endCaption.h + dh;
  endCaption.v := endCaption.v + dv;
  OffsetRect(r, dh, dv);

  FillOval(r, white);
  FrameOval(r);
  MoveTo(endCaption.h, endCaption.v);
  DrawString(s);

  IF forPicture THEN
   PicComment(picGrpEnd, 0, NIL);
 END;


 PROCEDURE TNode.Locate (middle : INTEGER;
         VAR v : INTEGER);
  VAR
   dh, dv, ignore : INTEGER;
   child : TNode;
   r: Rect;
 BEGIN
  with fBounds do
   BEGIN
    dh := right;
    dv := bottom;
   END;

  SetRect(r, middle - (dh div 2), v, middle + (dh div 2), v + dv);
  fBounds := r;

  MeasureText(ignore, dv, ignore);
  v := v + dv;

  child := fFirstChild;
  while child <> NIL do
   BEGIN
    child.Locate(middle, v);
    child.AddLinkHeight(child.fNextChild, v);
    child := child.fNextChild;
   END;

  v := fBounds.bottom;
 END;


 PROCEDURE TNode.Measure (VAR dh, dv : INTEGER);
  VAR
   cdh, cdv, ignore : INTEGER;
   child : TNode;
   r: Rect;
 BEGIN
  MeasureText(ignore, dv, dh);

  with fTree do
    dh := dh + 2 * (fTypeSize + fPenThickness);

  IF fDoubled THEN
   dh := dh + 3 * fTree.fPenThickness + 4
  ELSE IF (fShapeKind = shOval) OR (fShapeKind = shRoundRect) THEN {add some slop for these shapes}
   dh := (dh * 9) div 7;

  child := fFirstChild;
  while child <> NIL do
   BEGIN
    cdh := 0;
    cdv := 0;
    child.Measure(cdh, cdv);
    IF cdh > dh THEN
     dh := cdh;
    dv := dv + cdv;
    child.AddLinkHeight(child.fNextChild, dv);
    child := child.fNextChild;
   END;

  IF fFirstChild <> NIL THEN
   IF (fFirstChild.fNextChild<>NIL) or (fShapeKind<>shRoundRect) or (fFirstChild.fShapeKind<>shRoundRect) THEN
    with fTree do
      dh := dh + 2 * (fTypeSize + fPenThickness);

  SetRect(r, 0, 0, dh, dv);

  fBounds := r;

  dh := dh + fTree.fShadow;
  dv := dv + fTree.fShadow;
 END;


 PROCEDURE TNode.MeasureText (VAR topToBase, topToBottom, leftToRight : INTEGER);
  VAR
   typeInfo : FontInfo;
   s : String80;
   isTitle : boolean;
   tSize : INTEGER;
   extraToBottom : INTEGER;
   i: INTEGER;

  BEGIN
  isTitle := (fShapeKind = shNone) and (fTree.fPath[0] = self);

  TextFont(fTree.fTypeFont);
  TextFace(fFace);
  tSize := fTree.fTypeSize;
  IF isTitle THEN
   BEGIN
   i := 1;
   WHILE (i < nMdrwSizes) & (tSize >= mDrwSizes[i]) DO
     i := i + 1;

   tSize := mDrwSizes[i];
   END;

  TextSize(tSize);

  GetFontInfo(typeInfo);

  s := fCaption; {In case of heap compaction}
  leftToRight := StringWidth(s);

  IF not gNowPrinting THEN
   IF italic in fFace THEN
    leftToRight := leftToRight + typeInfo.ascent - 2 * typeInfo.descent;

  extraToBottom := fTree.fPenThickness + fTree.fSpacing;
  topToBase := typeInfo.ascent + extraToBottom;

  IF fShapeKind = shOval THEN {oval}
   BEGIN
    topToBase := topToBase + fTree.fSpacing;
    extraToBottom := extraToBottom + ord(odd(topToBase))
   END
  ELSE IF fShapeKind = shRectNone THEN {first in a multi-line box}
   extraToBottom := -fTree.fPenThickness - 3
  ELSE IF fShapeKind = shNone THEN
   IF isTitle THEN {title}
     extraToBottom := topToBase + typeInfo.descent
   ELSE IF fNextChild <> NIL THEN {middle of a multi-line box}
    extraToBottom := -fTree.fPenThickness - 2;

  topToBottom := topToBase + typeInfo.descent + extraToBottom + fTree.fSpacing;
 END;


 PROCEDURE TTree.ITree (aTypeFont, aTypeSize: INTEGER; shadowed: BOOLEAN);
   VAR
    i: INTEGER;
  BEGIN
   fTypeFont := aTypeFont;
   fTypeSize := aTypeSize;

   IF aTypeSize < 12 THEN
    fPenThickness := 1
   ELSE IF aTypeSize < 24 THEN
    fPenThickness := 2
   ELSE
    fPenThickness := 4;

   IF shadowed THEN
    fShadow := (fPenThickness + 3) DIV 2
   ELSE
    fShadow := 0;

   fSpacing := 1;
   fHead := NIL;
   fLastLevel := -2;
  END;


 PROCEDURE TTree.Free;
  BEGIN
   IF fLastLevel > -2 THEN
    fPath[-1].Free;
    INHERITED Free;
  END;


 PROCEDURE TTree.Draw(area: Rect; forPicture: BOOLEAN);
  BEGIN
   IF forPicture THEN
    PicComment(picDwgBeg, 0, NIL);

   PenNormal;
   fHead.Draw(area, forPicture);

   IF forPicture THEN
    PicComment(picDwgEnd, 0, NIL);
  END;


 PROCEDURE TTree.GenLine (inputLine : String80);
  VAR
   level, len, position : INTEGER;
   longerLine: STRING[82];
   aCaption, keyword : String80;
   anAlignment : KAlignment;
   aStyle : Style;
   aShape : KShape;
   aNumber : NumStr;
   dummy: STRING[1];
   kwIndex: INTEGER;

 BEGIN
  dummy := '$';
  len := Length(inputLine);
  longerLine := Concat(inputLine, ' ');
  position := 1;
  {Advance past tabs, spaces, etc - i.e. find level}
  while (position <= len) & (ord(longerLine[position]) <= ord(' ')) do
   position := position + 1;
  IF position > len THEN
   exit(GenLine);
  level := position - 1;

  keyword := '';
  while (position <= len) & (ord(longerLine[position]) > ord(' ')) & (longerLine[position] <> '*') do
   BEGIN
    dummy[1] := longerLine[position];
    keyword := Concat(keyword, dummy);
    position := position + 1;
   END;

  kwIndex := nKeywords;
  WHILE kwIndex > 0 DO
   BEGIN
   IF keyword = keywordTable[kwIndex].keyword THEN
    LEAVE;
   kwIndex := kwIndex - 1;
   END;

  IF kwIndex = 0 THEN
   position := level + 1;  {revert line ptr back to before keyword}

  WITH keywordTable[kwIndex] DO
   BEGIN
   anAlignment := itsAlignment;
   aStyle := itsStyle;
   aShape := itsShape;
   END;

  IF longerLine[position] = '*' THEN
   BEGIN
   aStyle := aStyle + [bold];
   position := position + 1;
   END;

  while (position <= len) & (ord(longerLine[position]) <= ord(' ')) do
   position := position + 1;

  Delete(longerLine, 1, position - 1); {delete keyword}
  len := len - (position - 1); {adjust len accordingly}

  position := Pos('#', longerLine);
  IF position > 0 THEN
   BEGIN
   IF len - position > kMaxNumStr THEN
    len := kMaxNumStr + position;

   aNumber := Copy(longerLine, position+1, len-position);
   len := position - 1;
   END
  ELSE
   aNumber := '';

  aCaption := Copy(longerLine, 1, len);

  GenNode(level, aCaption, anAlignment, aStyle, aShape, aNumber);
 END;


 PROCEDURE TTree.GenNode (level : INTEGER;
         aCaption : String80;
         anAlignment : KAlignment;
         aStyle : Style;
         aShape : KShape;
         aNumber : NumStr);
  VAR
   nd : TNode;
 BEGIN
  IF level >= maxDepth THEN
   GenNode(maxDepth, aCaption, anAlignment, aStyle + [shadow], aShape, aNumber)
  ELSE
   BEGIN
   New(nd);
   fPath[level] := nd;
   nd.INode(self, aCaption, anAlignment, aStyle, aShape, aNumber);
   IF level >= 0 THEN
    BEGIN
    IF level > (fLastLevel + 1) THEN
     GenNode(level - 1, 'MISSING LEVEL', alMiddle, [outline], shRect, '');
    fPath[level - 1].AddChild(nd);
    END;
   fLastLevel := level;
   END;
 END;


 PROCEDURE TTree.Layout (VAR viewRect : Rect);
   VAR
    dh, dv, dhPage, dvPage, dhView, dvView, h, v : INTEGER;
  BEGIN
   IF fLastLevel < 0 THEN
    GenNode(0, 'NO TEXT', alMiddle, [outline], shRect, '');

   IF fPath[0].fNextChild = NIL THEN
    fHead := fPath[0]
   ELSE
    fHead := fPath[-1];

   fHead.Condense;
   dh := 0;
   dv := 0;
   fHead.Measure(dh, dv);

   SetRect(viewRect, 0, 0, dh+15, dv+15);
   h := (dh + 1) div 2 + 10;
   v := 0 + 10;
   fHead.Locate(h, v);
  END;


 PROCEDURE TTree.SetFont (aTypeFont : INTEGER);
  BEGIN
   fTypeFont := aTypeFont;
  END;


 PROCEDURE TTree.SetSize (aTypeSize : INTEGER);
  BEGIN
   fTypeSize := aTypeSize;
  END;


 PROCEDURE TTree.SetThickness (aPenThickness : INTEGER);
  BEGIN
   fPenThickness := aPenThickness;
  END;