(FILECREATED "15-Mar-84 18:35:49" {INDIGO}<LOOPS>SOURCES>LOOPSBROWSE.;37 70258
changes to: (FNS LatticeBrowser.DoSelectedCommand)
previous date: " 8-Mar-84 14:04:34" {INDIGO}<LOOPS>SOURCES>LOOPSBROWSE.;36)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSBROWSECOMS)
(RPAQQ LOOPSBROWSECOMS [(* Copyright (c)
Xerox Corporation, 1983)
(CLASSES * BROWSECLASSES)
(METHODS ClassBrowser.BoxNode ClassBrowser.CVDoc ClassBrowser.ClassDoc ClassBrowser.CopyTo
ClassBrowser.DefineSubclass ClassBrowser.DeleteCV ClassBrowser.DeleteClass
ClassBrowser.DeleteClassItem ClassBrowser.DeleteIV ClassBrowser.DeleteMethod
ClassBrowser.DestroyAndRecompute ClassBrowser.FindWhere ClassBrowser.GetSubs
ClassBrowser.IVDoc ClassBrowser.LeftShiftSelect ClassBrowser.MoveTo
ClassBrowser.Recompute ClassBrowser.RenameCV ClassBrowser.RenameClass
ClassBrowser.RenameIV ClassBrowser.RenameMeth ClassBrowser.RenamePart
ClassBrowser.SetItNew ClassBrowser.SubBrowser ClassBrowser.WhereIsCV
ClassBrowser.WhereIsIV ClassBrowser.WhereIsMethod InstanceBrowser.GetSubs
InstanceBrowser.NewPath LatticeBrowser.AddRoot LatticeBrowser.BoxNode
LatticeBrowser.BrowserItems LatticeBrowser.BrowserMenu LatticeBrowser.ChangeFontSize
LatticeBrowser.ChangeFormat LatticeBrowser.DeleteRoot
LatticeBrowser.DoSelectedCommand LatticeBrowser.EEObject LatticeBrowser.EditObject
LatticeBrowser.FlashNode LatticeBrowser.FlipNode LatticeBrowser.GetLabel
LatticeBrowser.GetNodeList LatticeBrowser.GetSubs LatticeBrowser.HasObject
LatticeBrowser.LeftChoice LatticeBrowser.LeftSelection
LatticeBrowser.LeftShiftSelect LatticeBrowser.ListObjects
LatticeBrowser.MiddleChoice LatticeBrowser.MiddleSelection
LatticeBrowser.MiddleShiftSelect LatticeBrowser.ObjNamePair LatticeBrowser.Recompute
LatticeBrowser.SaveInIT LatticeBrowser.ShapeToHold LatticeBrowser.Show
LatticeBrowser.TitleFn LatticeBrowser.Unread MetaBrowser.GetSubs
PathBrowser.AddAndBox PathBrowser.AddToPath PathBrowser.Clear PathBrowser.GetSubs
PathBrowser.LeftShiftSelect PathBrowser.Recompute SupersBrowser.GetSubs)
(FNS BOXNODE BoxWindowNode BrSel1 Browse BrowserTtySelect DoMenuMethod DualMenu DualSelection
DualSubItems FILECLASSES FileBrowse FindSelectedNode GetMethodArgs
LatticeBrowser.ButtonFn LatticeBrowser.LeftFn LatticeBrowser.MiddleFn
LatticeBrowser.WhenHeldFn SubItemSelection TreeRoots)
(VARS BrowserMargin MaxLatticeHeight MaxLatticeWidth NestedMenuFlg)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML BrSel1)
(LAMA])
(* Copyright (c) Xerox Corporation, 1983)
(RPAQQ BROWSECLASSES (ClassBrowser InstanceBrowser LatticeBrowser PathBrowser SupersBrowser
MetaBrowser TextItem))
(DEFCLASSES ClassBrowser InstanceBrowser LatticeBrowser PathBrowser SupersBrowser MetaBrowser
TextItem)
[DEFCLASS ClassBrowser
(MetaClass Class Edited: (* dgb: "15-Feb-84 14:47")
doc (* A window containing a lattice displaying classes.)
)
(Supers LatticeBrowser)
(ClassVariables (LeftButtonItems ((Print*(PrintSummary (PP PP! PPV! PPMethod MethodSummary
PrintSummary))
"PrintSummary of class")
(Doc*(ClassDoc (ClassDoc MethodDoc IVDoc CVDoc))
"Documentation for Class, Methods, IVs and CVs
Class is default")
(WhereIs*(FindWhere (WhereIsIV WhereIsCV WhereIsMethod))
"Find location of method, iv, or cv")
(SubBrowser SubBrowser "Make a subBrowser on this class")
(TypeInName Unread "Put class name in typein buffer")))
(MiddleButtonItems ((BoxNode BoxNode "Draw a box around selected node")
(EM*(EditMethod (EditMethod BreakMethod UnbreakMethod
(EM! EM!
"Edit method selected from Menu, making it local if necessary")
(EditMethodObject EditMethodObject
"Edit the object representing the method"))
"Edit method of class selected from Menu"))
(Add*(DefMethod ((Specialize DefineSubclass
"Define a specialized subclass")
DefMethod DefRSM AddIV AddCV
(New SetItNew
"Set IT to a new instance of selected class")))
"Add a new method, a specialized class, IV or CV to class, or make a new instance.")
(Delete*(DeleteClass (DeleteIV DeleteCV DeleteMethod
DeleteClass))
"Delete one of Methods IVs CVs
or the class itself")
(Move*(MoveTo (MoveTo CopyTo))
"Move or copy")
(Rename*(RenameMeth (RenameClass RenameIV RenameCV RenameMeth))
"Rename some part of the class")
(Edit*(EditObject (EditObject
(Edit! Edit!
"Edit class showing inherited info")
(EditIVs (QUOTE (EditObject (F
InstanceVariables T)
DE))
"Edit IVs of class")
(EditCVs (QUOTE (EditObject (F
ClassVariables T)
DE))
"Edit CVs of class")
(Inspect (QUOTE Inspect)
"Inspect selected class")))
"Edit class")))
(LocalCommands (CopyTo BoxNode ClassDoc CVDoc DefineSubclass DeleteClassItem
DeleteIV EditObject FindWhere FlipNode IVDoc MoveTo
Recompute RenamePart SubBrowser Unread)))
(InstanceVariables (title "Class Inheritance Lattice"))]
[DEFCLASS InstanceBrowser
(MetaClass Class doc
(* Follows the downward lattice in object named in subIV. If subIV is changed after display, will show the newly
defined alternative lattice starting at the same starting points)
Edited: (* dgb: "19-SEP-83 17:31")
)
(Supers LatticeBrowser)
(ClassVariables (TitleItems ((Recompute (QUOTE Recompute)
"Recompute lattice from starting objects")
(NewPath (QUOTE NewPath)
"Change name of sub to be followed in computing lattice.")
(AddRoot (QUOTE AddRoot)
"Add named item to startingList for browser")
(DeleteRoot (QUOTE DeleteRoot)
"Delete named item on startinglist for browser")
(SaveInIT (QUOTE SaveInIT)
"IT←<this browser>"))
doc (* Items for menu of selections in title of window)
))
(InstanceVariables (subIV NIL doc (* Name of instance variable which provides names and/or
pointers to subobjects)))]
[DEFCLASS LatticeBrowser
(MetaClass Class Edited: (* dgb: "15-Feb-84 14:19"))
(Supers Window)
(ClassVariables (LocalCommands (EditObject BoxNode Recompute AddStartingItem)
doc (* messages that should be sent to browser when item
seleted in menu, even if object does understand them)
)
(TitleItems ((Recompute Recompute "Recompute lattice from starting objects")
(ShapeToHold ShapeToHold
"Make window large or small enough to just hold graph")
(AddRoot AddRoot "Add named item to startingList for browser")
(DeleteRoot DeleteRoot
"Delete named item on startinglist for browser")
(ChangeFontSize ChangeFontSize "Choose a new size Font")
(Lattice/Tree ChangeFormat "Change format between lattice and tree")
(SaveInIT SaveInIT "Save browser in global variable IT"))
doc (* Items for menu of selections in title of window)
)
(LeftButtonItems ((BoxNode BoxNode
"Draw box around selected node.
Unboxed by another BoxNode")
(PP PP "Prettyprint selected item"))
doc (* Menu items for LeftButton seletion -- Value sent as
message to object or browser -- see LocalCommands)
)
(MiddleButtonItems ((Inspect Inspect "Inspect selected item")
(Edit EditObject "Edit selected item"))
doc (* Menu items for MiddleButton seletion -- Value sent as
message to object or browser -- see LocalCommands)
))
(InstanceVariables (window NIL doc (* Window for browsing)
DontSave
(Value))
(menus NIL DontSave Any Title NIL LeftButtonItems NIL MiddleButtonItems NIL
TitleItems NIL)
(topAlign T doc (* Flg used to indicate whether graph should be aligned
with the top or bottom of the window))
(title "Browser Window" doc (* Title passed to GRAPHER package))
(startingList NIL doc (* list of objects used to compute this browser)
)
(goodList NIL doc (* limit choices to this set))
(lastSelectedObject NIL doc (* last object selected)
DontSave Any)
(browseFont #((FONTCREATE (QUOTE (HELVETICA 10 BOLD)))
FirstFetch ReplaceMe) FontFamily HELVETICA FontSize 10 FontFace
BOLD DontSave (Value))
(boxedNode NIL doc (* last item Boxed, if any))
(graphFormat (LATTICE)
doc (* Controls format for laying out graph for GRAPHER)
))]
[DEFCLASS PathBrowser
(MetaClass Class doc (* A mixin which shows paths and their locl context in a
browser)
Edited: (* dgb: " 7-FEB-84 17:52")
)
(Supers LatticeBrowser)
(InstanceVariables (pathObjects NIL doc (* objects which have been put on the path)
))]
[DEFCLASS SupersBrowser
(MetaClass Class Edited: (* edited: "13-NOV-83 17:17")
doc (* Browses upwards from a class to all of its supers.)
)
(Supers ClassBrowser)
(InstanceVariables (title "Supers Lattice" doc (* Title passed to GRAPHER package)))]
[DEFCLASS MetaBrowser
(MetaClass Class doc (* Runs through the meta classes of a class)
Edited: (* dgb: "22-JUL-83 15:39")
)
(Supers ClassBrowser)]
[DEFCLASS TextItem
(MetaClass Class doc (* Simplest structured text object)
Edited: (* dgb: "12-OCT-82 23:09")
)
(Supers NamedObject)
(InstanceVariables (subs NIL doc (* list of other elemetns which are subparts of this
one))
(text "" doc (* local text for this item)))]
[METH ClassBrowser BoxNode NIL
(* Box selected node and unbox previous)]
[METH ClassBrowser CVDoc (class className)
(* Show menu of classVariables and give documentation for each)]
[METH ClassBrowser ClassDoc (object objname)
(* Print out class documentation if there is any)]
[METH ClassBrowser CopyTo (object objName)
(* Ask user whether to copy CVs IVs or Methods and then find which ones)]
[METH ClassBrowser DefineSubclass (object objName)
(* Define a new subclass, giving it a name typed in by user)]
[METH ClassBrowser DeleteCV (obj objName)
(* Delete selected CV)]
[METH ClassBrowser DeleteClass (obj objName)
(* Delete selected IV)]
[METH ClassBrowser DeleteClassItem (class className type)
(* Delete an item from a class, or the class itself)]
[METH ClassBrowser DeleteIV (obj objName)
(* Delete selected IV)]
[METH ClassBrowser DeleteMethod (obj objName)
(* Delete selected Method)]
[METH ClassBrowser DestroyAndRecompute (object objName)
(* Destroy class and recompute lattice.)]
[METH ClassBrowser FindWhere (object objName type)
(* Ask user whether CVs IVs or Methods wanted and then find that one)]
[METH ClassBrowser GetSubs (obj objName)
(* Returns subclasses of a class on goodlist if any)]
[METH ClassBrowser IVDoc (class className)
(* Show menu of classVariables and give documentation for each)]
[METH ClassBrowser LeftShiftSelect (object objName)
(* Ask user whether to move CVs IVs or Methodsand then find which ones)]
[METH ClassBrowser MoveTo (object objName)
(* mjs: "16-MAR-83 15:06")]
[METH ClassBrowser Recompute NIL
(* Recompute graph, and rebox bosedNode)]
[METH ClassBrowser RenameCV (object objName)
(* Rename an IV if one is given)]
[METH ClassBrowser RenameClass (object objName)
(* Read in a new name for the class, and rename it)]
[METH ClassBrowser RenameIV (object objName)
(* Rename an IV if one is given)]
[METH ClassBrowser RenameMeth (object objName)
(* Rename an IV if one is given)]
[METH ClassBrowser RenamePart (object objName)
(* Ask user whether to rename CVs IVs or Methods or class and then find which ones)]
[METH ClassBrowser SetItNew (object objName)
(*)]
[METH ClassBrowser SubBrowser (obj objName)
(* Make a generic subBrowser on this class)]
[METH ClassBrowser WhereIsCV (obj objName)
(* Whereis CV)]
[METH ClassBrowser WhereIsIV (obj objName)
(* Find class containing IV description)]
[METH ClassBrowser WhereIsMethod (obj objName)
(* Where is method)]
[METH InstanceBrowser GetSubs NIL
(* Gets a set of subs from an object for browsing.)]
[METH InstanceBrowser NewPath (subName)
(* Changes the name of the sub by which the lattice is computed, changes the title, and
recomputes the graph)]
[METH LatticeBrowser AddRoot (newItem)
(* Add a named item to the starting list of the browser)]
[METH LatticeBrowser BoxNode (object unboxPrevious)
(* Puts a box around the node in the graph representing the object.)]
[METH LatticeBrowser BrowserItems (itemCV)
(* Get item list for menu)]
[METH LatticeBrowser BrowserMenu (itemCV)
(* Create a menu which allows subitems to be displayed. Cache it in the menus field of the
browser under the property name itemCV)]
[METH LatticeBrowser ChangeFontSize (size)
(* Change the font size from whatever it is to size)]
[METH LatticeBrowser ChangeFormat (format)
(* Change format between Lattice and Tree)]
[METH LatticeBrowser DeleteRoot (deletedItem)
(* Delete a named item from the starting list of the browser)]
[METH LatticeBrowser DoSelectedCommand (command obj objName)
(* does the selected command or forwards it to the object)]
[METH LatticeBrowser EEObject (object objName)
(* Call editor with EE on object)]
[METH LatticeBrowser EditObject (object objName args)
(* Call editor with commands args)]
[METH LatticeBrowser FlashNode (node N flashTime)
(* Flip node N times)]
[METH LatticeBrowser FlipNode (object)
(* Inverts the video around the node in the graph representing the object)]
[METH LatticeBrowser GetLabel (object)
(* Get a label for an object to be displayed in the browser.)]
[METH LatticeBrowser GetNodeList (browseList goodList)
(* Compute the node data structures of the tree starting at browseList. If goodList is given,
only include elements of it. If goodList=T make it be browseList.)]
[METH LatticeBrowser GetSubs (object)
(* Gets a set of subs from an object for browsing)]
[METH LatticeBrowser HasObject (object)
NIL]
[METH LatticeBrowser LeftChoice NIL
(* Get the choices from the LeftButtonItems)]
[METH LatticeBrowser LeftSelection NIL
(* * Move object if CTRL down. Do LeftShiftSelect if SHIFT down. Else choose from
LeftButtonItems)]
[METH LatticeBrowser LeftShiftSelect (object objname)
(* Called when item is selected with left key and LSHIFT is down)]
[METH LatticeBrowser ListObjects (object)
(* return a list of the objects that are being displayed in the browser)]
[METH LatticeBrowser MiddleChoice NIL
(* New method template)]
[METH LatticeBrowser MiddleSelection NIL
(* This function called from the GRAPHER package when a node is selected with the middle mouse
button. If no node is selected then just returns.)]
[METH LatticeBrowser MiddleShiftSelect (object objname)
(* Called when item is selected with middle key and LSHIFT is down)]
[METH LatticeBrowser ObjNamePair (objOrName)
(* Make a pair (object . objName)
where objName is label to be used in browser)]
[METH LatticeBrowser Recompute NIL
(* Recompute the browseGraph in the same window)]
[METH LatticeBrowser SaveInIT NIL
(* save value in IT)]
[METH LatticeBrowser ShapeToHold (margin)
(* Shape the browse window to just hold the nodes with (OR margin Browsemargin)
to spare)]
[METH LatticeBrowser Show (browseList windowOrTitle goodList)
(* * Show the items and their subs on a browse window.)]
[METH LatticeBrowser TitleFn NIL
(*)]
[METH LatticeBrowser Unread (object objName)
(* Unread name into system buffer)]
[METH MetaBrowser GetSubs (elt)
(* Subs for meta browser is the meta class of the class.)]
[METH PathBrowser AddAndBox (obj objName)
(* Add selected object to path, and box it)]
[METH PathBrowser AddToPath (object)
(* Add a new object to the path)]
[METH PathBrowser Clear NIL
(* Empty PathBrowser)]
[METH PathBrowser GetSubs (obj)
(* Only get subs for elements on the path)]
[METH PathBrowser LeftShiftSelect (obj objName)
(* Add selected object to path, and box it)]
[METH PathBrowser Recompute NIL
(* Flip nodes which are on path)]
[METH SupersBrowser GetSubs (object objName)
(* Returns metaclass plus local supers)]
(DEFINEQ
(ClassBrowser.BoxNode
[LAMBDA (self object) (* dgb: " 4-JUN-83 17:07")
(* Box selected node and unbox previous)
(←Super
self BoxNode object T])
(ClassBrowser.CVDoc
[LAMBDA (self class className) (* dgb: "21-JUL-83 15:46")
(* Show menu of classVariables and give documentation
for each)
(PROG [choice menu (vbls (← class List!(QUOTE CVS]
(COND
((NULL vbls)
(PROMPT (CHARACTER 7)
"
No Class Variables found for " className)))
(SETQ menu (create MENU
ITEMS ← vbls
CHANGEOFFSETFLG ← T
TITLE ←(CONCAT className " ClassVars")))
LP (COND
((NULL (SETQ choice (MENU menu)))
(RETURN NIL)))
(printout PPDefault T T className "::" choice ": " (GetClassValue class choice
(QUOTE doc)))
(GO LP])
(ClassBrowser.ClassDoc
[LAMBDA (self object objname) (* dgb: " 8-DEC-82 17:02")
(* Print out class documentation if there is any)
(PROG [(doc (GetClassHere object (QUOTE doc]
(COND
((NotSetValue doc)
(printout PPDefault T objname " has no documentation." T))
(T (printout PPDefault T objname ": " doc T])
(ClassBrowser.CopyTo
[LAMBDA (self object objName) (* dgb: "19-SEP-83 13:24")
(* Ask user whether to copy CVs IVs or Methods and then
find which ones)
(PROG (name type value items flg)
(COND
((NULL (@ boxedNode))
(PrintStatus (CHARACTER 7)
"First Box the node which is target for move.")
(RETURN NIL)))
(OR [SETQ type (MENU (create MENU
ITEMS ←(QUOTE (IVS CVS Methods]
(RETURN NIL))
LP (COND
((NULL (SETQ items (← object List type)))
(OR flg (PrintStatus (CHARACTER 7)
objName " has no " type))
(RETURN)))
(SETQ flg T) (* So that when last IV is removed, no comment is made)
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items]
(RETURN NIL))
(SELECTQ type
(IVS (← object CopyIV name (@ boxedNode)))
(CVS (← object CopyCV name (@ boxedNode)))
(Methods (← object CopyMethod name (@ boxedNode)
name))
NIL)
(PrintStatus type " " name " has been copied to " (@ boxedNode))
(GO LP])
(ClassBrowser.DefineSubclass
[LAMBDA (self object objName) (* dgb: "20-SEP-83 16:47")
(* Define a new subclass, giving it a name typed in by
user)
(PROG (className)
(COND
((SETQ className (PromptRead "Type in the name of the new class, or NIL for none."))
[COND
((NOT (LITATOM className))
(RETURN (PROMPT (CHARACTER 7)
className "should be an atom to name a class"]
(← object Specialize className)
(← self Recompute])
(ClassBrowser.DeleteCV
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 08:11")
(* Delete selected CV)
(← self DeleteClassItem obj objName (QUOTE CVs])
(ClassBrowser.DeleteClass
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 08:12")
(* Delete Class)
(← self DeleteClassItem obj objName (QUOTE Class])
(ClassBrowser.DeleteClassItem
[LAMBDA (self class className type) (* dgb: "29-Feb-84 15:48")
(* Delete an item from a class, or the class itself)
(PROG (choice choices)
(OR type [SETQ type (MENU (MenuGetOrCreate ClassChoiceMenu (QUOTE (IVs CVs Methods Class]
(RETURN))
(OR (SETQ choices (← class List type))
(PROMPT "
No items for " className " of type " type ".
")
(RETURN))
(AND (EQ type (QUOTE Class))
(RETURN (← self DestroyAndRecompute class className)))
(OR (SETQ choice (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ← choices)))
(RETURN))
(SELECTQ type
(IVs (← class Delete (QUOTE IV)
choice))
(CVs (← class Delete (QUOTE CV)
choice))
[Methods (← class Delete (QUOTE Method)
choice
(EQ (QUOTE Yes)
(INMENU "Select Yes to Delete Function Defintion"
(QUOTE (Yes No]
(LoopsHelp type " wrong in DeleteClassItem."])
(ClassBrowser.DeleteIV
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 08:11")
(* Delete selected IV)
(← self DeleteClassItem obj objName (QUOTE IVs])
(ClassBrowser.DeleteMethod
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 08:11")
(* Delete selected Method)
(← self DeleteClassItem obj objName (QUOTE Methods])
(ClassBrowser.DestroyAndRecompute
[LAMBDA (self object objName) (* dgb: "12-OCT-82 23:40")
(* Destroy class and recompute lattice.)
(AND [MENU (create MENU
TITLE ←(QUOTE Confirm)
ITEMS ←(LIST (CONCAT "Destroy " objName]
(PROGN (← object Destroy)
(← self Recompute])
(ClassBrowser.FindWhere
[LAMBDA (self object objName type) (* dgb: "15-DEC-83 07:57")
(* Ask user whether CVs IVs or Methods wanted and then
find that one)
(PROG (name value items menu)
(OR type [SETQ type (MENU (create MENU
ITEMS ←(QUOTE (IVS CVS Methods]
(RETURN NIL))
(COND
((NULL (SETQ items (← object List! type)))
(PrintStatus (CHARACTER 7)
objName " has no " type)
(RETURN)))
(SETQ menu (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items)))
LP (OR (SETQ name (MENU menu))
(RETURN NIL))
(SETQ value (← object WhereIs name type))
(← self FlashNode value)
(PrintStatus type " " name " is in " value "
")
(GO LP])
(ClassBrowser.GetSubs
[LAMBDA (self obj objName) (* dgb: "12-DEC-83 16:10")
(* Returns subclasses of a class on goodlist if any)
(for C in (← obj SubClasses) when (OR (NULL (@ goodList))
(FMEMB C (@ goodList))
(FMEMB (GetObjectRec C)
(@ goodList)))
collect (GetObjectRec C])
(ClassBrowser.IVDoc
[LAMBDA (self class className) (* dgb: "21-JUL-83 15:49")
(* Show menu of classVariables and give documentation
for each)
(PROG [choice menu (vbls (← class List!(QUOTE IVS]
(COND
((NULL vbls)
(PROMPT (CHARACTER 7)
"
No Instance Variables found for " className)))
(SETQ menu (create MENU
ITEMS ← vbls
CHANGEOFFSETFLG ← T
TITLE ←(CONCAT className " Instance Vars")))
LP (COND
((NULL (SETQ choice (MENU menu)))
(RETURN NIL)))
(printout PPDefault T T className ":" choice ": " (GetClassIV class choice (QUOTE doc)))
(GO LP])
(ClassBrowser.LeftShiftSelect
[LAMBDA (self object objname) (* dgb: "25-MAR-83 12:15")
(* Call PrintSummary when selected with LSHIFT down)
(← object PrintSummary])
(ClassBrowser.MoveTo
[LAMBDA (self object objName) (* dgb: "20-SEP-83 16:52")
(* mjs: "16-MAR-83 15:06")
(* Ask user whether to move CVs IVs or Methodsand then
find which ones)
(PROG (name type value items flg)
(COND
((NULL (@ boxedNode))
(PROMPT (CHARACTER 7)
"Use BoxNode to box node which
is to be target for Move or Copy")
(RETURN NIL)))
(OR [SETQ type (MENU (create MENU
ITEMS ←(QUOTE (IVS CVS Methods Supers]
(RETURN NIL))
LP (COND
((NULL (SETQ items (← object List type)))
(OR flg (PrintStatus (CHARACTER 7)
objName " has no " type))
(RETURN)))
(SETQ flg T) (* So that when last IV is removed, no comment is made)
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(COND
((EQ type (QUOTE Supers))
items)
(T (SORT items]
(RETURN NIL))
(SELECTQ type
(Supers (* Substitute the boxed node for the selected super in
the list of items)
(← object ReplaceSupers (SUBST (ClassName (@ boxedNode))
name items))
(← self Recompute)
(RETURN))
(IVS (MoveVariable objName (ClassName (@ boxedNode))
name))
(CVS (MoveClassVariable objName (ClassName (@ boxedNode))
name))
(Methods (MoveMethod objName (ClassName (@ boxedNode))
name name))
NIL)
(PrintStatus type " " name " is now in " (@ boxedNode))
(GO LP])
(ClassBrowser.Recompute
[LAMBDA (self) (* dgb: " 7-JUN-83 15:50")
(* Recompute graph, and rebox bosedNode)
(←Super
self Recompute)
(AND (%@ boxedNode)
(BoxWindowNode (%@ boxedNode)
(%@ window])
(ClassBrowser.RenameCV
[LAMBDA (self object objName) (* dgb: "14-DEC-83 16:47")
(* Rename an IV if one is given)
(PROG (name newName)
(COND
([NULL (SETQ items (← object List (QUOTE CVs]
(OR flg (PrintStatus (CHARACTER 7)
objName " has no Class Variables"))
(RETURN)))
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items]
(RETURN NIL))
(AND (SETQ newName (PromptRead "New CV name:"))
(RenameVariable objName name newName T])
(ClassBrowser.RenameClass
[LAMBDA (self object objName) (* dgb: "23-DEC-83 00:50")
(* Read in a new name for the class, and rename it)
(PROG ((className (PromptRead "Type in the new name for this class,
or NIL not to change.")))
(COND
(className (← object Rename className)
(← self Recompute])
(ClassBrowser.RenameIV
[LAMBDA (self object objName) (* dgb: "14-DEC-83 16:44")
(* Rename an IV if one is given)
(PROG (name newName)
(COND
([NULL (SETQ items (← object List (QUOTE IVs]
(OR flg (PrintStatus (CHARACTER 7)
objName " has no Instance Variables"))
(RETURN)))
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items]
(RETURN NIL))
(AND (SETQ newName (PromptRead "New IV name:"))
(RenameVariable objName name newName])
(ClassBrowser.RenameMeth
[LAMBDA (self object objName) (* dgb: "14-DEC-83 16:59")
(* Rename an IV if one is given)
(PROG (name newName)
(COND
([NULL (SETQ items (← object List (QUOTE Methods]
(OR flg (PrintStatus (CHARACTER 7)
objName " has no Methods"))
(RETURN)))
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items]
(RETURN NIL))
(AND (SETQ newName (PromptRead "New Selector Name:"))
(← object RenameMethod name newName])
(ClassBrowser.RenamePart
[LAMBDA (self object objName) (* dgb: "19-SEP-83 13:29")
(* Ask user whether to rename CVs IVs or Methods or
class and then find which ones)
(PROG (name newName type value items flg)
(OR [SETQ type (MENU (create MENU
ITEMS ←(QUOTE (IVS CVS Methods Class]
(RETURN NIL))
LP (SELECTQ type
(Class (RETURN (← self RenameClass object objName)))
((IVS CVS Methods))
(RETURN NIL))
(COND
((NULL (SETQ items (← object List type)))
(OR flg (PrintStatus (CHARACTER 7)
objName " has no " type))
(RETURN))) (* So that when last IV is removed, no comment is made)
(SETQ flg T)
(OR [SETQ name (MENU (create MENU
CHANGEOFFSETFLG ← T
ITEMS ←(SORT items]
(RETURN NIL))
(SELECTQ type
(IVS (AND (SETQ newName (PromptRead "New IV name:"))
(RenameVariable objName name newName)))
(CVS (AND (SETQ newName (PromptRead "New CV name:"))
(RenameVariable objName name newName T)))
(Methods (AND (SETQ newName (PromptRead "New Selector Name:"))
(← object RenameMethod name newName)))
NIL)
(GO LP])
(ClassBrowser.SetItNew
[LAMBDA (self class) (* dgb: "28-SEP-82 16:02")
(* Set self to instance of selected class)
(SETTOPVAL (QUOTE IT)
(PRINT (← class New)
T])
(ClassBrowser.SubBrowser
[LAMBDA (self obj objName) (* dgb: "12-DEC-83 10:35")
(* Make a generic subBrowser on this class)
(Browse obj (CONCAT "SubBrowser on " objName])
(ClassBrowser.WhereIsCV
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 07:59")
(* Whereis CV)
(← self FindWhere obj objName (QUOTE CVS])
(ClassBrowser.WhereIsIV
[LAMBDA (self obj objName) (* dgb: "14-Feb-84 13:51")
(* Find class containing IV description)
(← self FindWhere obj objName (QUOTE IVS])
(ClassBrowser.WhereIsMethod
[LAMBDA (self obj objName) (* dgb: "15-DEC-83 08:00")
(* Where is method)
(← self FindWhere obj objName (QUOTE Methods])
(InstanceBrowser.GetSubs
[LAMBDA (self object) (* dgb: "19-SEP-83 17:12")
(* Gets a set of subs from an object for browsing.)
(COND
((AND (@ subIV)
(← object HasIV (@ subIV)))
(* If the object has an IV named in (@ subIV) and that is an IV of object, then use that for following links)
(GetValue object (@ subIV])
(InstanceBrowser.NewPath
[LAMBDA (self subName) (* dgb: "19-SEP-83 17:31")
(* Changes the name of the sub by which the lattice is
computed, changes the title, and recomputes the graph)
(PROG NIL
[COND
((NULL subName)
(OR (SETQ subName (PromptRead "Name of new IV for browsing: "))
(RETURN]
(←@
subIV subName)
(←@
title
(CONCAT subName " instance browser"))
(AND (← self HasLispWindow)
(← self Recompute])
(LatticeBrowser.AddRoot
[LAMBDA (self newItem) (* dgb: "13-DEC-83 15:59")
(* Add a named item to the starting list of the browser)
(PROG ((sl (@ startingList)))
(OR newItem (SETQ newItem (PromptRead "Give name of item to be added"))
(RETURN NIL))
(AND (LITATOM newItem)
(SETQ newItem (GetObjectRec newItem)))
(OR (LISTP sl)
(SETQ sl (LIST sl)))
(pushnew sl newItem)
(←@
self startingList sl)
(AND (@ goodList)
(NOT (FMEMB newItem (@ goodList)))
(PushValue self (QUOTE goodList)
newItem))
(← self Recompute])
(LatticeBrowser.BoxNode
[LAMBDA (self object unboxPrevious) (* dgb: " 5-JUN-83 16:49")
(* Puts a box around the node in the graph representing
the object.)
(PROG (bn)
[COND
((LITATOM object)
(SETQ object (OR (GetObjectRec object)
(ERROR object " is not a named object."]
(BoxWindowNode object (%@ window))
(SETQ bn (%@ boxedNode)) (* Now remember new boxed node)
(←%@
boxedNode
(COND
((NULL bn)
object)
((NEQ bn object) (* If there was a previously boxed node, remove the box
from around it)
(AND unboxPrevious (BoxWindowNode bn (%@ window)))
object)
(T NIL])
(LatticeBrowser.BrowserItems
[LAMBDA (self itemCV) (* dgb: "15-DEC-83 09:11")
(* Get item list for menu)
(GetClassValue self itemCV])
(LatticeBrowser.BrowserMenu
[LAMBDA (self itemCV) (* dgb: "10-Feb-84 13:44")
(* Create a menu which allows subitems to be displayed.
Cache it in the menus field of the browser under the
property name itemCV)
(PROG (items (menu (GetValue self (QUOTE menus)
itemCV)))
(COND
(menu (RETURN menu))
((NULL (SETQ items (← self BrowserItems itemCV)))
(RETURN NIL)))
(SETQ menu (create MENU
ITEMS ← items
WHENSELECTEDFN ←(QUOTE SubItemSelection)
SUBITEMFN ←(QUOTE DualSubItems)
WHENHELDFN ←(QUOTE LatticeBrowser.WhenHeldFn)
CHANGEOFFSETFLG ← T)) (* Cache menu)
(PutValue self (QUOTE menus)
menu itemCV)
(RETURN menu])
(LatticeBrowser.ChangeFontSize
[LAMBDA (self size) (* dgb: "13-DEC-83 21:48")
(* Change the font size from whatever it is to size)
[OR size (SETQ size (MENU (COND
((type? MENU (GETTOPVAL (QUOTE MenuSize)))
MenuSize)
(T (SETTOPVAL (QUOTE MenuSize)
(create MENU
TITLE ← "Select Desired Size"
CHANGEOFFSETFLG ← T
ITEMS ←(QUOTE ((Abort NIL)
8 10 12 16]
(COND
(size [←@
browseFont
(FONTCREATE (LIST (@ browseFont:,FontFamily)
size
(@ browseFont:,FontFace]
(← self Recompute])
(LatticeBrowser.ChangeFormat
[LAMBDA (self format) (* dgb: "15-Feb-84 14:27")
(* Change format between Lattice and Tree)
[COND
((LISTP format)
(←@
graphFormat format))
[(EQUAL (@ graphFormat)
(QUOTE (LATTICE)))
(←@
graphFormat
(QUOTE (COPIES/ONLY]
(T (←@
graphFormat
(QUOTE (LATTICE]
(← self Recompute])
(LatticeBrowser.DeleteRoot
[LAMBDA (self deletedItem) (* dgb: "20-SEP-83 16:54")
(* Delete a named item from the starting list of the
browser)
(PROG ((sl (@ startingList)))
(SETQ deletedItem (OR deletedItem (@ boxedNode)
(PromptRead "Give name of item to be deleted")
(RETURN NIL)))
(SETQ sl (DREMOVE (GetObjectRec deletedItem)
sl))
(←@
self startingList sl)
(← self Recompute])
(LatticeBrowser.DoSelectedCommand
[LAMBDA (self command obj objName) (* dgb: "15-Mar-84 18:13")
(* does the selected command or forwards it to the
object)
(PROG (args)
(COND
((NULL command)
(RETURN NIL)))
[COND
((LISTP command)
(SETQ args (CDR command))
(SETQ command (CAR command]
[COND
((LISTP obj) (* Take care of being passed in a dummy node from
browser in Lattice mode)
(SETQ obj (CAR obj))
(SETQ objName (GetObjectName obj]
(COND
((AND (NOT (FMEMB command (@@ LocalCommands)))
(← obj Understands command))
(ApplyMethod obj command args))
(T (DoMethod self command NIL obj objName args])
(LatticeBrowser.EEObject
[LAMBDA (self object objName) (* dgb: "10-Feb-84 13:38")
(* Call editor with EE on object)
(← object Edit])
(LatticeBrowser.EditObject
[LAMBDA (self object objName args) (* dgb: " 2-MAR-83 10:58")
(* Call editor with commands args)
(← object Edit args])
(LatticeBrowser.FlashNode
[LAMBDA (self node N flashTime) (* dgb: "22-NOV-82 23:35")
(* Flip node N times)
(for i from 1 to (OR N 3)
do (← self FlipNode node)
(DISMISS (OR flashTime 300))
(← self FlipNode node)
(DISMISS (OR flashTime 300])
(LatticeBrowser.FlipNode
[LAMBDA (self object) (* dgb: "14-Feb-84 16:07")
(* Inverts the video around the node in the graph
representing the object)
(PROG (node nodes (window (@ window)))
[COND
((LITATOM object)
(SETQ object (OR (GetObjectRec object)
(ERROR object " is not a named object."]
[SETQ nodes (fetch GRAPHNODES of (WINDOWPROP window (QUOTE GRAPH]
(COND
[(SETQ node (FASSOC object nodes))
(SETTOPVAL (QUOTE IT)
object)
(FLIPNODE node window)
(COND
((AND (LISTP object)
(SETQ node (FASSOC (CAR object)
nodes)))
(FLIPNODE node window]
(T (PROMPTPRINT (CONCAT object " is not a node in this browser.
"])
(LatticeBrowser.GetLabel
[LAMBDA (self object) (* dgb: "26-SEP-82 15:51")
(* Get a label for an object to be displayed in the
browser.)
(GetObjectName object])
(LatticeBrowser.GetNodeList
[LAMBDA (self browseList goodList) (* dgb: "12-DEC-83 16:14")
(* Compute the node data structures of the tree starting at browseList. If goodList is given, only include
elements of it. If goodList=T make it be browseList.)
(COND
((EQ goodList T)
(SETQ goodList browseList)))
(PROG (subs pair (objList (CONS)))
(* first make objList which is a list of pairs (object . objName). objName will be used as a title for a node in
the browser. This structure will be replaced by a graphNode when it is processed. The nodeID of the graphNode will
be the object, and the label will be the name.)
(for objOrName in browseList do (AND (SETQ pair (← self ObjNamePair objOrName))
(NOT (FASSOC (CAR pair)
(CAR objList)))
(TCONC objList pair)))
(* * Now MAP ON list so pair can be replaced by graphNode)
(for pair name obj subObjs on (CAR objList) when (NLISTP (SETQ name (CDAR pair)))
do (SETQ subObjs (CONS))
[for sub objPair obj1 in (← self GetSubs (SETQ obj (CAAR pair)))
do (* ObjNamePair returns NIL for destroyed objects.
include only members of goodList in subs if given.
Add to objList only once)
(COND
((SETQ objPair (← self ObjNamePair sub))
(COND
((NOT (FASSOC (SETQ obj1 (CAR objPair))
(CAR objList)))
(TCONC objList objPair)))
(TCONC subObjs obj1]
(RPLACA pair (create GRAPHNODE
NODEID ← obj
TONODES ←(CAR subObjs)
NODELABEL ← name)))
(RETURN (CAR objList])
(LatticeBrowser.GetSubs
[LAMBDA (self object) (* dgb: "26-SEP-82 17:17")
(* Gets a set of subs from an object for browsing)
(COND
((← object HasIV (QUOTE subs)) (* If the object has an IV called subs then use the
contents of that)
(%@ object subs])
(LatticeBrowser.HasObject
[LAMBDA (self object) (* dgb: "24-NOV-82 10:44")
(AND [FASSOC (GetObjectRec object)
(fetch GRAPHNODES of (WINDOWPROP (%@ window)
(QUOTE GRAPH]
T])
(LatticeBrowser.LeftChoice
[LAMBDA (self) (* dgb: " 9-FEB-84 15:53")
(* Get the choices from the LeftButtonItems)
(PROG [(menu (← self BrowserMenu (QUOTE LeftButtonItems]
(RETURN (AND menu (MENU menu])
(LatticeBrowser.LeftSelection
[LAMBDA (self) (* dgb: "14-Feb-84 16:17")
(* * Move object if CTRL down. Do LeftShiftSelect if SHIFT down. Else choose from LeftButtonItems)
(PROG (oldMode realObj (window (@ window)))
(COND
((KEYDOWNP (QUOTE CTRL))
(SETQ oldMode (DSPOPERATION NIL window))
(GETMOUSESTATE) (* Here to move a node.)
(DSPOPERATION (QUOTE INVERT)
window)
(EDITMOVENODE window)
(DSPOPERATION oldMode window))
(T (* Here if left button depressed but not control.)
(PROG (selector items objName (latticeBrowser self)
(object (FindSelectedNode window)))
(DECLARE (SPECVARS object latticeBrowser))
(* SPECVARS for whenHeldFn)
(OR object (RETURN NIL)) (* Don't do anything unless an object selected)
(GETMOUSESTATE)
(SETQ objName (GetObjectName (OR (CAR (LISTP object))
object)))
(COND
((KEYDOWNP (QUOTE LSHIFT))
(← latticeBrowser LeftShiftSelect (OR (CAR (LISTP object))
object)
objName))
(T (SETQ selector (OR (← self LeftChoice)
(RETURN NIL)))
(← latticeBrowser DoSelectedCommand selector (OR (CAR (LISTP object))
object)
objName])
(LatticeBrowser.LeftShiftSelect
[LAMBDA (self object objname) (* dgb: "28-SEP-82 11:31")
(* Called when item is selected with left key and LSHIFT
is down)
(← object PP!])
(LatticeBrowser.ListObjects
[LAMBDA (self object) (* dgb: "24-NOV-82 10:47")
(* return a list of the objects that are being displayed
in the browser)
(AND (for node in (fetch GRAPHNODES of (WINDOWPROP (%@ window)
(QUOTE GRAPH)))
collect (CAR node])
(LatticeBrowser.MiddleChoice
[LAMBDA (self) (* dgb: " 9-FEB-84 16:05")
(* New method template)
(PROG NIL
(RETURN (MENU (OR (← self BrowserMenu (QUOTE MiddleButtonItems))
(RETURN NIL])
(LatticeBrowser.MiddleSelection
[LAMBDA (self) (* dgb: " 9-FEB-84 16:06")
(* This function called from the GRAPHER package when a node is selected with the middle mouse button.
If no node is selected then just returns.)
(PROG (objName selection object (window (@ window))
(latticeBrowser self))
(DECLARE (SPECVARS object latticeBrowser))
(COND
((NULL (SETQ object (FindSelectedNode window)))
(RETURN)))
(SETQ objName (GetObjectName object))
(←@
latticeBrowser lastSelectedObject object)
(GETMOUSESTATE)
(← self FlipNode object)
(COND
((KEYDOWNP (QUOTE LSHIFT)) (* Invoke editor if Left Shift Key is down)
(← self FlipNode object)
(BrowserTtySelect latticeBrowser (QUOTE MiddleShiftSelect)
(LIST object objName)))
(T (← self FlipNode object)
(SETQ selection (OR (← self MiddleChoice)
(RETURN NIL)))
(BrowserTtySelect latticeBrowser (QUOTE DoSelectedCommand)
(LIST selection object objName])
(LatticeBrowser.MiddleShiftSelect
[LAMBDA (self object objname) (* dgb: "13-JUN-83 20:41")
(* Called when item is selected with middle key and
LSHIFT is down)
(← self EditObject object])
(LatticeBrowser.ObjNamePair
[LAMBDA (self objOrName) (* dgb: "12-DEC-83 16:13")
(* Make a pair (object . objName) where objName is label
to be used in browser)
(PROG (obj name)
[COND
((LITATOM objOrName)
(SETQ name objOrName) (* assume this is the name of the object.
RETURN NIL if it is not.)
(OR (SETQ obj (GetObjectRec objOrName))
(RETURN NIL))
(RETURN (CONS obj objOrName)))
(T (* Assume it is an object)
(SETQ obj objOrName)
(SETQ name (← self GetLabel objOrName]
(RETURN (COND
((← obj InstOf!(QUOTE DestroyedObject))
NIL)
([AND (@ goodList)
(NOT (FMEMB obj (@ goodList]
NIL)
(T (CONS obj name])
(LatticeBrowser.Recompute
[LAMBDA (self) (* dgb: " 8-FEB-84 10:54")
(* Recompute the browseGraph in the same window)
(← self Show (@ startingList)
(@ window))
self])
(LatticeBrowser.SaveInIT
[LAMBDA (self) (* dgb: " 4-JUN-83 17:51")
(* save value in IT)
(SETTOPVAL (QUOTE IT)
self])
(LatticeBrowser.ShapeToHold
[LAMBDA (self margin) (* dgb: " 8-Mar-84 14:02")
(* Shape the browse window to just hold the nodes with
(OR margin Browsemargin) to spare)
(PROG [left bottom height width right top (region (WINDOWPROP (@ window)
(QUOTE REGION)))
(nodes (fetch GRAPHNODES of (WINDOWPROP (@ window)
(QUOTE GRAPH]
(SETQ left (MIN/LEFT nodes))
(SETQ bottom (MIN/BOTTOM nodes))
(SETQ right (MAX/RIGHT nodes))
(SETQ top (MAX/TOP nodes))
(SETQ width (IMIN MaxLatticeWidth (WIDTHIFWINDOW (IDIFFERENCE right left)
4)))
(SETQ height (IMIN MaxLatticeHeight (WIDTHIFWINDOW (IDIFFERENCE top bottom)
4)))
(AND (STRICTLY/BETWEEN (fetch WIDTH of region)
(SUB1 width)
(IPLUS 1 width (OR margin BrowserMargin)))
(STRICTLY/BETWEEN (fetch HEIGHT of region)
(SUB1 height)
(IPLUS 1 height (OR margin BrowserMargin)))
(RETURN T))
[SHAPEW (@ window)
(create REGION
LEFT ←(fetch LEFT of region)
BOTTOM ←(fetch BOTTOM of region)
WIDTH ←(IPLUS width (OR margin BrowserMargin))
HEIGHT ←(IPLUS height (OR margin BrowserMargin]
(SCROLLW (@ window)
(WTODSX 0 (@ window))
(WTODSY 0 (@ window])
(LatticeBrowser.Show
[LAMBDA (self browseList windowOrTitle goodList) (* dgb: "11-Feb-84 00:12")
(* * Show the items and their subs on a browse window.)
(* * If windowOrTitle is not a window it will be used as a title for a window which will be created.)
(PROG (NODELST roots window)
(OR (←@
startingList
(for C in (AND browseList (COND
((NOT (LISTP browseList))
(SETQ browseList (LIST browseList)))
(T browseList)))
when (GetObjectRec C) collect (GetObjectRec C)))
(RETURN (PROMPTPRINT (CHARACTER 7)
"Starting List for Browser is Empty")))
[AND goodList (←@
goodList
(for C in goodList when (GetObjectRec C) collect (GetObjectRec C]
(COND
((AND windowOrTitle (NOT (WINDOWP windowOrTitle)))
(←@
title windowOrTitle)))
(SETQ NODELST (← self GetNodeList (@ startingList)
(@ goodList)))
(SETQ window (SHOWGRAPH (LAYOUTGRAPH NODELST (SETQ roots (TreeRoots NODELST))
(@ graphFormat)
(@ browseFont))
(OR (@ window)
windowOrTitle
(@ title))
NIL NIL (@ topAlign)))
(WINDOWPROP window (QUOTE BUTTONEVENTFN)
(QUOTE WindowButtonEventFn))
(WINDOWPROP window (QUOTE LoopsWindow)
self)
(←@
window window)
(RETURN window])
(LatticeBrowser.TitleFn
[LAMBDA (self) (* dgb: " 9-FEB-84 16:17")
(*)
(PROG NIL
(← self DoSelectedCommand (MENU (OR (← self BrowserMenu (QUOTE TitleItems))
(RETURN NIL])
(LatticeBrowser.Unread
[LAMBDA (self object objName) (* dgb: "15-DEC-83 08:02")
(* Unread name into system buffer)
(BKSYSBUF objName])
(MetaBrowser.GetSubs
[LAMBDA (self elt) (* dgb: "22-JUL-83 15:38")
(* Subs for meta browser is the meta class of the
class.)
(PROG [(meta (GetObjectRec (CAR (← (GetObjectRec elt)
List
(QUOTE Meta]
(RETURN (COND
((EQ meta (GetObjectRec elt))
NIL)
(T (CONS meta])
(PathBrowser.AddAndBox
[LAMBDA (self obj objName) (* dgb: "14-Feb-84 13:40")
(* Add selected object to path, and box it)
(← self AddToPath obj)
(← self BoxNode obj])
(PathBrowser.AddToPath
[LAMBDA (self object) (* dgb: " 8-FEB-84 10:31")
(* Add a new object to the path)
(PROG NIL
(COND
((FMEMB object (@ pathObjects))
(RETURN NIL)))
(PushNewValue self (QUOTE pathObjects)
object)
(PushNewValue self (QUOTE startingList)
object)
(← self Recompute))
object])
(PathBrowser.Clear
[LAMBDA (self) (* dgb: "14-Feb-84 09:11")
(* Empty PathBrowser)
(←@
startingList NIL)
(←@
pathObjects NIL)
(←@
lastSelectedObject NIL])
(PathBrowser.GetSubs
[LAMBDA (self obj) (* dgb: " 7-FEB-84 18:03")
(* Only get subs for elements on the path)
(COND
((FMEMB obj (@ pathObjects))
(←Super
self GetSubs obj])
(PathBrowser.LeftShiftSelect
[LAMBDA (self obj objName) (* dgb: "14-Feb-84 15:11")
(* Add selected object to path, and box it)
(QUOTE AddAndBox])
(PathBrowser.Recompute
[LAMBDA (self) (* dgb: " 8-FEB-84 10:15")
(* Flip nodes which are on path)
(←Super
self Recompute)
(for obj in (@ pathObjects) do (← self FlipNode obj))
self])
(SupersBrowser.GetSubs
[LAMBDA (self object objName) (* dgb: "28-MAR-83 11:53")
(* Returns local supers)
(Supers object])
)
(DEFINEQ
(BOXNODE
[LAMBDA (NODE DS) (* dgb: " 9-DEC-82 17:18")
(DRAWBOX (LOWER/LEFT/POSITION NODE)
(NODEBOXWIDTH NODE)
(NODEBOXHEIGHT NODE)
1
(QUOTE INVERT)
DS])
(BoxWindowNode
[LAMBDA (nodeLabel window) (* dgb: " 3-JUN-83 15:51")
(* Puts a box around the node with nodeLabel in the graph. A nodeLabel in browsers is an object.
Does nothing if node not found.)
(PROG (node nodes)
(AND (WINDOWP window)
[SETQ nodes (fetch GRAPHNODES of (WINDOWPROP window (QUOTE GRAPH]
(SETQ node (FASSOC nodeLabel nodes))
(BOXNODE node window])
(BrSel1
[NLAMBDA (methodFn methodArgs) (* dgb: "28-NOV-83 13:45")
(* binding \INSIDE.TTYIN to fool TTYIN)
(PROG ((\INSIDE.TTYIN))
(APPLY methodFn methodArgs)
(AND (RELSTK (STKPOS (QUOTE DEDITL)))
(ERROR!])
(Browse
[LAMBDA (classes title goodClasses) (* dgb: "12-DEC-83 10:13")
(←New
($ ClassBrowser)
Show classes title (COND
((EQ goodClasses T)
classes)
(T goodClasses])
(BrowserTtySelect
[LAMBDA (browser selector args) (* dgb: "29-Feb-84 08:51")
(* Kludge to allow DEDIT to work right in FUGUE.3)
(PROG [(methodFn (OR (FetchMethod (fetch CLASS of browser)
selector)
(ERROR selector "not found in browser"]
(EVAL.IN.TTY.PROCESS (LIST (QUOTE BrSel1)
methodFn
(CONS browser args])
(DoMenuMethod
[LAMBDA (object items) (* edited: "13-NOV-83 16:20")
(PROG [(selector (AND items (DualMenu items]
(AND selector (RETURN (←!
object selector])
(DualMenu
[LAMBDA (items whenHeldFn) (* dgb: " 9-FEB-84 16:17")
(* creates and pops up a menu which allows differential
selection on left an middle buttons)
(MENU (create MENU
ITEMS ← items
WHENSELECTEDFN ←(QUOTE SubItemSelection)
SUBITEMFN ←(QUOTE DualSubItems)
WHENHELDFN ← whenHeldFn
CHANGEOFFSETFLG ← T])
(DualSelection
[LAMBDA (item menu button) (* dgb: "29-MAR-83 17:57")
(* A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential
selection item should be of form -
(itemSeenInMenu (leftValue midValue)) -
where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an
itemList, which will be displayed in a subselection menu)
(PROG (it it1)
(RETURN (COND
((NLISTP item)
item)
((NLISTP (SETQ it (CADR item)))
it)
((EQ (SETQ it1 (CAR it))
(QUOTE QUOTE))
(CADR it))
((EQ it1 (QUOTE PROGN))
(EVAL it))
((EQ button (QUOTE LEFT))
(COND
((LISTP it1)
(EVAL it1))
(T it1)))
((NLISTP (SETQ it1 (CADR it)))
it1)
(T (DualMenu it1])
(DualSubItems
[LAMBDA (menu item) (* dgb: "13-DEC-83 21:07")
(* A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential
selection item should be of form -
(itemSeenInMenu (leftValue midValue)) -
where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an
itemList, which will be displayed in a subselection menu)
(PROG (it it1)
(RETURN (COND
([OR (NLISTP item)
(NLISTP (SETQ it (CADR item)))
(EQ (SETQ it1 (CAR it))
(QUOTE QUOTE))
(EQ it1 (QUOTE PROGN))
(NLISTP (SETQ it1 (CADR it]
NIL)
(T it1])
(FILECLASSES
[LAMBDA (FILE) (* dgb: "13-DEC-83 09:32")
(FILECOMSLST FILE (QUOTE CLASSES])
(FileBrowse
[LAMBDA (file) (* dgb: "14-DEC-83 16:29")
(PROG [(fileClasses (FILECOMSLST file (QUOTE CLASSES]
(RETURN (Browse fileClasses (CONCAT "Classes on " file)
fileClasses])
(FindSelectedNode
[LAMBDA (WINDOW) (* dgb: "15-Feb-84 14:08")
(* Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down. Adapted from APPLYTOSELECTEDNODE
in GRAPHER package; returns the selected item rather than applying a function on the inside of the button event
fn.)
(PROG ((loopsWindow (WINDOWPROP WINDOW (QUOTE LoopsWindow)))
[NODELST (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW (QUOTE GRAPH]
(DS (WINDOWPROP WINDOW (QUOTE DSP)))
BUTTON OLDPOS REG NOW NEAR) (* note which button is down.)
(* get the region of this window.)
(SETQ REG (WINDOWPROP WINDOW (QUOTE REGION)))
(until (LASTMOUSESTATE (OR LEFT MIDDLE)) do (GETMOUSESTATE))
[SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS]
FLIP(AND NOW (← loopsWindow FlipNode (fetch NODEID of NOW)))
(AND NEAR (← loopsWindow FlipNode (fetch NODEID of NEAR)))
(SETQ NOW NEAR)
LP (* wait for a button up or move out of region)
(GETMOUSESTATE)
(COND
((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* button up, process it.)
(AND NOW (← loopsWindow FlipNode (fetch NODEID of NOW)))
(* NOW node has been selected.)
(RETURN (fetch NODEID of NOW)))
((NOT (INSIDE? (WINDOWPROP WINDOW (QUOTE REGION))
LASTMOUSEX LASTMOUSEY)) (* outside of region, return)
(AND NOW (← loopsWindow FlipNode (fetch NODEID of NOW)))
(RETURN))
([EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS]
(GO LP))
(T (GO FLIP])
(GetMethodArgs
[LAMBDA (fn) (* dgb: "29-Feb-84 08:51")
(COND
([NOT (FMEMB fn (QUOTE (← ←Super ←New SEND]
NIL)
(T (PROG (sel meth evalObj obj class arglist (actuals (TTYIN.READ?=ARGS)))
(SETQ obj (CAR actuals)) (* Fix up atoms starting with @ and $)
(AND (LITATOM obj)
(Fix@$ obj actuals)
(SETQ obj (CAR actuals)))
[SETQ evalObj (OR (Object? obj)
(AND (EQ (QUOTE $)
(CAR (LISTP obj)))
(GetObjectRec (CADR obj]
(OR [SETQ class (COND
((EQ fn (QUOTE ←New))
evalObj)
(T (OR (AND evalObj (Class evalObj))
(RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW)
(CLEARW PROMPTWINDOW)
(GetClassRec (CAR (INTTYL (CONCAT "Class of " obj
" not known.
Enter name of class: ")
NIL "Type in name of class: " T]
(RETURN NIL))
(OR (SETQ sel (CADR actuals))
(AND [SETQ sel (MENU (create MENU
ITEMS ←(← class List (QUOTE Selectors]
(BKSYSBUF sel))
(RETURN NIL))
(COND
((SETQ meth (FetchMethod class sel))
(SETQ arglist (ARGLIST meth))
(TTYIN.PRINTARGS (QUOTE ←)
(CONS (CAR arglist)
(CONS (QUOTE Method)
(CDR arglist)))
(CONS obj (CONS meth (CDDR actuals)))
0)
(RETURN T)))
(RETURN NIL])
(LatticeBrowser.ButtonFn
[LAMBDA (window) (* dgb: "10-FEB-83 23:50")
(* * Invoked when a mouse button is depressed in the LatticeBrowser window.)
(COND
((KEYDOWNP (QUOTE CTRL))
(PROG ((oldMode (DSPOPERATION NIL window)))
(GETMOUSESTATE) (* Here to move a node.)
(DSPOPERATION (QUOTE INVERT)
window)
(EDITMOVENODE window)
(DSPOPERATION oldMode window)))
((NULL (INSIDEP (DSPCLIPPINGREGION NIL window)
(LASTMOUSEX window)
(LASTMOUSEY window))) (* In the title region)
(← (WINDOWPROP window (QUOTE LatticeBrowser))
TitleFn))
(T (* Here if either button depressed.
Invokes either LatticeBrowser.MiddleFn or
LatticeBrowser.LeftFn)
(APPLYTOSELECTEDNODE window])
(LatticeBrowser.LeftFn
[LAMBDA (graphNode window) (* edited: "13-NOV-83 16:27")
(* This function called from the GRAPHER package when a node is selected with the middle mouse button.
If no node is selected then just returns.)
(PROG [objName object selection (latticeBrowser (WINDOWPROP window (QUOTE LatticeBrowser]
(DECLARE (SPECVARS object latticeBrowser))
(COND
((NULL graphNode)
(RETURN)))
(SETQ objName (fetch NODELABEL of graphNode))
(←@
latticeBrowser lastSelectedObject (SETQ object (fetch NODEID of graphNode)))
(GETMOUSESTATE)
(FLIPNODE graphNode window)
(COND
((KEYDOWNP (QUOTE LSHIFT))
(FLIPNODE graphNode window)
(← latticeBrowser LeftShiftSelect object objName))
(T (SETQ selection (DualMenu (@@ latticeBrowser LeftButtonItems)
(QUOTE LatticeBrowser.WhenHeldFn)))
(FLIPNODE graphNode window)
(← latticeBrowser DoSelectedCommand selection object objName])
(LatticeBrowser.MiddleFn
[LAMBDA (graphNode window) (* dgb: "27-NOV-83 17:47")
(* This function called from the GRAPHER package when a node is selected with the middle mouse button.
If no node is selected then just returns.)
(PROG [objName object selection (latticeBrowser (WINDOWPROP window (QUOTE LatticeBrowser]
(DECLARE (SPECVARS object latticeBrowser))
(COND
((NULL graphNode)
(RETURN)))
(SETQ objName (fetch NODELABEL of graphNode))
(←@
latticeBrowser lastSelectedObject (SETQ object (fetch NODEID of graphNode)))
(GETMOUSESTATE)
(FLIPNODE graphNode window)
(COND
((KEYDOWNP (QUOTE LSHIFT)) (* Invoke editor if Left Shift Key is down)
(FLIPNODE graphNode window)
(BrowseTtySelect latticeBrowser (QUOTE MiddleShiftSelect)
(LIST object objName)))
(T (SETQ selection (DualMenu (@@ latticeBrowser MiddleButtonItems)
(QUOTE LatticeBrowser.WhenHeldFn)))
(FLIPNODE graphNode window)
(BrowseTtySelect latticeBrowser (QUOTE DoSelectedCommand)
(LIST selection object objName])
(LatticeBrowser.WhenHeldFn
[LAMBDA (item menu key) (* dgb: "30-SEP-82 08:22")
(* Prints documentation for the method, either from the item list of from the class of object or latticeBrowser,
bound above in LatticeBrowser.LeftFn or LatticeBrowser.MiddleFn)
(DECLARE (SPECVARS object latticeBrowser))
(PROMPTPRINT (COND
[(LITATOM item) (* Get method documentation from object or browser)
(COND
((← object Understands item)
(GetMethod (Class object)
item
(QUOTE doc)))
(T (GetMethod (Class latticeBrowser)
item
(QUOTE doc]
((AND (LISTP item)
(CDDR item))
(CADDR item))
(T "When released this item will be selected"])
(SubItemSelection
[LAMBDA (item menu button) (* dgb: "13-DEC-83 21:03")
(* A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential
selection item should be of form -
(itemSeenInMenu (leftValue midValue)) -
where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an
itemList, which will be displayed in a subselection menu)
(PROG (it it1)
(RETURN (COND
((NLISTP item)
item)
((NLISTP (SETQ it (CADR item)))
it)
((EQ (SETQ it1 (CAR it))
(QUOTE QUOTE))
(CADR it))
((EQ it1 (QUOTE PROGN))
(EVAL it))
((LISTP it1)
(EVAL it1))
(T it1])
(TreeRoots
[LAMBDA (nodeLst) (* dgb: "13-OCT-83 22:06")
(* Computes the set of root nodes for a lattice -- those
with no connections TO them in list of nodes.)
(for ND in nodeLst bind (ROOTLST ←(MAPCAR nodeLst (FUNCTION CAR)))
do (for D in (TOLINKS ND) do (DREMOVE D ROOTLST)) finally (RETURN ROOTLST])
)
(RPAQQ BrowserMargin 20)
(RPAQQ MaxLatticeHeight 750)
(RPAQQ MaxLatticeWidth 900)
(RPAQQ NestedMenuFlg T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML BrSel1)
(ADDTOVAR LAMA )
)
(PUTPROPS LOOPSBROWSE COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (18259 56621 (ClassBrowser.BoxNode 18269 . 18534) (ClassBrowser.CVDoc 18536 . 19321) (
ClassBrowser.ClassDoc 19323 . 19770) (ClassBrowser.CopyTo 19772 . 21049) (ClassBrowser.DefineSubclass
21051 . 21641) (ClassBrowser.DeleteCV 21643 . 21902) (ClassBrowser.DeleteClass 21904 . 22162) (
ClassBrowser.DeleteClassItem 22164 . 23251) (ClassBrowser.DeleteIV 23253 . 23512) (
ClassBrowser.DeleteMethod 23514 . 23785) (ClassBrowser.DestroyAndRecompute 23787 . 24186) (
ClassBrowser.FindWhere 24188 . 25074) (ClassBrowser.GetSubs 25076 . 25505) (ClassBrowser.IVDoc 25507
. 26282) (ClassBrowser.LeftShiftSelect 26284 . 26556) (ClassBrowser.MoveTo 26558 . 28332) (
ClassBrowser.Recompute 28334 . 28669) (ClassBrowser.RenameCV 28671 . 29320) (ClassBrowser.RenameClass
29322 . 29748) (ClassBrowser.RenameIV 29750 . 30400) (ClassBrowser.RenameMeth 30402 . 31052) (
ClassBrowser.RenamePart 31054 . 32415) (ClassBrowser.SetItNew 32417 . 32710) (ClassBrowser.SubBrowser
32712 . 32996) (ClassBrowser.WhereIsCV 32998 . 33244) (ClassBrowser.WhereIsIV 33246 . 33518) (
ClassBrowser.WhereIsMethod 33520 . 33779) (InstanceBrowser.GetSubs 33781 . 34239) (
InstanceBrowser.NewPath 34241 . 34856) (LatticeBrowser.AddRoot 34858 . 35602) (LatticeBrowser.BoxNode
35604 . 36470) (LatticeBrowser.BrowserItems 36472 . 36721) (LatticeBrowser.BrowserMenu 36723 . 37606)
(LatticeBrowser.ChangeFontSize 37608 . 38316) (LatticeBrowser.ChangeFormat 38318 . 38785) (
LatticeBrowser.DeleteRoot 38787 . 39353) (LatticeBrowser.DoSelectedCommand 39355 . 40236) (
LatticeBrowser.EEObject 40238 . 40478) (LatticeBrowser.EditObject 40480 . 40728) (
LatticeBrowser.FlashNode 40730 . 41107) (LatticeBrowser.FlipNode 41109 . 41967) (
LatticeBrowser.GetLabel 41969 . 42261) (LatticeBrowser.GetNodeList 42263 . 44039) (
LatticeBrowser.GetSubs 44041 . 44457) (LatticeBrowser.HasObject 44459 . 44703) (
LatticeBrowser.LeftChoice 44705 . 45039) (LatticeBrowser.LeftSelection 45041 . 46536) (
LatticeBrowser.LeftShiftSelect 46538 . 46832) (LatticeBrowser.ListObjects 46834 . 47252) (
LatticeBrowser.MiddleChoice 47254 . 47577) (LatticeBrowser.MiddleSelection 47579 . 48740) (
LatticeBrowser.MiddleShiftSelect 48742 . 49053) (LatticeBrowser.ObjNamePair 49055 . 49989) (
LatticeBrowser.Recompute 49991 . 50290) (LatticeBrowser.SaveInIT 50292 . 50539) (
LatticeBrowser.ShapeToHold 50541 . 51991) (LatticeBrowser.Show 51993 . 53427) (LatticeBrowser.TitleFn
53429 . 53742) (LatticeBrowser.Unread 53744 . 53986) (MetaBrowser.GetSubs 53988 . 54437) (
PathBrowser.AddAndBox 54439 . 54719) (PathBrowser.AddToPath 54721 . 55190) (PathBrowser.Clear 55192 .
55495) (PathBrowser.GetSubs 55497 . 55797) (PathBrowser.LeftShiftSelect 55799 . 56055) (
PathBrowser.Recompute 56057 . 56388) (SupersBrowser.GetSubs 56390 . 56619)) (56622 69907 (BOXNODE
56632 . 56869) (BoxWindowNode 56871 . 57352) (BrSel1 57354 . 57694) (Browse 57696 . 57914) (
BrowserTtySelect 57916 . 58380) (DoMenuMethod 58382 . 58607) (DualMenu 58609 . 59069) (DualSelection
59071 . 60002) (DualSubItems 60004 . 60758) (FILECLASSES 60760 . 60907) (FileBrowse 60909 . 61163) (
FindSelectedNode 61165 . 63105) (GetMethodArgs 63107 . 64501) (LatticeBrowser.ButtonFn 64503 . 65453)
(LatticeBrowser.LeftFn 65455 . 66550) (LatticeBrowser.MiddleFn 66552 . 67791) (
LatticeBrowser.WhenHeldFn 67793 . 68607) (SubItemSelection 68609 . 69426) (TreeRoots 69428 . 69905))))
)
STOP