--- dev-commands.lisp	Thu Aug 19 15:53:34 2004
+++ dev-commands-graphs.lisp	Thu Aug 19 16:42:04 2004
@@ -349,28 +349,33 @@
 
 ;;; CLOS introspection commands
 
-(defun class-grapher (stream class inferior-fun)
+(defun class-grapher (stream class inferior-fun &key (scale-x 1) (scale-y 1))
   "Does the graphing for Show Class Superclasses and Subclasses commands"
   (let ((normal-ink +foreground-ink+)
         (arrow-ink  (make-rgb-color 0.72 0.72 0.72))	
 	(text-style (make-text-style :fixed :roman :normal)))
-    (with-drawing-options (stream :text-style text-style)
-    (format-graph-from-roots (list class)
-			     #'(lambda (class stream)                                 
-                                 (with-drawing-options (stream :ink normal-ink
-							       :text-style text-style)
-                                   (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name)
-                                     ; (surrounding-output-with-border (stream :shape :drop-shadow)
-				       (princ (clim-mop:class-name class))))) ;)
-			     inferior-fun
-			     :stream stream
-                             :merge-duplicates T
-                             :graph-type :tree
-			     :orientation :horizontal
-			     :arc-drawer
-			     #'(lambda (stream foo bar x1 y1 x2 y2)
-				 (declare (ignore foo bar))
-				 (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink))))))
+    (with-scaling (stream scale-x scale-y)
+      (with-drawing-options (stream :text-style text-style)
+        (format-graph-from-roots (list class)
+                                 (if (or (< scale-x 1) (< scale-y 1))
+                                     #'(lambda (class stream)
+                                         (declare (ignore class stream))
+                                         t)
+                                     #'(lambda (class stream)                                 
+                                         (with-drawing-options (stream :ink normal-ink
+                                                                       :text-style text-style)
+                                           (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name)
+                                        ; (surrounding-output-with-border (stream :shape :drop-shadow)
+                                             (princ (clim-mop:class-name class)))))) ;)
+                                 inferior-fun
+                                 :stream stream
+                                 :merge-duplicates T
+                                 :graph-type :tree
+                                 :orientation :horizontal
+                                 :arc-drawer
+                                 #'(lambda (stream foo bar x1 y1 x2 y2)
+                                     (declare (ignore foo bar))
+                                     (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink)))))))
 
 (defun frob-to-class (spec)
   (if (typep spec 'class)
@@ -380,20 +385,28 @@
 (define-command (com-show-class-superclasses :name "Show Class Superclasses"
                                              :command-table dev-commands
 					     :provide-output-destination-keyword t)
-    ((class-spec 'class-name :prompt "class"))
+    ((class-spec 'class-name :prompt "class")
+     &key
+     (scale-x 'number :default 1 :prompt "scale x")
+     (scale-y 'number :default 1 :prompt "scale-y"))
   (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
+                       :scale-x scale-x :scale-y scale-y))))
 
 (define-command (com-show-class-subclasses :name "Show Class Subclasses"
                                            :command-table dev-commands
 					   :provide-output-destination-keyword t)
-    ((class-spec 'class-name :prompt "class"))
+    ((class-spec 'class-name :prompt "class")
+     &key
+     (scale-x 'number :default 1 :prompt "scale x")
+     (scale-y 'number :default 1 :prompt "scale-y"))
   (let ((class (frob-to-class class-spec)))
     (if (not (null class))
-        (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses)
-      (note "~A is not a defined class." class-spec))))
+        (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses
+                       :scale-x scale-x :scale-y scale-y)
+        (note "~A is not a defined class." class-spec))))
 
 
 ; Lookup direct slots from along the CPL given a class and a slot name.