[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
dlichteblau
dlichteblau at common-lisp.net
Wed Mar 14 23:33:25 UTC 2007
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 at 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 at 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 at 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 at 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]
More information about the Mcclim-cvs
mailing list