(FILECREATED " 2-AUG-83 19:19:50" {INDIGO}<LOOPS>STRUCTUREDINSTANCESYSTEM.;1 101467
changes to: (VARS STRUCTUREDINSTANCESYSTEMCOMS)
(FNS StructuredInstanceObject.GetSubs StructuredInstanceObject.GetSupers
StructuredInstanceObject.FetchSubs StructuredInstanceObject.FetchSupers
StructuredInstanceObject.FetchSubs! StructuredInstanceObject.FetchSupers!
InstanceBrowser.AddRoot InstanceBrowser.RemoveInstanceFromRelation
StructuredInstanceMeta.BrowseInstances InstanceBrowser.LinkDown
InstanceBrowser.LinkUp InstanceBrowser.MoveInstance InstanceBrowser.Spawn
InstanceBrowser.UnLinkDown StructuredInstanceMeta.FetchInstanceBrowser
StructuredInstanceMeta.New
StructuredInstanceObjectClassBrowser.CreateNewInstance
InstanceBrowser.InitializeWithAll InstanceBrowser.MoveSubTree
InstanceBrowser.UnLinkUp StructuredInstanceObject.LinkDown
StructuredInstanceObject.LinkUp StructuredInstanceObject.MoveSubLattice
StructuredInstanceObject.Rename StructuredInstanceObject.SpliceIn
StructuredInstanceObject.SpliceOut StructuredInstanceObject.UnLinkDown
StructuredInstanceObject.UnLinkUp ssi)
(CLASSES StructuredInstanceObject InstanceBrowser StructuredInstanceMeta)
previous date: " 1-AUG-83 14:25:40" {IVY}<STICKLEN>LISP>STRUCTUREDINSTANCESYSTEM.;12)
(PRETTYCOMPRINT STRUCTUREDINSTANCESYSTEMCOMS)
(RPAQQ STRUCTUREDINSTANCESYSTEMCOMS ((CLASSES StructuredInstanceObjectClassBrowser
StructuredInstanceMeta StructuredInstanceObject
InstanceBrowser)
(FNS ShowStructuredInstanceObjects StructuredInstanceMeta.AddInstanceName
StructuredInstanceMeta.AddLink StructuredInstanceMeta.AddLocalIV
StructuredInstanceMeta.BrowseInstances
StructuredInstanceMeta.CalculateBrowserStartingList
StructuredInstanceMeta.CloseInstanceBrowser StructuredInstanceMeta.DeleteInstanceName
StructuredInstanceMeta.Destroy StructuredInstanceMeta.DestroyRelation
StructuredInstanceMeta.FetchDefaultLinks StructuredInstanceMeta.FetchInstanceBrowser
StructuredInstanceMeta.FetchInstanceNames StructuredInstanceMeta.FetchLinks
StructuredInstanceMeta.FetchRoot StructuredInstanceMeta.New
StructuredInstanceMeta.Specialize StructuredInstanceMeta.UpDateAppropriateBrowser
StructuredInstanceMeta.UpDateBrowserList StructuredInstanceObject.Destroy
StructuredInstanceObject.FetchSubs StructuredInstanceObject.FetchSubs!
StructuredInstanceObject.FetchSupers StructuredInstanceObject.FetchSupers!
StructuredInstanceObject.LinkDown StructuredInstanceObject.LinkUp
StructuredInstanceObject.Rename StructuredInstanceObject.UnLinkDown
StructuredInstanceObject.UnLinkUp StructuredInstanceObjectClassBrowser.AddInstanceLink
StructuredInstanceObjectClassBrowser.BrowseInstances
StructuredInstanceObjectClassBrowser.CreateNewInstance
StructuredInstanceObjectClassBrowser.SaveClassAndInstances
StructuredInstanceObjectClassBrowser.SaveClassAndInstances!
StructuredInstanceObjectClassBrowser.SaveClassOnly
StructuredInstanceObjectClassBrowser.SaveClassOnly!
StructuredInstanceObjectClassBrowser.SaveInstancesOnly
StructuredInstanceObjectClassBrowser.SaveInstancesOnly! InstanceBrowser.AddRoot
InstanceBrowser.DefineSubclass InstanceBrowser.DestroyThisRelation
InstanceBrowser.GatherBoxedNodes InstanceBrowser.GetIV InstanceBrowser.GetSubs
InstanceBrowser.InitializeWithAll InstanceBrowser.LeftSelection InstanceBrowser.LinkDown
InstanceBrowser.LinkUp InstanceBrowser.MiddleSelection InstanceBrowser.MoveInstance
InstanceBrowser.MoveSubTree InstanceBrowser.Recompute
InstanceBrowser.RemoveInstanceFromRelation InstanceBrowser.Rename InstanceBrowser.SetIV
InstanceBrowser.SetIVofInterest InstanceBrowser.Show InstanceBrowser.Spawn
InstanceBrowser.Specialize InstanceBrowser.SpecializeInstance
InstanceBrowser.SpliceNewInstance InstanceBrowser.TotallyDestroyInstance
InstanceBrowser.UnLinkDown InstanceBrowser.UnLinkUp InstanceBrowser.Unread PromptRead
PromptWindowBlink ssi)
(VARS *NoBrowserUpdates*)))
(DEFCLASSES StructuredInstanceObjectClassBrowser StructuredInstanceMeta StructuredInstanceObject
InstanceBrowser)
[DEFCLASS StructuredInstanceObjectClassBrowser
(MetaClass Class Edited: (* js: "27-JUL-83 14:30"))
(Supers ClassBrowser)
(ClassVariables (MiddleButtonItems ((EM*(EditMethod ((EM (QUOTE EditMethod))
(EM!(QUOTE EM!)
"Edit method selected from Menu, making it local if necessary"))
"Edit method of class selected from Menu"))
(Add*(DefMethod ((Specialize (QUOTE DefineSubclass)
"Define a specialized subclass")
DefMethod DefRSM AddIV AddCV
(New (QUOTE 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 DeleteClassItem
"Delete one of Methods IVs CVs
or the class itself")
(Move*(MoveTo (MoveTo CopyTo))
"Move or copy")
(BoxNode (QUOTE BoxNode)
"Draw a box around selected node")
(Rename*(QUOTE RenamePart)
"Rename some part of the class")
(Edit*(EditObject (EditObject (EditIVs (QUOTE (EditObject
-2 DE))
"Edit IVs of class")
(EditCVs (QUOTE (EditObject
-3 DE))
"Edit CVs of class")
(Inspect (QUOTE Inspect)
"Inspect selected class")))
"Edit class"))
doc (* Undocumented CV added by STICKLEN)
)
(LocalCommands (CopyTo BoxNode ClassDoc CVDoc DefineSubclass DeleteClassItem
EditObject FindWhere FlipNode IVDoc MoveTo Recompute
RenamePart Unread BrowseInstances AddInstanceLink
SaveClassOnly SaveClassOnly! SaveInstancesOnly
SaveInstancesOnly! SaveClassAndInsatnces
SaveClassAndInstances! CreateNewInstance)
doc (* Undocumented CV added by STICKLEN)
)
(LeftButtonItems ((Print*(PrintSummary (PP PP! PPV!(PPM (QUOTE PPMethod)
"Prettyprint selected method")
PrintSummary))
"PrintSummary of class")
(Doc*(ClassDoc (ClassDoc MethodDoc IVDoc CVDoc))
"Documentation for Class, Methods, IVs and CVs
Class is default")
(WhereIs (QUOTE FindWhere)
"Find location of method, iv, or cv")
(Unread (QUOTE Unread)
"Put class name in typein buffer")
(BrowseInstances (QUOTE BrowseInstances)
"Create an instance browser. Only applicable for StructuredInstanceObjects.")
(AddNewInstanceLink (QUOTE AddInstanceLink)
"Create a new super/sub link pair for some StructuredInstanceObject. Only applicable for StructuredInstanceObject."
)
(Save*(SaveClassOnly ((SaveClassOnly (QUOTE SaveClassOnly)
"Saves the current class on a file with the name reflecting the class name.")
(SaveClassOnly!(QUOTE SaveClassOnly!)
"Saves the current class and recursively defined subs files with descriptive names.")
(SaveInstancesOnly (QUOTE
SaveInstancesOnly)
"Saves all instances on a file with a descriptive name.")
(SaveInstancesOnly!(QUOTE
SaveInstancesOnly!)
"Saves all instances here and in all recursively defined subs on files with descriptive names.")
(SaveClassAndInstances (QUOTE
SaveClassAndInstances)
"Saves the class and all instances in a file with a descriptive name.")
(SaveClassAndInstances!(QUOTE
SaveClassAndInstances!)
"Saves this class and all its instances, then all the recursively defined subs also, on files with descriptive names."
))
"Save the current class on a file."))
(CreateNewInstance (QUOTE CreateNewInstance)
"Create a new instance of the class."))
doc (* Undocumented CV added by STICKLEN)
))
(InstanceVariables (title "StructuredInstanceObject Class Inheritance Lattice" doc
(* Undocumented InstanceVariable added by STICKLEN)
))
(Methods (AddInstanceLink StructuredInstanceObjectClassBrowser.AddInstanceLink args (object
objectName)
doc (* method to add a new super/sub link pair for a
StructuredInstanceObject.)
)
(BrowseInstances StructuredInstanceObjectClassBrowser.BrowseInstances args (object
objectName)
doc (* method to create an instance browser for any
StructuredInstanceObject.)
)
(CreateNewInstance StructuredInstanceObjectClassBrowser.CreateNewInstance args
(object objectName)
doc (* a slight modification to the New method used for
StructuredInstanceObjects. Prompts the user for a name
for the new instance.)
)
(SaveClassAndInstances StructuredInstanceObjectClassBrowser.SaveClassAndInstances args
(object objectName)
doc (* method to save a class and instances.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
)
(SaveClassAndInstances! StructuredInstanceObjectClassBrowser.SaveClassAndInstances! args
(object objectName)
doc (* method to save recursively defined class and
instances. Note checking is done to make sure the object
is a StructuredInstanceObject.)
)
(SaveClassOnly StructuredInstanceObjectClassBrowser.SaveClassOnly args (object objectName)
doc (* method to save a class only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
)
(SaveClassOnly! StructuredInstanceObjectClassBrowser.SaveClassOnly! args (object
objectName)
doc (* method to save a recursively defined class only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
)
(SaveInstancesOnly StructuredInstanceObjectClassBrowser.SaveInstancesOnly args
(object objectName)
doc (* method to save class instances only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
)
(SaveInstancesOnly! StructuredInstanceObjectClassBrowser.SaveInstancesOnly! args
(object objectName)
doc (* method to save the recursively definned instances
only. Note checking is done to make sure the object is a
StructuredInstanceObject.)
))]
[DEFCLASS StructuredInstanceMeta
(MetaClass MetaClass Edited: (* js: "29-JUL-83 15:11"))
(Supers Class)
(ClassVariables)
(InstanceVariables (Links (super sub)
doc (* default link pair)
))
(Methods (AddLink StructuredInstanceMeta.AddLink args (linkPair)
doc (* method to add the name of a link pair)
)
(FetchLinks StructuredInstanceMeta.FetchLinks args NIL doc
(* method to fetch the current links))
(New StructuredInstanceMeta.New args (name)
doc
(* creates an instance of some class that is a StructuredInstanceObject. The name parm must be specified or else
the function will do nothing and generate an error. Note that the new instance is made a root in the default link
relation.)
)
(FetchRoot StructuredInstanceMeta.FetchRoot args NIL doc
(* method to fetch the current instance root.)
)
(FetchInstanceNames StructuredInstanceMeta.FetchInstanceNames args NIL doc
(* method to fetch the names of all instances.)
)
(AddInstanceName StructuredInstanceMeta.AddInstanceName args (newInstanceName)
doc (* adds the names of a newly created instances to the
list in the IV InstanceNames)
)
(AddLocalIV StructuredInstanceMeta.AddLocalIV args (IVname IVvalue)
doc (* method to add a locally defined IV for a class that
is a StructuredInstanceObject)
)
(BrowseInstances StructuredInstanceMeta.BrowseInstances args (StartingList linkPair)
doc (* New method template)
)
(Specialize StructuredInstanceMeta.Specialize doc
(* a slight addition to the normal Specialize method:
each new class is initialized with StoargeFileName,
FilePackageComs, Root, InstanceName, and Links IV's.)
args
(newName))
(SaveClassOnly! StructuredInstanceMeta.SaveClassOnly! args NIL doc
(* method to store on the currently connected direcotry
a file containing the class and all recursively defined
subclasses))
(SaveInstancesOnly StructuredInstanceMeta.SaveInstancesOnly args NIL doc
(* method to store on the currently connected direcotry
a file containing all currently defined instances)
)
(SaveInstancesOnly! StructuredInstanceMeta.SaveInstancesOnly! args NIL doc
(* method to store on the currently connected direcotry
a file containing all currently defined instances and
all instances of recursively defined subs)
)
(SaveClassAndInstances StructuredInstanceMeta.SaveClassAndInstances args NIL doc
(* method to store on the currently connected direcotry
a file containing the class and all currently defined
instances))
(SaveClassAndInstances! StructuredInstanceMeta.SaveClassAndInstances! args NIL doc
(* method to store on the currently connected direcotry a file containing the class and all currently defined
instances both for self and for all subs of self)
)
(SaveClassOnly StructuredInstanceMeta.SaveClassOnly args NIL doc
(* method to store on the currently connected direcotry
a file containing the class))
(Destroy StructuredInstanceMeta.Destroy doc (* this is a patch so that when the class is killed, the
instances will be appropriately killed too.)
)
(DestroyRelation StructuredInstanceMeta.DestroyRelation args (superLink subLink)
doc
(* method used to remove one link pair from the class, smash all instances that participate in that relation and
no others, and close the current window for the browser along this relation, if there is one.)
)
(UpDateBrowserList StructuredInstanceMeta.UpDateBrowserList args (linkPair newValue)
doc (* method to change the browser for the given relation.
Note this closes the old browser if it is active.)
)
(UpDateAppropriateBrowser StructuredInstanceMeta.UpDateAppropriateBrowser args (linkPair)
doc (* method that looks to see if there is a browser for a
specified link and updates it if there is.)
)
(DeleteInstanceName StructuredInstanceMeta.DeleteInstanceName args (oldName)
doc (* method to remove one instance name from the CV)
)
(FetchDefaultLinks StructuredInstanceMeta.FetchDefaultLinks args NIL doc
(* fetches the current default links from
StructuredInstanceMeta))
(FetchInstanceBrowser StructuredInstanceMeta.FetchInstanceBrowser args (linkPair)
doc (* method to fetch the current Browser for a given
relation)
)
(CloseInstanceBrowser StructuredInstanceMeta.CloseInstanceBrowser args (linkPair)
doc (* method to close a given instance browser window)
)
(CalculateBrowserStartingList StructuredInstanceMeta.CalculateBrowserStartingList args
NIL doc (* New method template)))]
[DEFCLASS StructuredInstanceObject
(MetaClass StructuredInstanceMeta Edited: (* js: "29-JUL-83 22:43")
doc (* all classes which have named structured instances
should have this class on their supers list)
)
(Supers NamedObject)
(ClassVariables (CurrentBrowsers NIL doc (* variable to hold an A-List of form
((linkPair browserForLinkPair) ...)))
(Links ((super sub))
doc (* CV to hold all current linkPairs known in the class)
)
(Root NIL doc (* CV to hold the current root for all instances for all
relations in the class.))
(InstanceNames (A0012 A0011 A0010 A0022 A0021 A0020)
doc (* all the names of objects that are instantiated from
this class.)
))
(InstanceVariables (super NIL doc (* default slot for instance supers))
(sub NIL doc (* default slot for instance subs)))
(Methods (LinkUp StructuredInstanceObject.LinkUp args (linkPair superObjectName)
doc
(* method to link to an already defined super along some superLink Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
)
(UnLinkUp StructuredInstanceObject.UnLinkUp args (linkPair superObjectName)
doc
(* method to link to an already defined super along some superLink Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
)
(LinkDown StructuredInstanceObject.LinkDown args (linkPair subObjectName)
doc
(* method to link to an already defined sub along some sublink. Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
)
(UnLinkDown StructuredInstanceObject.UnLinkDown args (linkPair subObjectName)
doc
(* method to unlink to an already defined sub along some sublink. Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
)
(Rename StructuredInstanceObject.Rename args (newName linkPair)
doc
(* this method renames self by changing all superObject/subLink names, all subObject/superLink names, the instance
IV InstanceNames at the class level, and by changing the name IV in self.)
)
(Destroy StructuredInstanceObject.Destroy doc
(* method to augment the standard Destroy from Object. Added is the removal of the object name from InstanceNames
and the splicing out of the object from all relations that it participates in.)
)
(FetchSubs StructuredInstanceObject.FetchSubs args (linkPair)
doc (* method to retreive all the subs of an instance along
a given relation)
)
(FetchSupers StructuredInstanceObject.FetchSupers args (linkPair)
doc
(* method to fetch all the supers of self along the specified relation. Note that the root instance, if it is an
immediate super to self, will be returned as a member of the list.)
)
(FetchSubs! StructuredInstanceObject.FetchSubs! args (linkPair)
doc (* New method template)
)
(FetchSupers! StructuredInstanceObject.FetchSupers! args (linkPair)
doc
(* method to recursively fetch all the supers of self along a specified Note that the root instance will be
returned as a member of list.)
))]
[DEFCLASS InstanceBrowser
(MetaClass Class Edited: (* js: " 2-AUG-83 03:30")
doc (* a browser to look at the instances of some class
along a link set in the instance variable
CurrentFollowLink)
)
(Supers LatticeBrowser)
(ClassVariables (TitleItems ((DestroyThisRelation (QUOTE DestroyThisRelation)
"Destroy the current relation and remove the link from the class.")
(AddRoot (QUOTE AddRoot)
"Add named item as a root in current relation AND in default relation.")
(Recompute (QUOTE Recompute)
"Recompute lattice from starting objects")
(SetIVofInterset (QUOTE SetIVofInterest)
"Sets the IV to use in SetIV and FetchIV (left button items).")
(InitializeWithAll (QUOTE InitializeWithAll)
"Set every instance in the class to a root in this relation. Best used for initialization."))
doc (* Items for menu of selections in title of window)
)
(MiddleButtonItems ((LinkUp (QUOTE LinkUp)
"Link the current node to the currently boxed node following the supers link. You must box a node first."
)
(UnLinkUp (QUOTE UnLinkUp)
"Unlinks the current node from the boxed node following the supers link. You must box a node first.")
(LinkDown (QUOTE LinkDown)
"Unlink the current node from the currently boxed node following the subs link. You must box a node first."
)
(UnLinkDown (QUOTE UnLinkDown)
"Unlink the current node from the currently boxed node following the subs link. You must box a node first."
)
(MoveInstance (QUOTE MoveInstance)
"Moves an instance from one place in the lattice to another, leaving the subs where they were. The exact target location is pinpointed interactively."
)
(MoveSubTree (QUOTE MoveSubTree)
"Moves an entire subtree to a new location."))
doc (* Menu items for MiddleButton seletion -- Value sent as
message to object or browser -- see LocalCommands)
)
(LocalCommands (EditObject BoxNode Recompute AddRoot SpecializeInstance Unread
Rename LinkUp LinkDown UnLinkUp UnLinkDown MoveInstance
MoveSubTree RemoveInstanceFromRelation
TotallyDestroyInstance GetIV SetIV DestroyThisRelation
Spawn)
doc (* messages that should be sent to browser when item
seleted in menu, even if object does understand them)
)
(LeftButtonItems ((CreateSubInstance (QUOTE SpecializeInstance)
"Create a new Instance (if necessary) and link it properly to the indicated instance along the current FollowLink."
)
(RemoveInstance (QUOTE RemoveInstanceFromRelation)
"Removes the current instance from the current relation, but leaves it alive throughout the rest of the class."
)
(TotallyDestroyInstance (QUOTE TotallyDestroyInstance)
"Removes the current instance from the current relation, and also totally removes it from the class.")
(Rename (QUOTE Rename)
"Rename the instance for use in the ENTIRE class.")
(Edit (QUOTE EditObject)
"Edit selected item")
(Inspect (QUOTE Inspect)
"'Inspect selected item")
(PP (QUOTE PP)
"Prettyprint selected item")
(Unread (QUOTE Unread)
"Unread the name of the instance into the system buffer")
(BoxInstance (QUOTE BoxNode)
"Draw box around selected node")
(GetIV (QUOTE GetIV)
"Gets the IV set with the Title function SetIVofInterest from the selected instance.")
(SetIV (QUOTE SetIV)
"Sets the IV set with the Title function SetIVofInterest from the selected instance.")
(SpawnNewBrowser (QUOTE Spawn)
"Creates a new instance browser for the class with the current instance as the root. User determines the relation shown in the new browser."
))
doc (* Menu items for LeftButton seletion -- Value sent as
message to object or browser -- see LocalCommands)
))
(InstanceVariables (FollowLink NIL doc (* IV holding the current link that is chased in the
browser. This is some subLink for the
StructuredInstanceObject whose instances are being
browsed.))
(ReverseFollowLink NIL doc (* the backlink corresonding to the FollowLink.
This is some superLink for the StructuredInstanceObject
whose instances are being browsed.))
(BrowsingClass NIL doc (* contains the Loops name of the class being browsed)
)
(startingList NIL doc (* a list of the nodes from which the Browser sprouts.)
)
(SpecialButtonActionMode NIL doc
(* this IV contains a value to indicate what actions the right and middle mouse buttons will currently have in the
browser. A NIL value means that normal action will procede with the MiddleSelection and RightSelection messages
going on normally to the supers. If this IV is equal to (QUOTE GatherBoxedNodes,) then the left mouse button will
add a node to the list maintained in GatheredBoxedNodeList, and the middle mouse button will remove a node from
GatherBoxedNodeList.)
)
(GatheredBoxedNodeList NIL doc (* contains a list of nodes that are selected during the
operation of the method GatherBoxedNodes)
)
(IVofInterest NIL doc (* name of the IV used in GetIV and SetIV.
Value is set in SetIVofInterest.))
(SupersObjectList NIL doc (* Undocumented InstanceVariable added by STICKLEN)
))
(Methods (GetSubs InstanceBrowser.GetSubs args (elt)
doc
(* returns the list of objects which are "subs" of "elt" using the value of IV "subLinks" in the browser to
determine the links to be used)
)
(Show InstanceBrowser.Show args (browseList windowOrTitle goodList)
doc
(* * Show the items and their subs on a browse window.)
)
(SpecializeInstance InstanceBrowser.SpecializeInstance args (object objectName)
doc
(* method to LinkUp some instance to the instance that has been buttoned along the FollowLink.
If the name of the LinkUp instance is not known, a new instance is created.)
)
(AddRoot InstanceBrowser.AddRoot args NIL doc
(* method to add a new root to the InstanceBrowser. Note that this method add a root both for the current relation
AND for the default relation if the instance is new to the class. If it is not new to the class, then only added
for the current relation.)
)
(Unread InstanceBrowser.Unread args (object objName)
doc (* Unread name into system buffer)
)
(Rename InstanceBrowser.Rename args (object objectName)
doc
(* method to rename an instance. The instance name is interactively entered, and once changed, is altered for use
no matter where in the class.)
)
(LinkUp InstanceBrowser.LinkUp args (object objectName)
doc (* links object to the current boxed node along the
current supersLink)
)
(UnLinkUp InstanceBrowser.UnLinkUp args (object objectName)
doc (* unlinks the current object to a list of interactively
determined other instances along the current supersLink)
)
(LinkDown InstanceBrowser.LinkDown args (object objectName)
doc (* links the current object to a list of interactively
determined other instances along the current subsLink.)
)
(UnLinkDown InstanceBrowser.UnLinkDown args (object objectName)
doc (* unlinks the current object to a list of interactively
determined other instances along the current subsLink.)
)
(MoveInstance InstanceBrowser.MoveInstance args (object objectName)
doc
(* method to move an instance from one place in the lattice to another. After removing from one location, the old
supers and subs are spliced together. The new splice in location is found by interactively boxing two nodes that
are currently dirrectly linked. If no node is boxed for the super, the old instance becomes a new root.
If no node is boxed for the sub, the old instance becomes a simple subinstance of the boxed super.)
)
(GatherBoxedNodes InstanceBrowser.GatherBoxedNodes args (promptString)
doc
(* this method allows the user to interactively choose a set of nodes for some operation. The IV
SpecialButtonActionMode is set to GatherBoxedNodes to indicate special action for both left button and middle
button. In this mode, the left button adds nodes to the list, the middle button deletes nodes from the list.)
)
(MoveSubTree InstanceBrowser.MoveSubTree args (object objectName)
doc (* method which moves an entire subtree to a new
location in the lattice.)
)
(MiddleSelection InstanceBrowser.MiddleSelection doc
(* this method allows special use of the left and middle mouse buttons. The action taken depends on the value of
the IV SpecialButtonActionMode. If NIL, then normal mouse functions are in operation. If equal to
GatherBoxedNodeList, then opertions is: left button = add item to list maintained in IV GatheredBoxedNodeList,
middle button = delete item from that list.)
)
(LeftSelection InstanceBrowser.LeftSelection doc
(* this method allows special use of the left and middle mouse buttons. The action taken depends on the value of
the IV SpecialButtonActionMode. If NIL, then normal mouse functions are in operation. If equal to
GatherBoxedNodeList, then opertions is: left button = add item to list maintained in IV GatheredBoxedNodeList,
middle button = delete item from that list.)
)
(RemoveInstanceFromRelation InstanceBrowser.RemoveInstanceFromRelation args (object
objectName)
doc (* method to kill an instance.
The instance is destroyed only in relation to the
displayed link, it is still alive in the class.)
)
(TotallyDestroyInstance InstanceBrowser.TotallyDestroyInstance args (object objectName)
doc (* method to kill an instance.
The instance is destroyed only in relation to the
displayed link, it is still alive in the class.)
)
(SetIVofInterest InstanceBrowser.SetIVofInterest args NIL doc
(* title function to set the InstanceBrowser IV,
IVofInterest. It is used in the left button methods
SetIV and GetIV.))
(SetIV InstanceBrowser.SetIV args (object objectName)
doc (* sets an IV in the selected instance that is the IV
named in IVofInterest.)
)
(GetIV InstanceBrowser.GetIV args (object objectName)
doc (* gets an IV in the selected instance that is the IV
named in IVofInterest.)
)
(InitializeWithAll InstanceBrowser.InitializeWithAll args NIL doc
(* this method sets every instance in the class that is in the super/sub relation (or whatever is currently the
default link as set in StructuredInstanceMeta) to a root in the current browser. If instance is already in the
browser, it will not be added.)
)
(DestroyThisRelation InstanceBrowser.DestroyThisRelation args NIL doc
(* method to destroy the current relation, remove the link from the class, and destroy any instances that take
part in this relation and no others)
)
(Recompute InstanceBrowser.Recompute doc (* inherits Recompute from Super if there is a non-null
starting list.)
args NIL)
(Spawn InstanceBrowser.Spawn args (object objectName)
doc (* creates a new browser with the current object as its
root. User determines the relation followed in the new
browser.)
))]
(DEFINEQ
(ShowStructuredInstanceObjects
[LAMBDA NIL (* js: "27-JUL-83 16:50")
(←New
$StructuredInstanceObjectClassBrowser Show (QUOTE (StructuredInstanceObject])
(StructuredInstanceMeta.AddInstanceName
[LAMBDA (self newInstanceName) (* js: "29-JUL-83 18:42")
(* adds the names of a newly created instances to the
list in the IV InstanceNames)
(PutClassValue self (QUOTE InstanceNames)
(CONS newInstanceName (GetClassValue self (QUOTE InstanceNames])
(StructuredInstanceMeta.AddLink
[LAMBDA (self linkPair) (* js: "29-JUL-83 20:12")
(* method to add the name of a link pair)
(PROG (currentLinks super sub)
(SETQ currentLinks (GetClassValue self (QUOTE Links)))
(SETQ super (CAR linkPair))
(SETQ sub (CADR linkPair))
(COND
((OR (NULL super)
(NULL sub))
(ERROR "Bidirectional links must be specified, you entered only one."))
((MEMBER linkPair currentLinks)
(ERROR (CONCAT "The link pair specified is already known for " self ".")))
(T (PutClassValue self (QUOTE Links)
(CONS linkPair currentLinks))
(SEND self AddLocalIV super)
(SEND self AddLocalIV sub])
(StructuredInstanceMeta.AddLocalIV
[LAMBDA (self IVname IVvalue) (* js: "21-JUL-83 18:32")
(* method to add a locally defined IV for a class that
is a StructuredInstanceObject)
(InstallInstanceVariables self (CONS (LIST IVname IVvalue)
(GetSourceIVs self])
(StructuredInstanceMeta.BrowseInstances
[LAMBDA (self StartingList linkPair) (* js: " 2-AUG-83 18:55")
(* New method template)
(PROG (instanceBrowser ReverseFollowLink FollowLink interactiveFollow subSelectionMenu allLinks
defaultLinks root rootObject supersObjectList)
(PRINT (QUOTE p1))
(COND
([AND (NOT (NULL StartingList))
(PRINT (for oneStrtingObject in (MKLIST StartingList) bind (answer)
do (COND
((NOT (EQ self (Class oneStartingInstance)))
(SETQ answer T)))
finally (RETURN answer]
(CLRPROMPT)
(PRINT (QUOTE shouldprint))
(PROMPTPRINT (CONCAT "Sorry, but the object " oneStartingObject
" on your startingList is not in the class "
self ". Hence I cannot make the browser for you."))
(RETURN)))
(PRINT (QUOTE p2))
(SETQ defaultLinks (SEND self FetchDefaultLinks))
(SETQ allLinks (SEND self FetchLinks))
(SETQ ReverseFollowLink (CAR linkPair))
(SETQ FollowLink (CADR linkPair))
(SETQ root (SEND self FetchRoot))
(SETQ rootObject (APPLY (QUOTE $)
(LIST root)))
(COND
([AND (NOT (ATOM StartingList))
(NOT (NULL (CDR StartingList]
(CLRPROMPT)
(PROMPTPRINT "Sorry, but an instance browser can be made only from one root.")
(RETURN)))
(COND
[(NULL linkPair)
[SETQ subSelectionMenu (create MENU
ITEMS ←(for onePair in allLinks collect (CADR onePair]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Choose the chase sub you want. Current default is "
(CADR (SEND self FetchDefaultLinks))
"."))
(SETQ interactiveFollow (MENU subSelectionMenu))
(CLRPROMPT)
(COND
[interactiveFollow (SETQ FollowLink interactiveFollow)
(SETQ ReverseFollowLink (for onePair in allLinks bind (answer)
do (SETQ answer (CAR onePair))
when (EQ (CADR onePair)
interactiveFollow)
finally (RETURN answer]
(T (SETQ FollowLink (CADR defaultLinks))
(SETQ ReverseFollowLink (CAR defaultLinks]
((NOT (MEMBER linkPair allLinks))
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Trying to browse instances of " self
" along the undefined linkPair "
linkPair "."))
(RETURN)))
(COND
((NULL ReverseFollowLink)
(PROMPTPRINT (CONCAT FollowLink " is not a valid SUBS link for the class " self)))
(T [COND
((NULL StartingList)
(SETQ StartingList (GetValue rootObject FollowLink))
(SETQ supersObjectList (CONS root)))
(T (SETQ supersObjectList (for oneObject in (MKLIST StartingList)
join (GetValue (APPLY (QUOTE $)
(LIST oneObject))
ReverseFollowLink]
(COND
((AND (NOT (NULL StartingList))
(NULL (GetValue (APPLY (QUOTE $)
(MKLIST StartingList))
ReverseFollowLink)))
(CLRPROMPT)
(PROMPTPRINT "Sorry, but that root object is not in the " (LIST ReverseFollowLink
FollowLink)
" relation.")
(RETURN)))
(SETQ instanceBrowser (SEND ($ InstanceBrowser)
New))
(PutValue instanceBrowser (QUOTE SupersObjectList)
supersObjectList)
(PutValue instanceBrowser (QUOTE FollowLink)
FollowLink)
(PutValue instanceBrowser (QUOTE ReverseFollowLink)
ReverseFollowLink)
(PutValue instanceBrowser (QUOTE BrowsingClass)
self)
(SEND instanceBrowser Show (MKLIST StartingList))
(SEND self UpDateBrowserList (LIST ReverseFollowLink FollowLink)
instanceBrowser)
(RETURN instanceBrowser])
(StructuredInstanceMeta.CalculateBrowserStartingList
[LAMBDA (self linkPair) (* js: "31-JUL-83 19:55")
(* method to recalculate a browser startingList and
store it.)
(PROG (currentBrowser rootName rootObject subLink)
(SETQ linkPair (OR linkPair (SEND self FetchDefaultLinks)))
(SETQ currentBrowser (SEND self FetchInstanceBrowser linkPair))
(SETQ rootName (SEND self FetchRoot))
(SETQ rootObject (APPLY (QUOTE $)
(LIST rootName)))
(SETQ subLink (CADR linkPair))
(PutValue currentBrowser (QUOTE startingList)
(GetValue rootObject subLink])
(StructuredInstanceMeta.CloseInstanceBrowser
[LAMBDA (self linkPair) (* js: "29-JUL-83 19:59")
(* method to close a given instance browser window)
(PROG (currentBrowser)
(SETQ currentBrowser (SEND self FetchInstanceBrowser linkPair))
(SEND self UpDateBrowserList linkPair NIL])
(StructuredInstanceMeta.DeleteInstanceName
[LAMBDA (self oldName) (* js: "29-JUL-83 19:03")
(* method to remove one instance name from the CV)
(PutClassValue self (QUOTE InstanceNames)
(REMOVE oldName (GetClassValue self (QUOTE InstanceNames])
(StructuredInstanceMeta.Destroy
[LAMBDA (self) (* js: "31-JUL-83 15:24")
(* this is a patch so that when the class is killed, the
instances will be appropriately killed too.)
(PROG (allInstances)
[SETQ allInstances (for oneInstanceName in (SEND self FetchInstanceNames)
collect (APPLY (QUOTE $)
(LIST oneInstanceName]
(for oneLinkPair in (SEND self FetchLinks) do (SEND self UpDateBrowserList oneLinkPair NIL))
(for oneInstance in allInstances do (DoMethod oneInstance (QUOTE Destroy)
($ NamedObject)))
(SENDSUPER self Destroy])
(StructuredInstanceMeta.DestroyRelation
[LAMBDA (self superLink subLink) (* js: "28-JUL-83 14:43")
(* method used to remove one link pair from the class, smash all instances that participate in that relation and
no others, and close the current window for the browser along this relation, if there is one.)
(PROG ((allInstances (GetValue self (QUOTE InstanceNames)))
(LinkBrowserForRelation (SEND self GetInstanceBrowser (LIST superLink subLink)))
(allLinks (GetValue self (QUOTE Links])
(StructuredInstanceMeta.FetchDefaultLinks
[LAMBDA (self) (* js: "29-JUL-83 20:18")
(* fetches the current default links from
StructuredInstanceMeta)
(GetValue ($ StructuredInstanceMeta)
(QUOTE Links])
(StructuredInstanceMeta.FetchInstanceBrowser
[LAMBDA (self linkPair) (* js: " 1-AUG-83 22:08")
(* method to fetch the current Browser for a given
relation)
(PROG (browser)
[SETQ browser (CADR (SASSOC linkPair (GetClassValue self (QUOTE CurrentBrowsers]
(COND
([AND browser (ACTIVEWP (GetValue browser (QUOTE window]
(RETURN browser])
(StructuredInstanceMeta.FetchInstanceNames
[LAMBDA (self) (* js: "29-JUL-83 19:16")
(* method to fetch the names of all instances.)
(GetClassValue self (QUOTE InstanceNames])
(StructuredInstanceMeta.FetchLinks
[LAMBDA (self) (* js: "29-JUL-83 19:17")
(* method to fetch the current links)
(GetClassValue self (QUOTE Links])
(StructuredInstanceMeta.FetchRoot
[LAMBDA (self) (* js: "29-JUL-83 19:36")
(* method to fetch the current instance root.)
(GetClassValue self (QUOTE Root])
(StructuredInstanceMeta.New
[LAMBDA (class name) (* js: " 1-AUG-83 22:12")
(* creates an instance of some class that is a StructuredInstanceObject. The name parm must be specified or else
the function will do nothing and generate an error. Note that the new instance is made a root in the default link
relation.)
(COND
((NULL name)
(ERROR "An instance of StructuredInstance must be given a name."))
((MEMBER name (SEND class FetchInstanceNames))
NIL)
(T (PROG (self defaultLinks)
(SETQ self (BlankInstance class))
(SETQ defaultLinks (SEND class FetchDefaultLinks))
(* Needed to add UID for all instances
(NewEntity self))
(SEND class Initialize self) (* Install IV description)
(SEND self SetName name)
(SEND class AddInstanceName name)
(SEND self LinkUp)
(RETURN self])
(StructuredInstanceMeta.Specialize
[LAMBDA (self newName) (* js: "31-JUL-83 12:57")
(* a slight addition to the normal Specialize method:
each new class is initialized with StoargeFileName,
FilePackageComs, Root, InstanceName, and Links IV's.)
(PROG (newClass newRootName newRootObject linksFromMeta superFromMeta subFromMeta)
(SETQ linksFromMeta (GetValue ($ StructuredInstanceMeta)
(QUOTE Links)))
(SETQ newRootName (GENSYM))
(SETQ newClass (SENDSUPER self Specialize newName))
(SETQ superFromMeta (CAR linksFromMeta))
(SETQ subFromMeta (CADR linksFromMeta))
[InstallClassVariables newClass (CONS (LIST (QUOTE InstanceNames)
NIL)
(CONS (LIST (QUOTE Root)
newRootName)
(CONS (LIST (QUOTE Links)
(CONS linksFromMeta))
(CONS (LIST (QUOTE CurrentBrowsers)
NIL)
(GetSourceCVs newClass]
[InstallInstanceVariables newClass (CONS (LIST superFromMeta NIL)
(CONS (LIST subFromMeta NIL)
(GetSourceIVs newClass]
(SETQ newRootObject (BlankInstance newClass))
(SEND newClass Initialize newRootObject)
(SEND newRootObject SetName newRootName)
(SEND newClass AddInstanceName newRootName)
(RETURN newClass])
(StructuredInstanceMeta.UpDateAppropriateBrowser
[LAMBDA (self linkPair) (* js: "31-JUL-83 16:38")
(* method that looks to see if there is a browser for a
specified link and updates it if there is.)
(PROG (browser)
(SETQ browser (SEND self FetchInstanceBrowser linkPair))
(COND
(browser (SEND browser Recompute])
(StructuredInstanceMeta.UpDateBrowserList
[LAMBDA (self linkPair newValue) (* js: "31-JUL-83 16:52")
(* method to change the browser for the given relation.
Note this closes the old browser if it is active.)
(PROG (allLinks currentEntry currentBrowser allBrowsers)
(SETQ allBrowsers (GetClassValue self (QUOTE CurrentBrowsers)))
(SETQ currentEntry (SASSOC linkPair allBrowsers))
(SETQ allLinks (SEND self FetchLinks))
(SETQ currentBrowser (CADR currentEntry))
(COND
((NOT (MEMBER linkPair allLinks)) (* check to make sure linkPair is valid)
(CLRPROMPT)
(PROMPTPRINT
"The linkPair you specified for adding a New Browser does not exsist for the class."))
([AND newValue (NOT (EQ (GetObjectName (Class newValue))
(QUOTE InstanceBrowser]
(* check to make sure the new value is an
InstanceBrowser)
(CLRPROMPT)
(PROMPTPRINT
"The browser you specified for adding a New Browser is a not a valid browser."))
((AND newValue currentBrowser) (* if there is both a new browser to add and an old one
to get rid of)
(PutClassValue self (QUOTE CurrentBrowsers)
(CONS (LIST linkPair newValue)
(REMOVE (LIST linkPair currentBrowser)
allBrowsers)))
(SEND currentBrowser Close))
(newValue (* if there is a new browser to add, but no old one to
update)
(PutClassValue self (QUOTE CurrentBrowsers)
(CONS (LIST linkPair newValue)
allBrowsers)))
(currentBrowser (* if there is an old browser, but no new entry)
(PutClassValue self (QUOTE CurrentBrowsers)
(REMOVE (LIST linkPair currentBrowser)
allBrowsers))
(SEND currentBrowser Close))
(T (* if there is neither a new browser nor an old browser)
NIL])
(StructuredInstanceObject.Destroy
[LAMBDA (self) (* js: "29-JUL-83 21:50")
(* method to augment the standard Destroy from Object. Added is the removal of the object name from InstanceNames
and the splicing out of the object from all relations that it participates in.)
(PROG (allLinksUsed classSelf)
(SETQ classSelf (Class self))
(SETQ allLinksUsed (SEND classSelf FetchLinks))
(for oneLinkPair in allLinksUsed do (SEND self SpliceOut oneLinkPair))
(SEND classSelf RemoveInstanceName (GetValue self (QUOTE name)))
(SENDSUPER self Destroy])
(StructuredInstanceObject.FetchSubs
[LAMBDA (self linkPair) (* js: " 2-AUG-83 12:13")
(* method to retreive all the subs of an instance along
a given relation)
(COND
((MEMBER linkPair (SEND (Class self)
FetchLinks))
(GetValue self (CADR linkPair])
(StructuredInstanceObject.FetchSubs!
[LAMBDA (self linkPair) (* js: " 2-AUG-83 13:01")
(* New method template)
(COND
((MEMBER linkPair (SEND (Class self)
FetchLinks))
(bind ([currentObjectList ←(CONS (GetValue self (QUOTE name]
(answer ← NIL)
(currentSubLink ←(CADR linkPair))
(currentSubNames ← NIL))
while currentObjectList do [for oneCurrentObject in currentObjectList
do (SETQ currentSubNames (GetValue (APPLY (QUOTE $)
(LIST
oneCurrentObject))
currentSubLink))
(SETQ currentObjectList (REMOVE oneCurrentObject
currentObjectList))
(for oneCurrentSubName in currentSubNames
do (COND
((NOT (MEMBER oneCurrentSubName answer))
(SETQ answer (CONS oneCurrentSubName answer))
(SETQ currentObjectList (CONS oneCurrentSubName
currentObjectList]
finally (RETURN answer])
(StructuredInstanceObject.FetchSupers
[LAMBDA (self linkPair) (* js: " 2-AUG-83 13:28")
(* method to fetch all the supers of self along the specified relation. Note that the root instance, if it is an
immediate super to self, will be returned as a member of the list.)
(COND
((MEMBER linkPair (SEND (Class self)
FetchLinks))
(GetValue self (CAR linkPair])
(StructuredInstanceObject.FetchSupers!
[LAMBDA (self linkPair) (* js: " 2-AUG-83 13:26")
(* method to recursively fetch all the supers of self along a specified Note that the root instance will be
returned as a member of list.)
(COND
((MEMBER linkPair (SEND (Class self)
FetchLinks))
(bind ([currentObjectList ←(CONS (GetValue self (QUOTE name]
(answer ← NIL)
(currentSuperLink ←(CAR linkPair))
(currentSuperNames ← NIL))
while currentObjectList do [for oneCurrentObject in currentObjectList
do (SETQ currentSuperNames (GetValue (APPLY (QUOTE $)
(LIST
oneCurrentObject))
currentSuperLink))
(SETQ currentObjectList (REMOVE oneCurrentObject
currentObjectList))
(for oneCurrentSuperName in currentSuperNames
do (COND
((NOT (MEMBER oneCurrentSuperName answer))
(SETQ answer (CONS oneCurrentSuperName answer))
(SETQ currentObjectList (CONS
oneCurrentSuperName
currentObjectList]
finally (RETURN answer])
(StructuredInstanceObject.LinkDown
[LAMBDA (self linkPair subObjectName) (* js: " 1-AUG-83 21:46")
(* method to link to an already defined sub along some sublink. Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
(PROG (selfName allLinks allInstanceNames superLink subLink subObject defaultLinks classSelf)
(COND
(subObjectName (SETQ classSelf (Class self))
(SETQ allInstanceNames (SEND classSelf FetchInstanceNames))
(SETQ allLinks (SEND classSelf FetchLinks))
(SETQ defaultLinks (SEND classSelf FetchDefaultLinks))
(SETQ selfName (GetValue self (QUOTE name)))
[COND
((NULL linkPair)
(SETQ superLink (CAR defaultLinks))
(SETQ subLink (CADR defaultLinks)))
(T (SETQ superLink (CAR linkPair))
(SETQ subLink (CADR linkPair]
(COND
((OR [NULL (SETQ subObject (APPLY (QUOTE $)
(LIST subObjectName]
(EQ (GetValue self (QUOTE name))
subObjectName)
(NOT (MEMBER subObjectName allInstanceNames)))
(ERROR "Botch up in LinkDown.")))
(COND
((NOT (EQ selfName subObjectName))
[PutValue subObject superLink (CONS selfName (REMOVE selfName
(GetValue
subObject
superLink]
(PutValue self subLink (CONS subObjectName (REMOVE subObjectName
(GetValue self
subLink])
(StructuredInstanceObject.LinkUp
[LAMBDA (self linkPair superObjectName) (* js: " 1-AUG-83 21:47")
(* method to link to an already defined super along some superLink Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
(PROG (selfName allLinks allInstanceNames superLink subLink superObject defaultLinks classSelf
instanceRoot)
(SETQ classSelf (Class self))
(SETQ allInstanceNames (SEND classSelf FetchInstanceNames))
(SETQ allLinks (SEND classSelf FetchLinks))
(SETQ defaultLinks (SEND classSelf FetchDefaultLinks))
(SETQ selfName (GetValue self (QUOTE name)))
(SETQ instanceRoot (SEND classSelf FetchRoot))
[COND
((NULL linkPair)
(SETQ superLink (CAR defaultLinks))
(SETQ subLink (CADR defaultLinks)))
(T (SETQ superLink (CAR linkPair))
(SETQ subLink (CADR linkPair]
(COND
((NULL superObjectName)
(SETQ superObjectName instanceRoot)))
(COND
((OR [NULL (SETQ superObject (APPLY (QUOTE $)
(LIST superObjectName]
(EQ (GetValue self (QUOTE name))
superObjectName)
(NOT (MEMBER superObjectName allInstanceNames)))
(ERROR "Botch up in LinkUp.")))
(COND
((NOT (EQ superObjectName selfName))
[PutValue superObject subLink (CONS selfName (REMOVE selfName (GetValue superObject
subLink]
(PutValue self superLink (CONS superObjectName (REMOVE superObjectName
(GetValue self superLink])
(StructuredInstanceObject.Rename
[LAMBDA (self newName linkPair) (* js: " 1-AUG-83 21:51")
(* this method renames self by changing all superObject/subLink names, all subObject/superLink names, the instance
IV InstanceNames at the class level, and by changing the name IV in self.)
(PROG (selfName classSelf)
(SETQ classSelf (Class self))
(selfName (GetValue self (QUOTE name)))
[for oneLinkPair in (SEND classSelf FetchLinks)
do (PROG (allSupers allSubs superLink subLink)
(SETQ subLink (CADR oneLinkPair))
(SETQ superLink (CAR oneLinkPair))
(SETQ allSupers (GetValue self superLink))
(SETQ allSubs (GetValue self subLink))
[for oneSubName in allSubs do (PROG (loopsNameOneSub)
(SETQ loopsNameOneSub (APPLY (QUOTE $)
(LIST
oneSubName)))
(PutValue loopsNameOneSub superLink
(CONS newName
(REMOVE selfName
(GetValue
loopsNameOneSub
superLink]
(for oneSuperName in allSupers
do (PROG (loopsNameOneSuper)
(SETQ loopsNameOneSuper (APPLY (QUOTE $)
(LIST oneSuperName)))
(PutValue loopsNameOneSuper subLink (CONS newName
(REMOVE selfName
(GetValue
loopsNameOneSuper
subLink]
(SEND classSelf AddInstanceName newName)
(SEND classSelf DeleteInstanceName selfName)
(PutValue self (QUOTE name)
newName])
(StructuredInstanceObject.UnLinkDown
[LAMBDA (self linkPair subObjectName) (* js: " 1-AUG-83 21:53")
(* method to unlink to an already defined sub along some sublink. Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
(PROG (selfName allLinks allInstanceNames superLink subLink subObject defaultLinks classSelf)
(COND
(subObjectName (SETQ classSelf (Class self))
(SETQ allInstanceNames (SEND classSelf FetchInstanceNames))
(SETQ allLinks (SEND classSelf FetchLinks))
(SETQ defaultLinks (SEND classSelf FetchDefaultLinks))
(SETQ selfName (GetValue self (QUOTE name)))
[COND
((NULL linkPair)
(SETQ superLink (CAR defaultLinks))
(SETQ subLink (CADR defaultLinks)))
(T (SETQ superLink (CAR linkPair))
(SETQ subLink (CADR linkPair]
(COND
((OR [NULL (SETQ subObject (APPLY (QUOTE $)
(LIST subObjectName]
(EQ (GetValue self (QUOTE name))
subObjectName)
(NOT (MEMBER subObjectName allInstanceNames)))
(ERROR "Botch up in UnLinkDown.")))
(PutValue subObject superLink (REMOVE selfName (GetValue subObject
superLink)))
(PutValue self subLink (REMOVE subObjectName (GetValue self subLink])
(StructuredInstanceObject.UnLinkUp
[LAMBDA (self linkPair superObjectName) (* js: " 1-AUG-83 21:53")
(* method to link to an already defined super along some superLink Also makes the upward backlink.
If the argument subLink is NIL, a default is taken from the IV Links in StructuredInstanceMeta.)
(PROG (selfName allLinks allInstanceNames superLink subLink superObject defaultLinks classSelf)
(SETQ classSelf (Class self))
(SETQ allInstanceNames (SEND classSelf FetchInstanceNames))
(SETQ allLinks (SEND classSelf FetchLinks))
(SETQ defaultLinks (SEND classSelf FetchDefaultLinks))
(SETQ selfName (GetValue self (QUOTE name)))
[COND
((NULL linkPair)
(SETQ superLink (CAR defaultLinks))
(SETQ subLink (CADR defaultLinks)))
(T (SETQ superLink (CAR linkPair))
(SETQ subLink (CADR linkPair]
[COND
((NULL superObjectName)
(SETQ superObjectName (SEND classSelf FetchRoot]
(COND
((OR [NULL (SETQ superObject (APPLY (QUOTE $)
(LIST superObjectName]
(EQ (GetValue self (QUOTE name))
superObjectName)
(NOT (MEMBER superObjectName allInstanceNames)))
(ERROR "Botch up in UnLinkUp.")))
(PutValue superObject subLink (REMOVE selfName (GetValue superObject subLink)))
(PutValue self superLink (REMOVE superObjectName (GetValue self superLink])
(StructuredInstanceObjectClassBrowser.AddInstanceLink
[LAMBDA (self object objectName) (* js: "29-JUL-83 21:10")
(* method to add a new super/sub link pair for a
StructuredInstanceObject.)
(COND
((MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers)))
(PROG (newSuperLinkName newSubLinkName)
(SETQ newSuperLinkName (PromptRead
"What is the name of the super for the new link pair?"))
(SETQ newSubLinkName (PromptRead "what is the name of the sub for the new Link pair?"))
(SEND object AddLink (LIST newSuperLinkName newSubLinkName))
(CLRPROMPT)
(PROMPTPRINT "OK. All done adding the new instance.")))
(T (CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but " objectName
" is not a StructuredInstanceObject. I cannot add link pairs for it."])
(StructuredInstanceObjectClassBrowser.BrowseInstances
[LAMBDA (self object objectName) (* js: " 1-AUG-83 13:53")
(* method to create an instance browser for any
StructuredInstanceObject.)
(COND
[(MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers)))
(PROG (interactiveStartingObject)
(SETQ interactiveStartingObject (PromptRead
"Enter the starting Object you want, ] for browsing from the top."))
(COND
([AND (NOT (ATOM interactiveStartingObject))
(NOT (NULL (CDR interactiveStartingObject]
(CLRPROMPT)
(PROMPTPRINT "Sorry, but you can only browse from one root.")
(RETURN))
(T (SEND object BrowseInstances interactiveStartingObject]
(T (CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but " objectName
" is not a StructuredInstanceObject. I cannot make an instance browser for it."])
(StructuredInstanceObjectClassBrowser.CreateNewInstance
[LAMBDA (self object objectName) (* js: " 2-AUG-83 01:10")
(* a slight modification to the New method used for
StructuredInstanceObjects. Prompts the user for a name
for the new instance.)
(COND
[(MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers)))
(PROG (newInstanceName)
(SETQ newInstanceName (PromptRead "What is the name of the new instance?"))
(COND
[newInstanceName (SEND object New newInstanceName)
(PROMPTPRINT "OK. I'm done")
(PROG (browser defaultLinks)
(SETQ defaultLinks (SEND object FetchDefaultLinks))
(SETQ browser (SEND object FetchInstanceBrowser defaultLinks))
(COND
([AND browser (EQUAL (GetValue browser (QUOTE
SupersObjectList))
(CONS (SEND object FetchRoot]
[PutValue browser (QUOTE startingList)
(CONS newInstanceName (GetValue browser
(QUOTE
startingList]
(SEND browser Recompute]
(T (CLRPROMPT)
(PROMPTPRINT
"Sorry, but an instance of a StructuredInstanceObject must be given a name."]
(T (SEND object New)
(PROMPPRINT "OK. I'm done"])
(StructuredInstanceObjectClassBrowser.SaveClassAndInstances
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:43")
(* method to save a class and instances.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveClassAndInstances])
(StructuredInstanceObjectClassBrowser.SaveClassAndInstances!
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:43")
(* method to save recursively defined class and
instances. Note checking is done to make sure the object
is a StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveClassAndInstances!])
(StructuredInstanceObjectClassBrowser.SaveClassOnly
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:43")
(* method to save a class only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveClassOnly])
(StructuredInstanceObjectClassBrowser.SaveClassOnly!
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:43")
(* method to save a recursively defined class only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveClassOnly!])
(StructuredInstanceObjectClassBrowser.SaveInstancesOnly
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:44")
(* method to save class instances only.
Note checking is done to make sure the object is a
StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveInstancesOnly])
(StructuredInstanceObjectClassBrowser.SaveInstancesOnly!
[LAMBDA (self object objectName) (* js: "27-JUL-83 14:44")
(* method to save the recursively definned instances
only. Note checking is done to make sure the object is a
StructuredInstanceObject.)
(COND
([NOT (MEMBER (QUOTE StructuredInstanceObject)
(SEND object List!(QUOTE supers]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Sorry, but since " objectName
" is not a StrucutredInstanceObject, I don't know how to store it.")))
(T (SEND object SaveInsatncesOnly!])
(InstanceBrowser.AddRoot
[LAMBDA (self) (* js: " 2-AUG-83 00:36")
(* method to add a new root to the InstanceBrowser. Note that this method add a root both for the current relation
AND for the default relation if the instance is new to the class. If it is not new to the class, then only added
for the current relation.)
(PROG (currentSuperLink currentSubLink currentLinkPair browsingClass rootName rootObject
startingList supersObjectList)
(SETQ currentSuperLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ currentSubLink (GetValue self (QUOTE FollowLink)))
(SETQ currentLinkPair (LIST currentSuperLink currentSubLink))
(SETQ browsingClass (GetValue self (QUOTE BrowsingClass)))
(COND
((EQUAL currentLinkPair (SEND browsingClass FetchDefaultLinks))
(CLRPROMPT)
(PROMPTPRINT
"If you want to add a root in the default relation, then do it from the class command.")
(RETURN)))
(SETQ rootName (PromptRead "enter the name of the root"))
[SETQ rootObject (OR (SEND browsingClass New rootName)
(APPLY (QUOTE $)
(LIST rootName]
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(COND
((NOT (NULL (GetValue rootObject currentSuperLink)))
(CLRPROMPT)
(PROMPTPRINT "The root you want to add is already in this relation."))
(T (for oneSuper in supersObjectList do (SEND rootObject LinkUp currentLinkPair oneSuper))
(PutValue self (QUOTE startingList)
(CONS rootName startingList))
(SEND self Recompute])
(InstanceBrowser.DefineSubclass
[LAMBDA (self object objName) (* js: "13-JUL-83 13:46")
(* Define a new subclass, giving it a name typed in by
user)
(PROG (newInstanceName)
(COND
((CLRPROMPT)
(SETQ newInstanceName (PromptRead "Enter the name of the new Instance."))
(← object Specialize className)
(← self Recompute])
(InstanceBrowser.DestroyThisRelation
[LAMBDA (self) (* js: "27-JUL-83 23:39")
(* method to destroy the current relation, remove the link from the class, and destroy any instances that take
part in this relation and no others)
self])
(InstanceBrowser.GatherBoxedNodes
[LAMBDA (self promptString) (* js: "28-JUL-83 14:27")
(* this method allows the user to interactively choose a set of nodes for some operation. The IV
SpecialButtonActionMode is set to GatherBoxedNodes to indicate special action for both left button and middle
button. In this mode, the left button adds nodes to the list, the middle button deletes nodes from the list.)
(PROG NIL
(PutValue self (QUOTE SpecialButtonActionMode)
(QUOTE GatherBoxedNodeList))
(PutValue self (QUOTE GatheredBoxedNodeList)
NIL)
(PromptRead (CONCAT promptString
" Left Button adds items; Middle Button deletes items. Press ] when done."))
(PutValue self (QUOTE SpecialButtonActionMode)
NIL)
(RETURN (for oneObject in (GetValue self (QUOTE GatheredBoxedNodeList))
collect (SEND self FlipNode oneObject)
(GetValue oneObject (QUOTE name))
WHEN oneObject])
(InstanceBrowser.GetIV
[LAMBDA (self object objectName) (* js: "25-JUL-83 23:50")
(* gets an IV in the selected instance that is the IV
named in IVofInterest.)
(PROG ((IVofInterest (GetValue self (QUOTE IVofInterest)))
value)
(COND
((NULL IVofInterest)
(CLRPROMPT)
(PROMPTPRINT
"You must first set the IVofInterest by using the title function of that name."))
(T (SETQ value (GetValue object IVofInterest))
(printout NIL T T "The current value for " IVofInterest " from " objectName " is "
value "." T T])
(InstanceBrowser.GetSubs
[LAMBDA (self elt) (* edited: "11-JUL-83 22:56")
(* returns the list of objects which are "subs" of "elt" using the value of IV "subLinks" in the browser to
determine the links to be used)
(PROG (Subs)
(SETQ elt (GetObjectRec elt))
(for x in (MKLIST (@ FollowLink)) do (SETQ Subs (APPEND (GetValue elt x)
Subs)))
(RETURN (MAPCAR Subs (QUOTE (LAMBDA (X)
(GetObjectRec X])
(InstanceBrowser.InitializeWithAll
[LAMBDA (self) (* js: " 2-AUG-83 00:58")
(* this method sets every instance in the class that is in the super/sub relation (or whatever is currently the
default link as set in StructuredInstanceMeta) to a root in the current browser. If instance is already in the
browser, it will not be added.)
(PROG (superLink subLink linkPair browsingClass allInstances startingList supersObjectList)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ browsingClass (GetValue self (QUOTE BrowsingClass)))
(COND
((EQUAL linkPair (SEND browsingClass FetchDefaultLinks))
(CLRPROMPT)
(PROMPTPRINT "InitializeWithAll is not to be used from the default relation.")
(RETURN)))
(SETQ allInstances (SEND browsingClass FetchInstanceNames))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(for oneInstance in (REMOVE (SEND browsingClass FetchRoot)
allInstances)
bind (oneObject objectsToAddToStartingList)
do [COND
((NULL (GetValue (SETQ oneObject (APPLY (QUOTE $)
(LIST oneInstance)))
superLink))
(for oneSuper in supersObjectList do (SEND oneObject LinkUp linkPair oneSuper))
(SETQ objectsToAddToStartingList (CONS oneInstance objectsToAddToStartingList]
finally (PutValue self (QUOTE startingList)
(APPEND objectsToAddToStartingList startingList)))
(SEND self Recompute])
(InstanceBrowser.LeftSelection
[LAMBDA (self) (* js: "27-JUL-83 12:56")
(* this method allows special use of the left and middle mouse buttons. The action taken depends on the value of
the IV SpecialButtonActionMode. If NIL, then normal mouse functions are in operation. If equal to
GatherBoxedNodeList, then opertions is: left button = add item to list maintained in IV GatheredBoxedNodeList,
middle button = delete item from that list.)
(PROG ((window (GetValue self (QUOTE window)))
(operationMode (GetValue self (QUOTE SpecialButtonActionMode)))
object)
(COND
((NULL operationMode)
(SENDSUPER self LeftSelection))
[(EQ operationMode (QUOTE GatherBoxedNodeList))
(SETQ object (FindSelectedNode window))
(COND
([NOT (MEMBER object (GetValue self (QUOTE GatheredBoxedNodeList]
(SEND self FlipNode object)
(PutValue self (QUOTE GatheredBoxedNodeList)
(CONS object (GetValue self (QUOTE GatheredBoxedNodeList]
(T (printout NIL T "Something has gone wrong!!!" T
" The middle select function is being invoked from InstanceBrowser to supers but the problem is that some unexpected value is found in SpecialButtonActionMode."
T " Please check this out." T T)
(SENDSUPER self LeftSelection])
(InstanceBrowser.LinkDown
[LAMBDA (self object objectName) (* js: " 2-AUG-83 15:36")
(* links the current object to a list of interactively
determined other instances along the current subsLink.)
(PROG (superLink subLink linkPair subsFromUser supersObjectList startingList)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SEND self BoxNode object)
(SETQ subsFromUser (SEND self GatherBoxedNodes "Box the instances you want for subs. "))
(SEND self BoxNode object)
(COND
((NULL subsFromUser)
(CLRPROMPT)
(PROMPTPRINT "You didn't choose any instances to link up.")
(RETURN))
((INTERSECTION subsFromUser (SEND object FetchSupers! linkPair))
(CLRPROMPT)
(PROMPTPRINT
"LinkDown on your list of subs would make a circularity in the instance lattice.")
(RETURN)))
[for oneSub in subsFromUser
do (SEND object LinkDown linkPair oneSub)
(COND
((MEMBER oneSub startingList)
(PutValue self (QUOTE startingList)
(REMOVE oneSub startingList))
(for oneSuper in supersObjectList do (SEND (APPLY (QUOTE $)
(LIST oneSub))
UnLinkUp linkPair oneSuper]
(SEND self Recompute])
(InstanceBrowser.LinkUp
[LAMBDA (self object objectName) (* js: " 2-AUG-83 15:39")
(* links object to the current boxed node along the
current supersLink)
(PROG (superLink subLink linkPair supersFromUser startingList supersObjectList)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SEND self BoxNode object)
(SETQ supersFromUser (SEND self GatherBoxedNodes
"Button the instances you want to link up to."))
(SEND self BoxNode object)
(COND
((NULL supersFromUser)
(CLRPROMPT)
(PROMPTPRINT "You didn't choose any instance to link up.")
(RETURN))
((INTERSECTION supersFromUser (SEND object FetchSubs! linkPair))
(CLRPROMPT)
(PROMPTPRINT
"LinkUp on your list of supers would cause a circularity in the browser lattice.")
(RETURN)))
(for oneSuper in supersFromUser do (SEND object LinkUp linkPair oneSuper))
[COND
((MEMBER objectName startingList)
(PutValue self (QUOTE startingList)
(REMOVE objectName startingList))
(for oneSuper in supersObjectList do (SEND object UnLinkUp linkPair oneSuper]
(SEND self Recompute])
(InstanceBrowser.MiddleSelection
[LAMBDA (self) (* js: "27-JUL-83 16:17")
(* this method allows special use of the left and middle mouse buttons. The action taken depends on the value of
the IV SpecialButtonActionMode. If NIL, then normal mouse functions are in operation. If equal to
GatherBoxedNodeList, then opertions is: left button = add item to list maintained in IV GatheredBoxedNodeList,
middle button = delete item from that list.)
(PROG ((window (GetValue self (QUOTE window)))
(operationMode (GetValue self (QUOTE SpecialButtonActionMode)))
object)
(COND
((NULL operationMode)
(SENDSUPER self MiddleSelection))
[(EQ operationMode (QUOTE GatherBoxedNodeList))
(SETQ object (FindSelectedNode window))
(COND
((MEMBER object (GetValue self (QUOTE GatheredBoxedNodeList)))
(SEND self FlipNode object)
(PutValue self (QUOTE GatheredBoxedNodeList)
(REMOVE object (GetValue self (QUOTE GatheredBoxedNodeList]
(T (printout NIL T "Something has gone wrong!!!" T
" The middle select function is being invoked from InstanceBrowser to supers but the problem is that some unexpected value is found in SpecialButtonActionMode."
T " Please check this out." T T)
(SENDSUPER self MiddleSelection])
(InstanceBrowser.MoveInstance
[LAMBDA (self object objectName) (* js: " 2-AUG-83 17:18")
(* method to move an instance from one place in the lattice to another. After removing from one location, the old
supers and subs are spliced together. The new splice in location is found by interactively boxing two nodes that
are currently dirrectly linked. If no node is boxed for the super, the old instance becomes a new root.
If no node is boxed for the sub, the old instance becomes a simple subinstance of the boxed super.)
(PROG (superLink subLink linkPair startingList supersObjectList supersFromUser subsFromUser
oldSuperLinks oldSubLinks allSupersOfSupersFromUser)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SEND self BoxNode object)
(SETQ supersFromUser (SEND self GatherBoxedNodes "Box a super. "))
(SETQ subsFromUser (SEND self GatherBoxedNodes "Box a sub. "))
(SEND self BoxNode object)
[SETQ allSupersOfSupersFromUser (APPLY (QUOTE UNION)
(for oneSuper in supersFromUser
collect (SEND (APPLY (QUOTE $)
(LIST oneSuper))
FetchSupers! linkPair]
(COND
((OR (INTERSECTION supersFromUser subsFromUser)
(INTERSECTION subsFromUser allSupersOfSupersFromUser))
(CLRPROMPT)
(PROMPTPRINT
"The supers and subs lists as you entered them would cause a circularity in the instance lattice.")
(RETURN)))
[COND
((AND (NULL supersFromUser)
(MEMBER objectName startingList))
(SETQ supersFromUser supersObjectList))
((MEMBER objectName startingList)
(PutValue self (QUOTE startingList)
(REMOVE objectName startingList)))
((NULL supersFromUser)
(SETQ supersFromUser supersObjectList)
(PutValue self (QUOTE startingList)
(CONS objectName startingList]
(SETQ oldSuperLinks (GetValue object superLink))
(SETQ oldSubLinks (GetValue object subLink))
(for oneOldSuper in oldSuperLinks do (SEND object UnLinkUp linkPair oneOldSuper))
(for oneOldSub in oldSubLinks do (SEND object UnLinkDown linkPair oneOldSub))
[for oneOldSuper in oldSuperLinks do (for oneOldSub in oldSubLinks
do (COND
((OR (NOT (MEMBER oneOldSub subsFromUser))
(NOT (MEMBER oneOldSuper supersFromUser)))
(SEND (APPLY (QUOTE $)
(LIST oneOldSub))
LinkUp linkPair oneOldSuper]
(for oneNewSuper in supersFromUser do (SEND object LinkUp linkPair oneNewSuper))
(for oneNewSub in subsFromUser do (SEND object LinkDown linkPair oneNewSub))
(SEND self Recompute])
(InstanceBrowser.MoveSubTree
[LAMBDA (self object objectName) (* js: " 2-AUG-83 02:18")
(* method which moves an entire subtree to a new
location in the lattice.)
(PROG (superLink subLink linkPair startingList supersObjectList newSuperObjectList)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SEND self BoxNode object)
(SETQ newSuperObjectList (SEND self GatherBoxedNodes "Box a super. "))
(SEND self BoxNode object)
[COND
((AND (NULL newSuperObjectList)
(MEMBER objectName startingList))
(CLRPROMPT)
(PROMPTPRINT "Your move would not change anything.")
(RETURN))
((NULL newSuperObjectList)
(SETQ newSuperObjectList supersObjectList)
(PutValue self (QUOTE startingList)
(CONS objectName startingList)))
((MEMBER objectName startingList)
(PutValue self (QUOTE startingList)
(REMOVE objectName startingList]
(for oneSuper in (GetValue object superLink) do (SEND object UnLinkUp linkPair oneSuper))
(for oneSuper in newSuperObjectList do (SEND object LinkUp linkPair oneSuper))
(SEND self Recompute])
(InstanceBrowser.Recompute
[LAMBDA (self) (* js: "31-JUL-83 12:41")
(* inherits Recompute from Super if there is a non-null
starting list.)
(COND
((GetValue self (QUOTE startingList))
(←Super
self Recompute])
(InstanceBrowser.RemoveInstanceFromRelation
[LAMBDA (self object objectName) (* js: " 2-AUG-83 14:14")
(* method to kill an instance.
The instance is destroyed only in relation to the
displayed link, it is still alive in the class.)
(PROG (superLink subLink linkPair startingList supersObjectList currentSupers currentSubs)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ superObjectList (GetValue self (QUOTE SupersObjectList)))
(SETQ currentSupers (GetValue object superLink))
(SETQ currentSubs (GetValue object subLink))
(COND
((EQUAL linkPair (SEND (Class object)
FetchDefaultLinks))
(CLRPROMPT)
(PROMPTPRINT "You cannot remove an instance from the default relation.")
(RETURN)))
(for oneSuper in currentSupers do (SEND object UnLinkUp linkPair oneSuper))
(for oneSub in currentSubs do (SEND object UnLinkDown linkPair oneSub))
(for oneSuper in currentSupers do (for oneSub in currentSubs
do (SEND (APPLY (QUOTE $)
(LIST oneSub))
LinkUp linkPair oneSuper)))
[COND
((MEMBER objectName startingList)
(for oneSub in currentSubs
do (SETQ startingList (CONS oneSub startingList))
(for oneSuper in supersObjectList do (SEND (APPLY (QUOTE $)
(LIST oneSuper))
LinkDown linkPair oneSub)))
(PutValue self (QUOTE startingList)
(REMOVE objectName startingList]
(SEND self Recompute])
(InstanceBrowser.Rename
[LAMBDA (self object objectName) (* js: "26-JUL-83 22:49")
(* method to rename an instance. The instance name is interactively entered, and once changed, is altered for use
no matter where in the class.)
(PROG (newName (startingList (GetValue self (QUOTE startingList)))
(allNames (SEND object FetchInstanceNames)))
(SEND self FlipNode object)
(SETQ newName (PromptRead "What is the name you want the instance to have?"))
(SEND self FlipNode object)
(COND
((MEMBER newName allNames)
(CLRPROMPT)
(PROMPTPRINT "The name you choose is already used in the class."))
(T [COND
((MEMBER newName startingList)
(PutValue self (QUOTE startingList)
(CONS newName (REMOVE objectName startingList]
(SEND object Rename newName)
[PROG [(currentStartingList (GetValue self (QUOTE startingList]
(COND
((MEMBER objectName currentStartingList)
(PutValue self (QUOTE startingList)
(CONS newName (REMOVE objectName currentStartingList]
(SEND self Recompute])
(InstanceBrowser.SetIV
[LAMBDA (self object objectName) (* js: "25-JUL-83 23:48")
(* sets an IV in the selected instance that is the IV
named in IVofInterest.)
(PROG ((IVofInterest (GetValue self (QUOTE IVofInterest)))
newVal oldVal)
(COND
((NULL IVofInterest)
(CLRPROMPT)
(PROMPTPRINT
"You must first set the IVofInterest by using the title function of that name."))
(T (SEND self FlipNode object)
(SETQ oldVal (GetValue object IVofInterest))
(printout NIL T T "Old value for " IVofInterest " in " objectName " is " oldVal "." T
T)
(SETQ newVal (PromptRead (CONCAT "What is the new value for " IVofInterest "?")))
(SEND self FlipNode object)
(PutValue object IVofInterest newVal)
(CLRPROMPT)
(PROMPTPRINT (CONCAT "OK. The change is made for " objectName "."])
(InstanceBrowser.SetIVofInterest
[LAMBDA (self) (* js: "25-JUL-83 23:38")
(* title function to set the InstanceBrowser IV,
IVofInterest. It is used in the left button methods
SetIV and GetIV.)
(PROG [(newIVofInterest (PromptRead "What IV do you want to make 'ofInterest?"))
(browsingClass (GetValue self (QUOTE BrowsingClass]
(COND
((SEND browsingClass HasIV newIVofInterest)
(PutValue self (QUOTE IVofInterest)
newIVofInterest))
(T (PROMPTPRINT (CONCAT "Sorry, but " browsingClass " has no IV named " newIVofInterest
"."])
(InstanceBrowser.Show
[LAMBDA (self browseList windowOrTitle goodList) (* js: "21-JUL-83 22:06")
(* * 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 FollowLink)
(SETQ FollowLink (GetValue self (QUOTE FollowLink)))
(PutValue self (QUOTE title)
(CONCAT "Instance Browser Along Link " (MKSTRING FollowLink)))
(←@
startingList browseList)
(COND
((AND windowOrTitle (NOT (WINDOWP windowOrTitle)))
(←@
title windowOrTitle)))
[COND
((NOT (LISTP browseList))
(SETQ browseList (LIST browseList]
(SETQ NODELST (← self GetNodeList browseList goodList))
(SETQ window (SHOWGRAPH (LAYOUTLATTICE NODELST (SETQ roots (TreeRoots NODELST))
NIL
(@ browseFont))
(OR windowOrTitle (@ title))
NIL NIL (@ topAlign)))
(WINDOWPROP window (QUOTE BUTTONEVENTFN)
(QUOTE WindowButtonEventFn))
(WINDOWPROP window (QUOTE LoopsWindow)
self)
(←@
window window)
(RETURN window])
(InstanceBrowser.Spawn
[LAMBDA (self object objectName) (* js: " 2-AUG-83 03:40")
(* creates a new browser with the current object as its
root. User determines the relation followed in the new
browser.)
(PROG (objectClass allLinks subSelectionMenu followLink reverseFollowLink newLinkPair)
(SETQ objectClass (GetValue self (QUOTE BrowsingClass)))
(SETQ allLinks (SEND objectClass FetchLinks))
[SETQ subSelectionMenu (create MENU
ITEMS ←(for onePair in allLinks collect (CADR onePair]
(CLRPROMPT)
(PROMPTPRINT (CONCAT "Choose the chase sub you want. Current default is "
(CADR (SEND objectClass FetchDefaultLinks))
"."))
(SETQ followLink (MENU subSelectionMenu))
(CLRPROMPT)
(SETQ reverseFollowLink (for onePair in allLinks bind (answer) do (SETQ answer
(CAR onePair))
when (EQ (CADR onePair)
followLink)
finally (RETURN answer)))
(SETQ newLinkPair (LIST reverseFollowLink followLink))
(SEND objectClass BrowseInstances (CONS objectName)
newLinkPair])
(InstanceBrowser.Specialize
[LAMBDA (self) (* js: "13-JUL-83 13:30")
(* New method template)
self])
(InstanceBrowser.SpecializeInstance
[LAMBDA (self object objectName) (* js: "23-JUL-83 19:41")
(* method to LinkUp some instance to the instance that has been buttoned along the FollowLink.
If the name of the LinkUp instance is not known, a new instance is created.)
(PROG ([superLink (SEND object GetSuperLinkFromSubLink (GetValue self (QUOTE FollowLink]
(specializationName (PromptRead "enter the name of the specialization instance")))
(COND
((MEMBER specializationName (GetValue object (QUOTE InstanceNames)))
(SEND (APPLY (QUOTE $)
(LIST specializationName))
LinkUp superLink objectName)
(SEND self Recompute))
(T (PROG ((newObject (SEND (GetValue self (QUOTE BrowsingClass))
New specializationName)))
(SEND newObject LinkUp superLink objectName)
(SEND self Recompute])
(InstanceBrowser.SpliceNewInstance
[LAMBDA (self) (* js: "25-JUL-83 15:20")
(* method to create a new instance and splice it into
the exsiting lattice)
(PROG ((superLink (GetValue self (QUOTE ReverseFollowLink)))
(subLink (GetValue self (QUOTE FollowLink)))
(object (SEND (GetValue self (QUOTE BrowsingClass))
New
(PromptRead "What is the name of your new instance?")))
superObjectList subObjectList)
(SEND object LinkUp superLink)
(SEND self Recompute)
(SEND self BoxNode object)
(SETQ superObjectList (SEND self GatherBoxedNodes "Box a super. "))
(SETQ subObjectList (SEND self GatherBoxedNodes "Box a sub. "))
(SEND self BoxNode object)
(SEND object SpliceInOld superObjectList subObjectList superLink subLink)
(SEND self Recompute])
(InstanceBrowser.TotallyDestroyInstance
[LAMBDA (self object objectName) (* js: "27-JUL-83 22:39")
(* method to kill an instance.
The instance is destroyed only in relation to the
displayed link, it is still alive in the class.)
(PROG [(allInstanceBrowsers (GetClassValue (Class object)
(QUOTE CurrentBrowsers]
[for oneOtherInstanceBrowser in allInstanceBrowsers bind (browser currentBrowserSuperLink)
do (SETQ browser (CADR oneOtherInstanceBrowser))
(SETQ currentBrowserSuperLink (CAAR oneOtherInstanceBrowser))
(COND
([AND (NOT (NULL (GetValue object currentBrowserSuperLink)))
(ACTIVEWP (GetValue browser (QUOTE window]
(SEND browser RemoveInstanceFromRelation object objectName]
(SEND object Destroy])
(InstanceBrowser.UnLinkDown
[LAMBDA (self object objectName) (* js: " 2-AUG-83 01:56")
(* unlinks the current object to a list of interactively
determined other instances along the current subsLink.)
(PROG (subLink superLink linkPair subsFromUser startingList supersObjectList oneSubObject)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SEND self BoxNode object)
(SETQ subsFromUser (SEND self GatherBoxedNodes
"Box the instances you want to delete as subs. "))
(SEND self BoxNode object)
(COND
((NULL subsFromUser)
(CLRPROMPT)
(PROMPTPRINT "You didn't choose any instances to unlink from.")
(RETURN)))
[for oneSub in subsFromUser
do (SEND object UnLinkDown linkPair oneSub)
(SETQ oneSubObject (APPLY (QUOTE $)
(LIST oneSub)))
(COND
((NULL (GetValue oneSubObject superLink))
(PutValue self (QUOTE startingList)
(CONS oneSub startingList))
(for oneSuper in supersObjectList do (SEND oneSubObject LinkUp linkPair oneSuper]
(SEND self Recompute])
(InstanceBrowser.UnLinkUp
[LAMBDA (self object objectName) (* js: " 2-AUG-83 01:55")
(* unlinks the current object to a list of interactively
determined other instances along the current supersLink)
(PROG (subLink superLink linkPair supersFromUser startingList supersObjectList)
(SETQ superLink (GetValue self (QUOTE ReverseFollowLink)))
(SETQ subLink (GetValue self (QUOTE FollowLink)))
(SETQ linkPair (LIST superLink subLink))
(SETQ startingList (GetValue self (QUOTE startingList)))
(SETQ supersObjectList (GetValue self (QUOTE SupersObjectList)))
(SEND self BoxNode object)
(SETQ supersFromUser (SEND self GatherBoxedNodes
"Box the instances you want to delete as supers. "))
(SEND self BoxNode object)
(COND
((NULL supersFromUser)
(CLRPROMPT)
(PROMPTPRINT "You didn't choose any instances to unlink from.")
(RETURN)))
(for oneSuper in supersFromUser do (SEND object UnLinkUp linkPair oneSuper))
[COND
((NULL (GetValue object superLink))
(PutValue self (QUOTE startingList)
(CONS objectName startingList))
(for oneSuper in supersObjectList do (SEND object LinkUp linkPair oneSuper]
(SEND self Recompute])
(InstanceBrowser.Unread
[LAMBDA (self object objName) (* js: "24-JUL-83 17:17")
(* Unread name into system buffer)
(BKSYSBUF (CONCAT "$" objName])
(PromptRead
[LAMBDA (promptString) (* js: "23-JUL-83 21:23")
(* Printout promptString in promptwindow and return
value of expression read there)
(PROG (NEWVALUE)
[RESETLST (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW))
(RESETSAVE (TTY.PROCESS (THIS.PROCESS)))
(CLRPROMPT)
(RESETSAVE (PRINTLEVEL 4 3))
(printout T promptString T "> ")
(PromptWindowBlink)
(CLEARBUF T T) (* clear tty buffer because it sometimes has stuff
left.)
(SETQ NEWVALUE (CAR (ERSETQ (LISPXREAD T T]
(RETURN NEWVALUE])
(PromptWindowBlink
[LAMBDA NIL (* js: "24-JUL-83 23:58")
(* Turn Window inverted, dismiss for 200, and return it
to normal)
(for from 1 to 2
do (DISMISS 100)
(BITBLT NIL NIL NIL PROMPTWINDOW NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE)
(DISMISS 100)
(BITBLT NIL NIL NIL PROMPTWINDOW NIL NIL NIL NIL (QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE])
(ssi
[LAMBDA NIL (* js: "27-JUL-83 16:50")
(←New
$StructuredInstanceObjectClassBrowser Show (QUOTE (StructuredInstanceObject])
)
(RPAQQ *NoBrowserUpdates* NIL)
(DECLARE: DONTCOPY
(FILEMAP (NIL (34445 101409 (ShowStructuredInstanceObjects 34455 . 34674) (
StructuredInstanceMeta.AddInstanceName 34676 . 35092) (StructuredInstanceMeta.AddLink 35094 . 35908) (
StructuredInstanceMeta.AddLocalIV 35910 . 36297) (StructuredInstanceMeta.BrowseInstances 36299 . 40122
) (StructuredInstanceMeta.CalculateBrowserStartingList 40124 . 40865) (
StructuredInstanceMeta.CloseInstanceBrowser 40867 . 41278) (StructuredInstanceMeta.DeleteInstanceName
41280 . 41643) (StructuredInstanceMeta.Destroy 41645 . 42411) (StructuredInstanceMeta.DestroyRelation
42413 . 42973) (StructuredInstanceMeta.FetchDefaultLinks 42975 . 43322) (
StructuredInstanceMeta.FetchInstanceBrowser 43324 . 43820) (StructuredInstanceMeta.FetchInstanceNames
43822 . 44119) (StructuredInstanceMeta.FetchLinks 44121 . 44392) (StructuredInstanceMeta.FetchRoot
44394 . 44672) (StructuredInstanceMeta.New 44674 . 45708) (StructuredInstanceMeta.Specialize 45710 .
47174) (StructuredInstanceMeta.UpDateAppropriateBrowser 47176 . 47644) (
StructuredInstanceMeta.UpDateBrowserList 47646 . 49862) (StructuredInstanceObject.Destroy 49864 .
50548) (StructuredInstanceObject.FetchSubs 50550 . 50944) (StructuredInstanceObject.FetchSubs! 50946
. 52045) (StructuredInstanceObject.FetchSupers 52047 . 52492) (StructuredInstanceObject.FetchSupers!
52494 . 53707) (StructuredInstanceObject.LinkDown 53709 . 55235) (StructuredInstanceObject.LinkUp
55237 . 56877) (StructuredInstanceObject.Rename 56879 . 58509) (StructuredInstanceObject.UnLinkDown
58511 . 59898) (StructuredInstanceObject.UnLinkUp 59900 . 61361) (
StructuredInstanceObjectClassBrowser.AddInstanceLink 61363 . 62321) (
StructuredInstanceObjectClassBrowser.BrowseInstances 62323 . 63323) (
StructuredInstanceObjectClassBrowser.CreateNewInstance 63325 . 64693) (
StructuredInstanceObjectClassBrowser.SaveClassAndInstances 64695 . 65360) (
StructuredInstanceObjectClassBrowser.SaveClassAndInstances! 65362 . 66047) (
StructuredInstanceObjectClassBrowser.SaveClassOnly 66049 . 66689) (
StructuredInstanceObjectClassBrowser.SaveClassOnly! 66691 . 67353) (
StructuredInstanceObjectClassBrowser.SaveInstancesOnly 67355 . 68011) (
StructuredInstanceObjectClassBrowser.SaveInstancesOnly! 68013 . 68690) (InstanceBrowser.AddRoot 68692
. 70469) (InstanceBrowser.DefineSubclass 70471 . 70953) (InstanceBrowser.DestroyThisRelation 70955 .
71270) (InstanceBrowser.GatherBoxedNodes 71272 . 72334) (InstanceBrowser.GetIV 72336 . 73023) (
InstanceBrowser.GetSubs 73025 . 73562) (InstanceBrowser.InitializeWithAll 73564 . 75347) (
InstanceBrowser.LeftSelection 75349 . 76722) (InstanceBrowser.LinkDown 76724 . 78375) (
InstanceBrowser.LinkUp 78377 . 79968) (InstanceBrowser.MiddleSelection 79970 . 81348) (
InstanceBrowser.MoveInstance 81350 . 84440) (InstanceBrowser.MoveSubTree 84442 . 85999) (
InstanceBrowser.Recompute 86001 . 86359) (InstanceBrowser.RemoveInstanceFromRelation 86361 . 88266) (
InstanceBrowser.Rename 88268 . 89434) (InstanceBrowser.SetIV 89436 . 90430) (
InstanceBrowser.SetIVofInterest 90432 . 91159) (InstanceBrowser.Show 91161 . 92391) (
InstanceBrowser.Spawn 92393 . 93694) (InstanceBrowser.Specialize 93696 . 93918) (
InstanceBrowser.SpecializeInstance 93920 . 94837) (InstanceBrowser.SpliceNewInstance 94839 . 95819) (
InstanceBrowser.TotallyDestroyInstance 95821 . 96735) (InstanceBrowser.UnLinkDown 96737 . 98237) (
InstanceBrowser.UnLinkUp 98239 . 99670) (InstanceBrowser.Unread 99672 . 99926) (PromptRead 99928 .
100663) (PromptWindowBlink 100665 . 101212) (ssi 101214 . 101407)))))
STOP