home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / HNET / HNET-Browser.lisp next >
Encoding:
Text File  |  1990-06-24  |  35.7 KB  |  840 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         HNET-BROWSER.LISP
  15. ; Author:       Dan Suthers
  16. ; Created:      27-May-88 23:34:08
  17. ; Modified:     22-Jun-90 02:30:07 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      HNET
  20. ;
  21. ; Description:  Allows interactive examination of the HNET.
  22. ;
  23. ; (c) Copyright 1988, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57. ;
  58. ; Status:       Usable but could use lots of improvement as an interface.
  59. ;               I recommend using the Grapher and writing network editing
  60. ;               mouse methods instead of this primitive interface.
  61. ;
  62. ; Tested:       Macintosh II Coral/Allegro 27-Jun-88 Dan Suthers
  63. ;
  64. ; Changes:
  65. ;  23-Jul-88 Don't show superordinate* in browser; takes too long.
  66. ;    Grapher no longer creates graph-nodes for terms not being graphed,
  67. ;    and finds the roots via new hnet-roots.
  68. ;  25-Sep-88 New Grapher mouse-methods.  Dive in to sub-views and come back,
  69. ;    etc.  Many other grapher-related changes.
  70. ;  04-Nov-88 Removed sort of HNET names (already sorted by :sort-instances);
  71. ;    Backup to Parent View mouse method restores gv to gw if there is no
  72. ;    parent view (bug introduced by 01-Nov change to MacGrapher).
  73. ;  15-Dec-88 Backup All the Way to Original View added to mouse methods.
  74. ;  27-Dec-88 Eliminated graph-node-parents.
  75. ;  11-Jan-88 Changed to accept any object as terms, not just symbols.
  76. ;  17-Apr-89 Changed a path name.
  77. ;  30-Jan-90 Updated for version 1.3.1: window-draw-contents -> view-...;
  78. ;    default-button now in button items.
  79. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80.  
  81. (in-package :HNET)
  82.  
  83. (export '(
  84.           browse-hnet
  85.           graph-hnet
  86.           hnet->graph-view-with-parameters
  87.           ))
  88.  
  89. (require :MISC    )
  90. (require :DIALOGUE)
  91. (require :SM      )
  92. (require :SMEDIT  )
  93. (require :HNET    )
  94. (require :GRAPHER )
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97.  
  98. (eval-when (compile eval)
  99.  
  100.   (defmacro OBJECT->STRING (object)
  101.     `(typecase ,object
  102.        (symbol (symbol-name ,object))
  103.        (string ,object)
  104.        (otherwise  (format nil "~S" ,object))))
  105.  
  106.   (defmacro NO-HNET-SELECTED-HANDLER ()
  107.     ;; Disable term menu and buttons.
  108.     '(progn
  109.        (ccl:ask ; term-menu
  110.         (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  111.         (ccl:set-table-sequence nil))
  112.        (ccl:ask ; add-term
  113.         (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  114.         (ccl:dialog-item-disable))
  115.        (ccl:ask ; delete-term
  116.         (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  117.         (ccl:dialog-item-disable))
  118.        (ccl:ask ; add-super
  119.         (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  120.         (ccl:dialog-item-disable))
  121.        (ccl:ask ; delete-super
  122.         (eighth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  123.         (ccl:dialog-item-disable))
  124.        (ccl:ask ; show-supers
  125.         (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  126.         (ccl:dialog-item-disable))
  127.        (ccl:ask ; show-subs
  128.         (tenth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  129.         (ccl:dialog-item-disable))))
  130.  
  131.   (defmacro NO-TERM-SELECTED-HANDLER ()
  132.     '(progn
  133.        ;; Ensure nothing is selected (useful after adding or deleting terms).
  134.        (ccl:ask ; term-menu
  135.         (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  136.         (if (ccl:selected-cells)
  137.           (ccl:cell-deselect (car (ccl:selected-cells)))))
  138.        ;; Disable stuff.
  139.        (ccl:ask ; delete-term
  140.         (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  141.         (ccl:dialog-item-disable))
  142.        (ccl:ask ; add-super
  143.         (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  144.         (ccl:dialog-item-disable))
  145.        (ccl:ask ; delete-super
  146.         (eighth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  147.         (ccl:dialog-item-disable))
  148.        (ccl:ask ; term-relation
  149.         (tenth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  150.         (ccl:dialog-item-disable))))
  151.  
  152.   (defmacro WITH-GIVEN-OBJECT (&rest body)
  153.     ;; Binds OBJECT to the object correponding to the typed string,
  154.     ;; and executes <body>, unless an error is encountered.
  155.     `(let ((term-string
  156.             (ccl:ask ; entry-window 
  157.              (third (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  158.              (ccl:dialog-item-text)))
  159.            (object nil))
  160.        (setf object (read-from-string term-string nil '$eof$))
  161.        (cond
  162.         ((eq object '$eof$)
  163.          (ccl:ed-beep)
  164.          (ccl:ask ; display-window 
  165.           (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  166.           (ccl:set-dialog-item-text "Error on read of your object.  Please type a~
  167.                                    ~%readable object in the entry window above.")))
  168.         (T ,@body))))
  169.  
  170.   (defmacro WITH-HNET (&rest body)
  171.     ;; binds HNET to an existing term chosen from the menu.
  172.     `(let ((hnet
  173.             (ccl:ask ; hnet-menu
  174.              (first (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  175.              (if (ccl:selected-cells)
  176.                ;; Got an HNET
  177.                (ccl:cell-contents (car (ccl:selected-cells)))
  178.                ;; No HNET: disable related buttons.
  179.                (progn
  180.                  (ccl:ed-beep)
  181.                  (no-hnet-selected-handler))))))
  182.        (when hnet ,@body)))
  183.  
  184.   (defmacro WITH-TERM (&rest body)
  185.     ;; Binds TERM to an existing term chosen from the menu.
  186.     `(let ((term
  187.             (if 
  188.               ;; If there is an hnet selected ...
  189.               (ccl:ask ; hnet-menu
  190.                (first (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  191.                (ccl:selected-cells))
  192.               ;; Then it is OK to see if a term is selected.
  193.               (ccl:ask ; term-menu
  194.                (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  195.                (if (ccl:selected-cells)
  196.                  ;; Got a TERM
  197.                  (ccl:cell-contents (car (ccl:selected-cells)))
  198.                  ;; Otherwise disable TERM buttons
  199.                  (progn
  200.                    (ccl:ed-beep)
  201.                    (no-term-selected-handler))))
  202.               ;; Otherwise disable HNET buttons
  203.               (progn
  204.                 (ccl:ed-beep)
  205.                 (no-hnet-selected-handler)))))
  206.        (when term ,@body)))
  207.  
  208.   ) ; end of eval-when
  209.  
  210. (defun OBJECT-LESSP (t1 t2) 
  211.   (declare (optimize speed))
  212.   (string< (object->string t1) (object->string t2)))
  213.  
  214. (defun BROWSE-HNET ()
  215.   "browse-hnet                                                      [Function]
  216.   Creates and returns an HNET browser object."
  217.   (let*
  218.     (
  219.      ;;----------------
  220.      ;; Display Windows
  221.      
  222.      ;; Window in which user types names of terms.
  223.      (entry-window
  224.       (ccl:oneof
  225.        ccl:*editable-text-dialog-item*
  226.        :dialog-item-size (ccl:make-point 275 16)
  227.        :dialog-item-position (ccl:make-point 137 88)
  228.        :dialog-item-font '("monaco" 12)
  229.        :dialog-item-text ""
  230.        :allow-returns nil))
  231.      
  232.      ;; Window where hnet and term descriptions are displayed.
  233.      (display-window
  234.       (ccl:oneof
  235.        ccl:*editable-text-dialog-item*
  236.        :dialog-item-size (ccl:make-point 580 180)
  237.        :dialog-item-position (ccl:make-point 10 120)
  238.        :dialog-item-font '("monaco" 12)
  239.        :dialog-item-text 
  240. "
  241.    Choose an HNET first, using the menu on the left.  When you do, all the
  242.    terms in the chosen HNET will be listed in the right menu.  You may add
  243.    terms or list undefined terms using the enabled buttons. To delete a term,
  244.    add or delete its superordinates, or compute its relation to another term,
  245.    you must select a term in the right menu. When you do, the buttons corre-
  246.    sponding to these operations will be enabled, and information about the 
  247.    chosen term will be displayed. Whenever an existing term must be specified,
  248.    it is done using the term menu.  Whenever the object to be a new term 
  249.    must be specified, it is done by typing the object into the narrow window."
  250.        :allow-returns t))
  251.      
  252.      ;;-----------------------------     
  253.      ;; Menu for selecting the hnet.
  254.      (hnet-menu
  255.       (ccl:oneof 
  256.        ccl:*sequence-dialog-item*
  257.        :dialog-item-size (ccl:make-point 100 168)
  258.        :dialog-item-position (ccl:make-point 9 10)
  259.        :table-vscrollp t
  260.        :table-hscrollp nil
  261.        :visible-dimensions (ccl:make-point 1 6)
  262.        :cell-size (ccl:make-point 100 16)
  263.        :table-sequence (sm:instances 'hnet)
  264.        :sequence-order :vertical
  265.        :dialog-item-action
  266.        #'(lambda ()
  267.            (with-hnet
  268.              (ccl:ask ; term-menu
  269.               (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  270.               (ccl:set-table-sequence
  271.                (sort (defined-terms hnet) #'object-lessp)))
  272.              (ccl:ask ; display-window
  273.               (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  274.               (ccl:set-dialog-item-text 
  275.                (format nil "HNET ~S's INFO:~%~S~%UNDEFINED TERMS: ~S"
  276.                        hnet (hnet-info (sm:gets 'hnet hnet))
  277.                        (undefined-terms hnet))))
  278.              ;; Enable applicable buttons, disable rest.
  279.              (ccl:ask ; add-term
  280.               (fifth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  281.               (ccl:dialog-item-enable))
  282.              (ccl:ask ; undefined-terms
  283.               (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  284.               (ccl:dialog-item-enable))
  285.              (no-term-selected-handler)))))
  286.      
  287.      ;;-----------------------------------
  288.      ;; Menu for selecting existing terms.
  289.      (term-menu 
  290.       (ccl:oneof
  291.        ccl:*sequence-dialog-item*
  292.        :dialog-item-size (ccl:make-point 150 168)
  293.        :dialog-item-position (ccl:make-point 427 10)
  294.        :table-vscrollp t
  295.        :table-hscrollp nil
  296.        :visible-dimensions (ccl:make-point 1 6)
  297.        :cell-size (ccl:make-point 150 16)
  298.        :table-sequence nil
  299.        :sequence-order :vertical
  300.        :dialog-item-action 
  301.        #'(lambda ()
  302.            (with-hnet
  303.              (with-term
  304.                ;; Display info about the term.  But don't search for 
  305.                ;; transitive supers and subs unless all terms defined.
  306.                (ccl:ask ; display-window
  307.                 (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  308.                 (ccl:set-dialog-item-text
  309.                  (format nil 
  310.                          "~%~S in HNET ~S:~
  311.                           ~%  Info:           ~S~
  312.                           ~%  Superordinates: ~S~
  313.                           ~%  Subordinates:   ~S~A"
  314.                          term hnet
  315.                          (term-info term hnet)
  316.                          (superordinates term hnet)
  317.                          (subordinates   term hnet)
  318.                          (if (undefined-terms hnet)
  319.                            (format nil "~%UNDEFINED TERMS: ~S"
  320.                                    (undefined-terms hnet))
  321.                            " "))))
  322.                ;; Enable buttons
  323.                (ccl:ask ; delete-term
  324.                 (sixth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  325.                 (ccl:dialog-item-enable))
  326.                (ccl:ask ; add-super
  327.                 (seventh (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  328.                 (ccl:dialog-item-enable))
  329.                (ccl:ask ; delete-super
  330.                 (eighth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  331.                 (ccl:dialog-item-enable))
  332.                (ccl:ask ; show-supers
  333.                 (ninth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  334.                 (ccl:dialog-item-enable))
  335.                (ccl:ask ; show-subs
  336.                 (tenth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  337.                 (ccl:dialog-item-enable)))))))
  338.      
  339.      ;;-----------------------------------------
  340.      ;; Buttons left to right across the top ...
  341.      
  342.      (add-term
  343.       (ccl:oneof
  344.        ccl:*button-dialog-item*
  345.        :dialog-item-text "Add Term"
  346.        :dialog-item-position (ccl:make-point 147 18)
  347.        :dialog-item-enabled-p nil
  348.        :dialog-item-action
  349.        #'(lambda ()
  350.            (with-hnet
  351.              (with-given-object
  352.                (if (member object (defined-terms hnet))
  353.                  (progn
  354.                    (ccl:ed-beep)
  355.                    (ccl:ask ; display-window
  356.                     (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  357.                     (ccl:set-dialog-item-text
  358.                      (format nil "Oops, ~S is already defined!" object))))
  359.                  (progn
  360.                    (define-term object nil hnet)
  361.                    (ccl:ask ; term-menu
  362.                     (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  363.                     (ccl:set-table-sequence
  364.                      (sort (defined-terms hnet) #'object-lessp)))
  365.                    (no-term-selected-handler))))))))
  366.  
  367.      (delete-term
  368.       (ccl:oneof 
  369.        ccl:*button-dialog-item*
  370.        :dialog-item-text "Delete Term"
  371.        :dialog-item-position (ccl:make-point 140 52)
  372.        :dialog-item-enabled-p nil
  373.        :dialog-item-action
  374.        #'(lambda ()
  375.            (with-hnet
  376.              (with-term
  377.                (when (wind:y-or-n-dialogue "Undefine term ~S?" term)
  378.                  (undefine-term term hnet)
  379.                  (ccl:ask ; term-menu
  380.                   (second (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  381.                   (ccl:set-table-sequence
  382.                    (sort (defined-terms hnet) #'object-lessp)))
  383.                  (no-term-selected-handler)))))))
  384.      
  385.      (add-super
  386.       (ccl:oneof
  387.        ccl:*button-dialog-item*
  388.        :dialog-item-text "Add Super"
  389.        :dialog-item-position (ccl:make-point 247 18)
  390.        :dialog-item-enabled-p nil
  391.        :dialog-item-action
  392.        #'(lambda ()
  393.            (with-hnet
  394.              (with-given-object
  395.                (with-term
  396.                  (if (eq term object)
  397.                    ;; A common error: forgetting to change the entry window.
  398.                    (progn
  399.                      (ccl:ed-beep)
  400.                      (ccl:ask ; display-window
  401.                       (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  402.                       (ccl:set-dialog-item-text
  403.                        (format nil 
  404.                                "Sorry, you can't make ~S a superordinate of itself."
  405.                                term))))
  406.                    (progn
  407.                      (add-superordinate term object hnet)
  408.                      ;; Display new info about the term.
  409.                      (ccl:ask ; display-window
  410.                       (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  411.                       (ccl:set-dialog-item-text
  412.                        (format nil 
  413.                                "~S in HNET ~S:~
  414.                                 ~%  Superordinates: ~S~
  415.                                 ~%  Subordinates:   ~S"
  416.                                term hnet
  417.                                (superordinates term hnet)
  418.                                (subordinates term hnet))))))))))))
  419.      
  420.      (delete-super
  421.       (ccl:oneof
  422.        ccl:*button-dialog-item*
  423.        :dialog-item-text "Delete Super"
  424.        :dialog-item-position (ccl:make-point 241 52)
  425.        :dialog-item-enabled-p nil
  426.        :dialog-item-action
  427.        #'(lambda ()
  428.            (with-hnet
  429.              (with-given-object
  430.                (with-term
  431.                  (if (eq term object)
  432.                    ;; A common error: forgetting to change the entry window.
  433.                    (progn
  434.                      (ccl:ed-beep)
  435.                      (ccl:ask ; display-window
  436.                       (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  437.                       (ccl:set-dialog-item-text
  438.                        (format nil 
  439.                                "Sorry, you can't delete ~S as its own superordinate."
  440.                                term))))
  441.                    (progn
  442.                      (delete-superordinate term object hnet)
  443.                      ;; Display info about the term.
  444.                      (ccl:ask ; display-window
  445.                       (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  446.                       (ccl:set-dialog-item-text
  447.                        (format nil 
  448.                                "~S in HNET ~S:~
  449.                                 ~%  Superordinates: ~S~
  450.                                 ~%  Subordinates:   ~S"
  451.                                term hnet
  452.                                (superordinates term hnet)
  453.                                (subordinates term hnet))))))))))))
  454.  
  455.      (undefined-terms
  456.       (ccl:oneof
  457.        ccl:*button-dialog-item*
  458.        :dialog-item-text "Undefined"
  459.        :dialog-item-position (ccl:make-point 338 18)
  460.        :dialog-item-enabled-p nil
  461.        :dialog-item-action
  462.        #'(lambda ()
  463.            (with-hnet
  464.              (let ((*print-pretty* t))
  465.                (ccl:ask ; display-window
  466.                 (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  467.                 (ccl:set-dialog-item-text
  468.                  (if (undefined-terms hnet)
  469.                    (format nil
  470.                            "Terms referenced in ~S but undefined:~%~S"
  471.                            hnet
  472.                            (undefined-terms hnet))
  473.                    (format nil 
  474.                            "All terms referenced in ~S are defined." hnet)))))))))
  475.      
  476.      (term-relation
  477.       (ccl:oneof
  478.        ccl:*button-dialog-item*
  479.        :dialog-item-text "Relation"
  480.        :dialog-item-position (ccl:make-point 345 52)
  481.        :dialog-item-enabled-p nil
  482.        :dialog-item-action
  483.        #'(lambda ()
  484.            (with-hnet
  485.              (with-term
  486.                (if (undefined-terms hnet)
  487.                  (progn
  488.                    (ccl:ed-beep)
  489.                    (ccl:ask ; display-window
  490.                     (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  491.                     (ccl:set-dialog-item-text
  492.                      (format nil 
  493.                              "RELATION cannot be used until all terms referenced are defined.~
  494.                               ~%The following are undefined: ~S" 
  495.                              (undefined-terms hnet)))))
  496.                  (let ((term-to-compare
  497.                         (wind:menu-dialogue
  498.                          (defined-terms hnet)
  499.                          "Compare ~S to which other term?" term))
  500.                        (*print-pretty* t))
  501.                    (ccl:ask ; display-window
  502.                     (fourth (ccl:ask ccl:my-dialog (ccl:dialog-items)))
  503.                     (ccl:set-dialog-item-text
  504.                      (case (subsumption-relation term term-to-compare hnet)
  505.                        ((:subordinate)
  506.                         (format nil "~S is SUBORDINATE to ~S in HNET ~S"
  507.                                 term term-to-compare hnet))
  508.                        ((:superordinate)
  509.                         (format nil "~S is SUPERORDINATE to ~S in HNET ~S"
  510.                                 term term-to-compare hnet))
  511.                        ((:incomparable)
  512.                         (format nil "~S and ~S are INCOMPARABLE in HNET ~S"
  513.                                 term term-to-compare hnet))))))))))))
  514.      
  515.      ;; Create the browser window itself.
  516.      (browser 
  517.       (ccl:oneof ccl:*dialog*
  518.                  :window-title " Hierarchical Net Browser "
  519.                  :window-position (ccl:make-point 25 45)
  520.                  :window-size (ccl:make-point 600 315)
  521.                  :window-type :tool
  522.                  :dialog-items (list 
  523.                                 hnet-menu       ; first
  524.                                 term-menu       ; second
  525.                                 entry-window    ; third
  526.                                 display-window  ; fourth 
  527.                                 add-term        ; fifth
  528.                                 delete-term     ; sixth
  529.                                 add-super       ; seventh 
  530.                                 delete-super    ; eighth
  531.                                 undefined-terms ; ninth
  532.                                 term-relation)  ; tenth
  533.                  :default-button add-term)))
  534.     browser))
  535.  
  536. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  537. ;;;
  538. ;;;                           GRAPHING HNETS
  539. ;;;
  540. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  541.  
  542. (defparameter *HNET-MOUSE-METHODS*
  543.   (append
  544.    (list
  545.     (cons 
  546.      "Make this Node the Root"
  547.      (compile
  548.       nil
  549.       '(lambda (gw gv gn)
  550.          (ccl:ask gw
  551.                   (let* ((gv-struct (sm:gets 'grapher:graph-view gv))
  552.                          (new-gv 
  553.                           (hnet->graph-view-with-parameters
  554.                            (grapher:graph-view-info-image :hnet gv)
  555.                            (list (grapher:graph-node-object
  556.                                   (sm:gets 'grapher:graph-node gn)))
  557.                            (grapher:graph-view-style gv-struct)
  558.                            (grapher:graph-view-ordering gv-struct)
  559.                            (grapher:graph-view-depth-bound gv-struct)
  560.                            gv))) ; parent view
  561.                     (grapher:set-graph-view new-gv)
  562.                     (ccl:set-window-title 
  563.                      (sm:prints 'grapher:graph-view new-gv 
  564.                                 :style :name :stream nil))
  565.                     (ccl:window-select)
  566.                     (ccl:view-draw-contents))))))
  567.      
  568.     (cons
  569.      "Backup Once to Parent View"
  570.      (compile
  571.       nil
  572.       '(lambda (gw gv gn)
  573.          (declare (ignore gn))
  574.          (ccl:ask gw
  575.                   (let ((parent-view 
  576.                          (grapher:graph-view-info-image :parent-view gv)))
  577.                     (if parent-view
  578.                       (if (sm:gets 'grapher:graph-view parent-view)
  579.                         (progn
  580.                           (grapher:set-graph-view parent-view :layout nil)
  581.                           (ccl:set-window-title
  582.                            (sm:prints 'grapher:graph-view parent-view
  583.                                       :style :name :stream nil))
  584.                           (ccl:window-select)
  585.                           (ccl:view-draw-contents)
  586.                           (unless (grapher:windows-using-graph-view gv)
  587.                             (ccl:eval-enqueue `(grapher:dispose-graph-view ',gv))))
  588.                         (progn (ccl:ed-beep)
  589.                                (setf (grapher:graph-view-info-image :parent-view gv) nil)
  590.                                (wind:message-dialogue 
  591.                                 "The parent view appears to have been destroyed.")
  592.                                ;; The graph-view of gw was set to nil since we 
  593.                                ;; thought gv was to be replaced ... restore it.
  594.                                (grapher:set-graph-view gv :layout nil)
  595.                                (ccl:view-draw-contents)))
  596.                       (progn (ccl:ed-beep)
  597.                              (wind:message-dialogue 
  598.                               "This graph view has no parent view.")
  599.                              (grapher:set-graph-view gv :layout nil)
  600.                              (ccl:view-draw-contents))))))))
  601.      
  602.     (cons 
  603.      "New Window with this Node as Root"
  604.      (compile
  605.       nil
  606.       '(lambda (gw gv gn)
  607.          (let* ((hnet (grapher:graph-view-info-image :hnet gv))
  608.                 (gv-struct (sm:gets 'grapher:graph-view gv))
  609.                 (roots 
  610.                  (list (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  611.                 (style       (grapher:graph-view-style gv-struct))
  612.                 (ordering    (grapher:graph-view-ordering gv-struct))
  613.                 (depth-bound (grapher:graph-view-depth-bound gv-struct)))
  614.            (multiple-value-setq
  615.             (roots style ordering depth-bound)
  616.             (grapher:graph-view-parameter-dialogue
  617.              hnet roots nil style ordering depth-bound))
  618.            (ccl:oneof
  619.             grapher:*graph-window* 
  620.             :graph-view
  621.             (hnet->graph-view-with-parameters 
  622.              hnet roots style ordering depth-bound gv))))))
  623.  
  624.     (cons
  625.      "Backup All the Way to Original View"
  626.      (compile
  627.       nil
  628.       '(lambda (gw gv gn)            
  629.          (declare (ignore gn))
  630.          (ccl:ask gw
  631.                   (let ((garbage-views nil) (original-view nil))
  632.                     ;; Search up to find original view; also recording the views
  633.                     ;; to be disposed of along the way. 
  634.                     (do* ((parent-view 
  635.                            (grapher:graph-view-info-image :parent-view gv)
  636.                            (grapher:graph-view-info-image :parent-view current-view))
  637.                           (current-view gv))
  638.                          ;; Invariant here: parent-view is parent of current-view,
  639.                          ;; so when parent-view nil, current-view is the root.
  640.                          ((null parent-view) (setq original-view current-view))
  641.                       (if (sm:gets 'grapher:graph-view parent-view)
  642.                         (progn
  643.                           (push current-view garbage-views)
  644.                           (setq current-view parent-view))
  645.                         (progn 
  646.                           (ccl:ed-beep)
  647.                           (setf (grapher:graph-view-info-image :parent-view current-view) nil)
  648.                           (wind:message-dialogue 
  649.                            "The parent of view ~A appears to have been destroyed."
  650.                            current-view)
  651.                           (setq parent-view nil)))) ; to exit
  652.                     (grapher:set-graph-view original-view :layout nil) ; already laid out
  653.                     (ccl:set-window-title
  654.                      (sm:prints 'grapher:graph-view original-view :style :name :stream nil))
  655.                     (ccl:window-select)
  656.                     (ccl:view-draw-contents)
  657.                     (dolist (ggv garbage-views)
  658.                       (unless (grapher:windows-using-graph-view ggv)
  659.                         (ccl:eval-enqueue `(grapher:dispose-graph-view ',ggv)))))))))
  660.      
  661.     (cons
  662.      "Show Term Info"
  663.      (compile
  664.       nil
  665.       '(lambda (gw gv gn)
  666.          (wind:message-dialogue 
  667.           "Term Info of ~S in ~S:~% ~S"
  668.           (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))
  669.           (grapher:graph-view-info-image :hnet gv)
  670.           (term-info (grapher:graph-node-object
  671.                       (sm:gets 'grapher:graph-node gn))
  672.                      (grapher:graph-view-info-image :hnet gv))))))
  673.     )
  674.    ;; Note that SM stores unevaluated expressions producing defaults.
  675.    (eval
  676.     (cdr (assoc 'grapher::mouse-methods
  677.                 (sm:slot-defaults 'grapher:graph-view))))))
  678.  
  679. (defun GRAPH-HNET (hnet &optional 
  680.                         (roots (hnet-roots hnet))
  681.                         (style :horizontal-tree)
  682.                         (ordering :as-found)
  683.                         (depth-bound 3))
  684.   "graph-hnet <hnet> &optional <roots> <style> <ordering> <depth-bound>
  685.   With user interaction to possibly modify the parameters, graphs the hnet."
  686.   (check-type hnet symbol)
  687.   (check-type style keyword)
  688.   (check-type ordering keyword)
  689.   (check-type depth-bound fixnum)
  690.   (assert (sm:gets 'hnet hnet) (hnet)
  691.           "[HNET:GRAPH-HNET] Unknown hnet ~S" hnet)
  692.  
  693.   ;; Get desired parameters.
  694.   (multiple-value-setq
  695.    (roots style ordering depth-bound)
  696.    (grapher:graph-view-parameter-dialogue
  697.     hnet roots 
  698.     (sort (defined-terms hnet) #'object-lessp)
  699.     style ordering depth-bound))
  700.  
  701.   ;; Graph and put up in window. Exist method handles layout, selecting, and drawing.
  702.   (ccl:oneof grapher:*graph-window* 
  703.              :graph-view
  704.              (hnet->graph-view-with-parameters
  705.                hnet roots style ordering depth-bound 
  706.                nil)))
  707.  
  708. (defun HNET->GRAPH-VIEW-WITH-PARAMETERS (hnet roots style ordering depth-bound 
  709.                                               &optional parent-view)
  710.   "hnet->graph-view-with-parameters <hnet> <roots> <style> <ordering>
  711.                                     &optional <parent-view>
  712.   Returns a graph-view of the HNET with the indicated parameters.  The optional
  713.   <parent-view>, if given, should be a graph view, presumably one containing as
  714.   a node the root of the current view. This is an 'internal' function with NO
  715.   ARGUMENT CHECKING."
  716.   (declare (optimize speed))
  717.  
  718.   (let ((graph-view-name 
  719.          (utils:unique-symbol
  720.            ;; If the graph is from a unique root, use the same name for the view.
  721.            ;; Otherwise use the hnet name.
  722.            (format nil "~A " 
  723.                     (if (and roots (null (cdr roots))) (first roots) hnet)))))
  724.     (declare (symbol graph-view-name))
  725.     (grapher:create-graph-view
  726.      graph-view-name
  727.      (build-view-below-roots hnet roots depth-bound parent-view)
  728.      depth-bound style ordering
  729.      '("monaco" 9) '("chicago" 12) 10
  730.      ;; Record this in INFO for use of mouse method.
  731.      `((:hnet . ,hnet) (:parent-view . ,parent-view))
  732.      *hnet-mouse-methods*)))
  733.  
  734. (defun BUILD-VIEW-BELOW-ROOTS (hnet roots depth-bound parent-view
  735.                                     &aux (terms->graph-nodes nil))
  736.   ;; return actual roots
  737.   (declare (symbol hnet parent-view) (list roots terms->graph-nodes) 
  738.            (fixnum depth-bound) (optimize speed))
  739.  
  740.   ;; Search for terms to be in the graph; generate graph nodes for them if needed.
  741.   (do ((frontier roots)
  742.        (new-frontier nil)
  743.        (depth 0 (1+ depth)))
  744.       ((or (null frontier) (> depth depth-bound)))
  745.     (declare (list frontier new-frontier) (fixnum depth))
  746.     (dolist (term frontier) 
  747.       (let ((t+gn (assoc term terms->graph-nodes)))
  748.         (declare (cons t+gn))
  749.         ;; Make sure the node exists.
  750.         (unless (and t+gn (sm:gets 'grapher:graph-node (cdr t+gn)))
  751.           (setq t+gn (cons term (gensym "GRAPH-NODE-")))
  752.           (push t+gn terms->graph-nodes)
  753.           (grapher:create-graph-node
  754.            (cdr t+gn)
  755.            (if (assoc :grapher-upcase (term-info term hnet)) ; label
  756.              (object->string term)
  757.              (string-capitalize (object->STRING term)))
  758.            nil                ; children set below
  759.            :rect              ; box-style set below
  760.            T                                       ; connector
  761.            term))                                  ; object
  762.  
  763.         ;; Now that it exists, set current children and box type.
  764.         (let ((gn-struct (sm:gets 'grapher:graph-node (cdr t+gn))))
  765.           ;; These will be changed to graph nodes, once they all exist.
  766.           (setf (grapher:graph-node-children gn-struct) (subordinates term hnet))
  767.           ;; Box style reflects whether it is a top level view root or has children.
  768.           (setf (grapher:graph-node-box-style gn-struct)
  769.                 (if (subordinates term hnet)
  770.                   (if (and (= depth 0) (null parent-view)) :oval :round-rect)
  771.                   :rect)))
  772.  
  773.         (setf new-frontier (append new-frontier (subordinates term hnet)))))
  774.     (setf frontier new-frontier)
  775.     (setf new-frontier nil))
  776.  
  777.   ;; Now that all graph nodes defined, replace child names with graph nodes.
  778.   (dolist (t+gn terms->graph-nodes)
  779.     (declare (cons t+gn))
  780.     (setf (grapher:graph-node-children (sm:gets 'grapher:graph-node (cdr t+gn)))
  781.           (mapcar #'(lambda (term) (cdr (assoc term terms->graph-nodes)))
  782.                   (grapher:graph-node-children 
  783.                    (sm:gets 'grapher:graph-node (cdr t+gn))))))
  784.  
  785.   ;; Returned value is mapping of roots to graph nodes.
  786.   (mapcar #'(lambda (term) (cdr (assoc term terms->graph-nodes)))
  787.           roots))
  788.  
  789. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  790.  
  791. (defparameter *HNET-MENU*
  792.   (let* ((line-item
  793.           (ccl:oneof ccl:*menu-item*
  794.                      :menu-item-title "-"))
  795.          (browse-item 
  796.           (ccl:oneof ccl:*menu-item*
  797.                      :menu-item-title "HNET Browser"
  798.                      :menu-item-action #'(lambda () (browse-hnet))))
  799.          (graph-item 
  800.           (ccl:oneof ccl:*menu-item*
  801.                      :menu-item-title "HNET Grapher ..."
  802.                      :menu-item-action 
  803.                      #'(lambda ()
  804.                          (graph-hnet
  805.                           (wind:menu-dialogue 
  806.                            (sm:instances 'hnet)
  807.                            "Which HNET do you wish to graph?")))))
  808.          (dispose-item
  809.           (ccl:oneof ccl:*menu-item*
  810.                      :menu-item-title "Hide This Menu"
  811.                      :menu-item-action 
  812.                      '(ccl:ask *hnet-menu* (ccl:menu-deinstall))))
  813.          (hnet-menu (ccl:oneof ccl:*menu* 
  814.                                :menu-title "HNET"
  815.                                :menu-items (list browse-item
  816.                                                  graph-item
  817.                                                  line-item
  818.                                                  dispose-item))))
  819.     (ccl:ask hnet-menu (ccl:menu-install))
  820.     (ccl:ask line-item (ccl:menu-item-disable))
  821.     ;; Menu-dispose dumped from version 1.3.1?
  822.     (if (and (boundp '*hnet-menu*) 
  823.              (typep *hnet-menu* ccl:*menu*))
  824.       (ccl:ask *hnet-menu* (ccl:menu-deinstall)))
  825.     hnet-menu))
  826.  
  827. (ccl:ask ccl:*tools-menu*
  828.   (ccl:add-menu-items
  829.    (ccl:oneof ccl:*menu-item*
  830.           :menu-item-title "Restore HNET Menu"
  831.           :menu-item-action
  832.           #'(lambda ()
  833.               (ccl:ask *hnet-menu*
  834.                 (unless (ccl:menu-installed-p) (ccl:menu-install)))))))
  835.  
  836. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  837. (provide :HNET-BROWSER)
  838. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  839. ;;; EOF
  840.