March 2007 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 16 Mar '07

16 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv13705 Modified Files: medium.lisp Log Message: clim-g-f medium fixes: Handle transformations like CLIM-CLX does. Implemented missing medium functions (beware untested code). * Backends/Graphic-Forms/medium.lisp (MEDIUM-DRAW-POINT*, MEDIUM-DRAW-POINTS*, MEDIUM-DRAW-LINE*, MEDIUM-DRAW-LINES*, MEDIUM-DRAW-RECTANGLES*, MEDIUM-DRAW-ELLIPSE*, MEDIUM-DRAW-CIRCLE*): Implemented. (MEDIUM-DRAW-POLYGON*, MEDIUM-DRAW-RECTANGLE*): Transform the coordinates. (INK-TO-COLOR): Cap at 255. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 14:42:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 15:31:56 1.5 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- +;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: @@ -60,9 +60,9 @@ ((eql ink +background-ink+) (setf ink (medium-background medium)))) (multiple-value-bind (red green blue) (clim:color-rgb ink) - (gfg:make-color :red (truncate (* red 256)) - :green (truncate (* green 256)) - :blue (truncate (* blue 256))))) + (gfg:make-color :red (min (truncate (* red 256)) 255) + :green (min (truncate (* green 256)) 255) + :blue (min (truncate (* blue 256)) 255)))) (defun target-of (medium) (let ((sheet (medium-sheet medium))) @@ -202,62 +202,163 @@ ())) (defmethod medium-draw-point* ((medium graphic-forms-medium) x y) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr x y) + (gfg:draw-point gc (gfs:make-point :x (round-coordinate x) + :y (round-coordinate y)))))) + (add-medium-to-render medium))) (defmethod medium-draw-points* ((medium graphic-forms-medium) coord-seq) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (loop for (x y) on (coerce coord-seq 'list) by #'cddr do + (climi::with-transformed-position (tr x y) + (gfg:draw-point gc + (gfs:make-point :x (round-coordinate x) + :y (round-coordinate y))))))) + (add-medium-to-render medium))) (defmethod medium-draw-line* ((medium graphic-forms-medium) x1 y1 x2 y2) - ()) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (gfg:draw-line gc + (gfs:make-point :x (round-coordinate x1) + :y (round-coordinate y1)) + (gfs:make-point :x (round-coordinate x2) + :y (round-coordinate y2))))))) + (add-medium-to-render medium))) -;; FIXME: Invert the transformation and apply it here, as the :around -;; methods on transform-coordinates-mixin will cause it to be applied -;; twice, and we need to undo one of those. The -;; transform-coordinates-mixin stuff needs to be eliminated. (defmethod medium-draw-lines* ((medium graphic-forms-medium) coord-seq) - (let ((tr (invert-transformation (medium-transformation medium)))) - (declare (ignore tr)) - nil)) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (loop for (x1 y1 x2 y2) on (coerce coord-seq 'list) by #'cddddr do + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (gfg:draw-line gc + (gfs:make-point :x (round-coordinate x1) + :y (round-coordinate y1)) + (gfs:make-point :x (round-coordinate x2) + :y (round-coordinate y2)))))))) + (add-medium-to-render medium))) (defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled) - #+nil (gfs::debug-format "draw-polygon ~a ~a ~a~%" coord-seq closed filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) - (let ((points-list (coordinates->points coord-seq)) - (color (ink-to-color medium (medium-ink medium)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color) - (if filled - (gfg:draw-filled-polygon gc points-list) - (gfg:draw-polygon gc points-list)))) + (climi::with-transformed-positions + ((sheet-native-transformation (medium-sheet medium)) coord-seq) + (let ((points-list (coordinates->points coord-seq)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) + (when (and closed (not filled)) + (push (car (last points-list)) points-list)) + (if filled + (gfg:draw-filled-polygon gc points-list) + (gfg:draw-polygon gc points-list))))) (add-medium-to-render medium))) (defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled) - #+nil (gfs::debug-format "draw-rectangle ~a ~a ~a ~a ~a~%" left top right bottom filled) (when (target-of medium) (gfw:with-graphics-context (gc (target-of medium)) - (let ((rect (coordinates->rectangle left top right bottom)) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (climi::with-transformed-position (tr left top) + (climi::with-transformed-position (tr right bottom) + (let ((rect (coordinates->rectangle left top right bottom)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) + (if filled + (gfg:draw-filled-rectangle gc rect) + (gfg:draw-rectangle gc rect))))))) + (add-medium-to-render medium))) + +(defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((tr (sheet-native-transformation (medium-sheet medium))) (color (ink-to-color medium (medium-ink medium)))) (setf (gfg:background-color gc) color (gfg:foreground-color gc) color) - (if filled - (gfg:draw-filled-rectangle gc rect) - (gfg:draw-rectangle gc rect)))) + (loop for i below (length position-seq) by 4 do + (let ((x1 (round-coordinate (elt position-seq (+ i 0)))) + (y1 (round-coordinate (elt position-seq (+ i 1)))) + (x2 (round-coordinate (elt position-seq (+ i 2)))) + (y2 (round-coordinate (elt position-seq (+ i 3))))) + (climi::with-transformed-position (tr x1 y1) + (climi::with-transformed-position (tr x2 y2) + (let ((rect (coordinates->rectangle x1 y1 x2 y2))) + (if filled + (gfg:draw-filled-rectangle gc rect) + (gfg:draw-rectangle gc rect))))))))) (add-medium-to-render medium))) -(defmethod medium-draw-rectangles* ((medium graphic-forms-medium) position-seq filled) - ()) - +;; FIXME: completely untested. Not sure we're even using the right GFG h +;; functions. Are start-point and end-point right? (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) - ()) + (unless (or (= radius-2-dx radius-1-dy 0) (= radius-1-dx radius-2-dy 0)) + (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses.")) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (climi::with-transformed-position + ((sheet-native-transformation (medium-sheet medium)) + center-x center-y) + (let* ((radius-dx (abs (+ radius-1-dx radius-2-dx))) + (radius-dy (abs (+ radius-1-dy radius-2-dy))) + (min-x (round-coordinate (- center-x radius-dx))) + (min-y (round-coordinate (- center-y radius-dy))) + (max-x (round-coordinate (+ center-x radius-dx))) + (max-y (round-coordinate (+ center-y radius-dy))) + (rect (coordinates->rectangle min-x min-y max-x max-y)) + (start-point + (gfs:make-point :x (round-coordinate + (* (cos start-angle) radius-dx)) + :y (round-coordinate + (* (sin start-angle) radius-dy)))) + (end-point + (gfs:make-point :x (round-coordinate + (* (cos end-angle) radius-dx)) + :y (round-coordinate + (* (sin end-angle) radius-dy))))) + (if filled + (gfg:draw-filled-pie-wedge gc rect start-point end-point) + (gfg:draw-pie-wedge gc rect start-point end-point))))) + (add-medium-to-render medium))) +;; FIXME: completely untested. (defmethod medium-draw-circle* ((medium graphic-forms-medium) center-x center-y radius start-angle end-angle filled) - ()) + (medium-draw-ellipse* medium + center-x center-y + radius radius + radius radius + start-angle end-angle + filled)) (defmethod text-style-ascent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium)))

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 16 Mar '07

16 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv934 Modified Files: gadgets.lisp medium.lisp port.lisp utils.lisp Log Message: More little clim-g-f fixes. demodemo still looks terrible but its buttons work. The Quit menu in the address book works. * Backends/Graphic-Forms/gadgets.lisp ((REALIZE-MIRROR PUSH-BUTTON)): Set the dispatcher. * Backends/Graphic-Forms/medium.lisp (add-medium-to-render): Do it only if the double buffering image has been installed. (RENDER-MEDIUM-BUFFER): Renamed from render-medium, since it is only used for the buffering image. (RENDER-PENDING-MEDIUMS): Use render-medium-buffer. (INK-TO-COLOR): New function. (TARGET-OF): Return (and create if needed) image-of, or return the normal mirror if no buffering has been requested. (TEXT-STYLE-TO-FONT): New function, based on the old sync-text-style. (SYNC-TEXT-STYLE): Use text-style-to-font. (MEDIUM-DRAW-POLYGON, MEDIUM-DRAW-RECTANGLE*): Use the medium ink. Use target-of instead of image-of. (TEXT-STYLE-*, MEDIUM-DRAW-TEXT*, MEDIUM-CLEAR-AREA): Use target-of instead of image-of. (TEXT-SIZE): Merge the text styles properly. (MEDIUM-DRAW-TEXT*): At least make some effort to draw the text above the y coordinate, not below it. Probably not correct yet. (MEDIUM-FINISH-OUTPUT, MEDIUM-FORCE-OUTPUT): Only if image-of is set. * Backends/Graphic-Forms/port.lisp (GFW-MENU-ITEM-PANE): New slot callback, needed for those commands that sit directly in the menu bar. (SHEET-DESIRED-INK): Copy&paste from CLX. (EVENT-PAINT): Clear the affected area with the desired color when enqueing an repaint, as expected by the frontend. (EVENT-RESIZE): Resize image-of only if it exists. (GADGET-EVENT, BUTTON-PRESSED-EVENT): New classes. (EVENT-SELECT): Handle push buttons. ((HANDLE-EVENT PUSH-BUTTON BUTTON-PRESSED-EVENT)): New method. (HANDLE-MENU-CLICKED-EVENT): Call the callback if present. * Backends/Graphic-Forms/utils.lisp (COORDINATES->POINTS): Rewritten to loop over the vector (it's not a list). --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/16 14:42:49 1.3 @@ -123,7 +123,11 @@ (defmethod realize-mirror ((port graphic-forms-port) (gadget push-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) - (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:push-button)))) + (mirror (make-instance 'gfw-button + :sheet gadget + :parent parent-mirror + :dispatcher *pane-dispatcher* + :style '(:push-button)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/16 14:42:49 1.4 @@ -37,21 +37,45 @@ (defvar *mediums-to-render* nil) (defun add-medium-to-render (medium) - (pushnew medium *mediums-to-render* :test #'eql)) + (when (image-of medium) + (pushnew medium *mediums-to-render* :test #'eql))) (defun remove-medium-to-render (medium) (setf *mediums-to-render* (remove medium *mediums-to-render*))) -(defun render-medium (medium) +(defun render-medium-buffer (medium) (let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))) (gfw:with-graphics-context (gc mirror) (gfg:draw-image gc (image-of medium) *medium-origin*)))) (defun render-pending-mediums () (loop for medium in *mediums-to-render* - do (render-medium medium)) + do (render-medium-buffer medium)) (setf *mediums-to-render* nil)) +(defun ink-to-color (medium ink) + (cond + ((eql ink +foreground-ink+) + (setf ink (medium-foreground medium))) + ((eql ink +background-ink+) + (setf ink (medium-background medium)))) + (multiple-value-bind (red green blue) (clim:color-rgb ink) + (gfg:make-color :red (truncate (* red 256)) + :green (truncate (* green 256)) + :blue (truncate (* blue 256))))) + +(defun target-of (medium) + (let ((sheet (medium-sheet medium))) + (if (climi::pane-double-buffering sheet) + (or (image-of medium) + (let* ((region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region)))) + (setf (image-of medium) + (make-instance 'gfg:image + :size (gfs:make-size width height))))) + (sheet-mirror (medium-sheet medium))))) + (defun resize-medium-buffer (medium size) (let ((old-image (image-of medium))) (when old-image @@ -81,6 +105,19 @@ (symbol (symbol-name text)))) (defun sync-text-style (medium text-style) + (gfw:with-graphics-context + (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) + (let* ((old-data + (when (font-of medium) + (gfg:data-object (font-of medium) gc))) + (new-font (text-style-to-font gc text-style old-data))) + (when new-font + (when old-data + (gfs:dispose (font-of medium)) + (setf (font-of medium) nil)) + (setf (font-of medium) new-font))))) + +(defun text-style-to-font (gc text-style old-data) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) #+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size) @@ -90,53 +127,47 @@ ;; FIXME: externalize these specific choices so that applications can ;; have better control over them ;; - (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) - (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) - (face-name (if (stringp family) - family - (ecase family - ((:fix :fixed) "Lucida Console") - (:serif "Times New Roman") - (:sans-serif "Arial")))) - (pnt-size (case size - (:tiny 6) - (:very-small 8) - (:small 10) - (:normal 12) - (:large 14) - (:very-large 16) - (:huge 18) - (otherwise 10))) - (style nil)) - (pushnew (case face - ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) - :bold) - (otherwise - :normal)) - style) - (pushnew (case face - ((:bold-italic :italic :italic-bold) - :italic) - (otherwise - :normal)) - style) - (pushnew (case family - ((:fix :fixed) :fixed) - (otherwise :normal)) - style) - (when (or (null old-data) - (not (eql pnt-size (gfg:font-data-point-size old-data))) - (string-not-equal face-name (gfg:font-data-face-name old-data)) - (/= (length style) - (length (intersection style (gfg:font-data-style old-data))))) - (when old-data - (gfs:dispose (font-of medium)) - (setf (font-of medium) nil)) - (let ((new-data (gfg:make-font-data :face-name face-name - :point-size pnt-size - :style style))) - #+nil (gfs::debug-format "new font data: ~a~%" new-data) - (setf (font-of medium) (make-instance 'gfg:font :gc gc :data new-data)))))))) + (let ((face-name (if (stringp family) + family + (ecase family + ((:fix :fixed) "Lucida Console") + (:serif "Times New Roman") + (:sans-serif "Arial")))) + (pnt-size (case size + (:tiny 6) + (:very-small 8) + (:small 10) + (:normal 12) + (:large 14) + (:very-large 16) + (:huge 18) + (otherwise 10))) + (style nil)) + (pushnew (case face + ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) + :bold) + (otherwise + :normal)) + style) + (pushnew (case face + ((:bold-italic :italic :italic-bold) + :italic) + (otherwise + :normal)) + style) + (pushnew (case family + ((:fix :fixed) :fixed) + (otherwise :normal)) + style) + (when (or (null old-data) + (not (eql pnt-size (gfg:font-data-point-size old-data))) + (string-not-equal face-name (gfg:font-data-face-name old-data)) + (/= (length style) + (length (intersection style (gfg:font-data-style old-data))))) + (let ((new-data (gfg:make-font-data :face-name face-name + :point-size pnt-size + :style style))) + (make-instance 'gfg:font :gc gc :data new-data)))))) (defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium)) (sync-text-style medium @@ -190,11 +221,12 @@ (defmethod medium-draw-polygon* ((medium graphic-forms-medium) coord-seq closed filled) #+nil (gfs::debug-format "draw-polygon ~a ~a ~a~%" coord-seq closed filled) - (when (image-of medium) - (gfw:with-graphics-context (gc (image-of medium)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-black*) - (let ((points-list (coordinates->points coord-seq))) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((points-list (coordinates->points coord-seq)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) (if filled (gfg:draw-filled-polygon gc points-list) (gfg:draw-polygon gc points-list)))) @@ -202,11 +234,12 @@ (defmethod medium-draw-rectangle* ((medium graphic-forms-medium) left top right bottom filled) #+nil (gfs::debug-format "draw-rectangle ~a ~a ~a ~a ~a~%" left top right bottom filled) - (when (image-of medium) - (gfw:with-graphics-context (gc (image-of medium)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-black*) - (let ((rect (coordinates->rectangle left top right bottom))) + (when (target-of medium) + (gfw:with-graphics-context (gc (target-of medium)) + (let ((rect (coordinates->rectangle left top right bottom)) + (color (ink-to-color medium (medium-ink medium)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color) (if filled (gfg:draw-filled-rectangle gc rect) (gfg:draw-rectangle gc rect)))) @@ -229,21 +262,21 @@ (defmethod text-style-ascent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:ascent (gfg:metrics gc font))) 1))) (defmethod text-style-descent (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:descent (gfg:metrics gc font))) 1))) (defmethod text-style-height (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:height (gfg:metrics gc font))) 1))) @@ -252,7 +285,7 @@ (width 1) (text (normalize-text-data char))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:font gc) font) (setf width (gfs:size-width (gfg:text-extent gc text))))) width)) @@ -260,34 +293,30 @@ (defmethod text-style-width (text-style (medium graphic-forms-medium)) (let ((font (font-of medium))) (if font - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (gfg:average-char-width (gfg:metrics gc font))) 1))) (defmethod text-size ((medium graphic-forms-medium) string &key text-style (start 0) end) (setf string (normalize-text-data string)) -#| - (setf text-style (merge-text-styles (or text-style (make-text-style nil nil nil)) - (medium-default-text-style medium))) -|# - ;; FIXME: handle embedded newlines - ;; - (let ((font (font-of medium))) - (if font - (gfw:with-graphics-context (gc (image-of medium)) - (let ((metrics (gfg:metrics gc font)) - (width (gfs:size-width (gfg:text-extent gc (subseq string - start - (or end (length string))))))) - (values width - (gfg:height metrics) - width - (gfg:height metrics) - (gfg:ascent metrics)))) - (values 1 1 1 1 1)))) + (setf text-style (or text-style (make-text-style nil nil nil))) + (setf text-style + (merge-text-styles text-style (medium-default-text-style medium))) + (gfw:with-graphics-context (gc (target-of medium)) + (let* ((font (text-style-to-font gc text-style nil)) + (metrics (gfg:metrics gc font)) + (width (gfs:size-width (gfg:text-extent gc (subseq string + start + (or end (length string))))))) + (values width + (gfg:height metrics) + width + (gfg:height metrics) + (gfg:ascent metrics))))) (defmethod climi::text-bounding-rectangle* ((medium graphic-forms-medium) string &key text-style (start 0) end) + ;; fixme, completely wrong (text-size medium string :text-style text-style :start start :end end)) (defmethod medium-draw-text* ((medium graphic-forms-medium) string x y @@ -295,15 +324,18 @@ align-x align-y toward-x toward-y transform-glyphs) #+nil (gfs::debug-format "medium-draw-text: ~d, ~d ~s~%" x y string) - (when (image-of medium) + (when (target-of medium) (setf string (normalize-text-data string)) - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (let ((font (font-of medium))) (if font (setf (gfg:font gc) font)) - (gfg:draw-text gc - (subseq string start (or end (length string))) - (gfs:make-point :x x :y y)))) + (let ((h (gfg:height (gfg:metrics gc font))) + (x (round-coordinate x)) + (y (round-coordinate y))) + (gfg:draw-text gc + (subseq string start (or end (length string))) + (gfs:make-point :x x :y (- y h)))))) (add-medium-to-render medium))) (defmethod medium-buffering-output-p ((medium graphic-forms-medium)) @@ -318,15 +350,17 @@ ()) (defmethod medium-finish-output ((medium graphic-forms-medium)) - (render-medium medium)) + (when (image-of medium) + (render-medium-buffer medium))) (defmethod medium-force-output ((medium graphic-forms-medium)) - (render-medium medium)) + (when (image-of medium) + (render-medium-buffer medium))) (defmethod medium-clear-area ((medium graphic-forms-medium) left top right bottom) - (when (image-of medium) + (when (target-of medium) (let ((rect (coordinates->rectangle left top right bottom))) - (gfw:with-graphics-context (gc (image-of medium)) + (gfw:with-graphics-context (gc (target-of medium)) (setf (gfg:background-color gc) gfg:*color-white* (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:49:05 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4 @@ -59,6 +59,7 @@ :accessor item :initarg :item :initform nil) + (callback :initarg :value-changed-callback :accessor callback) (command :accessor command :initarg :command @@ -408,12 +409,35 @@ (setf (event (port self)) (make-instance 'window-manager-delete-event :sheet (sheet mirror)))) +;; copy&paste from port.lisp|CLX: +(defun sheet-desired-ink (sheet) + (typecase sheet + (sheet-with-medium-mixin + (medium-background sheet)) + (basic-pane + ;; CHECKME [is this sensible?] seems to be + (let ((background (pane-background sheet))) + (if (typep background 'color) + background + +white+))) + (t + +white+))) + (defmethod gfw:event-paint ((self sheet-event-dispatcher) mirror gc rect) (declare (ignore gc)) (let ((sheet (sheet mirror))) - (setf (event (port self)) (make-instance 'window-repaint-event - :sheet sheet - :region (translate-rectangle rect))))) + (when (and (typep sheet 'sheet-with-medium-mixin) + (not (image-of (sheet-medium sheet)))) + (gfw:with-graphics-context (gc mirror) + (let ((c (ink-to-color (sheet-medium sheet) + (sheet-desired-ink sheet)))) + (setf (gfg:background-color gc) c + (gfg:foreground-color gc) c)) + (gfg:draw-filled-rectangle gc rect))) + (setf (event (port self)) + (make-instance 'window-repaint-event + :sheet sheet + :region (translate-rectangle rect))))) (defun generate-configuration-event (mirror pnt size) (make-instance 'window-configuration-event @@ -431,15 +455,26 @@ (let ((sheet (sheet mirror))) (if (and sheet (subtypep (class-of sheet) 'sheet-with-medium-mixin)) (let ((medium (climi::sheet-medium sheet))) - (if medium + (if (and medium (image-of medium)) (resize-medium-buffer medium size)))) (setf (event (port self)) (generate-configuration-event mirror (gfw:location mirror) size)))) +(defclass gadget-event (window-event) ()) +(defclass button-pressed-event (gadget-event) ()) + (defmethod gfw:event-select ((self pane-event-dispatcher) mirror) - (setf (event (port self)) (make-instance 'menu-clicked-event - :sheet (sheet (gfw:owner mirror)) - :item (sheet mirror)))) + (setf (event (port self)) + (typecase mirror + (gfw-button + (make-instance 'button-pressed-event :sheet (sheet mirror))) + (t + (make-instance 'menu-clicked-event + :sheet (sheet (gfw:owner mirror)) + :item (sheet mirror)))))) + +(defmethod handle-event ((pane push-button) (event button-pressed-event)) + (activate-callback pane (gadget-client pane) (gadget-id pane))) (defun translate-button-name (name) (case name @@ -553,8 +588,9 @@ (if pane (let ((menu-item (item pane))) (if menu-item - (if (eql (command-menu-item-type menu-item) :command) - (climi::throw-object-ptype menu-item 'menu-item))))))) + (if (eql (command-menu-item-type menu-item) :command) + (climi::throw-object-ptype menu-item 'menu-item)) + (funcall (callback pane) pane nil)))))) (defmethod handle-event ((pane gfw-menu-pane) (event menu-clicked-event)) (handle-menu-clicked-event event)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/16 14:42:51 1.2 @@ -44,10 +44,8 @@ :width (round-coordinate (- right left)) :height (round-coordinate (- bottom top)))) -(defun coordinates->points (list) - (cond - ((null list) (values)) - ((and (car list) (cdr list)) - (concatenate 'list (list (gfs:make-point :x (round-coordinate (car list)) - :y (round-coordinate (car (cdr list))))) - (coordinates->points (cdr (cdr list))))))) +(defun coordinates->points (seq) + (loop for i from 2 below (length seq) by 2 + collect + (gfs:make-point :x (round-coordinate (elt seq i)) + :y (round-coordinate (elt seq (+ i 1))))))

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 14 Mar '07

14 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv21895 Modified Files: gadgets.lisp graft.lisp medium.lisp port.lisp Log Message: g-f fixes, including keyboard and mouse events. * Backends/Graphic-Forms/gadgets.lisp (REALIZE-MIRROR): Spell gfw-scroll-bar correctly, with a dash. * Backends/Graphic-Forms/graft.lisp (graft-height): Fixed order of arguments to gethash. * Backends/Graphic-Forms/medium.lisp (sync-text-style): It's :sans-serif, not :sansserif. Use ECASE to avoid this going undetected. Allow family names that are strings, not symbols, and pass them through unchanged. * Backends/Graphic-Forms/port.lisp (resolve-abstract-pane-name): Copy&paste from gtkairo. (make-pane-2): Call make-instance with a real class name, not the pane type spec. ((realize-mirror mirrored-sheet-mixin)): Removed the :border style. (port-frame-keyboard-input-focus, and its setf method): New methods. (translate-button-name, char-to-sym): New functions. (gfw:event-mouse-move, gfw:event-mouse-up, gfw:event-mouse-down, gfw:event-key-up, gfw:event-key-down): New methods. --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2 @@ -141,7 +141,7 @@ (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) - (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical))) + (mirror (make-instance 'gfw-scroll-bar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:42:40 1.2 @@ -37,7 +37,7 @@ (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes)))) + (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics))))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:42:40 1.2 @@ -92,10 +92,12 @@ ;; (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) - (face-name (case family - ((:fix :fixed) "Lucida Console") - (:serif "Times New Roman") - (:sansserif "Arial"))) + (face-name (if (stringp family) + family + (ecase family + ((:fix :fixed) "Lucida Console") + (:serif "Times New Roman") + (:sans-serif "Arial")))) (pnt-size (case size (:tiny 6) (:very-small 8) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:42:40 1.2 @@ -122,10 +122,21 @@ (setf (get :graphic-forms :port-type) 'graphic-forms-port) (setf (get :graphic-forms :server-path-parser) 'parse-graphic-forms-server-path) +(defun resolve-abstract-pane-name (type) + (when (get type 'climi::concrete-pane-class-name) + (setf type (get type 'climi::concrete-pane-class-name))) + (class-name + (or (find-class + (intern (concatenate 'string (symbol-name type) "-PANE") :climi) + nil) + (if (keywordp type) + (find-class (intern (symbol-name type) :climi)) + (find-class type))))) + (defgeneric make-pane-2 (type &rest initargs) (:documentation "Implement this to instantiate specific pane types.") (:method (type &rest initargs) - (apply #'make-instance type initargs))) + (apply #'make-instance (resolve-abstract-pane-name type) initargs))) ;;; ;;; helper functions @@ -211,7 +222,7 @@ (mirror (make-instance 'gfw-panel :sheet sheet :dispatcher *sheet-dispatcher* - :style '(:border) + :style '() ;was: '(:border) :parent parent))) (setf (gfw:size mirror) (requirement->size req)) (multiple-value-bind (x y) @@ -335,6 +346,16 @@ ;;; Set the keyboard input focus for the port. +(defmethod port-frame-keyboard-input-focus + ((port graphic-forms-port) frame) + ;; fixme + (frame-properties frame 'focus)) + +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port graphic-forms-port) frame) + (gfw:give-focus (sheet-mirror focus)) + (setf (frame-properties frame 'focus) focus)) + (defmethod %set-port-keyboard-focus (focus (port graphic-forms-port) &key timestamp) (declare (ignore timestamp)) ()) @@ -420,6 +441,109 @@ :sheet (sheet (gfw:owner mirror)) :item (sheet mirror)))) +(defun translate-button-name (name) + (case name + (:left-button +pointer-left-button+) + (:right-button +pointer-right-button+) + (:middle-button +pointer-middle-button+) + (t + (warn "unknown button name: ~A" name) + nil))) + +(defmethod gfw:event-mouse-move + ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-motion-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-press-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-release-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defun char-to-sym (char) + (case char + (#\ :| |) (#\! :!) (#\" :|"|) (#\# :|#|) (#\$ :$) (#\% :%) (#\& :&) + (#\' :|'|) (#$ :|(|) (#$ :|)|) (#\* :*) (#\+ :+) (#\, :|,|) (#\- :-) + (#\. :|.|) (#\/ :/) (#\0 :|0|) (#\1 :|1|) (#\2 :|2|) (#\3 :|3|) (#\4 :|4|) + (#\5 :|5|) (#\6 :|6|) (#\7 :|7|) (#\8 :|8|) (#\9 :|9|) (#\: :|:|) (#\; :|;|) + (#\< :<) (#\= :=) (#\> :>) (#\? :?) (#\@ :@) (#\A :A) (#\B :B) (#\C :C) + (#\D :D) (#\E :E) (#\F :F) (#\G :G) (#\H :H) (#\I :I) (#\J :J) (#\K :K) + (#\L :L) (#\M :M) (#\N :N) (#\O :O) (#\P :P) (#\Q :Q) (#\R :R) (#\S :S) + (#\T :T) (#\U :U) (#\V :V) (#\W :W) (#\X :X) (#\Y :Y) (#\Z :Z) (#\[ :[) + (#\\ :|\\|) (#\] :]) (#\_ :_) (#\` :|`|) (#\a :|a|) (#\b :|b|) (#\c :|c|) + (#\d :|d|) (#\e :|e|) (#\f :|f|) (#\g :|g|) (#\h :|h|) (#\i :|i|) (#\j :|j|) + (#\k :|k|) (#\l :|l|) (#\m :|m|) (#\n :|n|) (#\o :|o|) (#\p :|p|) (#\q :|q|) + (#\r :|r|) (#\s :|s|) (#\t :|t|) (#\u :|u|) (#\v :|v|) (#\w :|w|) (#\x :|x|) + (#\y :|y|) (#\z :|z|) (#\{ :{) (#\| :|\||) (#\} :}) (#\Backspace :BACKSPACE) + (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) + +(defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-press-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + +(defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-release-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + + ;;; ;;; McCLIM handle-event methods ;;;

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 14 Mar '07

14 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv19686/Backends/Graphic-Forms Added Files: frame-manager.lisp gadgets.lisp graft.lisp medium.lisp package.lisp port.lisp utils.lisp Log Message: Added the native windows backend clim-graphic-forms, by Jack D. Unrue --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/frame-manager.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/frame-manager.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes(a)gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-frame-manager (frame-manager) ()) (defmethod make-pane-1 ((fmgr graphic-forms-frame-manager) (frame application-frame) type &rest initargs) #+nil (gfs::debug-format "make-pane-1 type: ~a initargs: ~a~%" type initargs) (apply #'make-pane-2 type :manager fmgr :frame frame :port (port frame) initargs)) (defmethod adopt-frame :after ((fmgr graphic-forms-frame-manager) (frame application-frame)) ()) (defmethod note-space-requirements-changed :after ((graft graphic-forms-graft) pane) (gfs::debug-format "space requirements changed: ~a~%" pane)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS; -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes(a)gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) ;;; ;;; base widget behaviors ;;; (defmethod activate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) t))) (call-next-method)) (defmethod deactivate-gadget ((widget gfw-widget-pane-mixin)) (with-slots (active-p) widget (unless active-p (gfw:enable (sheet-mirror widget) nil))) (call-next-method)) ;;; ;;; menus ;;; (defun append-menu-items (port menu-pane) (let ((table-name (command-table menu-pane))) (when table-name (let ((table (find-command-table table-name))) (dolist (thing (slot-value table 'climi::menu)) (let* ((sub-table-name (if (eql (command-menu-item-type thing) :menu) (command-table-name thing) nil)) (sub-pane (climi::make-menu-button-from-menu-item thing nil :command-table sub-table-name))) (if (eql (command-menu-item-type thing) :command) (setf (gadget-label sub-pane) (climi::command-menu-item-name thing) (item sub-pane) thing) (setf (label sub-pane) (climi::command-menu-item-name thing))) (setf (sheet-parent sub-pane) menu-pane) (realize-mirror port sub-pane)))))) (dolist (menu-item (contents menu-pane)) (unless (integerp menu-item) (setf (sheet-parent menu-item) menu-pane) (realize-mirror port menu-item)))) (defmethod make-pane-2 ((type (eql 'climi::menu-bar)) &rest initargs) (apply #'make-instance 'gfw-menu-bar-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let* ((top-level (sheet-mirror (sheet-parent (sheet-parent pane)))) (mirror (gfw:menu-bar top-level))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-bar-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-submenu-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let* ((parent (sheet-mirror (sheet-parent pane))) (mirror (make-instance 'gfw-menu :sheet pane :handle (gfs::create-popup-menu)))) (gfw:append-submenu parent (label pane) mirror nil) (climi::port-register-mirror port pane mirror) (append-menu-items port pane) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod make-pane-2 ((type (eql 'climi::menu-button-leaf-pane)) &rest initargs) (apply #'make-instance 'gfw-menu-item-pane initargs)) (defmethod realize-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-item menu (gadget-label pane) *pane-dispatcher* nil nil 'gfw-menu-item))) (setf (sheet mirror) pane) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane gfw-menu-item-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) (defmethod realize-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let* ((menu (sheet-mirror (sheet-parent pane))) (mirror (gfw:append-separator menu))) (climi::port-register-mirror port pane mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (pane climi::menu-divider-leaf-pane)) (let ((mirror (climi::port-lookup-mirror port pane))) (climi::port-unregister-mirror port pane mirror))) ;;; ;;; other gadgets ;;; (defmethod realize-mirror ((port graphic-forms-port) (gadget push-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:push-button)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget toggle-button)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-button :parent parent-mirror :style '(:check-box)))) (if (gadget-label gadget) (setf (gfw:text mirror) (gadget-label gadget))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror)) (defmethod destroy-mirror ((port graphic-forms-port) (gadget value-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) (defmethod destroy-mirror ((port graphic-forms-port) (gadget action-gadget)) (let ((mirror (climi::port-lookup-mirror port gadget))) (climi::port-unregister-mirror port gadget mirror))) ;;; ;;; layout ;;; (defmethod compose-space ((gadget action-gadget) &key width height) (declare (ignore width height)) (let ((mirror (climi::port-lookup-mirror (port gadget) gadget)) (pref-size (gfs:make-size :width 100 :height 100))) (if mirror (setf pref-size (gfw:preferred-size mirror -1 -1)) (progn (gfs::debug-format "compose-space parent: ~a~%" (sheet-mirror (sheet-parent gadget))) (setf mirror (make-instance 'gfw:button :parent (sheet-mirror (sheet-parent gadget)) :text (gadget-label gadget))) (setf pref-size (gfw:preferred-size mirror -1 -1)) (gfs:dispose mirror) (setf mirror nil))) (gfs::debug-format "pref size ~a for ~a mirror ~a~%" pref-size gadget mirror) (make-space-requirement :width (gfs:size-width pref-size) :height (gfs:size-height pref-size)))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006-2007 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes(a)gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-graft (graft) ()) (defmethod graft-width ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (gfs:size window))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-width size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+horzsize+)) (:inches (floor (gfs:size-width size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsx+))) (:screen-sized 1)))))) (defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes)))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) (:millimeters (gfs::get-device-caps (gfs:handle gc) gfs::+vertsize+)) (:inches (floor (gfs:size-height size) (gfs::get-device-caps (gfs:handle gc) gfs::+logpixelsy+))) (:screen-sized 1)))))) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1 ;;; -*- Mode: Lisp; Package: CLIM-GRAPHIC-FORMS -*- ;;; (c) 2006 Jack D. Unrue (jdunrue (at) gmail (dot) com) ;;; based on the null backend by: ;;; (c) 2005 Christophe Rhodes (c.rhodes(a)gold.ac.uk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-graphic-forms) (defclass graphic-forms-medium (basic-medium) ((font :accessor font-of :initform nil) (image :accessor image-of :initform nil) (port :accessor port-of :initarg :port :initform nil))) (defvar *medium-origin* (gfs:make-point)) (defvar *mediums-to-render* nil) (defun add-medium-to-render (medium) (pushnew medium *mediums-to-render* :test #'eql)) (defun remove-medium-to-render (medium) (setf *mediums-to-render* (remove medium *mediums-to-render*))) (defun render-medium (medium) (let ((mirror (climi::port-lookup-mirror (port-of medium) (medium-sheet medium)))) (gfw:with-graphics-context (gc mirror) (gfg:draw-image gc (image-of medium) *medium-origin*)))) (defun render-pending-mediums () (loop for medium in *mediums-to-render* do (render-medium medium)) (setf *mediums-to-render* nil)) (defun resize-medium-buffer (medium size) (let ((old-image (image-of medium))) (when old-image (if (not (gfs:disposed-p old-image)) (let ((old-size (gfg:size old-image))) (unless (gfs:equal-size-p size old-size) (gfs:dispose old-image) (setf old-image nil))) (setf old-image nil))) (unless old-image (setf (image-of medium) (make-instance 'gfg:image :size size))))) (defun destroy-medium (medium) (remove-medium-to-render medium) (let ((image (image-of medium))) (if (and image (not (gfs:disposed-p image))) (gfs:dispose image))) (let ((font (font-of medium))) (if (and font (not (gfs:disposed-p font))) (gfs:dispose font)) (setf (font-of medium) nil))) (defun normalize-text-data (text) (etypecase text (string text) (character (string text)) (symbol (symbol-name text)))) (defun sync-text-style (medium text-style) (multiple-value-bind (family face size) (text-style-components (merge-text-styles text-style *default-text-style*)) #+nil (gfs::debug-format "family: ~a face: ~a size: ~a~%" family face size) ;; ;; FIXME: what to do about font data char sets? ;; ;; FIXME: externalize these specific choices so that applications can ;; have better control over them ;; (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) (face-name (case family ((:fix :fixed) "Lucida Console") (:serif "Times New Roman") (:sansserif "Arial"))) (pnt-size (case size (:tiny 6) (:very-small 8) (:small 10) (:normal 12) (:large 14) (:very-large 16) (:huge 18) (otherwise 10))) (style nil)) (pushnew (case face ((:bold :bold-italic :bold-oblique :italic-bold :oblique-bold) :bold) (otherwise :normal)) style) (pushnew (case face ((:bold-italic :italic :italic-bold) :italic) (otherwise :normal)) style) (pushnew (case family ((:fix :fixed) :fixed) (otherwise :normal)) style) (when (or (null old-data) (not (eql pnt-size (gfg:font-data-point-size old-data))) (string-not-equal face-name (gfg:font-data-face-name old-data)) (/= (length style) (length (intersection style (gfg:font-data-style old-data))))) (when old-data (gfs:dispose (font-of medium)) (setf (font-of medium) nil)) (let ((new-data (gfg:make-font-data :face-name face-name :point-size pnt-size :style style))) #+nil (gfs::debug-format "new font data: ~a~%" new-data) (setf (font-of medium) (make-instance 'gfg:font :gc gc :data new-data)))))))) (defmethod (setf medium-text-style) :before (text-style (medium graphic-forms-medium)) (sync-text-style medium (merge-text-styles (medium-text-style medium) (medium-default-text-style medium)))) (defmethod (setf medium-line-style) :before (line-style (medium graphic-forms-medium)) [197 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/package.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/package.lisp 2007/03/14 23:33:25 1.1 [222 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1 [661 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp 2007/03/14 23:33:25 1.1 [714 lines skipped]

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 14 Mar '07

14 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19686 Modified Files: mcclim.asd ports.lisp Log Message: Added the native windows backend clim-graphic-forms, by Jack D. Unrue --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/02/04 12:55:43 1.54 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/03/14 23:33:24 1.55 @@ -62,7 +62,7 @@ (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) - #-(or clx gtkairo) + #-(or clx gtkairo clim-graphic-forms) (require :clx) #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) @@ -409,6 +409,20 @@ (:file "frame-manager") (:file "gadgets"))))) +(defsystem :clim-graphic-forms + :depends-on (:clim :graphic-forms-uitoolkit) + :components + ((:module "Backends/Graphic-Forms" + :pathname #.(make-pathname :directory '(:relative "Backends" "Graphic-Forms")) + :components + ((:file "package") + (:file "utils" :depends-on ("package")) + (:file "graft" :depends-on ("package")) + (:file "port" :depends-on ("utils" "graft")) + (:file "medium" :depends-on ("port")) + (:file "frame-manager" :depends-on ("medium")) + (:file "gadgets" :depends-on ("port")))))) + ;;; 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" @@ -425,8 +439,10 @@ :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(and (or sbcl scl openmcl ecl clx allegro) (not gtkairo)) + #+(and (or sbcl scl openmcl ecl clx allegro) + (not (or gtkairo clim-graphic-forms))) :clim-clx + #+clim-graphic-forms :clim-graphic-forms #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). @@ -440,7 +456,7 @@ ;; null backend :clim-null ) - :components (#-gtkairo + :components (#-(or gtkairo clim-graphic-forms) (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) --- /project/mcclim/cvsroot/mcclim/ports.lisp 2007/02/07 12:44:17 1.55 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2007/03/14 23:33:24 1.56 @@ -25,7 +25,18 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtkairo :clx :x11 :opengl :beagle :null)) +;; - CLX is the de-facto reference backend. +;; - Prefer Graphic-Forms and Gtkairo over CLX, since they get installed only +;; on explicit user request anyway. +;; - If both are present, use Graphics-Forms in favour of Gtkairo, since +;; it is the native Windows backend. +;; - Beagle should be treated like Graphic-Forms in the long term, but is +;; currently lacking a maintainer, so let's leave it near the end. +;; - OpenGL and Null are in this list mostly to document their existence, +;; and neither is currently a complete backend we would want to make +;; a default. Put them after CLX, so that they won't actually be reached. +(defvar *server-path-search-order* + '(:graphic-forms :gtkairo :clx :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order*

1 0

[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
by dlichteblau 14 Mar '07

14 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv19587/Graphic-Forms Log Message: Directory /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms added to the repository

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 12 Mar '07

12 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12716 Modified Files: bordered-output.lisp Log Message: Added some valid default values for line styles in borders. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/02/05 03:16:55 1.15 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/03/12 17:36:52 1.16 @@ -175,9 +175,9 @@ `(or line-style (merge-line-styles (make-line-style - :unit line-unit - :thickness line-thickness - :cap-shape line-cap-shape + :unit (or line-unit :point) + :thickness (or line-thickness 1) + :cap-shape (or line-cap-shape :butt) :dashes line-dashes) (medium-line-style stream))))

2 1

[mcclim-cvs] CVS mcclim/Experimental/tree-with-cross-edges
by rgoldman 09 Mar '07

09 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges In directory clnet:/tmp/cvs-serv24198 Added Files: mcclim-tree-with-cross-edges.asd tree-with-cross-edges.lisp Log Message: First draft version of an experimental extension to the graph-formatting protocol. --- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/mcclim-tree-with-cross-edges.asd 2007/03/09 23:42:34 1.1 ;;;; -*- Lisp -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; A system that adds a new type of graph to the ;;; format-graph-from-roots protocol for McCLIM. ;;; ;;; ;;;--------------------------------------------------------------------------- (defpackage :mcclim-tree-with-cross-edges-system (:use :cl :asdf)) (in-package :mcclim-tree-with-cross-edges-system) (defsystem :mcclim-tree-with-cross-edges :depends-on (:mcclim) :serial t :components ((:file "tree-with-cross-edges"))) --- /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges/tree-with-cross-edges.lisp 2007/03/09 23:42:34 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*- ;;;--------------------------------------------------------------------------- ;;; Copyright (c) 2005-2007 Robert P. Goldman and Smart Information ;;; Flow Technologies, d/b/a SIFT, LLC ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; All rights reserved. ;;; ;;;--------------------------------------------------------------------------- ;;; File Description: ;;; ;;; File for definitions of a new graph type that should allow tree ;;; style layouts with edges across in a level. [2005/05/05:rpg] ;;; ;;; History/Bugs/Notes: ;;; ;;; [2005/05/05:rpg] Created. ;;; ;;;--------------------------------------------------------------------------- (in-package "CLIM-INTERNALS") ;;;--------------------------------------------------------------------------- ;;; A graph with cross trees will have an additional type option: a ;;; cross-edge-producer ;;;--------------------------------------------------------------------------- (eval-when (:compile-toplevel :load-toplevel :execute) (define-graph-type :tree-with-cross-edges cross-tree-output-record)) (defun standard-cross-arc-drawer (stream from-node to-node x1 y1 x2 y2 &rest drawing-options &key edge-type &allow-other-keys) "The standard cross-arc-drawer simply ignores the edge-type keyword argument." (declare (ignore edge-type)) (remf drawing-options :edge-type) (apply #'standard-arc-drawer stream from-node to-node x1 y1 x2 y2 drawing-options)) (defclass cross-tree-output-record (tree-graph-output-record) ((cross-arc-drawer :initarg :cross-arc-drawer :reader cross-arc-drawer :documentation "This slot should be bound to a function that takes all the arguments accepted by a normal arc-drawer, but also an edge-type keyword argument, which it is free to ignore." :initform #'standard-cross-arc-drawer ) (cross-arc-producer :initarg :cross-arc-producer ;; by default, this just acts like a tree... :initform nil :reader cross-arc-producer :documentation "This should be bound to a function that takes a graph-node as argument, like inferior-producer, but that returns two values: a list of destination nodes and (optionally) a list of type-designators, that can be passed to the cross-arc-drawer, as the value of the :edge-type keyword argument." ) (cross-arc-drawing-options :reader cross-arc-drawing-options ) ) ) ;;;--------------------------------------------------------------------------- ;;; This is very yucky. It will be expensive on large graphs (perhaps ;;; a mixin for using a hash-table would be better), and needs some ;;; kind of good way of specifying the test in your graph class, which ;;; will be difficult... [2005/05/06:rpg] ;;;--------------------------------------------------------------------------- (defmethod lookup-node (source-node (graph graph-output-record) &key (test #'eql) (default :error)) (let ((hash-table (make-hash-table :test #'eq))) (flet ((visitedp (node) (gethash node hash-table nil)) (mark (node) (setf (gethash node hash-table) t))) (or (loop with openlist = (graph-root-nodes graph) for node = (pop openlist) while node unless (visitedp node) when (funcall test source-node (graph-node-object node)) return node end and do (mark node) (setf openlist (append openlist (graph-node-children node)))) (when (eq default :error) (error "Unable to find graph node for ~S in ~S" source-node graph)) default)))) (defmethod initialize-instance :after ((obj cross-tree-output-record) &key cross-arc-drawing-options arc-drawing-options) "A possibly reasonable default is to draw cross-arcs as if they were normal tree edge arcs." (unless cross-arc-drawing-options (setf (slot-value obj 'cross-arc-drawing-options) arc-drawing-options))) ;;; note that this could later be made into a function argument, so ;;; that programmers could customize [2005/05/06:rpg] (defgeneric cross-arc-routing (from to orientation) (:documentation "Return four values, x1, y1, x2, y2 for the arc-drawing for a cross-arc. More complex than for the tree case.")) (defun middle (dim1 dim2) (/ (+ dim1 dim2) 2)) (defmethod cross-arc-routing (from to (orientation (eql :horizontal))) (with-bounding-rectangle* (x1 y1 x2 y2) from (with-bounding-rectangle* (u1 v1 u2 v2) to (cond ((< x2 u1) ;; node entirely to the left of k (values x2 (middle y1 y2) u1 (middle v1 v2))) ((< u2 x1) ;; node entirely to the right of k ;; draw from the top or bottom to make distinguishable... (if (<= v1 y1) ;; draw from the top to the x middle of TO on the ;; bottom (values x1 y1 (middle u1 u2) v2) ;; draw from the bottom to the x middle of TO on the ;; top... (values x1 y2 (middle u1 u2) v1))) ;; overlapping in X -- as long as this is a tree, means ;; they are siblings. ((< y2 v1) ;; FROM above: middle x of FROM to middle x of TO, bottom to top... (values (middle x1 x2) y2 (middle u1 u2) v1)) ((< v2 y1) ;; TO above: middle x of FROM to middle x of TO, top to bottom... (values (middle x1 x2) y1 (middle u1 u2) v2)) (t (error "Unforeseen node positioning.")))))) ;;; copied from original layout-graph-edges and enhanced to add cross ;;; edges. (defmethod layout-graph-edges :after ((graph cross-tree-output-record) stream arc-drawer arc-drawing-options) "After the main method has drawn the tree, add the cross-edges." (declare (ignore arc-drawer arc-drawing-options)) ;;; (format excl:*initial-terminal-io* "~&Invoking after method to layout cross-edges.~%") ;;; (unless (cross-arc-producer graph) ;;; (format excl:*initial-terminal-io* "~&Uh-oh! No cross-arc-producer!~%")) (with-slots (orientation) graph ;; We tranformed the position of the nodes when we inserted them into ;; output history, so the bounding rectangles queried below will be ;; transformed. Therefore, disable the transformation now, otherwise ;; the transformation is effectively applied twice to the edges. (when (cross-arc-producer graph) (with-identity-transformation (stream) ;; for some damn reason, this graph traversal isn't working.... (traverse-graph-nodes graph (lambda (node children continuation) ;;; (format excl:*initial-terminal-io* ;;; "~&Invoking traverse function on ~S and ~S!~%" node children) (unless (eq node graph) (multiple-value-bind (source-siblings types) (funcall (cross-arc-producer graph) (graph-node-object node)) ;; there's a kind of odd loop here ;; because types might be NIL. Using ;; a built-in stepper would cause the ;; loop to terminate too soon if types ;; was nil [2005/05/06:rpg] (loop for ss in source-siblings for k = (lookup-node ss graph) for typelist = types then (cdr typelist) for type = (when typelist (car typelist)) do (multiple-value-bind (fromx fromy tox toy) (cross-arc-routing node k orientation) (apply (cross-arc-drawer graph) stream node k fromx fromy tox toy :edge-type type (cross-arc-drawing-options graph)))))) (map nil continuation children)))))))

1 0

[mcclim-cvs] CVS mcclim/Experimental/tree-with-cross-edges
by rgoldman 09 Mar '07

09 Mar '07

Update of /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges In directory clnet:/tmp/cvs-serv23996/tree-with-cross-edges Log Message: Directory /project/mcclim/cvsroot/mcclim/Experimental/tree-with-cross-edges added to the repository

1 0

[mcclim-cvs] CVS mcclim
by ahefner 04 Mar '07

04 Mar '07

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22852 Modified Files: utils.lisp Log Message: Fix parse-space, the unit name is :inches, not :inch (that's what all the backends use, anyway). --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/10/29 11:58:58 1.46 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2007/03/04 22:37:36 1.47 @@ -498,7 +498,7 @@ (gunit (graft-units graft))) ;; mungle specification into what grafts talk about (case unit - ((:point) (setf value (/ value 72) unit :inch)) + ((:point) (setf value (/ value 72) unit :inches)) ((:pixel) (setf unit :device)) ((:mm) (setf unit :millimeters))) ;;

1 0