Copyright (C) 1994, Digital Equipment Corp. <* PRAGMA LL *> MODULE**************** Control Panel Form ****************ZeusPanel EXPORTSZeusPanel ,ZeusPanelFriends ,ZeusPanelPrivate ; IMPORT AlbumVBT, Algorithm, AlgorithmClass, Animate, Atom, Axis, Classes, DataView, FileRd, FileWr, FlexVBT, FloatMode, Fmt, FormsVBT, RefList, RefListSort, RefListUtils, Lex, ListVBT, Math, MultiFilter, OSError, ScrollerVBT, Params, Rd, Rsrc, ScaleFilter, Stdio, Sx, Text, TextEditVBT, TextList, TextPort, TextRd, TextWr, Thread, Trestle, TrestleComm, VBT, View, ViewClass, ViewportVBT, Wr, Zeus, ZeusBundle, ZeusClass, ZeusCodeView, ZeusPanelFriends, ZeusPrivate, ZeusSnapshot; VAR me: VBT.T; (* This is the VBT installed into Trestle *) VAR ControlPanel: T; <*FATAL FormsVBT.Error, FormsVBT.Unimplemented, TrestleComm.Failure, Zeus.Error, Zeus.Locked, Thread.Alerted, OSError.E, Wr.Failure, Rd.Failure *>
PROCEDURENewPanel (): T = <* LL = VBT.mu *> VAR panel: T; PROCEDURE Attach (name: TEXT; proc: FormsVBT.Proc) = BEGIN FormsVBT.AttachProc(panel.fv, name, proc, panel); END Attach; BEGIN panel := NEW(T, (* InitInterpreter *) mu := NEW(MUTEX), runCond := NEW(Thread.Condition), algCond := NEW(Thread.Condition)); panel.fvpath := Rsrc.BuildPath("$ZEUSPATH", ZeusBundle.Get()); panel.fv := NewForm("zeusPanel.fv", panel.fvpath); me := panel.fv; Attach("quit", QuitP); Attach("goBtn", GoP); Attach("stepBtn", StepP); Attach("abortBtn", AbortP); FormsVBT.MakeDormant(panel.fv, "goBtn"); FormsVBT.MakeDormant(panel.fv, "stepBtn"); FormsVBT.MakeDormant(panel.fv, "abortBtn"); Attach("delay", SpeedP); Attach("minDelayFrac", MinDelayP); Attach("codeDelayFrac", CodeDelayP); Attach("maxSpeedFactor", SpeedFactorP); Attach("errClear", ErrClearP); Attach("errClearAndShut", ErrClearP); Attach("priority", PriorityP); Attach("snapshot", SnapshotP); Attach("restore", RestoreP); Attach("restoreShortcut", RestoreP); Attach("photoBtn", PhotoP); Attach("clearAlbum", ClearAlbumP); Attach("delViews", DelAllViewsP); Attach("recordBtn", RecordBtnP); Attach("record", RecordP); Attach("grabData", GrabDataP); Attach("futurePause", FuturePauseP); Attach("playbackBtn", PlaybackBtnP); Attach("playback", PlaybackP); LoadFromPanel(panel); VAR i := 0; cnt := Params.Count; param: TEXT; BEGIN WHILE i < cnt DO param := Params.Get(i); TRY IF Text.Equal(param, "-scale") THEN INC(i); IF i >= cnt THEN EXIT END; panel.scale := Lex.Real(TextRd.New (Params.Get(i))); ScaleFilter.Scale( FormsVBT.GetVBT(panel.fv, "scale"), panel.scale, panel.scale); ELSIF Text.Equal(param, "-xdrift") THEN INC(i); IF i >= cnt THEN EXIT END; XDRIFT := Lex.Int(TextRd.New (Params.Get(i))); ELSIF Text.Equal(param, "-ydrift") THEN INC(i); IF i >= cnt THEN EXIT END; YDRIFT := Lex.Int(TextRd.New (Params.Get(i))); ELSE INC(i); END; EXCEPT Lex.Error, FloatMode.Trap => END; END; END; RETURN panel; END NewPanel; PROCEDURENewForm (name: TEXT; path: Rsrc.Path := NIL): FormsVBT.T = <* FATAL FormsVBT.Error, Rd.Failure, Rsrc.NotFound, Thread.Alerted *> BEGIN IF path = NIL THEN path := GetPath() END; RETURN NEW(FormsVBT.T).initFromRsrc(name, path) END NewForm; PROCEDURELoadFromPanel (panel: T) = <*LL = VBT.mu*> BEGIN FormsVBT.MakeEvent(panel.fv, "delay", 0); FormsVBT.MakeEvent(panel.fv, "minDelayFrac", 0); FormsVBT.MakeEvent(panel.fv, "codeDelayFrac", 0); FormsVBT.MakeEvent(panel.fv, "maxSpeedFactor", 0); FormsVBT.MakeEvent(panel.fv, "priority", 0); END LoadFromPanel; <*UNUSED*> PROCEDURENYI (msg: TEXT) = BEGIN (* LL = VBT.mu *) ReportError(msg & " not yet implemented."); END NYI; PROCEDUREQuitP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED *> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Trestle.Delete(NARROW(arg, T).fv); END QuitP; PROCEDUREGoP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) (* ignored in playback, so don't generate it. *) (* Script(ActionType.Go);*) ScriptMaybeStartFrame(arg); Go(NARROW(arg, T), t); END GoP; PROCEDUREStepP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) (* ignored in playback, so don't generate it. *) (* Script(ActionType.Step);*) ScriptMaybeStartFrame(arg); Step(NARROW(arg, T), t); END StepP; PROCEDUREAbortP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Script(ActionType.Abort); AbortInternal(NARROW(arg, T), t); END AbortP; PROCEDURESpeedP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) UpdateSpeed(NARROW(arg, T)); END SpeedP; PROCEDUREMinDelayP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) UpdateMinDelay(NARROW(arg, T)); END MinDelayP; PROCEDURECodeDelayP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) UpdateCodeDelay(NARROW(arg, T)); END CodeDelayP; PROCEDURESpeedFactorP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) UpdateSpeedFactor(NARROW(arg, T)); END SpeedFactorP; PROCEDUREPriorityP ( fv : FormsVBT.T; e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Script(ActionType.Priority, Sx.FromInt(FormsVBT.GetInteger(fv, e))); SetPanelPriority(NARROW(arg, T), FormsVBT.GetInteger(fv, e)); END PriorityP; PROCEDUREErrClearP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) (* Don't script. Should we? *) ClearError(arg); END ErrClearP; PROCEDURESnapshotP ( fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Script(ActionType.Snapshot, FormsVBT.GetText(fv, "snapshot")); ZeusSnapshot.Snapshot(NARROW(arg, T), FormsVBT.GetText(fv, "snapshot")); END SnapshotP; PROCEDURERestoreP ( fv : FormsVBT.T; e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) ZeusSnapshot.Restore(NARROW(arg, T), FormsVBT.GetText(fv, e));
DON'T PUT Restore IN SCRIPT. Leave it to the frame restore. (* put Script call afterward, so session deletions (part of Restore's operation) happen before the Restore in scriptOut.
(* put snapshots in-line in scripts, rather than using filenames *)
TRY
WITH list = Sx.Read(FileRd.Read(FormsVBT.GetText(fv, e))) DO
Script(ActionType.Restore, list);
(* The following would hide information better: *)
(* Script(ActionType.Restore, SnapshotToList()); *)
END;
EXCEPT
ELSE
END;
*)
Script(ActionType.Restore, FormsVBT.GetText(fv, e));
END RestoreP; PROCEDURE**************** Session Form ****************RecordBtnP ( fv : FormsVBT.T; <*UNUSED*> e : TEXT; <*UNUSED*> arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF scripting = ScriptingState.Off THEN FormsVBT.PopUp(fv, "RecordDialog"); ELSIF scripting = ScriptingState.Recording THEN StopScript(); END (* IF *); END RecordBtnP; PROCEDURERecordP ( fv : FormsVBT.T; <*UNUSED*> e : TEXT; <*UNUSED*> arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF scripting = ScriptingState.Off THEN StartScript(FormsVBT.GetText(fv, "record")); END (* IF *); END RecordP; PROCEDUREPlaybackBtnP ( fv : FormsVBT.T; <*UNUSED*> e : TEXT; <*UNUSED*> arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF scripting = ScriptingState.Off THEN FormsVBT.PopUp(fv, "PlaybackDialog"); ELSIF scripting = ScriptingState.Playback THEN StopPlayback(); END (* IF *); END PlaybackBtnP; PROCEDUREPlaybackP ( fv : FormsVBT.T; <*UNUSED*> e : TEXT; <*UNUSED*> arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF scripting = ScriptingState.Off THEN StartPlayback(FormsVBT.GetText(fv, "playback")); END (* IF *); END PlaybackP; PROCEDUREFuturePauseP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF NOT stateIdle[NARROW(arg, T).runState] THEN Script(ActionType.FuturePause); END; END FuturePauseP; PROCEDUREGrabDataP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) IF NOT stateIdle[NARROW(arg, T).runState] THEN Script(ActionType.GrabData, ZeusSnapshot.GrabDataList(arg)); END; END GrabDataP; PROCEDURESessionsP ( fv : FormsVBT.T; e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = (* This is called only when stateIdle[panel.runState], thanks to the dormancy of the session menu at other times. See SetRunState. *) BEGIN (* LL = VBT.mu *) <*ASSERT Text.Equal("SESS", Text.Sub(e, 0, 4)) *> Script( ActionType.Sessions, RefList.List2( Text.Sub(e, 4, LAST(INTEGER)), Sx.FromBool(FormsVBT.GetBoolean(fv, "inTrestle")))); NewSessionDefault( Text.Sub(e, 4, LAST(INTEGER)), NARROW(arg, T)); END SessionsP; PROCEDUREPhotoP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Script(ActionType.Photo); Photo(NARROW(arg, T)); END PhotoP; PROCEDUREClearAlbumP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) Script(ActionType.ClearAlbum); ClearAlbum(NARROW(arg, T)); END ClearAlbumP; PROCEDUREDelAllViewsP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) (* Don't script; will be caught by frame restore. *) DeleteAllViews(arg); END DelAllViewsP;
PROCEDURE**************** Main Interaction ****************AlgsP ( fv : FormsVBT.T; e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = (* This is called only when stateIdle[panel.runState], thanks to the dormancy of the algs menu at other times. See SetRunState. *) VAR sess := NARROW(arg, Session); tb : ListVBT.T := FormsVBT.GetVBT(fv, e); sel : ListVBT.Cell; st : TEXT; BEGIN (* LL = VBT.mu *) IF tb.getFirstSelected(sel) THEN st := tb.getValue(sel); WITH name = sess.name & "." & st DO Script(ActionType.Algs, RefList.List2(SessListPos(sess), name)); PickedAlg(sess, name); TRY IF sess.alg # NIL THEN sess.alg.restore(NIL); END; EXCEPT ZeusClass.Error => END; END; END; END AlgsP; PROCEDUREViewsP ( fv : FormsVBT.T; e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = VAR sess := NARROW(arg, Session); tb : ListVBT.T := FormsVBT.GetVBT(fv, e); sel : ListVBT.Cell; BEGIN (* LL = VBT.mu *) IF tb.getFirstSelected(sel) THEN WITH name = sess.name & "." & NARROW(tb.getValue(sel), TEXT) DO Script(ActionType.Views, RefList.List2(SessListPos(sess), name)); WITH view = PickedView(sess, name) DO TRY IF view # NIL THEN view.restore(NIL); END; EXCEPT ZeusClass.Error => END; END; END; tb.selectNone(); END; END ViewsP; PROCEDUREAbortAlgP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = (* This should abort just the algorithm for this session *) BEGIN (* LL = VBT.mu *) Script(ActionType.AbortAlg, SessListPos(arg)); AbortAlg(NARROW(arg, Session)); END AbortAlgP; PROCEDUREDestroyP (<*UNUSED*> fv : FormsVBT.T; <*UNUSED*> e : TEXT; arg: REFANY; <*UNUSED*> t : VBT.TimeStamp) = VAR sess := NARROW(arg, Session); BEGIN (* LL = VBT.mu *) (* put Script() call in DestroySession() to catch WM deletes, too. *) IF sess.inTrestle THEN Trestle.Delete(sess.fv); ELSE DestroySession(sess); END; END DestroyP;
PROCEDURE**************** Miscellaneous Entries ****************Interact (title: TEXT := "ZEUS Control Panel"; path : Rsrc.Path := NIL ) = VAR panel := Resolve(NIL); BEGIN panel.title := title; panel.path := path; Start(panel); Trestle.Install(panel.fv, "Zeus", NIL, panel.title); (* LOCK VBT.mu DO Trestle.MoveNear(panel.fv, NIL); END;*) Trestle.AwaitDelete(panel.fv); Finish(panel); END Interact; TYPE PanelClosure = Thread.SizedClosure OBJECT panel: T; OVERRIDES apply := PanelThread END; AlgClosure = Thread.SizedClosure OBJECT panel: T; sess : Session; OVERRIDES apply := AlgThread END; PROCEDUREStart (panel: T) = VAR pclosure: PanelClosure; BEGIN (* LL = {} *) LOCK VBT.mu DO ZeusSnapshot.InitialRestore(panel); IF (panel.sessions = NIL) AND (groupInfo # NIL) THEN NewSessionDefault( NARROW(groupInfo.head, AlgGroupInfo).groupName, panel); END; END; pclosure := NEW(PanelClosure, panel := panel, stackSize := 10000); panel.panelThread := Thread.Fork(pclosure); END Start; PROCEDUREFinish (panel: T) = BEGIN (* LL = {} *) (* DebugFinish();*) StopScript(); LOCK panel.mu DO panel.quit := TRUE; Thread.Broadcast(panel.runCond); AbortWithLock(panel, 0); END; EVAL Thread.Join(panel.panelThread); LOCK VBT.mu DO ZeusSnapshot.FinalSnapshot(panel); DestroyAllSessions(panel); END; LOCK VBT.mu DO VBT.Discard(panel.fv); END; END Finish;
PROCEDURE**************** Registration ****************GetAnimationTime (): REAL = <* LL = VBT.mu *> VAR panel := Resolve(NIL); BEGIN RETURN panel.delayTime END GetAnimationTime; PROCEDURESetTitle (title: TEXT) = VAR panel := Resolve(NIL); BEGIN panel.title := title; LOCK VBT.mu DO RenameTrestleChassis(panel.fv, title); END; END SetTitle; PROCEDUREGetPath (): Rsrc.Path = VAR panel := Resolve(NIL); BEGIN RETURN panel.path END GetPath; PROCEDUREReportErrorC (report: BOOLEAN; t: TEXT) = BEGIN (* LL = VBT.mu *) IF report THEN ReportError(t); END; END ReportErrorC; PROCEDUREReportError (text: TEXT) = VAR panel : T; tlength: INTEGER; BEGIN (* LL = VBT.mu *) panel := Resolve(NIL); IF text = NIL THEN RETURN END; tlength := Text.Length(text); IF tlength = 0 THEN RETURN END; IF (Text.GetChar(text, tlength - 1) # '\n') THEN text := text & "\n"; END; TextEditVBTAppend(FormsVBT.GetVBT(panel.fv, "error"), text); FormsVBT.PopUp(panel.fv, "ErrorDialog"); END ReportError; PROCEDUREAbort () = VAR panel := Resolve(NIL); BEGIN (* LL = VBT.mu *) Script(ActionType.Abort); AbortInternal(panel, 0); END Abort; PROCEDUREClearError (panel: T) = BEGIN TextEditVBTClear(FormsVBT.GetVBT(panel.fv, "error")) END ClearError; PROCEDUREPrepForSnapshot (panel: T) = <* LL = VBT.mu *> BEGIN ClearError(panel); END PrepForSnapshot; PROCEDUREOverrideRestore (panel: T) = <* LL = VBT.mu *> (* Call this from ZeusSnapshot.m3 after a restore to reset things that the restore operation shouldn't have changed, but may have. *) BEGIN ClearError(panel); SetRunState(panel, RunState.Virgin); ChangeScriptingState(scripting); ResetSessionMenu(panel); END OverrideRestore; <*UNUSED*> PROCEDUREAlgReady (alg: Algorithm.T; ready: BOOLEAN) = (* Enable or disable the GO and STEP buttons. The buttons are enabled whenever the user changes the algorithm. This procedure is useful when it is known that the user has specified invalid data such that it is meaningless to run the algorithm with such data. *) (* This doesn't work. *) VAR fv: FormsVBT.T; BEGIN fv := Resolve(alg).fv; IF ready THEN FormsVBT.MakeActive(fv, "goBtn"); FormsVBT.MakeActive(fv, "stepBtn"); ELSE FormsVBT.MakeDormant(fv, "goBtn"); FormsVBT.MakeDormant(fv, "stepBtn"); END; END AlgReady;
TYPE
AlgGroupInfo = REF RECORD
groupName: TEXT;
title : TEXT;
vbt : VBT.T; (* menu entry *)
algs : TextList.T := NIL;
views : TextList.T := NIL;
END;
VAR
groupInfo: RefList.T := NIL; (* of AlgGroupInfo *)
PROCEDURE GICompare (a1, a2: REFANY): [-1 .. 1] =
VAR
i1 := NARROW(a1, AlgGroupInfo);
i2 := NARROW(a2, AlgGroupInfo);
BEGIN
IF i1 = NIL THEN
RETURN -1
ELSIF i2 = NIL THEN
RETURN 1
ELSE
RETURN Text.Compare(i1.title, i2.title);
END;
END GICompare;
PROCEDURE GetGroupInfo (sessName: TEXT; inMenu: BOOLEAN := TRUE):
AlgGroupInfo =
<* LL = VBT.mu *>
(* Look up the named algorithm group and return its AlgGroupInfo record.
Create an AlgGroupInfo record if none exists. In this case, and if
inMenu is TRUE, then insert an entry into the menu in the Sessions
menu in the control panel. *)
VAR
panel := Resolve(NIL);
info := GetExistingGI(sessName);
BEGIN
IF info # NIL THEN RETURN info END;
info := NEW(AlgGroupInfo, groupName := sessName, title := sessName);
IF inMenu THEN
RefListUtils.Push(groupInfo, info);
UpdateSessionMenu(panel);
END;
RETURN info;
END GetGroupInfo;
PROCEDURE UpdateSessionMenu (panel: T) =
<* LL = VBT.mu *>
VAR
l : RefList.T;
info: AlgGroupInfo;
BEGIN
groupInfo := RefListSort.SortD(groupInfo, GICompare);
l := groupInfo;
FormsVBT.Delete(panel.fv, "sessionMenu", 0, LAST(CARDINAL));
WHILE l # NIL DO
info := RefListUtils.Pop(l);
(*
IF info.vbt # NIL THEN
FormsVBT.InsertVBT(panel.fv, "sessionMenu", info.vbt);
ELSE
*)
info.vbt := FormsVBT.Insert(
panel.fv, "sessionMenu",
"(Shape (Width 100) (MButton %SESS" & info.groupName
& " (Text %TITLE" & info.groupName & " \""
& info.title & "\")))");
FormsVBT.AttachProc(
panel.fv, "SESS" & info.groupName, SessionsP, panel);
(*
END;
*)
END;
END UpdateSessionMenu;
PROCEDURE GetExistingGI (sessName: TEXT): AlgGroupInfo =
(* Look up the named algorithm group and return its AlgGroupInfo record.
RETURN NIL if none exists. *)
VAR l := groupInfo;
BEGIN (* LL = VBT.mu *)
WHILE l # NIL DO
IF Text.Equal(sessName, NARROW(l.head, AlgGroupInfo).groupName) THEN
RETURN l.head
END;
l := l.tail;
END;
RETURN NIL;
END GetExistingGI;
PROCEDURE GroupInfoExists (sessName: TEXT): BOOLEAN =
BEGIN (* LL = VBT.mu *)
RETURN GetExistingGI(sessName) # NIL
END GroupInfoExists;
PROCEDURE SetSessTitle (sessName, sessTitle: TEXT) =
(* Change the title of session "sessName" to "sessTitle." Create a
session named "sessName," if none existed previously. *)
VAR
info : AlgGroupInfo;
panel := Resolve(NIL);
BEGIN (* LL = {} *)
LOCK VBT.mu DO
info := GetGroupInfo(sessName);
info.title := sessTitle;
FormsVBT.PutText(panel.fv, "TITLE" & sessName, sessTitle);
UpdateSessionMenu(panel);
END;
END SetSessTitle;
PROCEDURE ResetSessionMenu (panel: T) =
<* LL = VBT.mu *>
(* Reset the titles of the sessions in the session menu to be equal to
their real titles. *)
VAR l := groupInfo;
BEGIN
WHILE l # NIL DO
WITH info = NARROW(l.head, AlgGroupInfo) DO
FormsVBT.PutText(panel.fv, "TITLE" & info.groupName, info.title);
END;
l := l.tail;
END;
UpdateSessionMenu(panel);
END ResetSessionMenu;
EXCEPTION DuplicateName;
<* FATAL DuplicateName *>
PROCEDURE RegisterAlg (proc: NewAlgProc; name, sessName: TEXT) =
(* LL = {} *)
VAR info: AlgGroupInfo;
BEGIN
LOCK VBT.mu DO
info := GetGroupInfo(sessName);
IF NOT TextList.Member(info.algs, name) THEN
Classes.RegisterAlg(proc, sessName & "." & name);
info.algs := TextList.Cons(name, info.algs);
ELSE
RAISE DuplicateName;
END;
END;
END RegisterAlg;
PROCEDURE RegisterView (proc : NewViewProc;
name, sessName: TEXT;
alertable : BOOLEAN := FALSE;
sample : View.T := NIL ) =
(* LL = {} *)
VAR info: AlgGroupInfo;
BEGIN
LOCK VBT.mu DO
info := GetGroupInfo(sessName);
IF NOT TextList.Member(info.views, name) THEN
Classes.RegisterView(proc, sessName & "." & name, alertable, sample);
info.views := TextList.Cons(name, info.views);
ELSE
RAISE DuplicateName;
END;
END;
END RegisterView;
**************** Creating and Destroying Sessions ****************
TYPE
SessionWatcherClosure = Thread.Closure OBJECT
sess: Session;
OVERRIDES
apply := SessionWatcher
END;
PROCEDURE NewSessionDefault (name: TEXT; panel: T) =
(* Get the inTrestle parm from the FV before calling NewSession. *)
BEGIN (* LL = VBT.mu *)
IF NOT ZeusSnapshot.SessionFromStateDir(panel, name, FALSE) THEN
NewSession(name, panel, FormsVBT.GetBoolean(panel.fv, "inTrestle"))
END;
LOCK panel.mu DO UpdateSessionButtons(panel); END;
END NewSessionDefault;
PROCEDURE NewSession (name : TEXT;
panel : T;
inTrestle: BOOLEAN;
pickAlg : BOOLEAN := TRUE) =
<* LL = VBT.mu *>
(* if pickAlg, call PickedAlg on the first alg assoc with the new
session. *)
VAR
sess := NEW(Session, name := name,
fv := NewForm("zeusSession.fv", panel.fvpath),
inTrestle := inTrestle,
(*mu := NEW(MUTEX), *)
runCond := NEW(Thread.Condition),
feedCond := NEW(Thread.Condition), alg := NEW(Algorithm.T));
info := GetGroupInfo(name, FALSE);
l : TextList.T;
browser : ListVBT.T;
aclosure: AlgClosure;
PROCEDURE Attach (id: TEXT; proc: FormsVBT.Proc) =
BEGIN
FormsVBT.AttachProc(sess.fv, id, proc, sess);
END Attach;
BEGIN
EVAL sess.init();
Zeus.AttachAlg(sess, sess.alg);
sess.alg.install();
Attach("algs", AlgsP);
Attach("views", ViewsP);
Attach("abort", AbortAlgP);
FormsVBT.MakeDormant(sess.fv, "abort");
Attach("destroy", DestroyP);
Attach("eventDataBool", ToggleTSplitP);
Attach("algBool", ToggleTSplitP);
Attach("dataFormBool", ToggleTSplitP);
browser := FormsVBT.GetVBT(sess.fv, "algs");
l := info.algs;
WHILE l # NIL DO InsertToBrowser(browser, l.head); l := l.tail END;
browser := FormsVBT.GetVBT(sess.fv, "views");
l := info.views;
WHILE l # NIL DO InsertToBrowser(browser, l.head); l := l.tail END;
aclosure :=
NEW(AlgClosure, panel := panel, sess := sess, stackSize := 10000);
sess.algThread := Thread.Fork(aclosure);
LOCK panel.mu DO
IF panel.sessions = NIL THEN
FormsVBT.MakeActive(panel.fv, "goBtn");
FormsVBT.MakeActive(panel.fv, "stepBtn");
END;
RefListUtils.Push(panel.sessions, sess);
Animate.SetDuration(panel.delayTime);
END;
IF sess.inTrestle THEN
ScaleFilter.Scale(
FormsVBT.GetVBT(sess.fv, "scale"), panel.scale, panel.scale);
Trestle.Attach(sess.fv);
Trestle.Decorate(sess.fv, applName := "Zeus",
windowTitle := "Zeus " & info.title & " Session");
MoveNear(sess.fv, panel.fv);
(* Trestle.Install(sess.fv, "Zeus", NIL, "Zeus " & name & "
Session");*)
EVAL Thread.Fork(NEW(SessionWatcherClosure, sess := sess));
ELSE
DestroyFVOwner(panel, FormsVBT.GetGeneric(panel.fv, "sessionFV"));
FormsVBT.PutText(panel.fv, "sessName", info.title);
FormsVBT.PutGeneric(panel.fv, "sessionFV", sess.fv);
END;
IF pickAlg AND (info.algs # NIL) THEN
PickedAlg(sess, sess.name & "." & NARROW(info.algs.head, TEXT));
END;
TRY
IF sess.alg # NIL THEN sess.alg.restore(NIL); END;
EXCEPT
ZeusClass.Error =>
END;
END NewSession;
PROCEDURE SessionWatcher (cl: SessionWatcherClosure): REFANY =
BEGIN (* LL = {} *)
WITH sess = cl.sess DO
Trestle.AwaitDelete(sess.fv);
LOCK VBT.mu DO DestroySession(sess); END;
END;
RETURN NIL;
END SessionWatcher;
PROCEDURE DestroyFVOwner (panel: T; fv: VBT.T) =
VAR
l : RefList.T;
tokill: Session := NIL;
BEGIN (* LL = VBT.mu *)
LOCK panel.mu DO
l := panel.sessions;
WHILE l # NIL DO
WITH sess = NARROW(RefListUtils.Pop(l), Session) DO
IF sess.fv = fv THEN tokill := sess END;
END;
END;
END;
IF tokill # NIL THEN DestroySession(tokill); END;
END DestroyFVOwner;
PROCEDURE DestroySession (sess: Session) =
VAR panel := Resolve(NIL);
wasActive: BOOLEAN;
BEGIN (* LL = VBT.mu *)
IF NOT stateIdle[panel.runState] THEN
(* frame restores will catch other destroys *)
Script(ActionType.Destroy, SessListPos(sess));
END;
IF scripting # ScriptingState.Playback THEN (* no need o/w *)
ZeusSnapshot.SessionToStateDir(sess);
END;
LOCK panel.mu DO
sess.quit := TRUE;
wasActive := sess.active;
ChangeSessActive(sess, panel, FALSE);
RefListUtils.Delete(panel.sessions, sess);
UpdateSessionButtons(panel);
IF (panel.sessions = NIL) AND (NOT panel.quit) THEN
FormsVBT.MakeDormant(panel.fv, "goBtn");
FormsVBT.MakeDormant(panel.fv, "stepBtn");
FormsVBT.MakeDormant(panel.fv, "abortBtn");
END
END;
IF wasActive THEN SetRunState(panel, RunState.Aborted) END;
DeleteViews(sess);
IF sess.alg # NIL THEN DeleteAlg(sess) END;
Thread.Alert(sess.algThread);
Thread.Broadcast(sess.runCond);
(* I think this caused a deadlock, and it doesn't seem necessary: *)
(* EVAL Thread.Join(sess.algThread);*)
IF (NOT sess.inTrestle)
AND (sess.fv = FormsVBT.GetGeneric(panel.fv, "sessionFV")) THEN
FormsVBT.PutGeneric(panel.fv, "sessionFV", NIL);
FormsVBT.PutText(panel.fv, "sessName", "Null");
END;
END DestroySession;
PROCEDURE DestroyAllSessions (panel: T) =
VAR
l, rest: RefList.T; (* of Session *)
sess : Session;
BEGIN (* LL = VBT.mu *)
LOCK panel.mu DO
l := panel.sessions;
panel.sessions := NIL; (* is this a good idea?
NO! Destroys the numActive invariant! *)
WHILE l # NIL DO
sess := RefListUtils.Pop(l);
IF sess.inTrestle THEN
sess.quit := TRUE; (* so sess won't be made active *)
Trestle.Delete(sess.fv);
ELSE
RefListUtils.Push(rest, sess); (* probably happens <= once *)
END;
END;
END;
WHILE rest # NIL DO DestroySession(RefListUtils.Pop(rest)) END;
END DestroyAllSessions;
PROCEDURE UpdateSessionButtons (panel: T) =
<* LL = {VBT.mu, panel.mu} *>
(* Selectively show the "Abort Alg" and "Destroy Session" buttons. *)
VAR
l : RefList.T;
sel : CARDINAL;
sess: Session;
BEGIN
l := panel.sessions;
IF RefList.Length(l) > 1 THEN sel := 1 ELSE sel := 0 END;
WHILE l # NIL DO
sess := RefListUtils.Pop(l);
FormsVBT.PutInteger(sess.fv, "showButtons", sel);
END;
END UpdateSessionButtons;
PROCEDURE ToggleTSplitP ( fv : FormsVBT.T;
e : TEXT;
arg: REFANY;
<* UNUSED *> t : VBT.TimeStamp) =
<* LL = VBT.mu *>
BEGIN
Script(ActionType.ToggleTSplit, RefList.List2(SessListPos(arg), e));
WITH tsplitName = Text.Sub(e, 0, Text.Length(e)
- Text.Length("Bool"))
& "T" DO
FormsVBT.PutInteger(
fv, tsplitName, 1 - FormsVBT.GetInteger(fv, tsplitName))
END
END ToggleTSplitP;
PROCEDURE SessListPos (sess: Session): REF INTEGER =
(* Return position of sess in panel.sessions as a REF INTEGER.
If sess NOTIN panel.sessions,
then return RefList.Length(panel.sessions), which is arguably wrong. *)
VAR panel := Resolve(NIL);
l: RefList.T;
pos:= 0;
BEGIN
LOCK panel.mu DO
l := panel.sessions;
WHILE (l # NIL) AND (RefListUtils.Pop(l) # sess) DO INC(pos) END;
END (* LOCK *);
RETURN Sx.FromInt(pos);
END SessListPos;
**************** Selecting Algorithms and Views ****************
PROCEDURE**************** Code Views ****************PickedAlg (sess: Session; which: TEXT) = (* LL = VBT.mu *) VAR alg : Algorithm.T; suffix: TEXT; BEGIN TRY ZeusPanelFriends.whichAlg := which; alg := Classes.NewAlg(Classes.FindAlg(which)); EXCEPT Classes.NotFound => RETURN END; Zeus.Acquire(sess); sess.viewsToAdd := RefList.Append(sess.viewsToAdd, sess.views); Zeus.Release(sess); IF sess.alg # NIL THEN DeleteAlg(sess) END; Zeus.AttachAlg(sess, alg); alg.install(); sess.algIsSet := TRUE; IF CheckPrefix(which, sess.name & ".", suffix) THEN FormsVBT.PutText(sess.fv, "algName", suffix); SelectInBrowser(FormsVBT.GetVBT(sess.fv, "algs"), suffix); END; FormsVBT.PutGeneric(sess.fv, "dataForm", alg.data); FormsVBT.PutGeneric(sess.fv, "eventDataForm", alg.eventData); InitViewBrowser(sess, alg); InitCodeViewBrowser(sess, alg); SetAllViewTitles(sess); (* also makes incompat views dormant *) END PickedAlg; PROCEDUREPickedView (sess: Session; which: TEXT): View.T = (* LL = VBT.mu *) VAR view: View.T; BEGIN TRY ZeusPanelFriends.whichView := which; view := Classes.NewView(Classes.FindView(which)); EXCEPT Classes.NotFound => view := NewCodeView(sess, which); END; IF view = NIL THEN RETURN NIL END; view.install(); SetViewTitle(sess, view); (* IF sess.inTrestle THEN MoveNear(view, sess.fv); ELSE MoveNear(view, Resolve(NIL).fv); END; *) RefListUtils.Push(sess.viewsToAdd, view); ZeusPrivate.Mark(sess, view); RETURN view END PickedView; PROCEDUREDeleteAlg (sess: Session) = (* LL = VBT.mu *) BEGIN (* DeleteCodeViews(sess); EmptyCodeViewBrowser(sess, sess.alg); *) sess.alg.delete(); END DeleteAlg; PROCEDUREAttachViews (sess: Session) = (* LL = VBT.mu *) VAR rest: RefList.T; view: View.T; BEGIN rest := sess.viewsToAdd; WHILE rest # NIL DO view := NARROW(rest.head, View.T); Zeus.AttachView(sess, view); rest := rest.tail; END; sess.viewsToAdd := NIL; END AttachViews; PROCEDUREDetachView (view: View.T) = (* LL = VBT.mu *) VAR sess := NARROW(Zeus.Resolve(view), Session); BEGIN RefListUtils.Delete(sess.viewsToAdd, view); Zeus.DetachView(view); END DetachView; PROCEDUREDeleteViews (sess: Session) = VAR rest: RefList.T; view: View.T; BEGIN (* LL = VBT.mu *) Zeus.Acquire(sess); rest := RefList.Append(sess.viewsToAdd, sess.views); Zeus.Release(sess); WHILE rest # NIL DO view := NARROW(rest.head, View.T); view.delete(); rest := rest.tail; END; sess.viewsToAdd := NIL; END DeleteViews; PROCEDUREDeleteAllViews (panel: T) = <* LL = VBT.mu *> VAR rest: RefList.T; BEGIN LOCK panel.mu DO rest := panel.sessions; WHILE rest # NIL DO DeleteViews(RefListUtils.Pop(rest)); END; END; END DeleteAllViews; PROCEDURESetAllViewTitles (sess: Session) = (* LL = VBT.mu *) (* This sets view titles, and also makes views that are incompatible with the current algorithm be Dormant. *) VAR rest: RefList.T; BEGIN rest := sess.viewsToAdd; WHILE rest # NIL DO WITH v = NARROW(RefListUtils.Pop(rest), View.T) DO IF v.isCompat(sess.alg) THEN SetViewTitle(sess, v); ViewClass.Activate(v, TRUE); ELSE ViewClass.Activate(v, FALSE); END; END; END; Zeus.Acquire(sess); rest := sess.views; Zeus.Release(sess); WHILE rest # NIL DO WITH v = NARROW(RefListUtils.Pop(rest), View.T) DO IF v.isCompat(sess.alg) THEN SetViewTitle(sess, v); ViewClass.Activate(v, TRUE); ELSE ViewClass.Activate(v, FALSE); END; END; END; END SetAllViewTitles; PROCEDURESetViewTitle (sess: Session; view: View.T) = (* LL = VBT.mu *) VAR asuffix, vsuffix: TEXT; BEGIN IF CheckPrefix(view.name, sess.name & ".", vsuffix) AND CheckPrefix(sess.alg.name, sess.name & ".", asuffix) THEN RenameTrestleChassis(view, asuffix & ": " & vsuffix); END; END SetViewTitle; PROCEDUREInitViewBrowser (sess: Session; alg: Algorithm.T) = VAR tp : ListVBT.T := FormsVBT.GetVBT(sess.fv, "views"); info := GetGroupInfo(sess.name, FALSE); l : TextList.T; view: View.T; BEGIN (* LL = VBT.mu *) tp.removeCells(0, LAST(INTEGER)); l := info.views; WHILE l # NIL DO WITH t = l.head, name = sess.name & "." & t DO TRY l := l.tail; view := Classes.SampleView(Classes.FindView(name)); IF view.isCompat(alg) THEN InsertToBrowser(tp, t); END; EXCEPT Classes.NotFound => END; END; END; END InitViewBrowser;
<*UNUSED*> PROCEDURE**************** Broadcasting to Zeus Routines ****************DeleteCodeViews (sess: Session) = VAR l: RefList.T; BEGIN (* LL = VBT.mu *) l := sess.viewsToAdd; WHILE l # NIL DO TYPECASE RefListUtils.Pop(l) OF | ZeusCodeView.T (v) => v.delete(); RefListUtils.Delete(sess.viewsToAdd, v); ELSE END; END; Zeus.Acquire(sess); l := sess.views; Zeus.Release(sess); WHILE l # NIL DO TYPECASE RefListUtils.Pop(l) OF | ZeusCodeView.T (v) => v.delete(); (* Zeus.DetachView does the rest *) ELSE END; END; END DeleteCodeViews; PROCEDUREIsCodeView (which: TEXT; sess: Session; VAR file: TEXT): BOOLEAN = (* LL = arbitrary *) VAR t : TEXT; list: RefList.T; BEGIN IF NOT CheckPrefix(which, sess.name & ".", t) THEN RETURN FALSE END; list := RefListUtils.Assoc(sess.alg.codeViews, t); IF RefList.Length(list) # 2 THEN RETURN FALSE; ELSE TYPECASE list.tail.head OF | TEXT (txt) => file := txt; RETURN TRUE; ELSE RETURN FALSE; END; END; END IsCodeView; PROCEDURENewCodeView (sess: Session; which: TEXT): ZeusCodeView.T = (* LL = VBT.mu *) VAR twr := TextWr.New(); view : ZeusCodeView.T; t, fn: TEXT; path: Rsrc.Path; BEGIN IF NOT IsCodeView(which, sess, fn) THEN ReportError(which & " is not a code view"); RETURN NIL END; path := sess.alg.codePath; IF path = NIL THEN path := GetPath() END; TRY view := ZeusCodeView.New(which, Rsrc.Open(fn, path), sess.alg, twr); EXCEPT Rsrc.NotFound => ReportError("Cannot find file " & fn); RETURN NIL; END; t := TextWr.ToText(twr); IF NOT Text.Equal(t, "") THEN ReportError(t); RETURN NIL ELSE RETURN view END; END NewCodeView; <*UNUSED*> PROCEDUREEmptyCodeViewBrowser (sess: Session; alg: Algorithm.T) = VAR l := alg.codeViews; browser := FormsVBT.GetVBT(sess.fv, "views"); BEGIN (* LL = VBT.mu *) WHILE l # NIL DO DeleteFromBrowser( browser, NARROW(NARROW(RefListUtils.Pop(l), RefList.T).head, TEXT)); END; END EmptyCodeViewBrowser; PROCEDUREInitCodeViewBrowser (sess: Session; alg: Algorithm.T) = VAR l := alg.codeViews; browser := FormsVBT.GetVBT(sess.fv, "views"); BEGIN (* LL = VBT.mu *) WHILE l # NIL DO InsertToBrowser( browser, NARROW(NARROW(RefListUtils.Pop(l), RefList.T).head, TEXT)); END; END InitCodeViewBrowser;
PROCEDURE**************** Interpreter ****************Startrun (sess: Session) = BEGIN (* LL = {} *) Zeus.Dispatch(sess.alg, Zeus.EventStyle.Broadcast, Zeus.MaxPriority, "ZeusClass.Startrun", DispatchStartrun, NIL); END Startrun; PROCEDUREDispatchStartrun (v: ZeusClass.T; <*UNUSED*> args: REFANY) = <* LL = {} *> (* Must test type of v, since Broadcast events go to both. *) BEGIN TYPECASE v OF | View.T (v) => v.startrun(); ELSE END; END DispatchStartrun; PROCEDUREEndrun (sess: Session) = BEGIN (* LL = {} *) Zeus.Dispatch(sess.alg, Zeus.EventStyle.Broadcast, Zeus.MaxPriority, "ZeusClass.Endrun", DispatchEndrun, NIL); END Endrun; PROCEDUREDispatchEndrun (v: ZeusClass.T; <*UNUSED*> args: REFANY) = <* LL = {} *> (* Must test type of v, since Broadcast events go to both. *) BEGIN TYPECASE v OF | View.T (v) => v.endrun(); ELSE END; END DispatchEndrun;
PROCEDUREPanelThread (pc: PanelClosure): REFANY = (* LL = {} *) VAR l : RefList.T; (* of Session *) sess : Session; panel := pc.panel; PROCEDURE OKToPause (): BOOLEAN = BEGIN RETURN (panel.runState = RunState.Paused) OR (panel.runState = RunState.Stepping);
RETURN (panel.runState = RunState.Paused) OR ((scripting # ScriptingState.Playback) AND (panel.runState = RunState.Stepping));
END OKToPause;
BEGIN (* LL = {} *)
DebugWrite(P-id =& Fmt.Ref(Thread.Self()) &\n);
panel.panelThread := Thread.Self();
WHILE TRUE DO
<* ASSERT (panel.numActive = 0) *>
LOCK panel.mu DO
IF debugP THEN DebugWrite(Pi ); END;
panel.clock := 0;
panel.subclock := 0;
IF panel.quit THEN RETURN NIL; END;
IF scripting = ScriptingState.Playback THEN
PanelThreadPlayback(panel, TRUE);
END;
WHILE (panel.runState # RunState.Running)
AND (panel.runState # RunState.Stepping)
AND (NOT panel.quit) DO
(* wait for a user-invoked Step or Go command... *)
IF debugP THEN DebugWrite(Pj ); END;
Thread.Wait(panel.mu, panel.runCond);
END;
IF panel.quit THEN RETURN NIL; END;
panel.clock := 1; (* clock is 0 only when idle *)
END;
LOCK VBT.mu DO
LOCK panel.mu DO
l := panel.sessions;
WHILE l # NIL DO
sess := RefListUtils.Pop(l);
IF NOT sess.quit THEN
ChangeSessActive(sess, panel, TRUE);
sess.waitUntil := 0;
FormsVBT.MakeActive(sess.fv, "abort");
END;
END;
END;
END;
LOCK panel.mu DO
WHILE panel.numActive > 0 DO
IF debugP THEN DebugWrite(Pa ); END;
panel.numRunning := 0;
l := panel.sessions;
WHILE l # NIL DO
sess := l.head;
IF sess.active AND (sess.waitUntil <= panel.clock) THEN
sess.running := TRUE;
INC(panel.numRunning);
Thread.Broadcast(sess.runCond);
ELSE
sess.running := FALSE;
END;
l := l.tail;
END;
IF panel.numRunning = 0 THEN
IF debugP THEN DebugWrite(Pb ); END;
INC(panel.clock);
panel.subclock := 0;
ELSE
IF debugP THEN DebugWrite(Pc ); END;
Thread.Wait(panel.mu, panel.algCond);
(* now panel.numRunning = 0 *)
IF debugP THEN DebugWrite(Pd ); END;
IF scripting = ScriptingState.Playback THEN
PanelThreadPlayback(panel, FALSE);
END;
IF OKToPause() THEN
WaitForUser(panel);
END;
INC(panel.subclock);
END;
END;
END;
END;
RETURN NIL;
END PanelThread;
PROCEDURE PanelThreadPlayback (panel: T; frameStart: BOOLEAN) =
<* LL = {panel.mu} *>
(* but NOT VBT.mu *)
(* No algorithm threads are running. Release panel.mu, lock VBT.mu.
If frameStart, flush playback records that aren't frame-starters.
Call DoNextPlayback, release VBT.mu, reacquire panel.mu, and return. *)
BEGIN
IF debugP THEN DebugWrite(ptp ); END;
Thread.Release(panel.mu);
TRY
LOCK VBT.mu DO
IF frameStart THEN FlushFramePlayback() END;
DoNextPlayback(panel);
END;
FINALLY
Thread.Acquire(panel.mu);
END;
END PanelThreadPlayback;
PROCEDURE WaitForUser (panel: T) =
<* LL = {panel.mu} *>
(* but NOT VBT.mu *)
(* panel.numRunning = 0, so no algorithm threads are running. Lock
ordering requires us to release panel.mu before we can lock VBT.mu.
We need to lock VBT.mu to enable/disable feedback. Sleeping unlocks
panel.mu anyway, so it's probably no big deal to unlock it a little
earlier. *)
VAR
l: RefList.T;
sess: Session;
BEGIN
IF debugP THEN DebugWrite(wfu ); END;
Thread.Release(panel.mu);
LOCK VBT.mu DO
LOCK panel.mu DO
l := panel.sessions;
WHILE l # NIL DO
sess := RefListUtils.Pop(l);
IF sess.active THEN EnableFeedback (sess) END;
END;
END
END;
TRY
LOCK panel.mu DO Thread.Wait(panel.mu, panel.runCond) END;
FINALLY
LOCK VBT.mu DO
LOCK panel.mu DO
l := panel.sessions;
WHILE l # NIL DO
sess := RefListUtils.Pop(l);
DisableFeedback (sess); (* not just for active sessions *)
END;
END
END;
Thread.Acquire(panel.mu);
END;
END WaitForUser;
VAR
NullDataView := NEW(DataView.T);
PROCEDURE AlgThread (ac: AlgClosure): REFANY =
VAR finalState: RunState;
BEGIN (* LL = {} *)
WITH panel = ac.panel,
sess = ac.sess,
alg = sess.alg
DO
DebugWrite(A-id =& Fmt.Ref(Thread.Self()) &\n);
sess.algThread := Thread.Self();
WHILE TRUE DO
IF debugP THEN DebugWrite(Ak ); END;
LOCK panel.mu DO
IF sess.quit THEN RETURN NIL; END;
(* wait for a user-invoked Step or Go command... *)
Thread.Wait(panel.mu, sess.runCond);
IF debugP THEN DebugWrite(Al ); END;
IF sess.quit THEN RETURN NIL; END;
END;
IF debugP THEN DebugWrite(Am ); END;
<* ASSERT (sess.active) *>
LOCK VBT.mu DO AttachViews(sess); END;
IF alg.varPath = NIL THEN alg.varPath := GetPath() END;
alg.varView := NIL;
Startrun(sess);
IF alg.varView = NIL THEN alg.varView := NullDataView END;
finalState := RunState.Done;
TRY
IF sess.algIsSet THEN
LOCK VBT.mu DO sess.alg.updateEventCounts(TRUE) END;
IF debugP THEN DebugWrite(An ); END;
sess.alg.run();
IF debugP THEN DebugWrite(Ao ); END;
LOCK VBT.mu DO sess.alg.updateEventCounts(FALSE) END;
END
EXCEPT
Thread.Alerted => finalState := RunState.Aborted;
IF debugP THEN DebugWrite(Ap ); END;
| FormsVBT.Error (errorText) =>
ReportError("FormsVBT error in algorithm: " & errorText);
ELSE
ReportError("Unhandled exception raised in algorithm.");
END;
(* Endrun is broadcast (doesn't go through PostEventCallback),
so we can now unregister from the panel's group of alg threads: *)
IF debugP THEN DebugWrite(Aq ); END;
IF NOT sess.quit THEN (* test unnecessary? *)
LOCK VBT.mu DO FormsVBT.MakeDormant(sess.fv, "abort"); END
END;
LOCK panel.mu DO
ChangeSessActive(sess, panel, FALSE);
END;
LOCK VBT.mu DO SetRunState(panel, finalState); END;
Endrun(sess);
LOCK panel.mu DO StopRunning(sess, panel) END;
END;
RETURN NIL;
END;
END AlgThread;
PROCEDURE StopRunning (sess: Session; panel: T) =
<* LL.sup = panel.mu *>
BEGIN
IF debugP THEN DebugWrite(sr ); END;
IF sess.running THEN
sess.running := FALSE;
DEC(panel.numRunning);
IF panel.numRunning = 0 THEN Thread.Signal(panel.algCond); END;
END;
END StopRunning;
PROCEDURE ChangeSessActive (sess: Session; panel: T; act: BOOLEAN) =
<*LL = panel.mu*>
BEGIN
IF RefList.Member(panel.sessions, sess) THEN
IF act THEN
IF NOT sess.active THEN INC(panel.numActive) END;
ELSE
IF sess.active THEN DEC(panel.numActive) END;
END;
sess.active := act;
panel.mustSynch := (panel.numActive > 1) OR
(scripting # ScriptingState.Off);
END;
END ChangeSessActive;
PROCEDURE Go (panel: T; eventTime: VBT.TimeStamp) =
BEGIN (* LL = VBT.mu *)
GrabFocus(panel, eventTime);
CASE GetRunState(panel) OF
| RunState.Virgin, RunState.Done, RunState.Aborted =>
SetRunState(panel, RunState.Running);
Thread.Broadcast(panel.runCond);
| RunState.Stepping, RunState.Paused =>
SetRunState(panel, RunState.Running);
Thread.Broadcast(panel.runCond);
| RunState.Running => SetRunState(panel, RunState.Paused);
END;
END Go;
PROCEDURE Step (panel: T; eventTime: VBT.TimeStamp) =
BEGIN (* LL = VBT.mu *)
GrabFocus(panel, eventTime);
SetRunState(panel, RunState.Stepping);
Thread.Broadcast(panel.runCond);
END Step;
PROCEDURE AbortInternal (panel: T; eventTime: VBT.TimeStamp) =
(* LL < panel.mu *)
BEGIN
LOCK panel.mu DO AbortWithLock(panel, eventTime) END;
END AbortInternal;
PROCEDURE AbortWithLock (panel: T; eventTime: VBT.TimeStamp) =
(* LL = panel.mu *)
VAR
l : RefList.T;
sess: Session;
BEGIN
(* DebugStart();*)
(* DebugWrite("abort:" & Fmt.Ref(Thread.Self()) & "\n");*)
IF NOT stateIdle[panel.runState] THEN
Thread.Broadcast(panel.runCond);
l := panel.sessions;
WHILE l # NIL DO sess := RefListUtils.Pop(l); AbortAlg(sess); END;
END;
ReleaseFocus(panel, eventTime);
END AbortWithLock;
PROCEDURE AbortAlg (sess: Session) =
BEGIN (* LL = arbitrary *)
DisableFeedback(sess);
IF sess.active THEN
Thread.Alert(sess.algThread);
ZeusPrivate.AlertViews(sess); (* abort any alertable views *)
END;
END AbortAlg;
PROCEDURE PreEventCallback (<*UNUSED*> sess : Session;
<*UNUSED*> initiator: ZeusClass.T;
<*UNUSED*> style : Zeus.EventStyle;
<*UNUSED*> priority : INTEGER;
<*UNUSED*> eventName: TEXT )
RAISES {Thread.Alerted} =
BEGIN (* LL = arbitrary *)
IF Thread.TestAlert() THEN RAISE Thread.Alerted END;
END PreEventCallback;
PROCEDURE PostEventCallback ( sess : Session;
initiator: ZeusClass.T;
style : Zeus.EventStyle;
priority : INTEGER;
<*UNUSED*> eventName: TEXT )
(* LL <= VBT.mu *)
RAISES {Thread.Alerted} =
VAR
feedFg, pauseFg: BOOLEAN;
alg : Algorithm.T;
panel := Resolve(NIL);
now, delayFrac : REAL;
PROCEDURE OKToPause (): BOOLEAN =
(* LL = panel.mu *)
BEGIN
RETURN
(panel.runState = RunState.Paused)
OR ((panel.mustSynch OR (panel.runState = RunState.Stepping))
AND (priority <= panel.priority) AND alg.stopAtEvent
AND sess.evtWasHandled);
END OKToPause;
PROCEDURE FeedbackOK (): BOOLEAN =
(* LL = panel.mu *)
BEGIN
RETURN (panel.runState = RunState.Paused)
OR ((panel.runState = RunState.Stepping)
AND (priority <= panel.priority) AND alg.stopAtEvent
AND sess.evtWasHandled);
END FeedbackOK;
BEGIN
IF (style = Zeus.EventStyle.Output) OR (style = Zeus.EventStyle.Code) THEN
(* LL < VBT.mu *)
alg := NARROW(initiator, Algorithm.T);
LOCK panel.mu DO feedFg := FeedbackOK(); pauseFg := OKToPause(); END;
IF (NOT feedFg) AND sess.evtWasHandled THEN
IF style = Zeus.EventStyle.Output THEN
delayFrac := panel.minDelayFrac;
ELSIF style = Zeus.EventStyle.Code THEN
delayFrac := panel.codeDelayFrac;
ELSE
delayFrac := 0.0;
END;
now := Animate.ATime();
IF now < delayFrac THEN
TRY
Thread.AlertPause(MAX(0.0D0, FLOAT(panel.delayTime
* (delayFrac - now), LONGREAL)));
EXCEPT
Thread.Alerted => Thread.Alert(Thread.Self());
END;
END;
END;
(* LOCK panel.mu DO feedFg := FeedbackOK(); END;*)
IF debugP THEN DebugWrite(pec ); END;
LOCK panel.mu DO
IF pauseFg (* OKToPause() *) THEN
<* ASSERT NOT RefList.Member(panel.sessions, sess) OR sess.running *>
StopRunning(sess, panel);
sess.waitUntil := panel.clock + alg.waitAtEvent;
Thread.AlertWait(panel.mu, sess.runCond);
END;
END;
END;
IF Thread.TestAlert() THEN RAISE Thread.Alerted END;
END PostEventCallback;
PROCEDURE GetRunState (panel: T): RunState =
BEGIN (* LL = arbitrary *)
LOCK panel.mu DO RETURN panel.runState; END;
END GetRunState;
PROCEDURE SetRunState (panel: T;
state: RunState;
msg : TEXT := NIL) =
<* LL = VBT.mu *>
BEGIN
LOCK panel.mu DO SetRunStateWithLock(panel, state, msg) END;
END SetRunState;
PROCEDURE SetRunStateWithLock (panel: T;
state: RunState;
msg : TEXT := NIL) =
<* LL = {VBT.mu, panel.mu} *>
PROCEDURE Set (btn: TEXT; status: TEXT) =
VAR l: RefList.T;
abortable := NOT stateIdle[state];
BEGIN
l := panel.sessions;
WHILE l # NIL DO
WITH sess = NARROW(RefListUtils.Pop(l), Session) DO
IF abortable THEN
FormsVBT.MakeDormant(sess.fv, "algs")
ELSE
FormsVBT.MakeActive(sess.fv, "algs")
END
END
END;
IF abortable THEN
FormsVBT.MakeDormant(panel.fv, "restoreBtn");
FormsVBT.MakeDormant(panel.fv, "restoreShortcut");
FormsVBT.MakeDormant(panel.fv, "restoreContents");
FormsVBT.MakeDormant(panel.fv, "sessionMenu");
FormsVBT.MakeActive(panel.fv, "abortBtn");
ELSE
FormsVBT.MakeActive(panel.fv, "restoreBtn");
FormsVBT.MakeActive(panel.fv, "restoreShortcut");
FormsVBT.MakeActive(panel.fv, "restoreContents");
FormsVBT.MakeActive(panel.fv, "sessionMenu");
FormsVBT.MakeDormant(panel.fv, "abortBtn");
END;
ActivateScriptButtons(panel);
FormsVBT.PutText(panel.fv, "goText", btn);
IF msg # NIL THEN status := status & " - " & msg END;
FormsVBT.PutText(panel.fv, "status", status);
END Set;
BEGIN
IF (panel.numActive > 0) AND ((state = RunState.Aborted)
OR (state = RunState.Done)) THEN
RETURN;
END;
panel.runState := state;
CASE state OF
| RunState.Virgin => Set("GO", "Ready");
| RunState.Running => Set("PAUSE", "Running");
| RunState.Stepping => Set("RESUME", "Paused");
| RunState.Paused => Set("RESUME", "Paused");
| RunState.Done => Set("GO", "Completed");
| RunState.Aborted => Set("GO", "Aborted");
END;
END SetRunStateWithLock;
**************** Reactivity / Feedback ****************
PROCEDUREEnableFeedback (sess: Session) = <* LL = VBT.mu *> BEGIN ControlSessionFeedback(sess, TRUE); END EnableFeedback; PROCEDUREDisableFeedback (sess: Session) = <* LL = VBT.mu *> BEGIN ControlSessionFeedback(sess, FALSE); END DisableFeedback; PROCEDUREControlSessionFeedback (sess: Zeus.Session; on: BOOLEAN) = <* LL = VBT.mu *> VAR l := sess.views; BEGIN WITH alg = sess.alg DO alg.reactivity(on); WHILE l # NIL DO WITH view = NARROW(RefListUtils.Pop(l), View.T) DO IF view.isCompat(alg) THEN view.reactivity(on); END; END; END; END; END ControlSessionFeedback; PROCEDUREStartFeedback (alg: Algorithm.T) RAISES {Thread.Alerted} = <* LL = {}, S = Running *>
Suspend the algorithm and allow feedback events (as if the user had
clicked Pause). Return after alg has called EndFeedback. This
procedure is a noop if there already is a 'pending' StartFeedback for
this alg.
VAR sess := NARROW(Zeus.Resolve(alg), Session);
BEGIN
LOCK VBT.mu DO
IF NOT sess.feedbackOn THEN
sess.feedbackOn := TRUE;
EnableFeedback(sess);
TRY Thread.AlertWait(VBT.mu, sess.feedCond);
FINALLY
DisableFeedback(sess);
sess.feedbackOn := FALSE;
END;
END;
END;
END StartFeedback;
PROCEDURE EndFeedback (alg: Algorithm.T) =
<* LL = VBT.mu, S = Paused *>
(* This procedure signals a previous call to StartFeedback to return. It
is typically called from an algorithm's Feedback method. *)
VAR sess := NARROW(Zeus.Resolve(alg), Session);
BEGIN
IF NOT sess.feedbackOn THEN
ReportError("EndFeedback called with feedback off")
ELSE
Thread.Broadcast(sess.feedCond);
END;
END EndFeedback;
PROCEDURE Pause (alg: Algorithm.T; msg: TEXT := NIL)
RAISES {Thread.Alerted} =
<* LL = 0, S = Running *>
VAR
sess := NARROW(Zeus.Resolve(alg), Session);
panel := Resolve(NIL);
BEGIN
LOCK VBT.mu DO SetRunState(panel, RunState.Paused, msg) END;
LOCK panel.mu DO
StopRunning(sess, panel);
sess.waitUntil := panel.clock;
Thread.AlertWait(panel.mu, sess.runCond)
END
END Pause;
**************** Event Priority ****************
PROCEDURE GetPriority (): INTEGER; Report what priority the user has set in the control panel.
<*UNUSED*> PROCEDUREPROCEDURE SetPriority (priority: INTEGER); Change the priority. Client algorithms can use this to cause events to be generated that are not included in theGetPriority (): INTEGER = (* LL = VBT.mu *) BEGIN RETURN GetPanelPriority(Resolve(NIL)); END GetPriority;
Step command. To do so, the
algorithm first retrieves the current priority, then lowers it (probably
to 0), does some stuff, then restores the priority to its initial
value.
<*UNUSED*> PROCEDURE**************** Speedometer ****************SetPriority (priority: INTEGER) = (* LL = VBT.mu *) BEGIN SetPanelPriority(Resolve(NIL), priority); END SetPriority; PROCEDURESetPanelPriority (panel: T; priority: INTEGER) = BEGIN (* LL = VBT.mu *) LOCK panel.mu DO panel.priority := priority; FormsVBT.PutInteger(panel.fv, "priority", priority); END; END SetPanelPriority; PROCEDUREGetPanelPriority (panel: T): INTEGER = BEGIN (* LL = arbitrary *) LOCK panel.mu DO RETURN panel.priority END; END GetPanelPriority;
M3 FormsVBT doesn't have a REAL-valued slider, so this is done another way.
PROCEDURE**************** Keyboard Focus ****************UpdateSpeed (panel: T) = (* LL = VBT.mu *) BEGIN panel.delayTime := FromFancySlider(panel); Script(ActionType.Speed, Sx.FromReal(panel.delayTime)); Animate.SetDuration(panel.delayTime); FormsVBT.PutText( panel.fv, "delayText", Fmt.Real(panel.delayTime, Fmt.Style.Fix, 4)); END UpdateSpeed; PROCEDUREUpdateMinDelay (panel: T) = (* LL = VBT.mu *) BEGIN panel.minDelayFrac := FromSimpleSlider(panel, "minDelayFrac"); Script(ActionType.MinDelay, Sx.FromReal(panel.minDelayFrac)); FormsVBT.PutText(panel.fv, "minDelayText", Fmt.Real(panel.minDelayFrac, Fmt.Style.Fix, 2)); END UpdateMinDelay; PROCEDUREUpdateCodeDelay (panel: T) = (* LL = VBT.mu *) BEGIN panel.codeDelayFrac := FromSimpleSlider(panel, "codeDelayFrac"); Script(ActionType.CodeDelay, Sx.FromReal(panel.codeDelayFrac)); FormsVBT.PutText(panel.fv, "codeDelayText", Fmt.Real(panel.codeDelayFrac, Fmt.Style.Fix, 2)); END UpdateCodeDelay; PROCEDUREUSFError (panel: T; t: TEXT) = (* LL = VBT.mu *) BEGIN FormsVBT.PutText(panel.fv, "maxSpeedFactor", Fmt.Real(panel.speedFactor, Fmt.Style.Fix, 2)); ReportError("Bad max speed factor value: " & t) END USFError; PROCEDUREUpdateSpeedFactor (panel: T) = (* LL = VBT.mu *) VAR t := FormsVBT.GetText(panel.fv, "maxSpeedFactor"); r: REAL; BEGIN TRY r := Lex.Real(TextRd.New (t)); IF r <= 1.0 THEN USFError(panel, t); ELSE panel.speedFactor := r; Script(ActionType.SpeedFactor, t); panel.logSpeedFactor := Math.log(FLOAT(panel.speedFactor, LONGREAL)); UpdateSpeed(panel) END; EXCEPT Lex.Error, FloatMode.Trap => USFError(panel, t); END; END UpdateSpeedFactor; PROCEDURESetupSliderConversion ( fv : FormsVBT.T; name: TEXT; VAR min, range, value: LONGREAL ) = (* LL = VBT.mu *) (* range is set to the range of the slider, min is set to its min, and value is set to its value. *) VAR v := NARROW(FormsVBT.GetVBT(fv, name), ScrollerVBT.T); BEGIN min := FLOAT(ScrollerVBT.GetMin(v), LONGREAL); range := FLOAT(ScrollerVBT.GetMax(v), LONGREAL) - min; value := FLOAT(ScrollerVBT.Get(v), LONGREAL); END SetupSliderConversion; PROCEDUREFromSimpleSlider (panel: T; name: TEXT): REAL = VAR min, range, value: LONGREAL; BEGIN SetupSliderConversion(panel.fv, name, min, range, value); RETURN FLOAT((value - min) / range); END FromSimpleSlider; PROCEDUREToSimpleSlider (panel: T; name: TEXT; r: REAL) = VAR min, range, value: LONGREAL; BEGIN SetupSliderConversion(panel.fv, name, min, range, value); WITH frac = FLOAT(MAX(0.0, MIN(1.0, r)), LONGREAL) DO FormsVBT.PutInteger(panel.fv, name, ROUND(frac * range + min)); END; END ToSimpleSlider; CONST SpeedoBreak: LONGREAL = 0.1d0; SpeedoRange: LONGREAL = (1.0d0 - SpeedoBreak); SpeedoMid: LONGREAL = (SpeedoBreak + 0.5d0 * SpeedoRange); PROCEDUREFromFancySlider (panel: T): REAL = (* LL = VBT.mu *) (* Returns a delay value *) VAR min, range, value: LONGREAL; BEGIN SetupSliderConversion(panel.fv, "delay", min, range, value); value := (value - min) / range; IF value <= SpeedoBreak THEN RETURN FLOAT(value) / (panel.speedFactor * FLOAT(SpeedoBreak)); ELSE RETURN FLOAT(Math.exp(panel.logSpeedFactor * 2.0d0 * (value - SpeedoMid) / SpeedoRange)) END; END FromFancySlider; PROCEDUREToFancySlider (panel: T; delay: REAL) = (* LL = VBT.mu *) VAR min, range, value: LONGREAL; BEGIN SetupSliderConversion(panel.fv, "delay", min, range, value); IF delay <= (1.0 / panel.speedFactor) THEN FormsVBT.PutInteger( panel.fv, "delay", ROUND(SpeedoBreak * FLOAT(delay * panel.speedFactor, LONGREAL) * range + min)); ELSE FormsVBT.PutInteger( panel.fv, "delay", ROUND( (SpeedoRange * Math.log(FLOAT(delay, LONGREAL)) / (panel.logSpeedFactor * 2.0d0) + SpeedoMid) * range + min)); END; END ToFancySlider;
PROCEDURE**************** Photo Album ****************GrabFocus (<*UNUSED*> panel: T; <*UNUSED*> time: VBT.TimeStamp) = BEGIN END GrabFocus; PROCEDUREReleaseFocus (<*UNUSED*> panel: T; <*UNUSED*> time: VBT.TimeStamp) = BEGIN END ReleaseFocus;
PROCEDURECntViews (panel: T): CARDINAL = VAR rest, views: RefList.T; cnt : CARDINAL := 0; BEGIN LOCK panel.mu DO rest := panel.sessions; WHILE rest # NIL DO views := NARROW(rest.head, Session).views; WHILE views # NIL DO INC(cnt); views := views.tail; END; rest := rest.tail; END; END; RETURN cnt END CntViews; PROCEDURETakePhotos (panel: T) = VAR rest, views: RefList.T; BEGIN LOCK panel.mu DO rest := panel.sessions; WHILE rest # NIL DO views := NARROW(rest.head, Session).views; WHILE views # NIL DO WITH view = NARROW(views.head, View.T), flex = NARROW(MultiFilter.Child(panel.album), FlexVBT.T), album = NARROW(MultiFilter.Child(flex), AlbumVBT.T) DO album.add(view); END; views := views.tail; END; rest := rest.tail; END; END; END TakePhotos; EXCEPTION Oops; PROCEDUREGetReal (fv: FormsVBT.T; name: TEXT): REAL RAISES {Oops} = VAR t := FormsVBT.GetText(fv, name); r: REAL; BEGIN TRY r := Lex.Real(TextRd.New (t)); IF r <= 5.0 THEN ReportError("Bad value (too small) for " & name & ": " & t); RAISE Oops; ELSE RETURN r END; EXCEPT Lex.Error, FloatMode.Trap => ReportError("Bad real value for " & name & ": " & t); RAISE Oops; END; END GetReal; CONST AlbumAxis = Axis.T.Ver;
OBSOLETE FixedShape = FlexShape.Shape{FlexShape.Fixed, FlexShape.Fixed};
FixedShape = FlexVBT.Fixed; PROCEDUREPROCEDURE PhotographViews(alg: Algorithm.T) RAISES {Thread.Alerted};NewAlbum (fv: FormsVBT.T; cnt: CARDINAL): AlbumVBT.T RAISES {Oops} = BEGIN RETURN NEW(AlbumVBT.T).init(AlbumAxis, cnt, GetReal(fv, "photoWidth"), GetReal(fv, "photoHeight")) END NewAlbum; TYPE MyViewport = ViewportVBT.T OBJECT panel: T; OVERRIDES misc := MiscVP; END; PROCEDUREMiscVP (t: MyViewport; READONLY cd: VBT.MiscRec) = BEGIN IF cd.type = VBT.Deleted THEN t.panel.album := NIL END; ViewportVBT.T.misc(t, cd); END MiscVP; PROCEDURESetAlbum (panel: T; cnt: CARDINAL) RAISES {Oops} = BEGIN IF panel.album = NIL THEN panel.album := NEW(MyViewport, panel := panel).init( NEW(FlexVBT.T).init( NewAlbum(panel.fv, cnt), FixedShape), Axis.Other[AlbumAxis], shapeStyle := ViewportVBT.ShapeStyle.Unrelated, scrollStyle := ViewportVBT.ScrollStyle.HorAndVer); (* panel.album := NEW(Filter.T).init(NewAlbum(panel.fv, cnt)); *) Trestle.Attach(panel.album); Trestle.Decorate( panel.album, applName := "Zeus Photo Album"); Trestle.MoveNear(panel.album, NIL); ELSE WITH flex = MultiFilter.Child(panel.album), oldAlbum = MultiFilter.Replace( flex, NewAlbum(panel.fv, cnt)) DO VBT.Discard(oldAlbum) END END; panel.cntViews := cnt; END SetAlbum; PROCEDUREPhoto (panel: T) = VAR cnt := CntViews(panel); BEGIN (* LL = VBT.mu *) TRY IF panel.album = NIL OR panel.cntViews # cnt THEN SetAlbum(panel, cnt); END; EXCEPT Oops => (* don't do anything *) END; TakePhotos(panel); END Photo; PROCEDUREClearAlbum (panel: T) = BEGIN (* LL = VBT.mu *) IF panel.album # NIL THEN WITH flex = NARROW(MultiFilter.Child(panel.album), FlexVBT.T), album = NARROW(MultiFilter.Child(flex), AlbumVBT.T) DO album.clear() END END END ClearAlbum;
<* LL=VBT.mu, s=Any *>
This procedure takes aphotograph(captures a miniture pixmap) of all active views and enters them into anphoto album. It creates the album if none exists. All views will get redisplayed (and maybe reshaped) when the photograph is taken.
<* UNUSED *> PROCEDUREPROCEDURE ClearPhotoAlbum(alg: Algorithm.T) RAISES {Thread.Alerted};PhotographViews (<* UNUSED *> alg: Algorithm.T) = VAR panel := Resolve(NIL); BEGIN (* LL = VBT.mu *) Photo(panel) END PhotographViews;
<* LL=VBT.mu, s=Any *>
This procedure removes anyphotographsfrom thephoto album(see PhotographViews, above).
<* UNUSED *> PROCEDURE**************** Scripting ****************ClearPhotoAlbum (<* UNUSED *> alg: Algorithm.T) = VAR panel := Resolve(NIL); BEGIN (* LL = VBT.mu *) ClearAlbum(panel) END ClearPhotoAlbum;
TYPE
ActionType = {Go, Step, Abort, Speed, MinDelay, CodeDelay, SpeedFactor,
Priority, Snapshot, Restore, Sessions, Photo, ClearAlbum,
Algs, Views, AbortAlg, Destroy, ToggleTSplit,
FutureGo, FuturePause, GrabData};
ScriptRec = REF RECORD
action: ActionType;
clock : INTEGER;
subclock : INTEGER;
args : REFANY;
END;
ScriptingState = {Off, Recording, Playback};
VAR scriptOut: RefList.T; (* of ScriptRec, in reverse order *)
scriptOutFile: TEXT; (* name of file where script will be written *)
scriptIn: RefList.T; (* of ScriptRec, in forward order *)
scripting: ScriptingState := ScriptingState.Off;
VAR actName:= ARRAY ActionType OF TEXT
{"Go", "Step", "Abort", "Speed", "MinDelay", "CodeDelay",
"SpeedFactor", "Priority", "Snapshot", "Restore",
"Sessions", "Photo", "ClearAlbum", "Algs", "Views",
"AbortAlg", "Destroy", "ToggleTSplit",
"FutureGo", "FuturePause", "GrabData"};
PROCEDURE StartScript (file: TEXT) =
<* LL=VBT.mu *>
BEGIN
IF scripting = ScriptingState.Off THEN
scriptOutFile := file;
scriptOut := NIL;
ChangeScriptingState(ScriptingState.Recording);
(* move the following to just after Go/Step has been pressed. *)
Script(ActionType.Restore, SnapshotToList());
END (* IF *);
END StartScript;
PROCEDURE StopScript () =
<* LL=VBT.mu *>
BEGIN
IF scripting = ScriptingState.Recording THEN
WriteScript(scriptOutFile);
ChangeScriptingState(ScriptingState.Off);
END (* IF *);
END StopScript;
PROCEDURE WriteScript (file: TEXT) =
<* LL=VBT.mu *>
(* write scriptOut to the named file in reverse order *)
VAR
wr:= FileWr.Open(file);
rec: ScriptRec;
list := RefList.ReverseD(scriptOut);
BEGIN
scriptOut := NIL;
WHILE list # NIL DO
rec := RefListUtils.Pop(list);
TRY
Wr.PutText(wr, "(" & actName[rec.action] & " " &
"(" & Fmt.Int(rec.clock) & " " & Fmt.Int(rec.subclock) & ") ");
Sx.Print(wr, rec.args);
Wr.PutText(wr, ")\n" );
EXCEPT
Sx.PrintError =>
END;
END (* WHILE *);
Wr.Close(wr);
END WriteScript;
PROCEDURE Script (act: ActionType; argsIn: REFANY := NIL) =
To find the calling sequences for Script(), search for ActionType.;
collecting them here doesn't work, since they tend to get obsolete.
<* LL=VBT.mu *>
VAR panel := Resolve(NIL);
BEGIN
IF scripting = ScriptingState.Recording THEN
RefListUtils.Push(scriptOut, NEW(ScriptRec, action := act,
clock := panel.clock,
subclock := panel.subclock,
args := argsIn));
END (* IF *);
END Script;
PROCEDURE ScriptMaybeStartFrame (panel: T) =
BEGIN
LOCK panel.mu DO
IF stateIdle[panel.runState] AND
(scripting = ScriptingState.Recording) THEN
Script(ActionType.Restore, SnapshotToList());
Script(ActionType.FutureGo);
END;
END;
END ScriptMaybeStartFrame;
PROCEDURE StartPlayback (file: TEXT) =
<* LL=VBT.mu *>
BEGIN
IF scripting = ScriptingState.Off THEN
ReadScript(file);
ChangeScriptingState(ScriptingState.Playback);
DoNextPlayback(Resolve(NIL));
END (* IF *);
END StartPlayback;
PROCEDURE StopPlayback () =
<* LL=VBT.mu *>
BEGIN
IF scripting = ScriptingState.Playback THEN
scriptIn := NIL;
ChangeScriptingState(ScriptingState.Off);
END (* IF *);
END StopPlayback;
PROCEDURE DoNextPlayback (panel: T) =
<*LL = VBT.mu*>
VAR rec: ScriptRec;
b: BOOLEAN;
BEGIN
IF scripting = ScriptingState.Playback THEN
LOOP
IF scriptIn = NIL THEN StopPlayback(); EXIT; END;
rec := scriptIn.head;
LOCK panel.mu DO
b := (stateIdle[panel.runState] AND
(rec.clock + rec.subclock + panel.clock + panel.subclock = 0))
OR ((rec.clock + rec.subclock # 0)
AND ((panel.clock > rec.clock)
OR ((panel.clock = rec.clock)
AND (panel.subclock >= rec.subclock))));
END;
IF b THEN
EVAL RefListUtils.Pop(scriptIn);
IF NOT Playback(panel, rec) THEN EXIT END;
ELSE
EXIT;
END;
END (* LOOP *);
END;
END DoNextPlayback;
PROCEDURE FlushFramePlayback () =
<* LL=VBT.mu *>
(* Delete all ScriptRecs up to the next one for time (0,0) *)
PROCEDURE NotAtFrameStart(rec: ScriptRec): BOOLEAN =
BEGIN
RETURN (rec.clock + rec.subclock # 0)
END NotAtFrameStart;
BEGIN
IF debugP THEN DebugWrite(ffp ); END;
IF scripting = ScriptingState.Playback THEN
WHILE (scriptIn # NIL) AND NotAtFrameStart(scriptIn.head) DO
EVAL RefListUtils.Pop(scriptIn);
END;
END;
IF scriptIn = NIL THEN StopPlayback(); END;
END FlushFramePlayback;
PROCEDURE Playback (panel: T; rec: ScriptRec): BOOLEAN =
(* Return TRUE if playback may continue, FALSE if algorithm should
execute at least one step now. *)
<* LL=VBT.mu *>
PROCEDURE SessFromPos(pos: REF INTEGER): Session =
BEGIN
LOCK panel.mu DO
IF RefList.Length(panel.sessions) > pos^ THEN
RETURN NARROW(RefList.Nth(panel.sessions, pos^), Session);
ELSE
ReportError("Playback error: not enough sessions");
RETURN NIL;
END;
END;
END SessFromPos;
BEGIN
IF debugP THEN DebugWrite(play:& Fmt.Int(ORD(rec.action)) &); END;
CASE rec.action OF
| ActionType.Go =>
(* Go(panel, 0);*) (* see FutureGo *)
| ActionType.Step =>
(* Step(panel, 0);*) (* see FutureGo *)
| ActionType.Abort =>
AbortInternal(panel, 0);
| ActionType.Speed =>
ToFancySlider(panel, NARROW(rec.args, REF REAL)^);
UpdateSpeed(panel); (* works because scripting # Recording *)
| ActionType.MinDelay =>
ToSimpleSlider(panel, "minDelayFrac", NARROW(rec.args, REF REAL)^);
UpdateMinDelay(panel);
| ActionType.CodeDelay =>
ToSimpleSlider(panel, "codeDelayFrac", NARROW(rec.args, REF REAL)^);
UpdateCodeDelay(panel);
| ActionType.SpeedFactor =>
FormsVBT.PutText(panel.fv, "maxSpeedFactor", rec.args);
UpdateSpeedFactor(panel);
| ActionType.Priority =>
SetPanelPriority(panel, NARROW(rec.args, REF INTEGER)^);
| ActionType.Snapshot =>
(* don't do snapshot during playback *)
(* ZeusSnapshot.Snapshot(panel, rec.args);*)
| ActionType.Restore =>
TYPECASE rec.args OF
| TEXT (file) =>
ZeusSnapshot.Restore(panel, file);
| RefList.T (list) =>
ZeusSnapshot.RestoreFromList(panel, list);
ELSE (* do nothing if restore format is wrong *)
END;
| ActionType.Sessions =>
(* do nothing; will be caught at next frame start *)
(* NOTE: REF BOOLEAN is also wrong type, it is Sx.True or Sx.False (an Atom.T) *)
(* FormsVBT.PutBoolean(panel.fv, "inTrestle",
NARROW(rec.args.tail.head, REF BOOLEAN)^);
NewSessionDefault(rec.args.head, panel);
*)
| ActionType.Photo =>
Photo(panel);
| ActionType.ClearAlbum =>
ClearAlbum(panel);
| ActionType.Algs =>
(* do nothing; will be caught at next frame start *)
(* WITH sess = SessFromPos(rec.args.head) DO
IF sess # NIL THEN
PickedAlg(sess, rec.args.tail.head);
TRY
IF sess.alg # NIL THEN sess.alg.restore(NIL); END;
EXCEPT
ZeusClass.Error =>
END;
END;
END;
*)
| ActionType.Views =>
(* do nothing; will be caught at next frame start *)
(* WITH sess = SessFromPos(rec.args.head) DO
IF sess # NIL THEN
WITH view = PickedView(sess, rec.args.tail.head) DO
TRY
IF view # NIL THEN view.restore(NIL); END;
EXCEPT
ZeusClass.Error =>
END;
END;
END;
END;
*)
| ActionType.AbortAlg =>
WITH sess = SessFromPos(rec.args) DO
IF sess # NIL THEN AbortAlg(sess); END;
END;
| ActionType.Destroy =>
WITH sess = SessFromPos(rec.args) DO
(* This works because Script checks the "scripting" variable. *)
IF sess # NIL THEN DestroyP(NIL, NIL, sess, 0); END;
END;
| ActionType.ToggleTSplit =>
IF NOT stateIdle[panel.runState] THEN
(* number of sessions not preserved during idle states. *)
WITH sess = SessFromPos(NARROW(rec.args, RefList.T).head) DO
(* This works because Script checks the "scripting" variable. *)
IF sess # NIL THEN
ToggleTSplitP(sess.fv, NARROW(rec.args, RefList.T).tail.head, sess, 0);
END;
END;
END;
| ActionType.FutureGo =>
SetRunState(panel, RunState.Running, "Playback Mode");
Thread.Broadcast(panel.runCond);
RETURN FALSE;
| ActionType.FuturePause =>
SetRunState(panel, RunState.Paused, "Under playback control");
| ActionType.GrabData =>
ZeusSnapshot.RestoreData(panel, rec.args);
ChangeScriptingState(scripting);
END (* CASE *);
RETURN TRUE;
END Playback;
EXCEPTION BadScript;
PROCEDURE ReadScript (file: TEXT) =
<* LL=VBT.mu *>
(* read in scriptIn from the named file *)
PROCEDURE ParseAct(a: REFANY): ActionType
RAISES {BadScript} =
BEGIN
TYPECASE a OF
| Atom.T (sxs) =>
WITH name = Atom.ToText(sxs) DO
FOR i := FIRST(ActionType) TO LAST(ActionType) DO
IF Text.Equal(name, actName[i]) THEN RETURN i END;
END;
RAISE BadScript;
END;
ELSE RAISE BadScript;
END;
END ParseAct;
VAR
rd:= FileRd.Open(file);
ref: REFANY := NIL;
BEGIN
scriptIn := NIL;
TRY
WHILE NOT Rd.EOF(rd) DO
TYPECASE Sx.Read(rd) OF
| RefList.T (l) =>
IF RefList.Length(l) >= 3 THEN ref := l.tail.tail.head END;
WITH l2 = l.tail.head DO
IF ISTYPE(l2, RefList.T)
AND (RefList.Length(l2) = 2)
AND ISTYPE(RefList.Nth(l2, 0), REF INTEGER)
AND ISTYPE(RefList.Nth(l2, 1), REF INTEGER) THEN
RefListUtils.Push(
scriptIn,
NEW(ScriptRec,
action := ParseAct(l.head),
clock := NARROW(RefList.Nth(l2, 0), REF INTEGER)^,
subclock := NARROW(RefList.Nth(l2, 1), REF INTEGER)^,
args := ref));
ELSE
RAISE BadScript;
END;
END;
ELSE
RAISE BadScript;
END;
END (* WHILE *);
EXCEPT
| BadScript, Sx.ReadError => ReportError("Bad script format");
ELSE
END;
scriptIn := RefList.ReverseD(scriptIn);
Rd.Close(rd);
END ReadScript;
PROCEDURE ChangeScriptingState (newState: ScriptingState) =
Implement the ScriptingState finite state machine.
VAR panel := Resolve(NIL);
fv := panel.fv;
BEGIN (* LL = VBT.mu *)
scripting := newState;
IF scripting = ScriptingState.Off THEN
FormsVBT.PutText(fv, "recordBtnText", "Record ...");
FormsVBT.PutText(fv, "playbackBtnText", "Playback ...");
ActivateScriptButtons(panel);
ELSIF scripting = ScriptingState.Recording THEN
FormsVBT.PutText(fv, "recordBtnText", "Stop Recording");
FormsVBT.PutText(fv, "playbackBtnText", "Playback ...");
FormsVBT.MakeActive(fv, "recordBtn");
FormsVBT.MakeDormant(fv, "playbackBtn");
ELSIF scripting = ScriptingState.Playback THEN
FormsVBT.PutText(fv, "recordBtnText", "Record ...");
FormsVBT.PutText(fv, "playbackBtnText", "Stop Playback");
FormsVBT.MakeDormant(fv, "recordBtn");
FormsVBT.MakeActive(fv, "playbackBtn");
END;
IF scripting = ScriptingState.Recording THEN
FormsVBT.MakeActive(fv, "futurePause");
FormsVBT.MakeActive(fv, "grabData");
ELSE
FormsVBT.MakeDormant(fv, "futurePause");
FormsVBT.MakeDormant(fv, "grabData");
END;
FormsVBT.PopDown(fv, "RecordDialog");
FormsVBT.PopDown(fv, "PlaybackDialog");
END ChangeScriptingState;
PROCEDURE ActivateScriptButtons (panel: T) =
<* LL = VBT.mu *>
BEGIN
IF scripting = ScriptingState.Off THEN
WITH fv = panel.fv DO
IF stateIdle[panel.runState] THEN
FormsVBT.MakeActive(fv, "playbackBtn");
FormsVBT.MakeActive(fv, "recordBtn");
ELSE
FormsVBT.MakeDormant(fv, "playbackBtn");
FormsVBT.MakeDormant(fv, "recordBtn");
END;
END;
ELSIF scripting = ScriptingState.Recording THEN
WITH fv = panel.fv DO
IF stateIdle[panel.runState] THEN
FormsVBT.MakeDormant(fv, "futurePause");
FormsVBT.MakeDormant(fv, "grabData");
ELSE
FormsVBT.MakeActive(fv, "futurePause");
FormsVBT.MakeActive(fv, "grabData");
END;
END;
END;
END ActivateScriptButtons;
**************** Utilities ****************
PROCEDUREResolve (v: ZeusClass.T): T = (* LL = arbitrary *) (* This should never be called with any argument but NIL. Probably should go away soon. *) BEGIN IF v = NIL THEN RETURN ControlPanel; ELSE <* ASSERT FALSE *>
RETURN NARROW(VBT.GetProp(v, TYPECODE(T)), T);
END;
END Resolve;
<*UNUSED*> PROCEDURE Bound (val: INTEGER; min, max: INTEGER): INTEGER =
BEGIN
RETURN MAX(min, MIN(val, max))
END Bound;
PROCEDURE TextEditVBTAppend (v: TextEditVBT.T; text: TEXT) =
(* LL = VBT.mu *)
BEGIN
TextPort.PutText(v.tp, text);
END TextEditVBTAppend;
PROCEDURE TextEditVBTClear (v: TextEditVBT.T) =
BEGIN
TextPort.SetText(v.tp, "")
END TextEditVBTClear;
PROCEDURE InsertToBrowser (tp: ListVBT.T; name: TEXT) =
(* LL = VBT.mu *)
VAR len := tp.count();
BEGIN
FOR i := 0 TO len - 1 DO
IF Text.Compare(name, tp.getValue(i)) = -1 THEN
tp.insertCells(i, 1);
tp.setValue(i, name);
RETURN;
END;
END;
tp.insertCells(len, 1);
tp.setValue(len, name);
END InsertToBrowser;
PROCEDURE DeleteFromBrowser (tp: ListVBT.T; name: TEXT) =
(* LL = VBT.mu *)
BEGIN
FOR i := 0 TO tp.count() - 1 DO
IF Text.Equal(name, tp.getValue(i)) THEN
tp.removeCells(i, 1);
RETURN;
END;
END;
END DeleteFromBrowser;
PROCEDURE SelectInBrowser (tp: ListVBT.T; name: TEXT) =
(* LL = VBT.mu *)
BEGIN
FOR i := 0 TO tp.count() DO
IF Text.Equal(name, tp.getValue(i)) THEN
tp.selectOnly(i);
RETURN;
END;
END;
END SelectInBrowser;
PROCEDURE RenameTrestleChassis (v: VBT.T; title: TEXT) =
(* LL = VBT.mu *)
BEGIN
Trestle.Decorate(v, NIL, title);
END RenameTrestleChassis;
PROCEDURE MoveNear (u, v: VBT.T) =
(* LL = VBT.mu *)
(* Replace Trestle.MoveNear(u, v). No, revert to Trestle-style. *)
BEGIN
Trestle.MoveNear(u, v);
WITH dom = VBT.Domain(v), ne = Trestle.ScreenOf(v, Rect.NorthEast(dom)) DO IF (ne.trsl # NIL) AND (ne.id # Trestle.NoScreen) THEN Trestle.Overlap( u, ne.id, Point.Add(ne.q, Point.FromCoords(-10, 30))); ELSE Trestle.MoveNear(u, v); END; END;
END MoveNear; PROCEDURE**************** Debugging ****************CheckPrefix (t, pref: TEXT; VAR (*OUT*) res: TEXT): BOOLEAN = (* LL = arbitrary *) (* If pref is a prefix of t, set res := the suffix of t and return TRUE; else return FALSE, with res unspecified. *) VAR len := Text.Length(pref); BEGIN IF Text.Equal(pref, Text.Sub(t, 0, len)) THEN res := Text.Sub(t, len, LAST(CARDINAL)); RETURN TRUE; ELSE RETURN FALSE; END; END CheckPrefix; PROCEDURESnapshotToList (): REFANY = VAR sx: REFANY; BEGIN WITH twr = TextWr.New() DO ZeusSnapshot.SnapshotToWr(Resolve(NIL), twr); TRY sx := Sx.Read(TextRd.New(TextWr.ToText(twr))) EXCEPT Rd.EndOfFile, Sx.ReadError => END; RETURN sx; END; END SnapshotToList;
VAR debugWr := TextWr.New();
debugMu := NEW(MUTEX);
debugP := FALSE;
<*UNUSED*>
PROCEDURE DebugWrite (t: TEXT) =
BEGIN
LOCK debugMu DO Wr.PutText(debugWr, t); END;
END DebugWrite;
<*UNUSED*>
PROCEDURE DebugStart () =
BEGIN
LOCK debugMu DO debugP := TRUE; END;
END DebugStart;
<*UNUSED*>
PROCEDURE DebugFinish () =
BEGIN
LOCK debugMu DO
debugP := FALSE;
Wr.PutText(Stdio.stderr, TextWr.ToText(debugWr));
END;
END DebugFinish;
**************** Mainline ****************
BEGIN LOCK VBT.mu DO ControlPanel := NewPanel(); END; END ZeusPanel.