? ChangeLog ? Apps/Inspector/disassembly.fasl ? Apps/Inspector/inspector.fasl ? Apps/Inspector/package.fasl ? Backends/Null ? Doc/Guided-Tour/draw-frame-commands ? Doc/Guided-Tour/draw-frame-def-app ? Doc/Guided-Tour/draw-frame-interfacing ? Doc/Guided-Tour/file-browser-all ? Doc/Guided-Tour/guided-tour.aux ? Doc/Guided-Tour/guided-tour.bbl ? Doc/Guided-Tour/guided-tour.blg ? Doc/Guided-Tour/guided-tour.dvi ? Doc/Guided-Tour/guided-tour.log ? Doc/Guided-Tour/guided-tour.ps ? Doc/Guided-Tour/hello-world-def-app ? Doc/Guided-Tour/hello-world-defclass ? Doc/Guided-Tour/hello-world-handle-repaint ? Doc/Guided-Tour/scheduler-part1 ? Doc/Guided-Tour/scheduler-part2 ? Doc/Guided-Tour/techno-dep.pstex ? Doc/Guided-Tour/techno-dep.pstex_t ? Experimental/freetype/freetype-fonts.fasl ? Experimental/freetype/freetype-package.fasl ? docs/guided-tour/draw-frame-commands ? docs/guided-tour/draw-frame-def-app ? docs/guided-tour/draw-frame-interfacing ? docs/guided-tour/guided-tour.aux ? docs/guided-tour/guided-tour.bbl ? docs/guided-tour/guided-tour.blg ? docs/guided-tour/guided-tour.dvi ? docs/guided-tour/guided-tour.log ? docs/guided-tour/guided-tour.ps ? docs/guided-tour/hello-world-def-app ? docs/guided-tour/hello-world-defclass ? docs/guided-tour/hello-world-handle-repaint ? docs/guided-tour/scheduler-part1 ? docs/guided-tour/scheduler-part2 ? docs/guided-tour/techno-dep.pstex ? docs/guided-tour/techno-dep.pstex_t Index: graph-formatting.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/graph-formatting.lisp,v retrieving revision 1.17 diff -u -r1.17 graph-formatting.lisp --- graph-formatting.lisp 10 Mar 2006 21:58:13 -0000 1.17 +++ graph-formatting.lisp 14 Mar 2006 17:16:14 -0000 @@ -240,6 +240,8 @@ :initarg :graph-children :initform nil :accessor graph-node-children) + (edges-from :initform (make-hash-table)) + (edges-to :initform (make-hash-table)) (object :initarg :object :reader graph-node-object) @@ -405,6 +407,15 @@ (incf v within-generation-separation))) (graph-root-nodes graph-output-record))))))))))) +;;;; Edges + +(defclass standard-edge-output-record (standard-sequence-output-record) + ((stream) + (arc-drawer) + (arc-drawing-options) + (from-node :initarg :from-node) + (to-node :initarg :to-node))) + (defmethod layout-graph-nodes ((graph-output-record dag-graph-output-record) stream arc-drawer arc-drawing-options) @@ -526,7 +537,7 @@ (with-slots (root-nodes orientation) graph-output-record (let ((hash (make-hash-table))) (labels ((walk (node) - (unless (gethash node hash) + (unless (gethash node hash) (setf (gethash node hash) t) (dolist (k (graph-node-children node)) (with-bounding-rectangle* (x1 y1 x2 y2) node @@ -551,6 +562,55 @@ (walk k))))) (map nil #'walk root-nodes))))) +(defun layout-edges (graph node stream arc-drawer arc-drawing-options) + (dolist (k (graph-node-children node)) + (layout-edge graph node k stream arc-drawer arc-drawing-options))) + +(defun ensure-edge-record (graph major-node minor-node) + (let ((edges-from (slot-value major-node 'edges-from)) + (edges-to (slot-value minor-node 'edges-to))) + (assert (eq (gethash minor-node edges-from) + (gethash major-node edges-to))) + (or (gethash minor-node edges-from) + (let ((record (make-instance 'standard-edge-output-record + :from-node major-node :to-node minor-node))) + (setf (gethash minor-node edges-from) record + (gethash major-node edges-to) record) + (add-output-record record graph) + record)))) + +(defun layout-edge-1 (graph major-node minor-node) + (let ((edge-record (ensure-edge-record graph major-node minor-node))) + (with-slots (stream arc-drawer arc-drawing-options) edge-record + (with-bounding-rectangle* (x1 y1 x2 y2) major-node + (with-bounding-rectangle* (u1 v1 u2 v2) minor-node + (clear-output-record edge-record) ;;; FIXME: repaint? + (letf (((stream-current-output-record stream) edge-record)) + (ecase (slot-value graph 'orientation) + ((:horizontal) + (multiple-value-bind (from to) (if (< x1 u1) + (values x2 u1) + (values x1 u2)) + (apply arc-drawer stream major-node minor-node + from (/ (+ y1 y2) 2) + to (/ (+ v1 v2) 2) + arc-drawing-options))) + ((:vertical) + (multiple-value-bind (from to) (if (< y1 v1) + (values y2 v1) + (values y1 v2)) + (apply arc-drawer stream major-node minor-node + (/ (+ x1 x2) 2) from + (/ (+ u1 u2) 2) to + arc-drawing-options)))))))))) + +(defun layout-edge (graph major-node minor-node stream arc-drawer arc-drawing-options) + (let ((edge-record (ensure-edge-record graph major-node minor-node))) + (setf (slot-value edge-record 'stream) stream + (slot-value edge-record 'arc-drawer) arc-drawer + (slot-value edge-record 'arc-drawing-options) arc-drawing-options) + (layout-edge-1 graph major-node minor-node))) + (defmethod layout-graph-edges ((graph standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (orientation) graph @@ -562,26 +622,7 @@ (traverse-graph-nodes graph (lambda (node children continuation) (unless (eq node graph) - (dolist (k children) - (with-bounding-rectangle* (x1 y1 x2 y2) node - (with-bounding-rectangle* (u1 v1 u2 v2) k - (ecase orientation - ((:horizontal) - (multiple-value-bind (from to) (if (< x1 u1) - (values x2 u1) - (values x1 u2)) - (apply arc-drawer stream node k - from (/ (+ y1 y2) 2) - to (/ (+ v1 v2) 2) - arc-drawing-options))) - ((:vertical) - (multiple-value-bind (from to) (if (< y1 v1) - (values y2 v1) - (values y1 v2)) - (apply arc-drawer stream node k - (/ (+ x1 x2) 2) from - (/ (+ u1 u2) 2) to - arc-drawing-options)))))))) + (layout-edges graph node stream arc-drawer arc-drawing-options)) (map nil continuation children)))))) (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record) Index: mcclim.asd =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/mcclim.asd,v retrieving revision 1.8 diff -u -r1.8 mcclim.asd --- mcclim.asd 10 Mar 2006 21:58:13 -0000 1.8 +++ mcclim.asd 14 Mar 2006 17:16:14 -0000 @@ -244,6 +244,18 @@ (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +(defsystem :clim-null + :depends-on (:clim) + :components + ((:module "Backends/Null" + :pathname #.(make-pathname :directory '(:relative "Backends" "Null")) + :components + ((:file "package") + (:file "port" :depends-on ("package")) + (:file "medium" :depends-on ("port" "package")) + (:file "graft" :depends-on ("port" "package")) + (:file "frame-manager" :depends-on ("medium" "port" "package")))))) + ;;; TODO/asf: I don't have the required libs to get :clim-opengl to load. tough. (clim-defsystem (:clim-opengl :depends-on (:clim)) "Backends/OpenGL/opengl-x-frame-manager" @@ -297,6 +309,9 @@ ;; But until it's ready, it's no use forcing users to ;; cope with possible bugs. ;; #+(or openmcl mcl) :clim-beagle + + ;; null backend + :clim-null ) :components ((:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) Index: ports.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/ports.lisp,v retrieving revision 1.50 diff -u -r1.50 ports.lisp --- ports.lisp 10 Mar 2006 21:58:13 -0000 1.50 +++ ports.lisp 14 Mar 2006 17:16:14 -0000 @@ -25,7 +25,7 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle)) +(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order* Index: Experimental/freetype/mcclim-freetype.asd =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd,v retrieving revision 1.4 diff -u -r1.4 mcclim-freetype.asd --- Experimental/freetype/mcclim-freetype.asd 6 Feb 2006 13:42:09 -0000 1.4 +++ Experimental/freetype/mcclim-freetype.asd 14 Mar 2006 17:16:14 -0000 @@ -12,13 +12,20 @@ (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) -(defclass uncompiled-cl-source-file (cl-source-file) ()) +(defclass uncompiled-cl-source-file (source-file) ()) (defmethod perform ((o compile-op) (f uncompiled-cl-source-file)) t) - +(defmethod perform ((o load-op) (f uncompiled-cl-source-file)) + (mapcar #'load (input-files o f))) (defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file)) + nil) +(defmethod input-files ((operation load-op) (c uncompiled-cl-source-file)) (list (component-pathname c))) +(defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file)) + t) +(defmethod source-file-type ((c uncompiled-cl-source-file) (s module)) + "lisp") (defsystem :mcclim-freetype :depends-on (:clim-clx)