[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp

[Andy Hefner]

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory common-lisp.net:/tmp/cvs-serv28867

Modified Files:
	dev-commands.lisp 
Log Message:
Applied patched from Paolo adding vertical grapher orientation to listener
commands.

Date: Thu Apr 21 05:41:24 2005
Author: ahefner

Index: mcclim/Apps/Listener/dev-commands.lisp
diff -u mcclim/Apps/Listener/dev-commands.lisp:1.28 mcclim/Apps/Listener/dev-commands.lisp:1.29
--- mcclim/Apps/Listener/dev-commands.lisp:1.28	Sun Jan  2 06:14:28 2005
+++ mcclim/Apps/Listener/dev-commands.lisp	Thu Apr 21 05:41:24 2005
@@ -434,7 +434,7 @@
 (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72))
 (defparameter *graph-text-style* (make-text-style :fix :roman :normal))
 
-(defun class-grapher (stream class inferior-fun)
+(defun class-grapher (stream class inferior-fun &key (orientation :horizontal))
   "Does the graphing for Show Class Superclasses and Subclasses commands"
   (let ((normal-ink +foreground-ink+)
         (arrow-ink  *graph-edge-ink*)
@@ -453,7 +453,7 @@
                                :stream stream
                                :merge-duplicates T
                                :graph-type :tree
-                               :orientation :horizontal
+                               :orientation orientation
                                :arc-drawer
                                #'(lambda (stream foo bar x1 y1 x2 y2)
                                    (declare (ignore foo bar))
@@ -468,20 +468,26 @@
                                              :command-table show-commands
                                              :menu "Class Superclasses"
 					     :provide-output-destination-keyword t)
-    ((class-spec 'class-name :prompt "class"))
+    ((class-spec 'class-name :prompt "class")
+     &key
+     (orientation 'keyword :prompt "orientation" :default :horizontal))
   (let ((class (frob-to-class class-spec)))
     (if (null class)
 	(note "~A is not a defined class." class-spec)
-        (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses))))
+        (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses
+                       :orientation orientation))))
 
 (define-command (com-show-class-subclasses :name "Show Class Subclasses"
                                            :command-table show-commands
                                            :menu "Class Subclasses"
 					   :provide-output-destination-keyword t)
-    ((class-spec 'class-name :prompt "class"))
+    ((class-spec 'class-name :prompt "class")
+     &key
+     (orientation 'keyword :prompt "orientation" :default :horizontal))     
   (let ((class (frob-to-class class-spec)))
     (if (not (null class))
-        (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses)
+        (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses
+                       :orientation orientation)
       (note "~A is not a defined class." class-spec))))