<* 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 *> VAR trace := FALSE; PROCEDURED (s: TEXT) = BEGIN IF NOT trace THEN RETURN END; TRY Wr.PutText(Stdio.stdout, s & Wr.EOL); Wr.Flush(Stdio.stdout); EXCEPT ELSE END; END D;
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**************** Creating and Destroying Sessions ****************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; PROCEDUREGetGroupInfo (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 D("GetGroupInfo: " & sessName); 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; PROCEDUREUpdateSessionMenu (panel: T) = <* LL = VBT.mu *> VAR l : RefList.T; info: AlgGroupInfo; BEGIN groupInfo := RefListSort.SortD(groupInfo, GICompare); D("UpdateSessionMenu: " & Fmt.Int(RefList.Length(groupInfo))); 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; PROCEDUREGetExistingGI (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; PROCEDUREGroupInfoExists (sessName: TEXT): BOOLEAN = BEGIN (* LL = VBT.mu *) RETURN GetExistingGI(sessName) # NIL END GroupInfoExists; PROCEDURESetSessTitle (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; PROCEDUREResetSessionMenu (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 *> PROCEDURERegisterAlg (proc: NewAlgProc; name, sessName: TEXT) = (* LL = {} *) VAR info: AlgGroupInfo; BEGIN D("RegisterAlg: " & name & ", " & sessName); 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; PROCEDURERegisterView (proc : NewViewProc; name, sessName: TEXT; alertable : BOOLEAN := FALSE; sample : View.T := NIL ) = (* LL = {} *) VAR info: AlgGroupInfo; BEGIN D("RegisterView: " & name & ", " & sessName); 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;
TYPE SessionWatcherClosure = Thread.Closure OBJECT sess: Session; OVERRIDES apply := SessionWatcher END; PROCEDURENewSessionDefault (name: TEXT; panel: T) = (* Get the inTrestle parm from the FV before calling NewSession. *) BEGIN (* LL = VBT.mu *) D("NewSessionDefault"); 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; PROCEDURENewSession (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 D("NewSession"); 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; PROCEDURESessionWatcher (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; PROCEDUREDestroyFVOwner (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; PROCEDUREDestroySession (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; PROCEDUREDestroyAllSessions (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**************** Selecting Algorithms and Views ****************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; PROCEDUREToggleTSplitP ( 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; PROCEDURESessListPos (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;
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; PROCEDUREPanelThreadPlayback (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; PROCEDUREWaitForUser (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); PROCEDUREAlgThread (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; PROCEDUREStopRunning (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; PROCEDUREChangeSessActive (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; PROCEDUREGo (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; PROCEDUREStep (panel: T; eventTime: VBT.TimeStamp) = BEGIN (* LL = VBT.mu *) GrabFocus(panel, eventTime); SetRunState(panel, RunState.Stepping); Thread.Broadcast(panel.runCond); END Step; PROCEDUREAbortInternal (panel: T; eventTime: VBT.TimeStamp) = (* LL < panel.mu *) BEGIN LOCK panel.mu DO AbortWithLock(panel, eventTime) END; END AbortInternal; PROCEDUREAbortWithLock (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; PROCEDUREAbortAlg (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; PROCEDUREPreEventCallback (<*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; PROCEDUREPostEventCallback ( 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**************** Reactivity / Feedback ****************GetRunState (panel: T): RunState = BEGIN (* LL = arbitrary *) LOCK panel.mu DO RETURN panel.runState; END; END GetRunState; PROCEDURESetRunState (panel: T; state: RunState; msg : TEXT := NIL) = <* LL = VBT.mu *> BEGIN LOCK panel.mu DO SetRunStateWithLock(panel, state, msg) END; END SetRunState; PROCEDURESetRunStateWithLock (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;
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**************** Event Priority ****************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; PROCEDUREPause (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;
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 anyphotographs
from 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"}; PROCEDUREStartScript (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; PROCEDUREStopScript () = <* LL=VBT.mu *> BEGIN IF scripting = ScriptingState.Recording THEN WriteScript(scriptOutFile); ChangeScriptingState(ScriptingState.Off); END (* IF *); END StopScript; PROCEDUREWriteScript (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; PROCEDUREScript (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; PROCEDUREScriptMaybeStartFrame (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; PROCEDUREStartPlayback (file: TEXT) = <* LL=VBT.mu *> BEGIN IF scripting = ScriptingState.Off THEN ReadScript(file); ChangeScriptingState(ScriptingState.Playback); DoNextPlayback(Resolve(NIL)); END (* IF *); END StartPlayback; PROCEDUREStopPlayback () = <* LL=VBT.mu *> BEGIN IF scripting = ScriptingState.Playback THEN scriptIn := NIL; ChangeScriptingState(ScriptingState.Off); END (* IF *); END StopPlayback; PROCEDUREDoNextPlayback (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; PROCEDUREFlushFramePlayback () = <* 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; PROCEDUREPlayback (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; PROCEDUREReadScript (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; PROCEDUREChangeScriptingState (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**************** Utilities ****************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;
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*> PROCEDUREBound (val: INTEGER; min, max: INTEGER): INTEGER = BEGIN RETURN MAX(min, MIN(val, max)) END Bound; PROCEDURETextEditVBTAppend (v: TextEditVBT.T; text: TEXT) = (* LL = VBT.mu *) BEGIN TextPort.PutText(v.tp, text); END TextEditVBTAppend; PROCEDURETextEditVBTClear (v: TextEditVBT.T) = BEGIN TextPort.SetText(v.tp, "") END TextEditVBTClear; PROCEDUREInsertToBrowser (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; PROCEDUREDeleteFromBrowser (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; PROCEDURESelectInBrowser (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; PROCEDURERenameTrestleChassis (v: VBT.T; title: TEXT) = (* LL = VBT.mu *) BEGIN Trestle.Decorate(v, NIL, title); END RenameTrestleChassis; PROCEDUREMoveNear (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**************** Mainline ****************DebugWrite (t: TEXT) = BEGIN LOCK debugMu DO Wr.PutText(debugWr, t); END; END DebugWrite; <*UNUSED*> PROCEDUREDebugStart () = BEGIN LOCK debugMu DO debugP := TRUE; END; END DebugStart; <*UNUSED*> PROCEDUREDebugFinish () = BEGIN LOCK debugMu DO debugP := FALSE; Wr.PutText(Stdio.stderr, TextWr.ToText(debugWr)); END; END DebugFinish;
BEGIN D("ZuesPanel.Main"); LOCK VBT.mu DO ControlPanel := NewPanel(); END; END ZeusPanel.