[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms

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@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@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@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@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]