Re: A small fragment to help with the namespace editor.

[Jerry Bakin <Jerry@marlowe.inference.dialnet.symbolics.com>]

A while back I distributed some code to sort the service entries in the
namespace editor.  Richard Lamson suggested a general purpose sorting
mechanism is what is required and gave me some hints on where to look.

I didn't implement the general purpose mechanism, I cheaped out and
opted for the quick and dirty method of sorting all "element" fields by
coercing the elements into strings.

The new code is below.  It sorts what is seen in the namespace editor.

Jerry Bakin.



;;; -*- Mode: LISP; Syntax: Zetalisp; Package: NETI; Base: 10; Patch-File: Yes -*-
1;;; From the namespace editor, this addition sorts the service property list

0(DEFMETHOD (:EDIT-OBJECT NAMESPACE-EDITOR-FRAME) (OBJECT-CLASS OBJECT-NAME MODE
							       &OPTIONAL COPY-P PROPERTY-LIST)
  (SETQ CLEAR-INTERACTOR NIL)
  ;; Decache information about this object, but do it carefully, so that if we cannot
  ;; connect to a server we don't leave something itching to be validated.
  (UNLESS NAMESPACE-EDIT-LOCALLY
    (CONDITION-CASE (OBJECT)
	(IF (TYPEP OBJECT-NAME 'NET:OBJECT)
	    OBJECT-NAME
	    ;; Don't contact server twice.
	    (LET ((NETI:*INHIBIT-VALIDITY-CHECKING* T))
	      (NET:FIND-OBJECT-NAMED OBJECT-CLASS OBJECT-NAME)))
      (NET:OBJECT-NOT-FOUND
	;; Not found, decache name
	(NETI:DECACHE-OBJECT-NAMED OBJECT-CLASS OBJECT-NAME))
      (:NO-ERROR
       (SEND OBJECT :CHECK-VALIDITY NIL T))))
  (WHEN (CONDITION-CASE (OBJECT)
	    (IF (TYPEP OBJECT-NAME 'NET:OBJECT)
		OBJECT-NAME
		(NET:FIND-OBJECT-NAMED OBJECT-CLASS OBJECT-NAME))
	  (NET:OBJECT-NOT-FOUND
	    (COND ((EQ MODE ':CREATING)
		   (SETQ NAMESPACE-NAME
			 (NETI:PARSE-NAME OBJECT-NAME
					  (NETI:CLASS-GLOBALLY-NAMED-P OBJECT-CLASS)))
		   T)
		  (T
		   (FORMAT INTERACTOR-PANE "~&~A~%" OBJECT)
		   NIL)))
	  (:NO-ERROR
	   (COND ((EQ MODE ':CREATING)
		  (FORMAT INTERACTOR-PANE "A ~@(~A~) with the name ~A already exists.~%"
			  OBJECT-CLASS OBJECT-NAME)
		  NIL)
		 (T (LET ((NAMESPACE (NAMESPACE-EDITOR-CHOOSE-NAMESPACE OBJECT)))
		      (WHEN NAMESPACE
			(SETQ NAMESPACE-OBJECT OBJECT)
			(MULTIPLE-VALUE (NAMESPACE-NAME PROPERTY-LIST)
			  (SEND OBJECT :NAMESPACE-VIEW NAMESPACE))
			T))))))
    (SETQ CLEAR-INTERACTOR T
	  NAMESPACE-CLASS OBJECT-CLASS
	  NAMESPACE-MODE MODE
	  NAMESPACE-MODIFIED NIL)
    (SEND NAME-PANE ':REFRESH)
    (SEND CHOICE-PANE ':SET-SENSITIVE-ITEM-TYPES (NEQ MODE ':VIEWING))
    ;;--- COPY-P should manage to get rid of any NAMING-PROPERTIES, since it's a disaster
    ;;if they are copied.
    (UNLESS COPY-P
      1;; Sort the property list
0      (cl:setf property-list (sort-plist property-list))
      1;; Sort values appropriately by class template
0      (loop for (indicator value) on property-list by 'cddr
	    for template = (class-get-template object-class indicator)
	    for element-p  = (eq (first template) :element)
	    when element-p
	      do (sort value
		       (if (listp (first value))
			   #'sort-tuples
			   #'sort-elements)))
      (SEND CHOICE-PANE ':SET-ITEMS (CONSTRUCT-ITEMS-FROM-PROPERTY-LIST
				      NAMESPACE-CLASS PROPERTY-LIST)))))
(DEFUN SORT-PLIST (X &optional (SORT-LESSP-PREDICATE #'string<))
  (DECLARE (DOWNWARD-FUNARG SORT-LESSP-PREDICATE))
  (COND ((LISTP X)
	 (loop for (indicator value) in
		   (sortcar
		     (loop for (indicator value) on x by 'cddr
			   collect (list indicator value))
		     SORT-LESSP-PREDICATE)
	       collect indicator
	       collect value))
	((NULL X)
	 X)))

(defun stringify (element)
  (typecase element
    (:string element)
    (:symbol (string element))
    (otherwise (cl:princ-to-string element))))

(defun sort-elements (element-1 element-2 &optional (sort-predicate #'string<) (stringify t))
  (when stringify
	     (setf element-1 (stringify element-1))
	     (setf element-2 (stringify element-2)))
  (funcall sort-predicate element-1 element-2))

(defun sort-tuples (tuple-1 tuple-2 &optional (sort-predicate #'string<) (stringify t))
  (let ((element-1 (car tuple-1))
	(element-2 (car tuple-2)))
    (cond ((and element-1 element-2)
	   (when stringify
	     (setf element-1 (stringify element-1))
	     (setf element-2 (stringify element-2)))
	   (if (null (funcall sort-predicate element-1 element-2))
	       (if (null (funcall sort-predicate element-2 element-1))
		   (sort-tuples (cdr tuple-1) (cdr tuple-2))
		   nil) t))
	  (element-1 nil))))