(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "WEB" ( USE "PCL"
"CL" "XCL") ( NICKNAMES "WEB-EDITOR")) READTABLE "XCL")
(il:filecreated " 4-Nov-87 18:26:00"
il:{dsk}<lispfiles>web-editor.\;12 155723
il:|changes| il:|to:| (pcl::methods (move (
web-editor
))
(initialize (web-editor
)))
il:|previous| il:|date:| "30-Sep-87 22:34:00"
il:{dsk}<lispfiles>web-editor.\;11)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:web-editorcoms)
(il:rpaqq il:web-editorcoms
(
(il:* il:|;;;| "***************************************")
(il:* il:|;;;| " Copyright (c) 1987 by Xerox Corporation. All rights reserved.")
(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.")
(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
(il:* il:|;;;| " CLOS Coordinator")
(il:* il:|;;;| " Xerox Artifical Intelligence Systems ")
(il:* il:|;;;| " 2550 Hanover St.")
(il:* il:|;;;| " Palo Alto, CA 94303")
(il:* il:|;;;|
"(or send internet mail to CLOSSupport.pa@Xerox.arpa)")
(il:* il:|;;;| " ****************************************")
(il:* il:|;;;| "")
(il:* il:|;;;| "Print out a copyright notice when loading")
(il:* il:|;;;| "")
(il:p (format t "~&;WEB-EDITOR Copyright (c) 1987, Xerox Corporation. All rights reserved.~%"
))
(il:* il:|;;;| "")
(il:* il:|;;;| "PACKAGE STUFF")
(il:prop il:makefile-environment il:web-editor)
(il:* il:|;;| "")
(il:* il:|;;;| "WEB EDITOR ")
(il:* il:|;;| "")
(il:* il:|;;| "Global Variables")
(il:* il:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)")
(il:variables destination-browser)
(il:* il:|;;| "")
(il:* il:|;;| "Web Node Class")
(pcl::classes web-node)
(pcl::methods (get-label (web-node))
(get-to-links (web-node))
(object-name (web-node)))
(il:* il:|;;| " Web Editor Class")
(pcl::classes web-editor)
(pcl::methods (get-label (web-editor))
(get-subs (web-editor)))
(il:* il:|;;| "Window Interface")
(pcl::methods (initialize (web-editor))
(create-window (web-editor))
(detach-lisp-window (web-editor))
(has-lisp-window (web-editor))
(set-outer-region (web-editor))
(set-region (web-editor))
(update (web-editor))
(move (web-editor))
(move1 (web-editor))
(after-move (web-editor))
(after-reshape (web-editor))
(scroll-window (web-editor)))
(pcl::methods (get-prompt-window (web-editor))
(prompt-print (web-editor))
(prompt-read (web-editor))
(prompt-for-list (web-editor))
(prompt-for-string (web-editor))
(prompt-for-word (web-editor)))
(pcl::methods (clear (web-editor))
(icon-title (web-editor)))
(il:fns web-window-after-move-fn
web-window-button-event-fn
web-window-reshape-fn web-window-close-fn
il:|PromptRead|)
(il:fns web-window-expand-fn)
(il:functions web-window-icon-fn)
(il:bitmaps *web-editor-icon-bm*
*web-editor-icon-mask*)
(il:variables *web-editor-template*)
(il:vars (il:*d-window-default-stream*
il:promptwindow))
(il:functions il:|CopyDown?| il:|MetaDown?|
il:|MoveDown?|)
(il:* il:|;;| "Layout and Display Engine")
(pcl::methods (browse (web-editor))
(show (web-editor))
(display-browser (web-editor))
(browser-objects (web-editor))
(get-node-list (web-editor))
(graph-fits (web-editor))
(node-region (web-editor))
(clear-label-cache (web-editor)))
(il:* il:|;;| "Button Events")
(pcl::methods (button-event-fn (web-editor))
(choice-menu (web-editor))
(when-menu-item-held (web-editor))
(item-menu (web-editor))
(get-menu-items (web-editor))
(clear-menu-cache (web-editor))
(left-choice (web-editor))
(middle-choice (web-editor))
(left-selection (web-editor))
(left-shift-select (web-editor))
(middle-selection (web-editor))
(middle-shift-select (web-editor))
(right-selection (web-editor))
(title-selection (web-editor)))
(il:fns web-menu-whenselectedfn
window-when-held-fn)
(il:fns sub-item-selection dual-sub-items
window-when-held-fn do-menu-method
dual-menu dual-selection)
(il:* il:|;;| "Event Triggering")
(pcl::methods (do-selected-command (web-editor))
(do-command-in-process (web-editor))
(eval-form-in-process (web-editor))
(message-form-for-process (web-editor)))
(il:fns eval.in.tty.context lispx-send)
(il:* il:|;;| "Browser Looks Control")
(pcl::methods (add-root (web-editor))
(delete-from-browser (web-editor))
(delete-subtree-from-browser (web-editor)
)
(recompute (web-editor))
(recompute-in-place (web-editor))
(recompute-labels (web-editor))
(remove-from-bad-list (web-editor))
(change-font-size (web-editor))
(change-format (web-editor))
(change-max-label-size (web-editor))
(shape-to-hold (web-editor)))
(il:* il:|;;| "Node Marking and Selecting")
(pcl::methods (box-node (web-editor))
(display-node-hightlights (web-editor))
(display-node-shading (web-editor))
(flash-node (web-editor))
(flip-node (web-editor))
(get-display-label (web-editor))
(highlight-node (web-editor))
(remove-highlights (web-editor))
(remove-shading (web-editor))
(unmark-nodes (web-editor))
(shade-node (web-editor)))
(pcl::methods (has-object (web-editor))
(make-parameter-menu (web-editor))
(new-item (web-editor))
(obj-name-pair (web-editor))
(object-from-label (web-editor))
(position-node (web-editor)))
(il:* il:|;;| "Dubious Methods")
(pcl::methods (save-in-it (web-editor))
(sub-browser (web-editor))
(unread (web-editor)))
(il:* il:|;;;| "AUXILIARY Stuff")
(il:fns find-selected-node)
(il:fns add-menu-window box-print-string
box-window-node break-string-for-boxing
fileclasses items-for-type
menu-group-size repaint-menu-window
\\delete-subtree \\menu-group-size
\\place-menu-group-in-window
\\portable-graph-node-id
\\remove-menu-group-from-window)
(il:fns tree-roots child-nodes reachable-nodes!)
(il:vars (web-stream il:promptwindow)
il:|BrowserMargin| il:grayshade1
il:grayshade2 il:grayshade3 il:grayshade4
il:|MaxLatticeHeight|
il:|MaxLatticeWidth| il:|NestedMenuFlg|)
(il:specvars il:|MaxLatticeHeight|
il:|MaxLatticeWidth|)
(il:* il:|;;;| " PCL Utils")
(il:functions pcl::objectp pcl::instance-of-p
pcl::understands pcl::get-object-rec)
(il:* il:|;;;| "")
(il:declare\: il:donteval@load il:doeval@compile
il:dontcopy il:compilervars
(il:addvars (il:nlama)
(il:nlaml lispx-send)
(il:lama window-when-held-fn
window-when-held-fn
web-window-expand-fn
web-window-reshape-fn
web-window-button-event-fn
web-window-after-move-fn)))
))
(il:* il:|;;;| "***************************************")
(il:* il:|;;;|
" Copyright (c) 1987 by Xerox Corporation. All rights reserved."
)
(il:* il:|;;;|
"Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws."
)
(il:* il:|;;;|
"This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification."
)
(il:* il:|;;;|
"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
)
(il:* il:|;;;| " CLOS Coordinator")
(il:* il:|;;;| " Xerox Artifical Intelligence Systems ")
(il:* il:|;;;| " 2550 Hanover St.")
(il:* il:|;;;| " Palo Alto, CA 94303")
(il:* il:|;;;|
"(or send internet mail to CLOSSupport.pa@Xerox.arpa)")
(il:* il:|;;;| " ****************************************")
(il:* il:|;;;| "")
(il:* il:|;;;| "Print out a copyright notice when loading")
(il:* il:|;;;| "")
(format t "~&;WEB-EDITOR Copyright (c) 1987, Xerox Corporation. All rights reserved.~%"
)
(il:* il:|;;;| "")
(il:* il:|;;;| "PACKAGE STUFF")
(il:putprops il:web-editor il:makefile-environment
(:package (defpackage "WEB"
(:use "PCL" "CL" "XCL")
(:nicknames "WEB-EDITOR"))
:readtable "XCL"))
(il:* il:|;;| "")
(il:* il:|;;;| "WEB EDITOR ")
(il:* il:|;;| "")
(il:* il:|;;| "Global Variables")
(il:* il:|;;|
"global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
)
(defglobalparameter destination-browser nil "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
)
(il:* il:|;;| "")
(il:* il:|;;| "Web Node Class")
(defclass web-node nil ((name (il:* il:\;
"Name of Node")
)
(to-links (il:* il:\;
"Nodes that this Node has Links TO")
)))
(defmethod get-label ((object web-node))
(slot-value object 'name))
(defmethod get-to-links ((object web-node))
(slot-value object 'to-links))
(defmethod object-name ((object web-node))
(slot-value object 'name))
(il:* il:|;;| " Web Editor Class")
(defclass web-editor
nil ((box-line-width :allocation :class
(il:* il:|;;| "width to make box for BoxNode")
:initform 1)
(local-commands :allocation :class
(il:* il:|;;| "messages that should be sent to browser when item seleted in menu, even if object does understand them")
:initform
(box-node recompute add-root))
(il:* il:|;;| "Window ITEMS")
(window)
(title :initform "Web Editor"
(il:* il:\;
"If not NIL will be put in title of window")
)
(cache-menu-p :initform t)
(menu-cache (il:* il:\;
"Will Cache Menus only if CACHE-MENU-P is T")
)
(title-items :allocation :class
(il:* il:|;;|
"Items for menu of selections in title of window")
:initform
(("Recompute" recompute ""
(il:subitems ("Save Value"
save-in-it
"(SavedValue)← thisBrowser"
)
("Recompute" recompute
"Recompute lattice from starting objects"
)
("Recompute Labels"
recompute-labels
"Recomputes the labels"
)
("Recompute In Place"
recompute-in-place
"Recompute keeping current view in window"
)
("Shape To Hold"
shape-to-hold
"Make window large or small enough to just hold graph"
)
("Change Font Size"
change-font-size
"Choose a new size Font"
)
("Change Format"
change-format
"Change format between lattice and tree"
)))
("Add Root" add-root ""
(il:subitems ("Add Root" add-root
"Add named item to startingList for browser"
)
(il:|RemoveFromBadList|
remove-from-bad-list
"Restore item previously deleted from browser"
))
"Add named item to startingList for browser"
)))
(left-button-items :allocation :class
(il:* il:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands")
:initform
(("Box Node" box-node "Draw box around selected node.
Unboxed by another BoxNode")
("Pretty Print" pp
"Prettyprint selected item")))
(shift-left-button-items :allocation :class
(il:* il:\; "Items to be done if Left button is selected in main window with SHIFT key down.")
)
(middle-button-items :allocation :class
(il:* il:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands")
:initform
(("Inspect" il:|Inspect| inspect
"Inspect selected item")
("Edit" edit-object "Edit selected item")
("Delete From Browser" delete-from-browser
"Do not show item or its subs")))
(shift-middle-button-items :allocation :class
(il:* il:\; "Items to be done if Middle button is selected in main window with SHIFT key down.")
)
(right-button-items :allocation :class :initform
(("Close" (closew (("Close" closew)
("Destroy" destroy))))
("Snap" snap)
("Paint" paint)
("Clear" clear)
("Bury" bury)
("Repaint" repaint)
("Hardcopy" (hardcopy (("Hardcopy to File"
hardcopy-to-file)
(
"Hardcopy to Printer"
hardcopy-to-printer
))))
("Move" move)
("Shape" shape)
("Shrink" shrink)) (il:* il:\;
"Items to be done if Right button is selected")
)
(top-align (il:* il:\; "Flg used to indicate whether graph should be aligned with the top or bottom of the window")
)
(starting-list :initform nil
(il:* il:\;
"list of objects used to compute this browser")
)
(good-list :initform nil (il:* il:\;
"limit choices to this set")
)
(bad-list :initform nil (il:* il:\;
"Don't put in any items on this set")
)
(last-selected-object :initform nil
(il:* il:\;
"last object selected")
)
(browse-font :initform
(il:fontcreate '(il:helvetica 10 il:bold)))
(browse-font-family :initform 'il:helvetica)
(browse-font-face :initform 'il:bold)
(label-max-lines :initform nil
(il:* il:|;;| "the maximum number of lines to use in 'boxed' labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated")
)
(label-max-chars-width :initform nil
(il:* il:\; "the maximum width for labels -- if label is too big, it will be 'boxed'")
)
(label-cache)
(boxed-node :initform nil (il:* il:\;
"last item Boxed, if any")
)
(graph-format :initform '(il:lattice)
(il:* il:\;
"Controls format for laying out graph for GRAPHER")
)
(graph-format-choices :allocation :class :initform
((il:horizontal/lattice '(il:lattice))
(il:vertical/lattice '(il:vertical
il:lattice))
(il:horizontal/tree '(il:copies/only))
(il:vertical/tree '(il:vertical
il:copies/only)))
)
(show-graph-fn :initform #'il:showgraph
(il:* il:|;;| "The function to use to display the graph in the window. This might want to be set to SHOWZOOMGRAPH.")
)
(left (il:* il:\;
"left position of window")
)
(bottom (il:* il:\;
"bottom position of window")
)
(width :initform 64)
(height :initform 32)))
(defmethod get-label ((il:|self| web-editor)
il:|object|) (il:* il:\; "Get a label for an object to be displayed in the browser.")
(get-label il:|object|))
(defmethod get-subs ((il:|self| web-editor)
il:|object|) (il:* il:\;
"Gets a set of subs from an object for browsing")
(get-to-links il:|object|))
(il:* il:|;;| "Window Interface")
(defmethod initialize ((self web-editor)
ignore)
(il:* il:|;;| "the ignored parameter is to keep the lambda list congruent with pcl::initialize which people import since it appears in pcl::*other-exports*.")
(let ((window (slot-value self 'window)))
(il:|if| (not window)
il:|then| (create-window self)
(setq window (slot-value self 'window)))
(il:windowprop window 'web-editor self)
(il:windowprop window 'il:iconfn 'web-window-icon-fn)
(il:windowprop window 'il:buttoneventfn '
web-window-button-event-fn)
(il:windowaddprop window 'il:aftermovefn '
web-window-after-move-fn)
(il:windowaddprop window 'il:reshapefn '
web-window-reshape-fn)
(il:windowaddprop window 'il:closefn '
web-window-close-fn)
(il:windowprop window 'il:iconfn 'web-window-icon-fn)
window))
(defmethod create-window ((self web-editor))
(il:* il:\;
"10-Apr-86 14:32")
(il:* il:\; "Create the Lisp window for this window but don't open it.")
(setf (slot-value self 'window)
(il:createw (il:createregion il:lastmousex
il:lastmousey 25 25)
(slot-value self 'title)
nil t)))
(defmethod detach-lisp-window ((self web-editor))
(il:* il:\;
" 8-Apr-87 17:25")
(il:* il:|;;;| "Forget about the current lisp window")
(let ((val (slot-value self 'window)))
(il:|if| (il:windowp val)
il:|then| (setf (slot-value self 'window)
nil)
(il:windowprop val 'web-editor nil)
(il:windowprop val 'il:rightbuttonfn nil)
(il:windowprop val 'il:buttoneventfn nil)
nil
il:|else| nil)))
(defmethod has-lisp-window ((self web-editor))
(il:* il:\;
"24-Sep-85 18:34")
(il:* il:\; "Checks if a Lisp window has ever been created for this Loops Window")
(il:windowp (slot-value self 'window)))
(defmethod set-outer-region ((self web-editor)
region no-update-flg)
(il:* il:\;
"16-Apr-86 13:21")
(il:* il:|;;;| "Make Loops Window have region parameters")
(setf (slot-value self 'left)
(il:|fetch| il:left il:|of| region))
(setf (slot-value self 'bottom)
(il:|fetch| il:bottom il:|of| region))
(setf (slot-value self 'width)
(il:|fetch| il:width il:|of| region))
(setf (slot-value self 'height)
(il:|fetch| il:height il:|of| region))
(il:|if| (not no-update-flg)
il:|then| (update self))
region)
(defmethod set-region ((self web-editor)
region &optional no-update-flg)
(il:* il:\;
"16-Apr-86 13:22")
(il:* il:|;;;| "Make Loops Window have region parameters")
(set-outer-region self
(il:createregion (il:|fetch| il:left il:|of| region
)
(il:|fetch| il:bottom il:|of| region)
(il:widthifwindow (il:|fetch| il:width
il:|of| region)
(il:windowprop (slot-value
self
'window)
'il:border))
(il:heightifwindow
(il:|fetch| il:height il:|of| region)
(slot-value self 'title)
(il:windowprop (slot-value self
'window)
'il:border)))
no-update-flg))
(defmethod update ((self web-editor))
(il:* il:\;
"29-Sep-86 11:56")
(il:* il:|;;;|
"make the Lisp window be consistent with ivs")
(let*
((window (slot-value self 'window))
(region
(and (slot-value self 'width)
(slot-value self 'height)
(il:|create| il:region
il:left il:←
(or (slot-value self 'left)
(setf (slot-value self 'left)
il:lastmousex))
il:bottom il:←
(or (slot-value self 'bottom)
(setf (slot-value self 'bottom)
il:lastmousey))
il:width il:← (slot-value self
'width)
il:height il:← (slot-value self
'height)))))
(cond
((and region (not (il:equal region
(il:windowprop window
'il:region))))
(il:* il:\; "The shape has changed. --- This is complicated because of ATTACHEDWINDOWS.")
(let*
((attached-windows (il:windowprop window
'il:attachedwindows))
(attachment-specs
(il:|for| il:\w il:|in| attached-windows
il:|collect| (list (il:windowprop
il:\w
'il:dowindowcomfn)
(il:windowprop
il:\w
'il:whereattached)
(il:windowprop
il:\w
'il:passtomaincoms)))))
(il:|for| il:\w il:|in| attached-windows
il:|do| (il:detachwindow il:\w))
(il:shapew window region)
(il:|for| il:\w il:|in| attached-windows
il:|as| il:|spec| il:|in| attachment-specs
il:|do| (il:attachwindow il:\w window
(caadr il:|spec|)
(cdadr il:|spec|))
(il:windowprop il:\w 'il:dowindowcomfn
(car il:|spec|))
(il:windowprop il:\w 'il:passtomaincoms
(caddr il:|spec|))))))
(and (not (il:equal (slot-value self 'title)
(il:windowprop window 'il:title)))
(il:windowprop window 'il:title
(slot-value self 'title)))))
(defmethod move ((self web-editor)
x-or-pos &optional y)
(il:* il:\;
"11-Sep-86 13:24")
(il:* il:|;;;| "Move the window")
(move1
self
(or x-or-pos
(let* ((entire-region (il:windowregion
(slot-value self
'window)))
(pos (il:getboxposition (il:|fetch| il:width
il:|of|
entire-region
)
(il:|fetch| il:height
il:|of| entire-region)
(il:|fetch| il:left il:|of|
entire-region
)
(il:|fetch| il:bottom
il:|of| entire-region))))
(il:|create|
il:position
il:xcoord il:←
(il:plus (il:|fetch| il:xcoord il:|of|
pos)
(il:difference (slot-value
self
'left)
(il:|fetch| il:left
il:|of| entire-region)))
il:ycoord il:←
(il:plus (il:|fetch| il:ycoord il:|of|
pos)
(il:difference (slot-value
self
'bottom)
(il:|fetch| il:bottom
il:|of| entire-region))))))
y))
(defmethod move1 ((self web-editor)
x-or-pos y) (il:* il:\;
"13-Aug-86 19:10")
(il:* il:|;;;| "Move the window")
(let
((needs-update?
(or (not (has-lisp-window self))
(not (il:subregionp (il:constant (il:createregion
0 0
il:screenwidth
il:screenheight
))
(il:windowprop (slot-value
self
'window)
'il:region))))))
(prog1 (il:movew (slot-value self 'window)
x-or-pos y) (il:* il:\; "The left and right IVs are updated by the message AfterMove")
(cond
(needs-update? (update self))))))
(defmethod after-move ((self web-editor))
(il:* il:\;
"10-Apr-86 16:10")
(il:* il:|;;;|
"The window has been moved. Update the left and bottom")
(let ((region (il:windowprop (slot-value self 'window)
'il:region)))
(setf (slot-value self 'left)
(il:|fetch| il:left il:|of| region))
(setf (slot-value self 'bottom)
(il:|fetch| il:bottom il:|of| region))))
(defmethod after-reshape ((self web-editor)
old-bitmap-image old-region
old-screen-region)
(il:* il:\;
"10-Apr-86 16:12")
(il:* il:|;;;| "The window has been reshaped")
(let ((region (il:windowprop (slot-value self 'window)
'il:region)))
(setf (slot-value self 'left)
(il:|fetch| il:left il:|of| region))
(setf (slot-value self 'bottom)
(il:|fetch| il:bottom il:|of| region))
(setf (slot-value self 'width)
(il:|fetch| il:width il:|of| region))
(setf (slot-value self 'height)
(il:|fetch| il:height il:|of| region))
(il:reshapebyrepaintfn (slot-value self 'window)
old-bitmap-image old-region old-screen-region)
))
(defmethod scroll-window ((self web-editor)
dsp-x dsp-y window-x window-y)
(il:* il:\;
"10-Apr-86 14:58")
(il:* il:|;;;| "scroll the window to set the point dspX,dspY in the given window position -- default is the lower left corner. If any x or y is a FIXP, it is treated as a absolute position. If FLOATP, it is treated as a relative position. Return the position of the new lower left corner.")
(let* ((window (slot-value self 'window))
(visible-region (il:dspclippingregion nil window))
(extent (il:windowprop window 'il:extent)))
(il:* il:\;
"figure out what to do with default and relative offsets")
(il:setq window-x
(il:|if| (null window-x)
il:|then| 0
il:|elseif| (il:floatp window-x)
il:|then| (il:fix (il:times window-x
(il:windowprop
window
'il:width)))
il:|else| window-x))
(il:setq window-y
(il:|if| (null window-y)
il:|then| 0
il:|elseif| (il:floatp window-y)
il:|then| (il:fix (il:times window-y
(il:windowprop
window
'il:height)))
il:|else| window-y))
(il:setq dsp-x
(il:|if| (null dsp-x)
il:|then| (il:|fetch| il:left il:|of|
visible-region
)
il:|elseif| (il:floatp dsp-x)
il:|then| (il:fix (il:times dsp-x
(il:|fetch| il:width
il:|of| extent)))
il:|else| dsp-x))
(il:setq dsp-y
(il:|if| (null dsp-y)
il:|then| (il:iminus (il:|fetch| il:bottom
il:|of| visible-region)
)
il:|elseif| (il:floatp dsp-y)
il:|then| (il:fix (il:times dsp-y
(il:|fetch| il:height
il:|of| extent)))
il:|else| dsp-y))
(il:scrollw window
(il:iplus window-x
(il:idifference (il:|fetch| il:left
il:|of|
visible-region
)
dsp-x))
(il:iplus window-y
(il:idifference (il:|fetch| il:bottom
il:|of|
visible-region
)
dsp-y)))
(il:* il:\;
"return the resulting position")
(il:setq visible-region (il:dspclippingregion nil
window))
(il:|create| il:position
il:xcoord il:← (il:|fetch| il:left
il:|of| visible-region)
il:ycoord il:← (il:|fetch| il:bottom
il:|of| visible-region))))
(defmethod get-prompt-window ((self web-editor)
lines font-def)
(il:* il:\;
" 8-Apr-87 15:43")
(il:* il:|;;;| "Return the current prompt window")
(let ((w (il:getpromptwindow (slot-value self 'window)
(or lines 2)
(il:fontcreate font-def))))
(il:|if| font-def
il:|then| (il:dspfont (il:fontcreate font-def)
w))
w))
(defmethod prompt-print ((self web-editor)
prompt) (il:* il:\;
"13-Aug-86 18:46")
(il:* il:|;;;|
"Prints out a prompt in an attached prompt window")
(il:prin1 prompt (get-prompt-window self)))
(defmethod prompt-read ((self web-editor)
msg) (il:* il:\;
"13-Aug-86 19:15")
(il:* il:|;;;| "Prompt the user for some input, using an attached prompt window")
(let ((p-window (get-prompt-window self)))
(il:clearw p-window)
(il:|PromptRead| msg p-window t)))
(defmethod prompt-for-list ((self web-editor)
prompt-str initial-string)
(il:* il:\;
" 8-Apr-87 16:44")
(il:* il:|;;;|
"Prompt user in prompt window for a list of words.")
(let ((p-window (get-prompt-window self)))
(il:resetform (il:ttydisplaystream p-window)
(il:clearw p-window)
(il:ttyin prompt-str nil nil '(il:noraise) nil
nil initial-string))))
(defmethod prompt-for-string ((self web-editor)
prompt-str initial-str)
(il:* il:\;
"13-Aug-86 18:42")
(il:* il:|;;;| "Prompt user in prompt window for a string.")
(let ((p-window (get-prompt-window self)))
(il:resetform (il:ttydisplaystream p-window)
(il:clearw p-window)
(il:ttyin prompt-str nil nil
'(string il:noraise) nil nil
initial-str))))
(defmethod prompt-for-word ((self web-editor)
&optional prompt-str
initial-word)
(il:* il:\;
" 8-Apr-87 16:43")
(il:* il:|;;;| "Prompt user in prompt window for a word.")
(car (prompt-for-list self prompt-str initial-word)))
(defmethod clear ((self web-editor))
(il:* il:\;
"empty the window of active regions, return the window")
(il:windowprop (slot-value self 'window)
'il:graph nil)
(call-next-method self)
(slot-value self 'window))
(defmethod icon-title ((self web-editor))
(il:* il:\;
"18-Jan-85 15:35")
(il:* il:|;;;| "Compute the icont title for this browser")
'|Web Editor|)
(il:defineq
(web-window-after-move-fn
(lambda (window) (il:* il:\;
"Edited 13-Jul-87 15:59 by Rao")
(il:* il:\;
"10-Apr-86 16:16")
(il:* il:|;;;| "The SimpleWindow AFTERMOVEFN")
(let ((w (il:windowprop window 'web-editor)))
(and w (after-move w)))))
(web-window-button-event-fn
(lambda (window) (il:* il:\;
"Edited 13-Jul-87 13:38 by Rao")
(il:* il:\;
"11-Sep-86 13:50")
(let ((window-for-menu (il:windowprop window
'web-editor)))
(declare (il:specvars window-for-menu))
(il:totopw window)
(button-event-fn window-for-menu))))
(web-window-reshape-fn
(lambda (window il:|oldBitmapImage| il:|oldRegion|
il:|oldScreenRegion|)
(il:* il:\;
"Edited 12-Jun-87 15:56 by Rao")
(il:* il:\;
" 9-May-86 10:07")
(il:* il:|;;;| "The RESHAPEFN for a Window")
(let ((il:\w (il:windowprop window 'web-editor)))
(and il:\w (after-reshape il:\w
il:|oldBitmapImage|
il:|oldRegion|)))))
(web-window-close-fn
(il:lambda (window) (il:* il:\;
"Edited 12-Jun-87 11:42 by Rao")
(il:* il:\;
"Remove link back to LoopsWindow")
(il:windowprop window 'web-editor nil)))
(il:|PromptRead|
(il:lambda (prompt-string window same-line?)
(il:* il:\;
"Edited 20-Jul-87 16:20 by Rao")
(il:* il:\; "Printout promptString in promptwindow and return value of expression read there")
(prog (newvalue)
(il:resetlst (il:resetsave (il:ttydisplaystream
(or window
il:promptwindow))
)
(il:resetsave (il:tty.process (
il:this.process
)))
(il:clrprompt)
(il:resetsave (il:printlevel 4 3))
(il:|printout| t prompt-string)
(il:|if| same-line?
il:|then| (il:|printout| t "> ")
il:|else| (il:|printout| t t "> "))
(il:clearbuf t t) (il:* il:\;
"clear tty buffer because it sometimes has stuff left.")
(il:allow.button.events)
(il:setq newvalue
(car (il:ersetq (il:ttyinread t t)))))
(return newvalue))))
)
(il:defineq
(web-window-expand-fn
(lambda (window) (il:* il:\;
"Edited 21-Jul-87 07:43 by Rao")
(il:* il:\;
"19-Feb-85 13:58")
(il:* il:|;;;| "When a browser window is expanded, it should be recomputed")
(let ((self (il:windowprop window 'web-editor)))
(recompute-in-place self))))
)
(defun web-window-icon-fn (window icon)
(let nil (or icon (il:titlediconw
*web-editor-template*
(icon-title (il:windowprop
window
'web-editor))
nil nil nil 'il:bottom
(il:constant (list (il:charcode
"-")
(il:charcode
il:space)
(il:charcode
il:eol)))))))
(il:rpaqq *web-editor-icon-bm* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@LOON@@@@@@OO@C@@LOON@@@@@@OO@AH@LOOO@@@@@@OO@@L@LOONH@@@@AOO@@F@LOOND@@@@BOOOOO@L@@@B@@@@DOOOHC@L@@@ACOOLH@@@@C@L@@@@KOOM@@@@@C@L@@@@GOON@@@@@C@L@@@@KOOM@@@@@C@L@@@ACOOLH@@@@C@LOOOB@@@@DOOOHC@LOOOD@@@@BOOOHC@LOOOH@@@@AOOOHC@LOOOD@@@@@OOOHC@LOOOB@@@@@OOOHC@L@@@ACOOO@@@@@C@L@@@@KOOO@@@@@C@L@@@@GOOO@@@@@C@L@@@@COOO@@@@@C@L@@@@COOO@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
)
(il:rpaqq *web-editor-icon-mask* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
)
(defvar *web-editor-template* (il:|create| il:titledicon
il:icon il:←
*web-editor-icon-bm*
il:mask il:←
*web-editor-icon-mask*
il:titlereg il:←
(il:createregion
5 2 50 30)) )
(il:rpaq il:*d-window-default-stream* il:promptwindow)
(defmacro il:|CopyDown?| nil
(il:* il:|;;;| "Is the Copy button down?")
'(or (il:keydownp 'il:copy)
(il:shiftdownp 'il:1shift)))
(defmacro il:|MetaDown?| nil
(il:* il:|;;;| "Is the Meta button down?")
'(il:shiftdownp 'il:meta))
(defmacro il:|MoveDown?| nil
(il:* il:|;;;| "Is the Meta button down?")
'(or (il:keydownp 'il:move)
(il:shiftdownp 'il:ctrl)))
(il:* il:|;;| "Layout and Display Engine")
(defmethod browse ((self web-editor)
&optional browse-list window-or-title
good-list position)
(il:* il:\;
"11-Sep-84 07:24")
(il:* il:\;
"Call Show and then shape to hold and move for first time")
(show self browse-list window-or-title good-list)
(shape-to-hold self)
(move self position))
(defmethod show ((self web-editor)
browse-list window-or-title good-list)
(il:* il:|;;;|
"Show the items and their subs on a browse window.")
(il:* il:|;;;| "If windowOrTitle is not a window it will be used as a title for a window which will be created.")
(cond
((il:windowp window-or-title)
(setf (slot-value self 'window)
window-or-title))
(window-or-title (setf (slot-value self 'title)
window-or-title)))
(cond
((and browse-list (il:nlistp browse-list))
(il:setq browse-list (list browse-list))))
(setf (slot-value self 'starting-list)
browse-list)
(il:* il:|;;| "The Next TWO forms are somewhat bogus, but work for the interim")
(setf (slot-value self 'starting-list)
(il:|for| c il:|in| browse-list
il:|when| (pcl::get-object-rec c)
il:|collect| (pcl::get-object-rec c)))
(and good-list (setf (slot-value self 'good-list)
(il:|for| c il:|in| good-list
il:|when| (pcl::get-object-rec
c)
il:|collect| (pcl::get-object-rec
c))))
(display-browser self))
(defmethod display-browser ((self web-editor))
(il:* il:\;
"29-Sep-86 12:15")
(il:* il:\;
"New method template")
(let ((nodelst (and (slot-value self 'starting-list)
(get-node-list self
(slot-value self 'starting-list
)
(slot-value self 'good-list))))
) (il:* il:\; "window should be invert so that links etc. can be erased")
(il:dspoperation 'il:invert (slot-value self
'window))
(cond
(nodelst (il:apply* (slot-value self '
show-graph-fn)
(il:layoutgraph
nodelst
(tree-roots nodelst)
(slot-value self 'graph-format)
(slot-value self 'browse-font))
(slot-value self 'window)
nil nil (slot-value self
'top-align))
(il:* il:\;
"kludge to reset the window props")
(initialize self)
(il:windowprop (slot-value self
'window)
'il:title
(slot-value self 'title))
(il:* il:\;
"kludge: because GRAPHER adds its own COPYBUTTONEVENTFN")
(il:windowprop (slot-value self
'window)
'il:copybuttoneventfn nil))
(t (clear self)))))
(defmethod browser-objects ((il:|self| web-editor))
(il:* il:\;
"28-May-84 12:58")
(il:* il:\;
"Return a list of all the objects shown in the browser")
(il:|for| il:|node|
il:|in| (il:|fetch| il:graphnodes
il:|of| (il:windowprop (slot-value
il:|self|
'window)
'il:graph))
il:|when| (il:nlistp (car il:|node|))
il:|collect| (car il:|node|)))
(defmethod get-node-list ((self web-editor)
browse-list good-list)
(il:* il:\;
"21-Mar-85 14:09")
(il:* il:|;;| "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.")
(declare (il:globalvars il:whiteshade))
(cond
((eq good-list t)
(il:setq good-list browse-list)))
(prog (subs pair node
(old-nodes (il:|fetch| il:graphnodes
il:|of|
(il:windowprop
(slot-value self 'window)
'il:graph)))
(obj-list (cons)))
(il:* il:|;;| "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.")
(il:|for| il:|objOrName| il:|in| browse-list
il:|do| (and (il:setq pair (obj-name-pair
self il:|objOrName|
))
(not (il:fassoc (car pair)
(car obj-list)))
(il:tconc obj-list pair)))
(il:* il:|;;;|
"Now MAP ON list so pair can be replaced by graphNode")
(il:|for| pair il:|name| il:|obj| il:|subObjs|
il:|on| (car obj-list)
il:|when| (il:nlistp (il:setq il:|name|
(cdar pair)))
il:|do|
(il:setq il:|subObjs| (cons))
(il:|for| il:|sub| il:|objPair| il:|obj1|
il:|in| (get-subs self (il:setq il:|obj|
(caar pair)))
il:|do|
(il:* il:|;;| "ObjNamePair returns NIL for destroyed objects. include only members of goodList in subs if given. Add to objList only once")
(il:setq il:|obj1|
(cond
((eq (car il:|sub|)
'il:|Link Parameters|)
(cadr il:|sub|))
(t il:|sub|)))
(cond
((il:setq il:|objPair|
(obj-name-pair self il:|obj1|))
(cond
((not (il:fassoc il:|obj1|
(car obj-list)))
(il:tconc obj-list
il:|objPair|)))
(il:tconc il:|subObjs| il:|sub|)))
)
(rplaca
pair
(il:setq node
(or (il:fassoc il:|obj| old-nodes)
(il:|create|
il:graphnode
il:nodeid il:← il:|obj|
il:nodeborder il:←
(list (il:add1 (slot-value self
'box-line-width))
il:whiteshade)))))
(il:|replace| il:tonodes il:|of| node
il:|with| (car il:|subObjs|))
(il:|replace| il:nodelabel il:|of| node
il:|with| il:|name|)
(il:|replace| il:nodefont il:|of| node
il:|with| (slot-value self 'browse-font))
(il:|replace| il:nodewidth il:|of| node
il:|with| nil)
(il:|replace| il:nodeheight il:|of| node
il:|with| nil))
(return (car obj-list))))
(defmethod graph-fits ((|self| web-editor))
(il:* il:\;
"24-Apr-86 15:00")
(il:* il:|;;;| "Tests if graph fits in region")
(let ((|window| (slot-value |self| 'window)))
(let ((|width| 0)
(|height| 0)
(|region| (il:windowprop |window| 'il:region))
(|nodes| (il:|fetch| il:graphnodes
il:|of| (il:windowprop |window|
'il:graph))))
(cond
(|nodes| (il:setq |width|
(il:widthifwindow
(il:idifference (il:max/right
|nodes|)
(il:min/left |nodes|))
(il:windowprop |window|
'il:border)))
(il:setq |height|
(il:heightifwindow
(il:idifference (il:max/top |nodes|)
(il:min/bottom |nodes|))
(il:windowprop |window| 'il:title)
(il:windowprop |window| 'il:border))
)))
(not (or (il:igreaterp |width|
(il:|fetch| il:width
il:|of| |region|))
(il:igreaterp |height|
(il:|fetch| il:height
il:|of| |region|)))))))
(defmethod node-region ((il:|self| web-editor)
il:|object|)
(il:* il:\;
"10-Dec-84 18:26")
(il:* il:|;;;| "what region does the object occupy in the display stream?")
(let ((il:|node| (il:fassoc
(cond
((il:litatom il:|object|)
(il:setq il:|object| (
il:|GetObjectRec|
il:|object|)))
(t il:|object|))
(il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value il:|self|
'window)
'il:graph)))))
(il:|if| il:|node|
il:|then| (il:|create| il:region
il:left il:←
(il:idifference
(il:|fetch| il:xcoord
il:|of| (il:|fetch|
il:nodeposition
il:|of| il:|node|
))
(il:iquotient (il:|fetch|
il:nodewidth
il:|of|
il:|node|
)
2))
il:bottom il:←
(il:idifference
(il:|fetch| il:ycoord
il:|of| (il:|fetch|
il:nodeposition
il:|of| il:|node|
))
(il:iquotient (il:|fetch|
il:nodeheight
il:|of|
il:|node|
)
2))
il:width il:←
(il:|fetch| il:nodewidth
il:|of| il:|node|)
il:height il:←
(il:|fetch| il:nodeheight
il:|of| il:|node|)))))
(defmethod clear-label-cache ((|self| web-editor)
|objects| &aux |cachedLabel|)
(il:* il:\;
" 5-Dec-85 12:02")
(il:* il:|;;;| "Delete the cached label for these items")
(cond
((eq |objects| t)
(setf (slot-value |self| 'label-cache)
nil))
(t
(if (atom |objects|)
(setq |objects| (cons |objects|)))
(il:|for| il:|item| il:|in| |objects|
il:|do| (if (setq |cachedLabel|
(il:assoc |objects|
(slot-value |self|
'label-cache)))
(setf (slot-value |self| 'label-cache
)
(il:dremove |cachedLabel|
(slot-value |self|
'label-cache)))))
)))
(il:* il:|;;| "Button Events")
(defmethod button-event-fn ((self web-editor))
(il:* il:\;
" 2-Jan-86 16:41")
(il:* il:\;
"Called when there is a button event in a Loops Window")
(let ((window (slot-value self 'window)))
(or (il:ersetq (cond
((null (il:insidep (
il:dspclippingregion
nil window)
(il:lastmousex window
)
(il:lastmousey window
)))
(title-selection self))
((il:mousestate il:left)
(left-selection self))
((il:mousestate il:middle)
(middle-selection self))
((il:mousestate il:right)
(right-selection self)))))))
(defmethod choice-menu ((self web-editor)
item-cv) (il:* il:\;
"29-Dec-85 13:54")
(il:* il:|;;| "Create a menu which allows subitems to be displayed. Cache it in the web-editor ")
(let (items menu)
(setq menu (rest (assoc item-cv (slot-value
self
'menu-cache))))
(cond
((and menu (il:type? il:menu menu))
(il:menu menu))
((not (listp (setq items (get-menu-items self
item-cv))))
items)
(t (il:setq menu
(il:create il:menu
il:items il:← items
il:whenselectedfn il:← '
web-menu-whenselectedfn
il:whenheldfn il:← 'window-when-held-fn
il:changeoffsetflg il:← t
il:centerflg il:← t))
(il:* il:\;
"Cache menu if menus is T")
(if (slot-value self 'cache-menu-p)
(setf (slot-value self 'menu-cache)
(acons item-cv menu
(slot-value self 'menu-cache))
))
(il:menu menu)))))
(defmethod when-menu-item-held ((self web-editor)
item menu key)
(il:* il:\;
" 8-Apr-87 17:13")
(il:* il:|;;;| "What to do when the menu item is held")
(il:promptprint (or (cond
((il:nlistp item)
nil)
(t (caddr item)))
"When released this item will be selected"
)))
(defmethod item-menu ((self web-editor)
items title) (il:* il:\;
"21-Apr-84 09:31")
(il:* il:\; "Create a simnple (one level) menu which will not overflow height of screen")
(il:|create| il:menu
il:items il:← items
il:menucolumns il:←
(il:add1 (il:iquotient (il:itimes (il:fontheight
il:menufont)
(il:length items))
750))
il:title il:← title
il:changeoffsetflg il:← t))
(defmethod get-menu-items ((self web-editor)
item-cv)
(il:* il:\;
"23-Oct-84 12:36")
(il:* il:\;
"Get item list for menu")
(slot-value self item-cv))
(defmethod clear-menu-cache ((self web-editor))
(il:* il:\;
"11-Apr-86 14:46")
(il:* il:\;
"Delete Menus saved on menus")
(setf (slot-value self 'menu-cache)
nil)
self)
(defmethod left-choice ((self web-editor))
(il:* il:\;
" 8-Apr-87 17:10")
(il:* il:|;;;| "Get the choices from the LeftButtonItems")
(declare (il:specvars window-for-menu))
(let ((window-for-menu self))
(il:getmousestate)
(choice-menu self (cond
((and (il:|MetaDown?|)
(slot-value self
'
shift-left-button-items
))
'shift-left-button-items)
(t 'left-button-items)))))
(defmethod middle-choice ((self web-editor))
(il:* il:\;
" 8-Apr-87 17:11")
(il:* il:|;;;| "Make choice for Middle Button down")
(declare (il:specvars window-for-menu))
(let ((window-for-menu self))
(il:getmousestate)
(choice-menu self (cond
((and (il:|MetaDown?|)
(get-menu-items
self
'
shift-middle-button-items
))
'shift-middle-button-items)
(t 'middle-button-items)))))
(defmethod left-selection ((self web-editor))
(il:* il:\;
"14-Jan-87 13:20")
(il:* il:|;;;| "Move object if CTRL down. Do LeftShiftSelect if SHIFT down, else choose from LeftButtonItems")
(let
((window (slot-value self 'window)))
(cond
((il:|MoveDown?|)
(il:resetlst (il:resetsave
nil
(list (il:function il:dspoperation)
(il:dspoperation 'il:invert
window)
window))
(il:getmousestate) (il:* il:\;
"Here to move a node.")
(il:dspoperation 'il:invert window)
(il:editmovenode window)))
(t (il:* il:\;
"Here if left button depressed but not control.")
(let ((lattice-browser self)
(object (find-selected-node window)))
(declare (il:specvars object lattice-browser
)) (il:* il:\;
"SPECVARS for whenHeldFn")
(cond
((il:listp object)
(il:setq object (car object))))
(cond
((not (null object))
(setf (slot-value self '
last-selected-object)
object)))
(il:getmousestate)
(cond
((il:|CopyDown?|)
(il:|while| (il:|CopyDown?|)
il:|do| (il:block))
(unread self object))
((null object)
nil)
((il:|MetaDown?|)
(left-shift-select lattice-browser
object))
(t (let ((selector (left-choice self)))
(cond
(selector (do-selected-command
lattice-browser
selector object))))
)))))))
(defmethod left-shift-select ((self web-editor)
object)
(il:* il:\;
"28-SEP-82 11:31")
(il:* il:\; "Called when item is selected with left key and LSHIFT is down")
(pp! object))
(defmethod middle-selection ((self web-editor))
(il:* il:\;
"15-May-85 19:04")
(il:* il:|;;| "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 (selection object (window (slot-value self
'window))
(web-editor self))
(declare (il:specvars object web-editor))
(cond
((null (il:setq object (find-selected-node window
)))
(return)))
(setf (slot-value web-editor 'last-selected-object)
object)
(il:getmousestate)
(flip-node self object)
(cond
((il:|MetaDown?|) (il:* il:\;
"Invoke editor ")
(flip-node self object)
(middle-shift-select web-editor object))
(t (il:setq selection
(or (middle-choice self)
(progn (flip-node self object)
(return nil))))
(flip-node self object)
(do-selected-command web-editor selection
object)))))
(defmethod middle-shift-select ((self web-editor)
object)
(il:* il:\;
"17-Sep-86 18:31")
(il:* il:|;;;| "Called when item is selected with middle key and LSHIFT is down ")
(do-command-in-process self self 'edit (list object)))
(defmethod right-selection ((self web-editor))
(il:* il:\;
"17-Apr-84 15:46")
(il:* il:\;
"Do RightButtonItems on selection.")
(let* ((choice (choice-menu self 'right-button-items)))
(if choice (funcall choice self))))
(defmethod title-selection ((self web-editor))
(il:* il:\;
"17-Apr-84 15:35")
(il:* il:|;;| " Do TitleItems if selected in title area. Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history")
(let* ((choice (choice-menu self 'title-items)))
(if choice (do-command-in-process self self choice
nil))))
(il:defineq
(web-menu-whenselectedfn
(il:lambda (item menu button)
(il:* il:\;
"Edited 14-Jul-87 17:43 by Rao")
(il:* il:\;
"13-DEC-83 21:03")
(prog (second-element)
(return (cond
((il:nlistp item)
item)
((il:nlistp (il:setq second-element
(cadr item)))
second-element)
((eq (car second-element)
'progn)
(il:eval second-element))
(t second-element))))))
(window-when-held-fn
(lambda (item menu key) (il:* il:\;
"Edited 9-Jul-87 11:58 by Rao")
(il:* il:\;
"29-Dec-85 15:28")
(il:* il:\; "Send to window the message to respond to time out on menu")
(declare (il:specvars window-for-menu))
(when-menu-item-held window-for-menu item menu key
)))
)
(il:defineq
(sub-item-selection
(il:lambda (item menu button)
(il:* il:\;
"Edited 14-Jul-87 17:13 by Rao")
(il:* il:\;
"13-DEC-83 21:03")
(il:* il:|;;| "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
((il:nlistp item)
item)
((il:nlistp (il:setq it (cadr item)))
it)
((eq (il:setq it1 (car it))
'quote)
(cadr it))
((eq it1 'progn)
(il:eval it))
((il:listp it1)
(il:eval it1))
(t it1))))))
(dual-sub-items
(il:lambda (menu item) (il:* il:\;
"Edited 14-Jul-87 17:14 by Rao")
(il:* il:\;
"13-DEC-83 21:07")
(il:* il:|;;| "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 (il:nlistp item)
(il:nlistp (il:setq it
(cadr item)))
(eq (il:setq it1 (car it))
'quote)
(eq it1 'progn)
(il:nlistp (il:setq it1
(cadr it))))
nil)
(t it1))))))
(window-when-held-fn
(lambda (item menu key) (il:* il:\;
"Edited 9-Jul-87 11:58 by Rao")
(il:* il:\;
"29-Dec-85 15:28")
(il:* il:\; "Send to window the message to respond to time out on menu")
(declare (il:specvars window-for-menu))
(when-menu-item-held window-for-menu item menu key
)))
(do-menu-method
(il:lambda (object items) (il:* il:\;
"Edited 14-Jul-87 17:15 by Rao")
(il:* il:\;
"13-NOV-83 16:20")
(prog ((selector (and items (dual-menu items))))
(and selector (return (funcall selector object)))
)))
(dual-menu
(il:lambda (items when-held-fn)
(il:* il:\;
"Edited 14-Jul-87 17:16 by Rao")
(il:* il:\;
" 9-FEB-84 16:17")
(il:* il:\; "and pops up a menu which allows differential selection on LEFT an middle buttons")
(il:menu (il:|create| il:menu
il:items il:← items
il:whenselectedfn il:← '
sub-item-selection
il:subitemfn il:← 'dual-sub-items
il:whenheldfn il:← when-held-fn
il:changeoffsetflg il:← t))))
(dual-selection
(il:lambda (item menu button)
(il:* il:\;
"Edited 14-Jul-87 17:28 by Rao")
(il:* il:\;
"29-MAR-83 17:57")
(il:* il:|;;| "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
((il:nlistp item)
item)
((il:nlistp (il:setq it (cadr item)))
it)
((eq (il:setq it1 (car it))
'quote)
(cadr it))
((eq it1 'progn)
(il:eval it))
((eq button 'il:left)
(cond
((il:listp it1)
(il:eval it1))
(t it1)))
((il:nlistp (il:setq it1 (cadr it)))
it1)
(t (dual-menu it1)))))))
)
(il:* il:|;;| "Event Triggering")
(defmethod do-selected-command ((self web-editor)
command obj)
(il:* il:\;
"17-Sep-86 17:49")
(il:* il:|;;;|
"Do the selected command or forwards it to the object")
(if command
(il:* il:|;;| "Take care of being passed in a dummy node from browser in Lattice mode. --- Dummy nodes are indicated by having the object in a list")
(let ((args (if (il:listp command)
(cdr command)
nil))
(command (if (il:listp command)
(car command)
command))
(obj (if (il:listp obj)
(car obj)
obj)))
(if (il:fmemb command (slot-value self
'local-commands))
(do-command-in-process self self command
`(,obj ,@args))
(do-command-in-process self obj command args)
))))
(defmethod do-command-in-process ((self web-editor)
obj selector args node)
(il:* il:\;
"17-Sep-86 17:46")
(il:* il:|;;| "Does a lattice command in a separate process. Grays out the node at the beginning of the command, and ungrays it when the command completes.")
(if node (progn (shade-node self node il:grayshade2)
(eval-form-in-process self obj selector
args)
(shade-node self node il:whiteshade))
(eval-form-in-process self obj selector args)))
(defmethod eval-form-in-process ((self web-editor)
obj selector args)
(il:* il:\;
"17-Sep-86 17:48")
(il:* il:|;;|
"Maybe this should be evaluated in another process")
(apply selector obj args))
(defmethod message-form-for-process ((self web-editor)
obj selector args)
(il:* il:\;
"17-Sep-86 17:48")
(il:* il:|;;;| "Create a form to evaluate in a new process that will send the obj the selector message with the given args ")
`(eval
'(,selector
',obj
,@(il:|for| il:\x il:|in| args
il:|collect| (cond
((or (null il:\x)
(pcl::objectp il:\x))
il:\x)
(t ',il:\x))))))
(il:defineq
(eval.in.tty.context
(il:lambda (form proc-name)(il:* il:\;
"Edited 10-Jul-87 14:24 by Rao")
(il:* il:|;;;| "Evaluate the form in the current TTY process, if that process is in a TTY wait in a BREAK --- otherwise evaluate it in a new process.")
(il:process.eval
(il:tty.process)
`(,#'(il:lambda (form proc-name)
(il:|if|
(and (il:stkpos 'il:lispxread)
(eq 'il:break1a
(il:stknthname -2 (il:stkpos
'il:lispxread)))
(eq 'il:\\ttybackground
(il:stknthname 1 (il:stkpos
'il:\\process.eval1
))))
il:|then| (il:eval form)
il:|else| (il:add.process
`(progn (il:ttydisplaystream
il:*d-window-default-stream*
)
,form)
'il:name proc-name)))
',form
',proc-name))))
(lispx-send
(il:nlambda (il:msgform) (il:* il:\;
"Edited 16-Jun-87 09:47 by Rao")
(il:* il:\;
" 3-Apr-86 17:23")
(il:* il:|;;| "Send a message given, recording on history, protected form errors I can't remember why we put in the RELSTK")
(prog ((il:\\inside.ttyin))
(declare (il:specvars il:msgform))
(il:ersetq (il:lispxeval il:msgform))
(and (il:relstk (il:stkpos 'il:deditl))
(il:error!)))))
)
(il:* il:|;;| "Browser Looks Control")
(defmethod add-root ((self web-editor)
new-item) (il:* il:\;
"11-Dec-86 10:23")
(il:* il:|;;;|
"Add a named item to the starting list of the browser")
(let ((new-item (or new-item (new-item self new-item))))
(if (pcl::objectp new-item)
(progn (pushnew new-item (slot-value self
'starting-list))
(if (slot-value self 'good-list)
(pushnew new-item (slot-value
self
'good-list)))
(setf (slot-value self 'bad-list)
(il:dremove new-item
(slot-value self 'bad-list)))
(recompute self))
(prompt-print self "Nothing Added To Browser"))))
(defmethod delete-from-browser ((|self| web-editor)
|obj| |objname|)
(il:* il:\;
" 5-Aug-86 16:50")
(il:* il:|;;;| "Place on badList for Browser")
(pushnew |obj| (slot-value |self| 'bad-list))
(recompute |self|))
(defmethod delete-subtree-from-browser ((self web-editor)
obj objname)
(il:* il:\;
" 5-Jun-86 14:14")
(il:* il:|;;;|
"Delete this node and any of its subnodes from the graph")
(\\delete-subtree self (il:windowprop (slot-value
self
'window)
'il:graph)
obj)
(pushnew obj (slot-value self 'bad-list))
(recompute self))
(defmethod recompute ((self web-editor)
&optional dont-reshape-flg)
(il:* il:\;
" 8-Apr-87 14:42")
(il:* il:\;
"Recompute the browseGraph in the same window")
(prog ((graph-fits (graph-fits self)))
(show self (slot-value self 'starting-list))
(cond
((or dont-reshape-flg (null graph-fits))
(il:* il:\; "Dont Reshape or rescroll. Assume window wants to stay the same size")
)
(t (shape-to-hold self))))
self)
(defmethod recompute-in-place ((il:|self| web-editor))
(il:* il:\;
"10-Dec-84 18:27")
(il:* il:|;;;|
"recompute the graph, maintaining the current position")
(let* ((il:|visibleRegion| (il:dspclippingregion
nil
(slot-value il:|self|
'window)))
(il:\x (il:|fetch| il:left il:|of|
il:|visibleRegion|
))
(il:\y (il:|fetch| il:bottom il:|of|
il:|visibleRegion|
))) (il:* il:\; "if we want to RecomputeInPlace, we must want the window to be kept the same")
(recompute il:|self| t) (il:* il:\; "we had to save x and y because visibleRegion gets clobbered by Recompute! Suprise!")
(scroll-window il:|self| il:\x il:\y)))
(defmethod recompute-labels ((|self| web-editor))
(il:* il:\;
"27-Feb-85 11:27")
(il:* il:\;
"recompute the graph, including the labels")
(clear-label-cache |self| t)
(recompute |self|))
(defmethod remove-from-bad-list ((il:|self| web-editor))
(il:* il:\;
"28-Dec-85 10:04")
(il:* il:\; "Remove an item from BadList to allow it to be displayed once again")
(cond
((null (slot-value il:|self| 'bad-list))
(il:clrprompt)
(il:promptprint "No BadList items."))
(t
(prog ((il:|item| (il:menu
(il:|create| il:menu
il:title il:←
"BadList Items"
il:items il:←
(slot-value il:|self|
'bad-list)))))
(cond
(il:|item|
(setf (slot-value il:|self| 'bad-list)
'(il:dremove il:|item|
(slot-value il:|self|
'bad-list)))
(recompute il:|self|))
(t (il:clrprompt)
(il:promptprint "Nothing Selected")))))))
(defmethod change-font-size ((|self| web-editor)
|size|)
(il:* il:\;
"13-Dec-84 13:04")
(il:* il:\;
"Change the font size from whatever it is to size")
(or
|size|
(setq
|size|
(il:menu (cond
((il:|type?| il:menu (il:gettopval
'il:|MenuSize|))
il:|MenuSize|)
(t (il:settopval
'il:|MenuSize|
(il:|create| il:menu
il:title il:←
"Select Desired Size"
il:changeoffsetflg il:← t
il:items il:←
'((il:|Abort| nil)
8 10 12 16))))))))
(cond
(|size|
(setf (slot-value |self| 'browse-font)
(il:fontcreate
`(,(slot-value |self| 'browse-font-family)
,|size|
,(slot-value |self| 'browse-font-face))))
(il:* il:\;
"clear out the label cache!")
(recompute-labels |self|))))
(defmethod change-format ((|self| web-editor)
|format|)
(il:* il:\;
"21-Apr-84 19:52")
(il:* il:\;
"Change format between Lattice and Tree")
(cond
((il:listp |format|)
(setf (slot-value |self| 'graph-format)
|format|))
((setq |format| (il:menu (il:|create|
il:menu
il:items il:←
(slot-value |self|
'graph-format-choices)
)))
(setf (slot-value |self| 'graph-format)
|format|)))
(recompute |self|))
(defmethod change-max-label-size ((self web-editor)
new-max-width
new-max-lines)
(il:* il:\;
"13-Dec-84 13:05")
(il:* il:\; "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change")
(il:|if| new-max-lines
il:|then| (setf (slot-value self 'label-max-lines)
new-max-lines))
(il:|if| new-max-width
il:|then| (setf (slot-value self '
label-max-chars-width)
new-max-width))
(il:* il:\;
"clear out the label cache")
(recompute-labels self))
(defmethod shape-to-hold ((self web-editor))
(il:* il:\;
"13-Jan-87 16:52")
(il:* il:|;;;| "Shape the browse window to just hold the nodes with BrowserMargin to spare")
(prog (left bottom height width right top
(min-width (il:iplus
5
(il:stringwidth
(slot-value self 'title)
(il:dspfont nil
il:|WindowTitleDisplayStream|
))))
(min-height
(il:fontheight (il:dspfont
nil
(slot-value self
'window))))
(region (il:windowprop (slot-value
self
'window)
'il:region))
(nodes (il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value self
'window)
'il:graph))))
(or nodes
(return (set-region self
(il:createregion (il:|fetch|
il:left
il:|of|
region)
(il:|fetch| il:bottom
il:|of| region)
min-width min-height))))
(setq left (il:min/left nodes))
(setq bottom (il:min/bottom nodes))
(setq right (il:max/right nodes))
(setq top (il:max/top nodes))
(setq
width
(il:imax min-width
(il:imin il:|MaxLatticeWidth|
(il:widthifwindow
(il:plus il:|BrowserMargin|
(il:idifference right left)
)
(il:windowprop (slot-value
self
'window)
'il:border)))))
(setq height (il:imax min-height
(il:imin il:|MaxLatticeHeight|
(il:plus
il:|BrowserMargin|
(il:idifference
top bottom)))))
(and (il:eqp width (il:|fetch| il:width
il:|of| region))
(il:eqp (il:heightifwindow
height
(il:windowprop (slot-value
self
'window)
'il:title)
(il:windowprop (slot-value
self
'window)
'il:border))
(il:|fetch| il:height il:|of| region))
(return t))
(set-region self (il:createregion (il:|fetch|
il:left
il:|of|
region)
(il:|fetch| il:bottom
il:|of| region)
width height)
nil)))
(il:* il:|;;| "Node Marking and Selecting")
(defmethod box-node ((self web-editor)
object keep-previous-box)
(il:* il:\;
" 8-Apr-87 18:34")
"Puts a box around the node in the graph representing the object"
(il:* il:|;;| "If there was a previously boxed node, remove the box from around it and set it to nil")
(when (and (not keep-previous-box)
destination-browser
(slot-value destination-browser 'boxed-node))
(highlight-node destination-browser
(slot-value destination-browser 'boxed-node)
'il:invert)
(setf (slot-value destination-browser 'boxed-node)
nil))
(setq destination-browser self) (il:* il:\;
"update the global")
(highlight-node self object (slot-value self '
box-line-width))
(setf (slot-value self 'boxed-node)
object))
(defmethod display-node-hightlights ((self web-editor)
node shade box-width)
(il:* il:\;
"13-Dec-85 15:15")
(il:* il:\;
"New method template")
(il:reset/node/border node (cond
(shade (list box-width shade
))
(t box-width))
(slot-value self 'window)))
(defmethod display-node-shading ((self web-editor)
node shade)
(il:* il:\;
"13-Dec-85 15:13")
(il:* il:\;
"New method template")
(il:reset/node/labelshade node (or shade il:whiteshade)
(slot-value self 'window)))
(defmethod flash-node ((il:|self| web-editor)
il:|node| il:n il:|flashTime|
il:|leaveFlipped?|)
(il:* il:\;
"12-Dec-84 16:09")
(il:* il:\;
"Flip node N times")
(il:setq il:|node|
(il:fassoc (cond
((il:litatom il:|node|)
(il:setq il:|node| (il:|GetObjectRec|
il:|node|)))
(t il:|node|))
(il:|fetch| il:graphnodes
il:|of| (il:windowprop (slot-value il:|self|
'window)
'il:graph))))
(il:|if| il:|node|
il:|then| (il:|for| il:\i il:|from| 1
il:|to| (or il:n 3)
il:|do| (il:flipnode il:|node|
(slot-value il:|self|
'window))
(il:dismiss (or il:|flashTime| 300)
)
(il:flipnode il:|node|
(slot-value il:|self|
'window))
(il:dismiss (or il:|flashTime| 300)
))
(il:|if| il:|leaveFlipped?|
il:|then| (il:flipnode il:|node|
(slot-value il:|self|
'window)))))
(defmethod flip-node ((self web-editor)
object) (il:* il:\;
"13-Dec-85 15:18")
(il:* il:\; "Inverts the video around the node in the graph representing the object")
(let ((node (il:fassoc (cond
((il:litatom object)
(il:setq object (
il:|GetObjectRec|
object)))
(t object))
(il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value self
'window)
'il:graph)))))
(and node (display-node-shading self node
(il:inverted/shade/for/grapher
(il:|fetch| il:nodelabelshade
il:|of| node))))))
(defmethod get-display-label ((self web-editor)
object)
(il:* il:|;;;| "get the display label. use the cache if it provides the answer; if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result.")
(let
((cached-label (il:assoc object (slot-value
self
'label-cache))))
(il:|if| cached-label
il:|then| (cdr cached-label)
il:|else| (let ((new-label (box-print-string
(get-label self object)
(slot-value self
'
label-max-chars-width
)
(slot-value self
'label-max-lines)
(slot-value self
'browse-font))))
(il:|if| (il:listp new-label)
il:|then| (il:* il:\;
"GRAPHER dies if the label is a list")
(il:setq new-label
(il:mkstring new-label)))
(push (cons object new-label)
(slot-value self 'label-cache))
new-label))))
(defmethod highlight-node ((self web-editor)
object width shade)
(il:* il:\;
"13-Dec-85 15:16")
(il:* il:|;;;|
"highlight a node by surronding it with a shaded box")
(let ((node (il:fassoc object
(il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value self
'window)
'il:graph)))))
(and node (display-node-hightlights self node shade
width))))
(defmethod remove-highlights ((il:|self| web-editor))
(il:* il:\;
"13-Dec-85 15:16")
(il:* il:|;;;|
"gets rid of all highlighting in the lattice")
(il:|for| il:|node|
il:|in| (il:|fetch| il:graphnodes
il:|of| (il:windowprop (slot-value
il:|self|
'window)
'il:graph))
il:|do| (display-node-hightlights il:|self| il:|node|
nil))
(setf (slot-value il:|self| 'boxed-node)
nil))
(defmethod remove-shading ((il:|self| web-editor))
(il:* il:\;
"13-Dec-85 15:14")
(il:* il:|;;;| "gets rid of all shading in the lattice")
(il:|for| il:|node|
il:|in| (il:|fetch| il:graphnodes
il:|of| (il:windowprop (slot-value
il:|self|
'window)
'il:graph))
il:|do| (display-node-shading il:|self| il:|node|
il:whiteshade)))
(defmethod unmark-nodes ((il:|self| web-editor))
(il:* il:\;
"10-Dec-84 12:27")
(il:* il:\; "clear the graph nodes, removing all shading and highlighting")
(remove-highlights il:|self|)
(remove-shading il:|self|))
(defmethod shade-node ((il:|self| web-editor)
il:|object| il:|shade|)
(il:* il:\;
"15-Jan-87 18:34")
(il:* il:|;;;| "shade the background of a node")
(let
((il:|node| (il:fassoc
(cond
((il:litatom il:|object|)
(il:setq il:|object| (
il:|GetObjectRec|
il:|object|)))
(t il:|object|))
(il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value il:|self|
'window)
'il:graph)))))
(il:|if| il:|node|
il:|then|
(il:|if| (il:bitmapp (il:|fetch| il:nodelabel
il:|of| il:|node|))
il:|then|
(il:* il:|;;| "Need to forget the old bitmap, in case it already has a shade blt'ed into it. This will fail if the GetDisplayLabel msg returns something different from the previous value, but what can you do?")
(clear-label-cache il:|self| il:|object|)
(let ((il:|newLabel| (get-display-label
il:|self|
il:|object|)))
(il:|replace| il:nodelabel il:|of|
il:|node|
il:|with| il:|newLabel|)
(il:|if| (and il:|shade| (il:bitmapp
il:|newLabel|))
il:|then| (il:bitblt nil nil nil
il:|newLabel| nil nil
nil nil 'il:texture
'il:paint il:|shade|)
)))
(display-node-shading il:|self| il:|node|
il:|shade|))))
(defmethod has-object ((self web-editor)
object) (il:* il:\;
"28-May-84 12:56")
(il:* il:\; "Check object in grapher nodes, and return if it is one of them")
(and (il:fassoc (il:|GetObjectRec| object)
(il:|fetch| il:graphnodes
il:|of| (il:windowprop (slot-value
self
'window)
'il:graph)))
t))
(defmethod make-parameter-menu ((self web-editor)
menu test-form change-form)
(il:* il:\;
"17-Sep-86 18:11")
(il:* il:|;;;|
"Create a menu for viewing a parameter of self")
(il:|replace| il:whenselectedfn il:|of| menu
il:|with|
(il:function (il:lambda (item menu)
(let
((self (il:getmenuprop menu
'self))
(test-form (il:getmenuprop
menu
'test-form))
(change-form (il:getmenuprop
menu
'change-form)))
(il:|if| item
il:|then|
(il:shadeitem item menu
il:blackshade)
(il:apply*
change-form self
(il:|if| (il:listp item)
il:|then| (cadr item)
il:|else| item))
(il:|for| item
il:|in| (il:|fetch| il:items
il:|of| menu)
il:|do|
(il:|if|
(il:apply*
test-form self
(il:|if| (il:listp item)
il:|then| (cadr item)
il:|else| item))
il:|then| (il:shadeitem
item menu
il:highlightshade
)
il:|else| (il:shadeitem
item menu
il:whiteshade))))
))))
(il:putmenuprop menu 'self self)
(il:putmenuprop menu 'test-form test-form)
(il:putmenuprop menu 'change-form change-form)
(il:|for| item il:|in| (il:|fetch| il:items il:|of|
menu)
il:|do| (il:|if| (il:apply* test-form self
(il:|if| (il:listp item)
il:|then| (cadr item)
il:|else| item))
il:|then| (il:shadeitem item menu
il:highlightshade)
il:|else| (il:shadeitem item menu
il:whiteshade)))
menu)
(defmethod new-item ((self web-editor)
new-item) (il:* il:\;
"23-Jan-85 13:02")
(il:* il:\;
"Return Object. Prompt for it if needed.")
(class-named (or new-item (prompt-read self
"Give name of item to be added"
))))
(defmethod obj-name-pair ((il:|self| web-editor)
il:|obj|)
(il:* il:\; il:|smL|
"15-Aug-86 09:24")
(il:* il:|;;;| "Make a pair (object . objName) where objName is label to be used in browser")
(let
nil
(il:|if| (null il:|obj|)
il:|then| nil
il:|elseif| (and (slot-value il:|self| 'good-list)
(not (il:fmemb il:|obj|
(slot-value il:|self|
'good-list))))
il:|then| nil
il:|elseif| (il:fmemb il:|obj| (slot-value
il:|self|
'bad-list))
il:|then| nil
il:|else| (cons il:|obj| (get-display-label il:|self|
il:|obj|)))))
(defmethod object-from-label ((self web-editor)
label)
(il:* il:\;
" 4-Jan-85 18:20")
(il:* il:|;;;| "What object has this label?")
(let
((object-node
(il:|for| il:|node|
il:|in| (il:|fetch| il:graphnodes
il:|of| (il:windowprop
(slot-value self 'window)
'il:graph))
il:|thereis| (il:equal label (il:|fetch|
il:nodelabel
il:|of| il:|node|)
))))
(il:|if| (il:nlistp (car object-node))
il:|then| (car object-node)
il:|else| nil)))
(defmethod position-node ((self web-editor)
object window-x window-y)
(il:* il:\;
"10-Dec-84 18:24")
(il:* il:|;;;| "scrolls the window so that the node is in the given position of the window. If windowX or windowY is a FLOATP, it it taken to be a window-relative postion; if a FIXP, it is a window-absolute position.")
(let ((region (node-region self object)))
(il:|if| region
il:|then| (scroll-window self
(il:|fetch| il:left il:|of|
region)
(il:|fetch| il:bottom
il:|of| region)
window-x window-y))))
(il:* il:|;;| "Dubious Methods")
(defmethod save-in-it ((self web-editor))
(il:* il:\;
" 5-Sep-86 12:40")
(il:* il:|;;;|
"A Browser command to save self in SavedValue")
(il:|PutSavedValue| self))
(defmethod sub-browser ((il:|self| web-editor)
il:|obj| il:|objName|)
(il:* il:\;
"13-Sep-84 22:10")
(il:* il:\;
"Create a subbrowser on selected object")
(il:|←New|
(il:|Class| il:|self|)
browse il:|obj|))
(defmethod unread ((self web-editor)
object) (il:* il:\;
"15-Aug-86 10:57")
(il:* il:|;;;| "Unread name into system buffer --- or if no node, unread the entire graph")
(let
((obj-name (and object (object-name object)))
(image-obj
(cond
(object obj-name)
(t
(il:grapherobj
(let
((il:|graph| (il:windowprop (slot-value
self
'window)
'il:graph)))
(il:* il:|;;| "Need to make a copy of the graph w/o any objects, so non-Loops systems can look at the resulting graph")
(il:|create| il:graph
il:|using|
il:|graph| il:graphnodes il:←
(il:|for| il:|node|
il:|in| (il:|fetch| il:graphnodes
il:|of| il:|graph|)
il:|collect|
(il:|create| il:graphnode
il:|using| il:|node| il:nodeid il:←
(\\portable-graph-node-id
(il:|fetch| il:nodeid
il:|of| il:|node|))
il:tonodes il:←
(il:|for| il:|id|
il:|in| (il:|fetch|
il:tonodes
il:|of| il:|node|)
il:|collect| (
\\portable-graph-node-id
il:|id|))
il:fromnodes il:←
(il:|for| il:|id|
il:|in| (il:|fetch|
il:fromnodes
il:|of| il:|node|)
il:|collect| (
\\portable-graph-node-id
il:|id|))))))))
))) (il:* il:\; "Need to check for TEdit target, since TEdit doesn't use the COPYINSERT protocol!")
(il:|if| (and (not (or (il:stringp image-obj)
(il:imageobjp image-obj)))
(il:windowprop (il:process.tty (
il:tty.process
))
'il:copyinsertfn))
il:|then|
(il:* il:|;;| "It is expecting something and we don't have an image object or string to give it, so we need to convert it first")
(il:copyinsert (il:mkstring image-obj))
il:|else| (il:copyinsert image-obj))))
(il:* il:|;;;| "AUXILIARY Stuff")
(il:defineq
(find-selected-node
(il:lambda (window) (il:* il:\;
"Edited 22-Sep-87 17:32 by kirk:")
(il:* il:\;
"10-Dec-84 17:53")
(il:* il:|;;| "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.")
(il:* il:|;;| "Also this was modified to pop up the middle button menu on button down rather than button up.")
(prog ((loops-window (il:windowprop window 'web-editor)
)
(nodelst (il:|fetch| (il:graph il:graphnodes)
il:|of| (il:windowprop window
'il:graph)))
(ds (il:windowprop window 'il:dsp))
button oldpos reg now near)
(il:* il:\;
"note which button is down.")
(il:* il:\;
"get the region of this window.")
(il:setq reg (il:windowprop window 'il:region))
(il:|until| (il:lastmousestate (or il:left
il:middle))
il:|do| (il:getmousestate))
(il:setq near (il:nodelst/as/menu nodelst
(il:setq oldpos
(il:cursorposition nil ds))
))
il:flip
(when (il:lastmousestate il:middle)
(return (il:|fetch| il:nodeid il:|of|
near)))
(and now (il:flipnode now ds))
(and near (il:flipnode near ds))
(il:setq now near)
il:lp
(il:* il:\;
"wait for a button up or move out of region")
(il:getmousestate)
(cond
((il:lastmousestate (and (not il:left)
(not il:middle)))
(il:* il:\;
"left button up, process it.")
(and now (il:flipnode now ds))
(il:* il:\;
"NOW node has been selected.")
(return (il:|fetch| il:nodeid il:|of| now)))
((not (il:inside? (il:windowprop window
'il:region)
il:lastmousex il:lastmousey))
(il:* il:\;
"outside of region, return")
(and now (il:flipnode now ds))
(return))
((eq now (il:setq near
(il:nodelst/as/menu nodelst
(il:cursorposition nil ds
oldpos))))
(go il:lp))
(t (go il:flip))))))
)
(il:defineq
(add-menu-window
(il:lambda (menu-group main-window edge menu-window-title
) (il:* il:\;
"Edited 10-Jul-87 18:48 by Rao")
(il:* il:|;;;| "Add an attached window to self containing the given menus --- put the menus in a row unless vertical? is true, in which case stack them in a single column")
(let* ((minimum-menu-size (menu-group-size menu-group))
(minimum-window-size (cons (il:widthifwindow
(car
minimum-menu-size
))
(il:heightifwindow
(cdr
minimum-menu-size
)
menu-window-title)))
(menu-window (il:createw (il:createregion
0 0 (car
minimum-window-size
)
(cdr
minimum-window-size
))
menu-window-title nil t)))
(il:windowprop menu-window 'il:minsize
minimum-window-size)
(il:windowprop
menu-window
'il:maxsize
(il:selectq edge
((il:top il:bottom)
(cons nil (il:heightifwindow
(cdr minimum-menu-size)
menu-window-title)))
((il:left il:right)
(cons (il:widthifwindow (car
minimum-menu-size
))
nil))
nil))
(il:windowprop menu-window 'menu-group menu-group
)
(il:windowaddprop menu-window 'il:repaintfn
'repaint-menu-window)
(il:windowaddprop menu-window 'il:reshapefn
(il:function (il:lambda (window)
(il:redisplayw window))))
(il:attachwindow menu-window main-window edge
'il:justify
'il:localclose)
menu-window)))
(box-print-string
(il:lambda (string max-chars-width max-lines font
old-bitmap)
(il:* il:\;
"Edited 10-Jul-87 18:50 by Rao")
(il:* il:\;
"29-Mar-85 13:51")
(il:* il:\; "return a bitmap containing the string, in the given font, with MAX-WIDTH at most width")
(il:* il:\;
"sizes of NULL or 0 mean no max size")
(il:setq max-chars-width (or max-chars-width 0))
(il:setq max-lines (or max-lines 0))
(il:|if| (il:zerop max-chars-width)
il:|then| (il:* il:\;
"no max width, then just return the STRING")
string
il:|else|
(prog ((max-width (il:itimes max-chars-width
(il:stringwidth "A" font)))
(nchars (il:nchars string))
(nlines 0)
(spos 0)
(region (il:constant (il:|create| il:region)))
(true-max-width 0)
nextpos dsp substr)
(il:setq string (il:mkstring string))
(il:* il:\;
"we need to find the size of the resultant bitmap")
il:nextbreak
(il:|if| (il:ilessp spos nchars)
il:|then|
(il:|add| nlines 1)
(il:* il:\;
"at least one character, even if exceed MAX-WIDTH")
(il:setq nextpos
(il:imax 1
(car (break-string-for-boxing
(il:substring string
(il:add1 spos)
-1)
max-width font))))
(il:setq true-max-width
(il:imax true-max-width
(il:stringwidth (il:substring
string
(il:add1 spos)
(il:iplus spos
nextpos))
font)))
(il:|add| spos nextpos)
(go il:nextbreak))
(il:|if| (not (il:zerop max-lines))
il:|then| (il:setq nlines (il:imin
max-lines
nlines)))
(il:* il:\;
"that we have the size, lets build it")
(il:setq dsp
(il:dspcreate
(il:|if|
(and
old-bitmap
(not
(or (il:greaterp true-max-width
(il:bitmapwidth old-bitmap))
(il:greaterp
(il:itimes nlines (il:fontprop
font
'il:height))
(il:bitmapheight old-bitmap)))))
il:|then| old-bitmap
il:|else| (il:bitmapcreate
true-max-width
(il:itimes nlines
(il:fontprop font
'il:height))))))
(il:dspfont font dsp)
(il:dspreset dsp)
(il:setq spos 0)
(il:|replace| il:left il:|of| region
il:|with| 0)
(il:|replace| il:width il:|of| region
il:|with| true-max-width)
(il:|replace| il:height il:|of| region
il:|with| (il:fontprop font 'il:height))
(il:|replace| il:bottom il:|of| region
il:|with| (il:itimes nlines
(il:fontprop font
'il:height)))
il:nextpiece
(il:|add| nlines -1)
(il:|if| (il:ilessp spos nchars)
il:|then|
(il:setq nextpos
(il:imax 1
(car (break-string-for-boxing
(il:substring string
(il:add1 spos)
-1)
true-max-width font))))
(il:setq substr (il:substring string
(il:add1 spos)
(il:iplus nextpos
spos)))
(il:|replace| il:bottom il:|of| region
il:|with| (il:idifference (il:|fetch|
il:bottom
il:|of|
region)
(il:|fetch| il:height
il:|of| region)))
(il:|if| (and (il:zerop nlines)
(il:ilessp (il:iplus nextpos
spos)
nchars))
il:|then| (il:* il:\;
"we need to abbreviate!")
(il:centerprintinregion
(il:concat (il:substring substr
1 -3)
"...")
region dsp)
(go il:alldone)
il:|else| (il:* il:\;
"out this piece")
(il:centerprintinregion substr
region dsp)
(il:|add| spos nextpos)
(go il:nextpiece)))
il:alldone
(return (il:dspdestination nil dsp))))))
(box-window-node
(il:lambda (il:|nodeLabel| window)
(il:* il:\;
" 7-Sep-84 14:36")
(il:* il:\; il:\a
il:|box| il:|around|
il:|the| il:|node|
il:|with|
il:|nodeLabel| il:|in|
il:|the| il:|graph.|
il:a il:|nodeLabel|
il:|in| il:|browsers|
il:|is| il:|an|
il:|object.|
il:|Does| il:|nothing|
il:|if| il:|node|
il:|not| il:|found.|)
(prog (il:|node| il:|nodes|)
(cond
((and (il:windowp window)
(il:setq il:|nodes|
(il:|fetch| il:graphnodes
il:|of| (il:windowprop window
'il:graph)))
(il:setq il:|node| (il:fassoc
il:|nodeLabel|
il:|nodes|)))
(il:drawareabox (il:gn/left il:|node|)
(il:gn/bottom il:|node|)
(il:|fetch| il:nodewidth il:|of|
il:|node|)
(il:|fetch| il:nodeheight il:|of|
il:|node|)
1
'il:invert window))))))
(break-string-for-boxing
(il:lambda (il:msg il:width il:font)
(il:* il:\;
"11-Dec-84 10:29")
(il:* il:\;
il:|Stolen| il:|from|
il:|the| il:|function|
il:iconw.formatline
il:-- il:|modified|
il:|to| il:|try|
il:|to| il:|break|
il:|at| "word"
il:|boundaries,|
il:|whatever|
il:|they| il:|are|)
(il:* il:\; il:\a
il:|list| il:|of|
il:|the| il:|char#|
il:|relative| il:|to|
il:|char| 1 il:|of|
il:|where| il:|to|
il:|break| il:|next|
il:|line,| il:|and|
il:|how| il:|much|
il:|space| il:|was|
left il:|over|
(il:|for|
il:|centering| il:&\c))
(cond
(il:msg (il:* il:\; il:|there|
il:|really| il:|is|
il:\a il:|title,|
il:|go| il:|ahead|
il:|and| il:|format|
il:|the| il:|next|
il:|line.|)
(il:|bind| (il:tx il:← 0)
(il:lastb il:← 0)
(il:ch il:← 0)
(il:tmsg il:← (il:openstringstream il:msg))
(il:msglen il:← (il:nchars il:msg))
il:|for| il:i il:|from| 1 il:|by| 1
il:|do| (il:* il:\; il:|thru|
il:|the|
il:|characters|
il:|one| il:|by|
il:|one.|)
(cond
((il:igreaterp il:tx il:width)
(il:* il:\; il:|past|
il:|the| il:|right|
il:|margin.|
il:|Time| il:|to|
il:|stop.|)
(il:closef? il:tmsg)
(return
(cond
((il:listp il:lastb)
(il:* il:\; il:|is|
il:\a il:|space|
il:|we| il:|can|
il:|break| il:|the|
il:|line| il:|at.|
il:|Break| il:|there.|)
il:lastb)
(t (il:* il:\; il:|were|
il:|no| il:|spaces|
il:|on| il:|this|
il:|line.| il:|Break|
il:|after| il:|the|
il:|last|
il:|character|
il:|that| il:|did|
il:|fit.|)
(cons (il:idifference il:i 2)
(il:idifference
il:width
(il:idifference il:tx
(il:charwidth il:ch
il:font))))))))
((il:eofp il:tmsg) (il:* il:\; il:|was|
il:|the| il:|last|
il:|character.|)
(il:closef? il:tmsg)
(return (cons (il:sub1 il:i)
(il:idifference il:width il:tx
))))
(t (il:* il:\; il:|at|
il:|the| il:|next|
il:|character.|)
(il:setq il:ch (il:bin il:tmsg))
(il:selcharq il:ch
((il:space il:\. il:\: il:\; il:\, /
il:\\ il:* - il:\#)
(il:* il:\; il:|where|
il:|word| il:|breaks|
il:|are,| il:|so|
il:|we| il:|can|
il:|back| il:|up|
il:|and| il:|split|
il:|lines| il:|there|
il:|if| il:|possible.|)
(il:setq il:lastb
(cons il:i (il:idifference
il:width il:tx))))
(il:cr (il:* il:\;
il:|forces| il:\a
il:|new| il:|line.|)
(return (cons (il:iminus il:i)
(il:idifference
il:width il:tx))
))
(il:|if|
(and (not (il:u-casep (il:character
il:ch)))
(not (il:eofp il:tmsg))
(il:u-casep (il:peekc il:tmsg)))
il:|then| (il:* il:\; il:|from|
il:|upper| il:|to|
il:|lower| il:|case|
il:|is| il:|also|
il:\a il:|word|
il:|break|)
(il:setq il:lastb
(cons il:i (il:idifference
il:width il:tx)
))))
(il:setq il:tx (il:iplus il:tx
(il:charwidth il:ch
il:font)))))))
(t (il:* il:\; il:|isn't|
il:\a il:|title;|
il:|return| il:\a
il:|dummy| il:|entry|
il:|for| il:|the|
il:|line|
il:|formatter.|)
(cons 0 il:width)))))
(fileclasses
(il:lambda (il:file) (il:* il:\;
"13-DEC-83 09:32")
(il:filecomslst il:file 'il:classes)))
(items-for-type
(il:lambda (il:|browser| il:|object| il:|objName|
il:|type|) (il:* il:\;
"11-Apr-86 14:54")
(cond
((null (slot-value il:|browser| ''boxed-node))
(il:|promptprint| il:|browser|
"First Box the node which is target for move."
)
nil)
(t (let ((il:|items| (il:sort (il:|listattribute|
il:|object| il:|type|
))))
(cond
((null il:|items|)
(il:|promptprint| il:|browser|
(il:concat il:|objName|
" has no " il:|type|))
nil)
(t il:|items|)))))))
(menu-group-size
(il:lambda (il:|menu-group|) (il:* il:\;
"10-Sep-86 09:53")
(il:* il:\;
il:|Compute| il:|the|
il:|minimum| il:|size|
il:|of| il:|the|
il:|menu| il:|group|)
(\\menu-group-size il:|menu-group| nil)))
(repaint-menu-window
(il:lambda (window) (il:* il:\;
"10-Sep-86 10:57")
(il:* il:\;
il:|Repaint| il:|the|
il:|menus| il:|in|
il:|the| window)
(let ((il:|menu-group| (il:windowprop window
'il:|menu-group|)))
(\\remove-menu-group-from-window il:|menu-group|
window)
(il:clearw window)
(\\place-menu-group-in-window il:|menu-group|
(menu-group-size il:|menu-group|)
window 0 0 (il:windowprop window
'il:width)
(il:windowprop window 'il:height)
nil))))
(\\delete-subtree
(il:lambda (self graph obj)(il:* il:\;
"Edited 10-Jul-87 18:05 by Rao")
(il:* il:\;
" 5-Jun-86 14:15")
(il:* il:\; "Delte the object and any of its subchildren from the GRAPH")
(il:|for| il:|child|
il:|in| (il:|fetch| il:tonodes
il:|of| (il:|for| il:|node|
il:|in| (il:|fetch|
il:graphnodes
il:|of| graph)
il:|thereis|
(eq obj (car il:|node|))))
il:|when| (not (il:memb il:|child|
(slot-value
self
''bad-list)))
il:|do| (pushnew il:|child|
(slot-value self ''bad-list))
(\\delete-subtree self graph il:|child|))))
(\\menu-group-size
(il:lambda (menu-group vertical?)
(il:* il:\;
"Edited 10-Jul-87 19:24 by Rao")
(il:* il:\;
"10-Sep-86 17:25")
(il:* il:\;
"Compute the minimum size of the menu group")
(il:|if| (il:|type?| il:menu menu-group)
il:|then| (cons (il:plus 2 (il:|fetch|
il:imagewidth
il:|of| menu-group))
(il:plus 2 (il:|fetch|
il:imageheight
il:|of| menu-group)))
il:|elseif| (il:stringp menu-group)
il:|then| (cons (il:plus 2 (il:stringwidth
menu-group
(il:dspfont nil
il:|WindowTitleDisplayStream|
)))
(il:plus 2 (il:fontprop
(il:dspfont nil
il:|WindowTitleDisplayStream|
)
'il:height)))
il:|elseif| vertical?
il:|then| (il:|for| il:|menu| il:|in| menu-group
il:|bind| (il:|running-size|
il:←
(cons 0 0))
il:|size|
il:|do| (il:setq il:|size|
(\\menu-group-size il:|menu|
nil))
(setf (car il:|running-size|)
(max il:datum (car
il:|size|
)))
(il:|add| (cdr il:|running-size|
)
(cdr il:|size|))
il:|finally| (return il:|running-size|
))
il:|else| (il:|for| il:|menu| il:|in| menu-group
il:|bind| (il:|running-size|
il:←
(cons 0 0))
il:|size|
il:|do| (il:setq il:|size|
(\\menu-group-size il:|menu| t)
)
(il:|add| (car il:|running-size|)
(car il:|size|))
(setf (cdr il:|running-size|)
(max il:datum (cdr il:|size|
)))
il:|finally| (return il:|running-size|))
)))
(\\place-menu-group-in-window
(il:lambda (il:|menu-group| il:|menu-group-size| window
left bottom width height il:|vertical?|
) (il:* il:\;
"10-Sep-86 18:52")
(il:* il:\; il:|Place|
il:|the|
il:|menu-group|
il:|in| il:|the|
il:|region| il:|of|
il:|the| window
il:|given| il:|by|
il:|the| il:|left,|
il:|bottom,|
il:|width,| il:|and|
height)
(let
((il:|excess-width| (il:difference width (car
il:|menu-group-size|
)))
(il:|excess-height| (il:difference height
(cdr il:|menu-group-size|)
)))
(il:|if| (il:|type?| il:menu il:|menu-group|)
il:|then| (il:addmenu il:|menu-group| window
(il:|create| il:position
il:xcoord il:←
(il:plus left
(il:quotient
il:|excess-width|
2))
il:ycoord il:←
(il:plus bottom
(il:quotient
il:|excess-height|
2))))
il:|elseif| (il:stringp il:|menu-group|)
il:|then|
(il:resetlst
(il:resetsave
nil
`(il:dspfont ,(il:dspfont (il:dspfont nil
il:|WindowTitleDisplayStream|
)
window) ,window))
(il:centerprintinregion il:|menu-group|
(il:createregion left bottom width height)
window))
il:|elseif| il:|vertical?|
il:|then|
(il:|for| il:|menu| il:|in| il:|menu-group|
il:|bind| (il:|space|
il:←
(il:quotient il:|excess-height|
(il:add1 (il:length
il:|menu-group|
))))
(il:|running-bottom| il:←
(il:plus bottom height))
il:|menu-size|
il:|do| (il:setq il:|menu-size|
(\\menu-group-size il:|menu| nil))
(setf il:|running-bottom|
(il:difference il:datum
(il:plus il:|space|
(cdr il:|menu-size|))
))
(\\place-menu-group-in-window
il:|menu| il:|menu-size| window left
il:|running-bottom| width (cdr
il:|menu-size|
)
nil))
il:|else|
(il:|for| il:|menu| il:|in| il:|menu-group|
il:|bind| (il:|space| il:←
(il:quotient il:|excess-width|
(il:add1 (il:length
il:|menu-group|
))))
(il:|running-left| il:← left)
il:|menu-size|
il:|do| (il:setq il:|menu-size| (
\\menu-group-size
il:|menu| t))
(il:|add| il:|running-left| il:|space|)
(\\place-menu-group-in-window il:|menu|
il:|menu-size| window
il:|running-left| bottom
(car il:|menu-size|)
height t)
(il:|add| il:|running-left| (car
il:|menu-size|
)))))))
(\\portable-graph-node-id
(il:lambda (il:|id|) (il:* il:\;
"15-Aug-86 11:11")
(il:* il:\;
il:|Create| il:\a
il:|graph| il:|node|
il:|id| il:|from|
il:|the| il:|given|
il:|id| il:|that|
il:|can| il:|be|
il:|ported| il:|to|
il:|nonLoops|
il:|systems|)
(il:|if| (not (il:|Object?| il:|id|))
il:|then| (il:pack* il:|id|)
il:|elseif| (il:|GetObjectName| il:|id|)
il:|then| (il:pack* (list 'il:$ (or (
il:|GetObjectName|
il:|id|)
(il:uid il:|id|
))))
il:|else| (il:pack* (list 'il:$& (il:|classname|
il:|id|)
(il:uid il:|id|))))))
(\\remove-menu-group-from-window
(il:lambda (il:|menu-group| window)
(il:* il:\;
"10-Sep-86 17:26")
(il:* il:\;
il:|Remove| il:|the|
il:|menu| il:|group|
il:|from| il:|the|
window)
(il:|if| (il:stringp il:|menu-group|)
il:|then| nil
il:|elseif| (il:listp il:|menu-group|)
il:|then| (il:|for| il:|menu| il:|in|
il:|menu-group|
il:|do| (
\\remove-menu-group-from-window
il:|menu| window))
il:|elseif| (il:memb il:|menu-group|
(il:windowprop window 'il:menu))
il:|then| (il:deletemenu il:|menu-group| nil window
))))
)
(il:defineq
(tree-roots
(il:lambda (node-lst) (il:* il:\;
"Edited 10-Jul-87 19:22 by Rao")
(il:* il:\;
"29-Sep-86 19:46")
(il:* il:|;;| "Computes a minimal set of root nodes for a lattice --- those with no connections TO them in list of nodes, or a single node from a cycle of nodes.")
(prog ((root-nodes (il:ldifference
node-lst
(il:|for| il:|node| il:|in|
node-lst
il:|join| (child-nodes il:|node|
node-lst))))
reachable-nodes not-reachable-nodes)
(setq reachable-nodes (il:copy root-nodes))
(setq not-reachable-nodes (il:ldifference
node-lst
reachable-nodes)
) (il:* il:\; "recompute the nodes that can't be reached from the current rootNodes")
il:|RecomputeReachableNodes|
(il:* il:|;;| "Compute the transitive closure of the set of reachableNodes --- updating the notReachableNodes at the same time")
(il:|for| il:|node| il:|in| reachable-nodes
il:|do| (il:|for| il:|childNode|
il:|in| (child-nodes il:|node|
node-lst)
il:|when| (il:memb il:|childNode|
not-reachable-nodes
)
il:|do|
(il:* il:|;;| "put the newly found reachable node at the end of the list, so we will find it later on during this iteration")
(il:nconc1 reachable-nodes
il:|childNode|)
(setq not-reachable-nodes
(il:dremove
il:|childNode|
not-reachable-nodes
))))
(il:* il:\;
"if we can reach all the nodes, fine...")
(il:|if| (null not-reachable-nodes)
il:|then| (il:* il:\;
"Now need to prune down to a minimal set")
(il:|bind| (il:|stable?| il:← nil)
il:|until| il:|stable?|
il:|do|
(setq il:|stable?| t)
(il:|for| il:|node| il:|in| root-nodes
il:|bind| il:|extraRoots|
il:|do|
(setq il:|extraRoots|
(il:dremove il:|node|
(il:intersection
root-nodes
(reachable-nodes!
il:|node| node-lst
))))
(il:|if| il:|extraRoots|
il:|then| (setq il:|stable?| nil)
(setq root-nodes
(il:ldifference
root-nodes
il:|extraRoots|)
)
(return t))
il:|finally| (return nil)))
(il:* il:\;
"return the node ids, not the GRAPHNODES")
(return (il:|for| il:|node| il:|in|
root-nodes
il:|collect| (il:|fetch| il:nodeid
il:|of| il:|node|)
))
il:|else| (il:* il:\; "must be a cycle. Select the least prolific node in the cycle as the a new root node.")
(il:|push|
root-nodes
(let ((prolific-node
(il:|for| il:|node| il:|in|
not-reachable-nodes
il:|smallest| (il:length
(il:|fetch|
il:tonodes
il:|of| il:|node|)
))))
(setq not-reachable-nodes
(il:dremove prolific-node
not-reachable-nodes))
prolific-node))
(go il:|RecomputeReachableNodes|)))))
(child-nodes
(il:lambda (parent-node node-list)
(il:* il:\;
"Edited 10-Jul-87 19:23 by Rao")
(il:* il:\;
" 8-Oct-85 14:15")
(il:* il:\; "Find all GRAPHNODES that are immediatly reachable from this node")
(il:|for| il:|label| il:|in| (il:|fetch| il:tonodes
il:|of| parent-node)
il:|collect| (il:|for| il:|node| il:|in| node-list
il:|thereis| (eq il:|label|
(il:|fetch|
il:nodeid
il:|of|
il:|node|)
)))))
(reachable-nodes!
(il:lambda (il:|root| il:|nodeList|)
(il:* il:\;
"30-Sep-86 10:22")
(il:* il:\;
il:|Return| il:\a
il:|list| il:|of|
il:|all| il:|nodes|
il:|that| il:|are|
il:|reachable|
il:|from| il:|the|
il:|root|)
(let ((il:|reachableNodes| (list il:|root|)))
(il:|for| il:|node| il:|in| il:|reachableNodes|
il:|do| (il:|for| il:|childNode|
il:|in| (child-nodes il:|node|
il:|nodeList|)
il:|when| (not (il:memb
il:|childNode|
il:|reachableNodes|
))
il:|do| (il:* il:\; il:|put|
il:|the| il:|newly|
il:|found|
il:|reachable|
il:|node| il:|at|
il:|the| il:|end|
il:|of| il:|the|
il:|list,| il:|so|
il:|we| il:|will|
il:|find| il:|it|
il:|later| il:|on|
il:|during| il:|this|
il:|iteration|)
(il:nconc1 il:|reachableNodes|
il:|childNode|)))
il:|reachableNodes|)))
)
(il:rpaq web-stream il:promptwindow)
(il:rpaqq il:|BrowserMargin| 0)
(il:rpaqq il:grayshade1 1)
(il:rpaqq il:grayshade2 1025)
(il:rpaqq il:grayshade3 64510)
(il:rpaqq il:grayshade4 65534)
(il:rpaqq il:|MaxLatticeHeight| 750)
(il:rpaqq il:|MaxLatticeWidth| 900)
(il:rpaqq il:|NestedMenuFlg| t)
(il:declare\: il:doeval@compile il:dontcopy
(il:specvars il:|MaxLatticeHeight| il:|MaxLatticeWidth|)
)
(il:* il:|;;;| " PCL Utils")
(defun pcl::objectp (obj) (pcl::pcl-object-p (class-of
obj)))
(defun pcl::instance-of-p (obj class-name) nil)
(defun pcl::understands (obj command)
(and (fboundp command)
(pcl::lookup-method (symbol-function command)
(class-of obj))))
(defun pcl::get-object-rec (obj) (if (typep (class-of
obj)
'object)
obj nil))
(il:* il:|;;;| "")
(il:declare\: il:donteval@load il:doeval@compile il:dontcopy
il:compilervars
(il:addtovar il:nlama )
(il:addtovar il:nlaml lispx-send)
(il:addtovar il:lama window-when-held-fn
window-when-held-fn
web-window-expand-fn
web-window-reshape-fn
web-window-button-event-fn
web-window-after-move-fn)
)
(il:putprops il:web-editor il:copyright ("Xerox Corporation"
1987))
(il:declare\: il:dontcopy
(il:filemap (nil (38070 41167 (web-window-after-move-fn
38083 . 38485) (web-window-button-event-fn 38487 . 38990) (
web-window-reshape-fn 38992 . 39598) (web-window-close-fn
39600 . 39902) (il:|PromptRead| 39904 . 41165)) (41168 41617
(web-window-expand-fn 41181 . 41615)) (69700 70929 (
web-menu-whenselectedfn 69713 . 70434) (window-when-held-fn
70436 . 70927)) (70930 76196 (sub-item-selection 70943 .
72107) (dual-sub-items 72109 . 73226) (window-when-held-fn
73228 . 73719) (do-menu-method 73721 . 74092) (dual-menu
74094 . 74817) (dual-selection 74819 . 76194)) (78958 80737
(eval.in.tty.context 78971 . 80144) (lispx-send 80146 .
80735)) (112425 115548 (find-selected-node 112438 . 115546))
(115549 146417 (add-menu-window 115562 . 118022) (
box-print-string 118024 . 124130) (box-window-node 124132 .
125901) (break-string-for-boxing 125903 . 133274) (
fileclasses 133276 . 133446) (items-for-type 133448 . 134263
) (menu-group-size 134265 . 134741) (repaint-menu-window
134743 . 135606) (\\delete-subtree 135608 . 136648) (
\\menu-group-size 136650 . 139580) (
\\place-menu-group-in-window 139582 . 144120) (
\\portable-graph-node-id 144122 . 145393) (
\\remove-menu-group-from-window 145395 . 146415)) (146418
154133 (tree-roots 146431 . 151237) (child-nodes 151239 .
152127) (reachable-nodes! 152129 . 154131)))))
il:stop