dps/src/OneSlideDLE.m3


Copyright (C) 1994, Digital Equipment Corp.

MODULE OneSlideDLE;

IMPORT DisplayList, DisplayListStack, DPS, DPSWindow, FileWr,
 Linked2Tree, PopupMenuDLE, Rd, SlideLineDLE, Text, Fmt,
 TextRd, TextWr, Thread, TranslateDLE, Wr, OSError;

CONST AllowTranslation = TRUE;

CONST millisecond = 0.001d0;
CONST second      = 1.0d0;

CONST pointsDefault = 24.0;
CONST aboveLeadingDefault = 8.0;
CONST heightDefault = pointsDefault;
CONST belowLeadingDefault = 0.0;
CONST lowLeadingDefault = 0.0;
CONST leftLeadingDefault = 24.0;

CONST pointsDefaultTop = 30.0;
CONST aboveLeadingDefaultTop = 8.0;
CONST heightDefaultTop = pointsDefaultTop;
CONST belowLeadingDefaultTop = 16.0;
CONST leftLeadingDefaultTop = 0.0;

CONST TopMargin = 32.0;
CONST LeftMarginOfLines = 60.0; (* Alas has to factor in the boilerplate. *)
CONST ItemsInitiallyVisible = 1; Cannot be zero. Need to start stack.

CONST DecorationMarginLeft = 20.0;
CONST DecorationMarginRight = 20.0;
CONST DecorationMarginTop = 20.0;
CONST DecorationMarginBottom = 40.0;
^^ Because bottom of screen hard to see.

CONST backgroundPostScript =
" 20.0 ButtonDLEDrawRoundedPath 6.0 setlinewidth 0.5 0.5 0.5 setrgbcolor stroke ";

PROCEDURE BoxFromXYWH (x, y: REAL; w, h: REAL := 0.0): DPS.Box =
 VAR box: DPS.Box;
  BEGIN
  box.low.x := x; box.high.x := x + w;
  box.low.y := y; box.high.y := y + h;
  RETURN box;
  END BoxFromXYWH;

PROCEDURE Repaint (t: T; box: DPS.Box; only: REFANY): TEXT =
 VAR bkgBox: DPS.Box;
  BEGIN
  bkgBox.low.x := t.box.low.x + DecorationMarginLeft;
  bkgBox.high.x := t.box.high.x - DecorationMarginRight;
  bkgBox.low.y := t.box.low.y + DecorationMarginBottom;
  bkgBox.high.y := t.box.high.y - DecorationMarginTop;
  RETURN
    DPS.GSaveAndClip(box)
    & " gsave "
    & DPS.BoxCoordsAsText (bkgBox) & " 20.0 ButtonDLEDrawRoundedPath clip "
    & DisplayList.Repaint (t, box, only)
    & " grestore "
    & DPS.BoxCoordsAsText (bkgBox) & backgroundPostScript
    & DPS.GRestore();
    END Repaint;

PROCEDURE Clip (e: E; text: TEXT): TEXT =
 VAR bkgBox: DPS.Box;
  BEGIN
  bkgBox.low.x := e.box.low.x + DecorationMarginLeft;
  bkgBox.high.x := e.box.high.x - DecorationMarginRight;
  bkgBox.low.y := e.box.low.y + DecorationMarginBottom;
  bkgBox.high.y := e.box.high.y - DecorationMarginTop;
  RETURN
    " gsave "
    & DPS.BoxCoordsAsText (bkgBox) & " 20.0 ButtonDLEDrawRoundedPath clip "
    & text
    & " grestore ";
    END Clip;

PROCEDURE PostScriptToParentClipped (e: E; script: TEXT) =
 VAR p: DisplayList.T;
  BEGIN
  p := e.parent;
  IF p # NIL THEN
    p.ImmediatePostScript (Clip (e, script));
    END;
  END PostScriptToParentClipped;

PROCEDURE DirtyToParentClipped (e: E; box: DPS.Box; only: DisplayList.T := NIL) =
 VAR p: DisplayList.T;
  BEGIN
  p := e.parent;
  IF p # NIL THEN
    p.Dirty (box, only);
    END;
  END DirtyToParentClipped;

PROCEDURE Init (t: T; window: DPSWindow.T; content: Rd.T := NIL) =
  BEGIN
  IF t.initialized THEN RETURN; END;

  (* Later compute based on content: *)
  t.box.low.y := t.box.high.y - t.maximumHeight;

  t.window := window; (* Used in capturing PostSCript. *)
  t.backgroundPopup := NEW ( PopupMenuDLE.T,
   items := NEW (REF ARRAY OF PopupMenuDLE.Item, 5) );
  t.backgroundPopup.items^[0] := NEW ( PopupMenuDLE.Item,
    text := "All Invisible", Proc := AllInvisiblePop, context := t );
  t.backgroundPopup.items^[1] := NEW ( PopupMenuDLE.Item,
    text := "Next Visible", Proc := NextVisiblePop, context := t );
  t.backgroundPopup.items^[2] := NEW (PopupMenuDLE.Item,
    text := "All Visible", Proc := AllVisiblePop, context := t);
  t.backgroundPopup.items^[3] := NEW (PopupMenuDLE.Item,
    text := "Toggle Mouse -> Child", Proc := ToggleMouseChildPop, context := t);
  t.backgroundPopup.items^[4] := NEW (PopupMenuDLE.Item,
    text := "PostScript -> /tmp/slide.ps", Proc := PSPop, context := t);
  t.initialized := TRUE;

  window.SendFoundation ( " /ButtonDLEDrawRoundedPath "
   & " { /r exch def /highy exch def /highx exch def "
   & " /lowy exch def /lowx exch def "
   & " newpath lowx lowy r add moveto "
   & " lowx r add highy r sub r 180 90 arcn "
   & " highx r sub highy r sub r 90 0 arcn "
   & " highx r sub lowy r add r 0 270 arcn "
   & " lowx r add lowy r add r 270 180 arcn "
   & "  closepath } def " );

  IF content # NIL THEN AddContent (t, window, content); END;
  END Init;

PROCEDURE RdDotGetLine (r: Rd.T): TEXT RAISES {Rd.EndOfFile} =
Rd.GetLine is buggy. 21aug91
 <*FATAL Rd.Failure, Thread.Alerted*>
 VAR c: CHAR;
 VAR line: TEXT := "";
  BEGIN
  c := Rd.GetChar(r); (* Initial EOF propogates. *)
  IF c = '\n' THEN RETURN line; END;
  line := line & Text.FromChar (c);
  WHILE NOT Rd.EOF(r) DO
    c := Rd.GetChar(r);
    IF c = '\n' THEN RETURN line; END;
    line := line & Text.FromChar (c);
    END;
  RETURN line;
  END RdDotGetLine;

PROCEDURE AddContent ( t: T; window: DPSWindow.T; data: Rd.T ) =
 VAR sle: SlideLineDLE.E;
 VAR line: TEXT;
 VAR itemIndex: INTEGER := 0;
 VAR invisible, newInvisible: BOOLEAN := FALSE;
 VAR xlate: TranslateDLE.T;
 VAR appendTo: DisplayList.T;
  BEGIN
  Init (t, window);
  t.fixed := NEW (DisplayList.T);
  t.visible := NEW ( DisplayListStack.T,
    MakeChildFirst := MakeChildFirstNOP, MakeChildLast := MakeChildLastNOP );
  t.invisible := NEW (Linked2Tree.T);
  IF AllowTranslation THEN
    xlate := NEW ( TranslateDLE.T,
      translationX := 0.0, translationY := 0.0,
      fixedX := TRUE,
      onlyIfShifted := FALSE );
    Linked2Tree.Append (t, xlate);
    appendTo := xlate;
   ELSE appendTo := t;
    END;
  Linked2Tree.Append (appendTo, t.fixed);
  Linked2Tree.Append (appendTo, t.visible);
  LOOP
    TRY
      line := RdDotGetLine (data);
      IF Text.Equal ("/invisible", Text.Sub(line,0,10)) THEN
        invisible := TRUE;
        newInvisible := TRUE;
        IF sle # NIL THEN sle.togetherWithNext := FALSE; END;
       ELSIF Text.Equal ("/half", Text.Sub(line,0,5)) THEN
        sle := NEW ( SlideLineDLE.E,
         box := BoxFromXYWH (LeftMarginOfLines, 0.0, 0.0, 0.0),
         typefacePoints := pointsDefault,
         aboveLeading := aboveLeadingDefault,
         height := heightDefault / 2.0,
         belowLeading := belowLeadingDefault,
         leftLeading := leftLeadingDefault,
         text := " ",
         togetherWithNext := TRUE );
        newInvisible := FALSE;
        SlideLineDLE.Init (sle, window);
        IF NOT invisible THEN t.visible.Append (sle);
         ELSE t.invisible.Append (sle);
          END;
        INC (itemIndex);
       ELSIF itemIndex < 1 THEN
        sle := NEW ( SlideLineDLE.E,
         box := BoxFromXYWH (LeftMarginOfLines, 0.0, 0.0, 0.0),
         typefacePoints := pointsDefaultTop,
         aboveLeading := aboveLeadingDefaultTop,
         height := heightDefaultTop,
         belowLeading := belowLeadingDefaultTop,
         leftLeading := leftLeadingDefaultTop,
         text := ConvertOctals(line),
         togetherWithNext := TRUE );
        newInvisible := FALSE;
        SlideLineDLE.Init (sle, window);
        IF NOT invisible THEN t.visible.Append (sle);
         ELSE t.invisible.Append (sle);
          END;
        INC (itemIndex);
       ELSE
        sle := NEW ( SlideLineDLE.E,
         box := BoxFromXYWH (LeftMarginOfLines, 0.0, 0.0, 0.0),
         typefacePoints := pointsDefault,
         aboveLeading := aboveLeadingDefault,
         height := heightDefault,
         belowLeading := belowLeadingDefault,
         leftLeading := leftLeadingDefault,
         text := ConvertOctals(line),
         togetherWithNext := TRUE );
        newInvisible := FALSE;
        SlideLineDLE.Init (sle, window);
        IF NOT invisible THEN t.visible.Append (sle);
         ELSE t.invisible.Append (sle);
          END;
        INC (itemIndex);
        END;
     EXCEPT Rd.EndOfFile => EXIT;
      END;
    END;
  t.visible.Stack (t.box.high.y - TopMargin - pointsDefault);
  END AddContent;

PROCEDURE ConvertOctals (t: TEXT): TEXT =
 <*FATAL Rd.Failure, Wr.Failure, Thread.Alerted*>
 VAR j: INTEGER;
 VAR rd: Rd.T;
 VAR wr: Wr.T;
 VAR c, o1, o2, o3: CHAR;
  BEGIN
  j := Text.FindChar (t,'\\');
  rd := TextRd.New (t);
  wr := TextWr.New();
  LOOP
    TRY
      c := Rd.GetChar (rd);
      IF  c = '\\' THEN
        o1 := Rd.GetChar (rd);
        o2 := Rd.GetChar (rd);
        o3 := Rd.GetChar (rd);
        j := (ORD(o1)-48) * 64 + (ORD(o2)-48) * 8 + (ORD(o3)-48);
        j := MIN (j, 255); j := MAX (0, j);
        c := VAL (j, CHAR);
        END;
      Wr.PutChar (wr, c);
     EXCEPT Rd.EndOfFile => RETURN TextWr.ToText(wr);
      END;
    END;
  END ConvertOctals;

PROCEDURE Prepend (t: T; e: Linked2Tree.E) =
  BEGIN
  Init (t, NIL);
  t.fixed.Prepend (e);
  END Prepend;

PROCEDURE Append (t: T; e: Linked2Tree.E) =
  BEGIN
  Init (t, NIL);
  AppendVariable (t, e);
  END Append;

PROCEDURE AppendFixed (t: T; e: Linked2Tree.E) =
  BEGIN
  Init (t, NIL);
  t.fixed.Append (e);
  END AppendFixed;

PROCEDURE AppendVariable (t: T; e: Linked2Tree.E) =
  BEGIN
  t.visible.Append (e);
  t.visible.Stack (t.box.high.y - TopMargin - pointsDefault);
  END AppendVariable;

PROCEDURE InsertBefore (t: T; e, before: Linked2Tree.E) =
  BEGIN
  Init (t, NIL);
  t.visible.InsertBefore (e, before);
  END InsertBefore;

PROCEDURE InsertAfter (t: T; e, after: Linked2Tree.E) =
  BEGIN
  Init (t, NIL);
  t.visible.InsertAfter (e, after);
  END InsertAfter;

PROCEDURE PSPop (p: PopupMenuDLE.Item) =
 <*FATAL OSError.E, Wr.Failure, Thread.Alerted*>
 VAR t: T;
 VAR wr: Wr.T;
  BEGIN
  t := NARROW (p.context, T);
  wr := FileWr.Open ("/tmp/slide.ps");
  Wr.PutText (wr, "%!IPS-Adobe-1.0\n");
  Wr.PutText (wr, "%%Creator: Postscript Button in SlideX\n");
  Wr.PutText (wr, "%%Title: Client Slides\n");
  Wr.PutText (wr, "%%EndComments\n");
  Wr.PutText (wr, "%%EndProlog\n\n");
  AllVisible (t);
  DPS.PostscriptToWriter (t.window, wr);
  Wr.PutText (wr, "\nshowpage\n\n");
  Wr.PutText (wr, "%%Trailer\n\n");
  Wr.Close(wr);
  END PSPop;

PROCEDURE ToggleMouseChildPop (p: PopupMenuDLE.Item) =
 VAR t: T;
  BEGIN
  t := NARROW (p.context, T);
  t.canMouseChildren := NOT t.canMouseChildren;
  END ToggleMouseChildPop;

PROCEDURE AllInvisiblePop (p: PopupMenuDLE.Item) =
  BEGIN
  AllInvisible (NARROW(p.context, T));
  END AllInvisiblePop;

PROCEDURE NextVisiblePop (p: PopupMenuDLE.Item) =
  BEGIN
  NextVisible (NARROW(p.context, T));
  END NextVisiblePop;

PROCEDURE AllVisiblePop (p: PopupMenuDLE.Item) =
  BEGIN
  AllVisible (NARROW(p.context, T));
  END AllVisiblePop;

PROCEDURE AllInvisible (t: T) =
 VAR cur: DisplayList.E;
  BEGIN
  t.LoseInputFocus();
  (* Have to kill input focus of anything moving to invisible list. *)
  LOOP
    cur := t.visible.First();
    IF cur = NIL THEN EXIT; END;
    cur.Remove ();
    t.invisible.Append (cur);
    END;
  t.Dirty (t.box, NIL);
  END AllInvisible;

PROCEDURE NextVisible (t: T) =
 VAR cur: DisplayList.E;
  BEGIN
  LOOP
    cur := t.invisible.First();
    IF cur = NIL THEN RETURN; END;
    cur.Remove ();
    t.visible.Append (cur);
    TYPECASE cur OF
    | SlideLineDLE.E (sle) =>
      Reappear (sle);
      IF NOT sle.togetherWithNext THEN EXIT; END;
     ELSE cur.Dirty (cur.box, cur); EXIT;
      END;
    END;
  END NextVisible;

PROCEDURE NextSomething (t: T): BOOLEAN =
  BEGIN
  IF t.invisible.First() # NIL THEN NextVisible (t); RETURN TRUE;
   ELSE RETURN FALSE;
    END;
  END NextSomething;

PROCEDURE AllVisible (t: T) =
 VAR cur: DisplayList.E;
  BEGIN
  LOOP
    cur := t.invisible.First();
    IF cur = NIL THEN RETURN; END;
    cur.Remove ();
    t.visible.Append (cur);
    TYPECASE cur OF
    | SlideLineDLE.E (sle) => Reappear (sle);
     ELSE cur.Dirty (cur.box, cur);
      END;
    END;
  END AllVisible;

PROCEDURE NthVisible (t: T; n: INTEGER): DisplayList.T =
 VAR cur: DisplayList.E;
  BEGIN
  cur := t.visible.First();
  WHILE n > 0 DO
    IF cur = NIL THEN RETURN NIL; END;
    cur := cur.Next();
    DEC (n);
    END;
  RETURN cur;
  END NthVisible;

TYPE RepaintClosure = Thread.Closure OBJECT item: SlideLineDLE.E; END;

PROCEDURE RepaintNormallyAFterPause (rc: RepaintClosure): REFANY RAISES {} =
  BEGIN
  Thread.Pause (2.0d0 * second);
  rc.item.Dirty (rc.item.box, rc.item);
  RETURN NIL;
  END RepaintNormallyAFterPause;

PROCEDURE Reappear (item: SlideLineDLE.E) =
 CONST wait = 100.0d0 * millisecond;
 CONST delta = 0.167;
 VAR r, g, b: REAL;
 VAR ps: TEXT;
  PROCEDURE DownRed () =
    BEGIN
    r := MAX (0.0, r - delta);
    item.ImmediatePostScript ( " "
     & Fmt.Real(r) & " " & Fmt.Real(g)
     & " " & Fmt.Real(b) & " setrgbcolor " & ps );
    Thread.Pause (wait);
    END DownRed;
  PROCEDURE DownGB () =
    BEGIN
    g := MAX (0.0, g - delta);
    b := MAX (0.0, b - delta);
    item.ImmediatePostScript ( " "
     & Fmt.Real(r) & " " & Fmt.Real(g)
     & " " & Fmt.Real(b) & " setrgbcolor " & ps );
    Thread.Pause (wait);
    END DownGB;
  BEGIN
  ps :=  item.Repaint (item.box, item);
  (* May not really be on top, but we lie in the Dirty/Repaint calls. *)
  (* If really obscured, the repaints would look ugly any way. *)
  r := 1.0; g := 1.0; b := 1.0;
  WHILE g > 0.0 DO DownGB(); END;
  WHILE r > 0.0 DO DownRed(); END;
  item.ImmediatePostScript ( " 0.0 0.0 0.0 setrgbcolor " );
  (*
  EVAL Thread.Fork (
   NEW ( RepaintClosure,
    apply := RepaintNormallyAFterPause,
    item := item ) );
  *)
END Reappear;

PROCEDURE MakeChildFirst (<*UNUSED*> t: T;
                          <*UNUSED*> e: Linked2Tree.E): Linked2Tree.E =
  BEGIN
  RETURN NIL;
  (* RETURN Linked2Tree.MakeChildFirst (t.visible, e); *)
  END MakeChildFirst;

PROCEDURE MakeChildLast (<*UNUSED*> t: T;
                         <*UNUSED*> e: Linked2Tree.E): Linked2Tree.E =
  BEGIN
  RETURN NIL;
  (* RETURN Linked2Tree.MakeChildLast (t.visible, e); *)
  END MakeChildLast;

PROCEDURE MakeChildFirstNOP (<*UNUSED*> t: Linked2Tree.T;
                             <*UNUSED*> e: Linked2Tree.E): Linked2Tree.E =
  BEGIN
  RETURN NIL;
  END MakeChildFirstNOP;

PROCEDURE MakeChildLastNOP (<*UNUSED*> t: Linked2Tree.T;
                            <*UNUSED*> e: Linked2Tree.E): Linked2Tree.E =
  BEGIN
  RETURN NIL;
  END MakeChildLastNOP;

PROCEDURE Mouse (t: T; window: DPSWindow.T; event: DPS.MouseEvent): BOOLEAN =
 VAR e: DisplayList.E;
  BEGIN
  Init (t, window);

  CASE event.whatChanged OF
  | DPS.Button.Left =>
    IF event.clickType=DPS.ClickType.FirstDown THEN t.GetInputFocus (); END;
  | DPS.Button.Middle =>
  | DPS.Button.Right =>
    END; (* of CASE *)

  IF (event.whatChanged = DPS.Button.Right) (* For imbedded translator. *)
   OR t.canMouseChildren THEN
    e := t.Last();
    WHILE e # NIL DO
      IF e.Mouse (window, event) THEN RETURN TRUE; END;
      e := e.Previous();
      END;
    END;

  IF event.clickType # DPS.ClickType.FirstDown THEN RETURN FALSE; END;

  (* Used to allow user to highlight by pointing. *)
  (* But that "cheated" by looking at boxes of children, *)
  (* which may be bogus due to intermediate translation. *)

  CASE event.whatChanged OF
  | DPS.Button.Left =>
  | DPS.Button.Middle => t.backgroundPopup.Popup (event.place, window);
  | DPS.Button.Right =>
    END; (* of CASE *)

  RETURN TRUE;
  END Mouse;

PROCEDURE ShortHighlight (sle: SlideLineDLE.E) =
 VAR ps: TEXT;
  BEGIN
  ps :=  sle.Repaint (sle.box, sle);
  sle.ImmediatePostScript ( " 1.0 0.0 0.0 setrgbcolor " & ps );
  sle.ImmediatePostScript ( " 0.0 0.0 0.0 setrgbcolor " );
  EVAL Thread.Fork (
   NEW ( RepaintClosure,
    apply := RepaintNormallyAFterPause,
    item := sle ) );
  END ShortHighlight;

PROCEDURE MaybeShortHighlight (e: DisplayList.E) =
  BEGIN
  IF e # NIL THEN
    TYPECASE e OF SlideLineDLE.E(sle) => ShortHighlight (sle);
     ELSE
      END;
    END;
  END MaybeShortHighlight;

PROCEDURE Char (e: E; window: DPSWindow.T; char: CHAR): BOOLEAN =
 VAR ee: DisplayList.E;
  BEGIN
  Init (e, window);
  ee := e.childWithInputFocus;
  IF ee # NIL THEN RETURN ee.Char (window, char); END;
  CASE char OF
  | ' ' =>  RETURN NextSomething (e);
  | 'i' =>  AllInvisible (e);
  | 'v' =>  NextVisible (e);
  | 'a' =>  AllVisible (e);
  | '1' =>  MaybeShortHighlight ( NthVisible (e, 0) );
  | '2' =>  MaybeShortHighlight ( NthVisible (e, 1) );
  | '3' =>  MaybeShortHighlight ( NthVisible (e, 2) );
  | '4' =>  MaybeShortHighlight ( NthVisible (e, 3) );
  | '5' =>  MaybeShortHighlight ( NthVisible (e, 4) );
  | '6' =>  MaybeShortHighlight ( NthVisible (e, 5) );
  | '7' =>  MaybeShortHighlight ( NthVisible (e, 6) );
  | '8' =>  MaybeShortHighlight ( NthVisible (e, 7) );
  | '9' =>  MaybeShortHighlight ( NthVisible (e, 8) );
   ELSE RETURN FALSE;
    END; (* of CASE *)
  RETURN TRUE;
  END Char;
******** PROCEDURE Key (t: T; window: DPSWindow.T; event: DPS.KeyEvent) = VAR got: CHAR; VAR e: DisplayList.E; BEGIN Init (t, window); got := DPS.CharFromKey (event.key, event.modifiers); IF got = '\000' THEN RETURN; END; e := t.Last(); WHILE e # NIL DO IF e.Char (window, got) THEN RETURN; END; e := e.Previous(); END; Err.Msg (Ignored Keystroke = , Text.FromChar(got), .); END Key; *********

BEGIN

  END OneSlideDLE.