Browse files

cells-gtk3 initial.

  • Loading branch information...
0 parents commit 4c7a018d3e690e075c7ae1d0e77caa4c893eda01 phildebrandt committed Apr 13, 2008
Showing with 12,120 additions and 0 deletions.
  1. +46 −0 INSTALL.TXT
  2. +1,109 −0 asdf.lisp
  3. +52 −0 cells-gtk/#cells-gtk.asd#
  4. +771 −0 cells-gtk/#tree-view.lisp#
  5. +81 −0 cells-gtk/actions.lisp
  6. +74 −0 cells-gtk/addon.lisp
  7. +103 −0 cells-gtk/buttons.lisp
  8. +778 −0 cells-gtk/cairo-drawing-area.lisp
  9. +39 −0 cells-gtk/callback.lisp
  10. +52 −0 cells-gtk/cells-gtk.asd
  11. +47 −0 cells-gtk/cells-gtk.lpr
  12. +34 −0 cells-gtk/cells3-porting-notes.lisp
  13. +44 −0 cells-gtk/compat.lisp
  14. +38 −0 cells-gtk/conditions.lisp
  15. +168 −0 cells-gtk/dialogs.lisp
  16. +155 −0 cells-gtk/display.lisp
  17. +132 −0 cells-gtk/drawing-area.lisp
  18. +221 −0 cells-gtk/drawing.lisp
  19. +153 −0 cells-gtk/entry.lisp
  20. +10 −0 cells-gtk/gl-drawing-area.lisp
  21. +345 −0 cells-gtk/gtk-app.lisp
  22. +308 −0 cells-gtk/layout.lisp
  23. +320 −0 cells-gtk/menus.lisp
  24. +145 −0 cells-gtk/packages.lisp
  25. +31 −0 cells-gtk/test-gtk/test-addon.lisp
  26. +48 −0 cells-gtk/test-gtk/test-buttons.lisp
  27. +71 −0 cells-gtk/test-gtk/test-dialogs.lisp
  28. +62 −0 cells-gtk/test-gtk/test-display.lisp
  29. +106 −0 cells-gtk/test-gtk/test-drawing-old.lisp
  30. +170 −0 cells-gtk/test-gtk/test-drawing.lisp
  31. +137 −0 cells-gtk/test-gtk/test-drawing2.lisp
  32. +69 −0 cells-gtk/test-gtk/test-entry.lisp
  33. +17 −0 cells-gtk/test-gtk/test-gtk.asd
  34. +75 −0 cells-gtk/test-gtk/test-gtk.lisp
  35. +43 −0 cells-gtk/test-gtk/test-gtk.lpr
  36. +65 −0 cells-gtk/test-gtk/test-layout.lisp
  37. +175 −0 cells-gtk/test-gtk/test-menus.lisp
  38. +82 −0 cells-gtk/test-gtk/test-textview.lisp
  39. +300 −0 cells-gtk/test-gtk/test-tree-view.lisp
  40. +173 −0 cells-gtk/textview.lisp
  41. +771 −0 cells-gtk/tree-view.lisp
  42. +464 −0 cells-gtk/widgets.lisp
  43. +44 −0 config.lisp
  44. +35 −0 gtk-ffi/Makefile
  45. +58 −0 gtk-ffi/Makefile.win32
  46. +54 −0 gtk-ffi/gdk-other.lisp
  47. +103 −0 gtk-ffi/gtk-adds.c
  48. +84 −0 gtk-ffi/gtk-button.lisp
  49. +127 −0 gtk-ffi/gtk-core.lisp
  50. +36 −0 gtk-ffi/gtk-ffi-impl.lisp
  51. +34 −0 gtk-ffi/gtk-ffi.asd
  52. +447 −0 gtk-ffi/gtk-ffi.lisp
  53. +40 −0 gtk-ffi/gtk-ffi.lpr
  54. +107 −0 gtk-ffi/gtk-gl-ext.lisp
  55. +221 −0 gtk-ffi/gtk-list-tree.lisp
  56. +106 −0 gtk-ffi/gtk-menu.lisp
  57. +919 −0 gtk-ffi/gtk-other.lisp
  58. +51 −0 gtk-ffi/gtk-threads.lisp
  59. +109 −0 gtk-ffi/gtk-tool.lisp
  60. +257 −0 gtk-ffi/gtk-utilities.lisp
  61. BIN gtk-ffi/libcellsgtk-solaris.so
  62. BIN gtk-ffi/libcellsgtk.so
  63. +81 −0 gtk-ffi/package.lisp
  64. +87 −0 gtk-ffi/specs.new
  65. +5 −0 ph-maths/ph-maths.asd
  66. +226 −0 ph-maths/ph-maths.lisp
  67. +89 −0 pod-utils/kt-trace.lisp
  68. +6 −0 pod-utils/pod-utils.asd
  69. +710 −0 pod-utils/utils.lisp
  70. BIN test-images/my-g.png
  71. BIN test-images/small.png
  72. BIN test-images/splash.png
  73. BIN test-images/tst.gif
46 INSTALL.TXT
@@ -0,0 +1,46 @@
+
+
+You don't need to read this file if you are installing from a snapshot tarball.
+This only concerns the situation where you get the pieces cells, hello-c, cells-gtk etc, individually.
+
+#############################################################################################################
+The notes below apply to the UFFI port of Cells-gtk done by Ken Tilton. (Actually I have forked UFFI and
+call it Hello-C, but the idea is the same: portable FFI.)
+
+For the original version by Vasilis Margioulas, which uses native CLisp FFI to
+good advantage, grab this:
+
+ http://common-lisp.net/cgi-bin/viewcvs.cgi/cells-gtk/clisp-cgtk/clisp-cgtk.tar.gz?tarball=1&cvsroot=cells-gtk
+
+...and follow the INSTALL.TXT in that.
+
+##############################################################################################################
+
+Dependencies:
+Utils-kt: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/utils-kt/utils-kt.tar.gz?tarball=1&cvsroot=cells
+Hello-C: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/hello-c/hello-c.tar.gz?tarball=1&cvsroot=cells
+Cells: http://common-lisp.net/cgi-bin/viewcvs.cgi/cell-cultures/cells/cells.tar.gz?tarball=1&cvsroot=cells
+
+On windows install
+ Gtk: http://prdownloads.sourceforge.net/gimp-win/gtk%2B-2.4.10-20041001-setup.zip?download
+
+Add the gtk libs to your PATH variable:
+
+ Start>Settings>Control Panel>System>Advanced>Environment Variables>
+
+ Then select PATH and hit "Edit". Append to existing value:
+
+ "C:\Program Files\Common Files\GTK\2.0\bin"; ..prior values...
+
+Edit load.lisp and follow the instructions there. No, you cannot just load it.
+
+
+Note: On windows under emacs with slime, the gtk window does not popup. You must start the application from a dos prompt.
+
+Tested on:
+ Windows xp with gtk 2.4.10 and clisp 2.33, using AllegroCL 6.2 Enterprise and Lispworks 4.3 Personal
+
+Known bugs:
+ On Windows: Clisp crash if
+ [My Computer]-> [Properties]-> [Advanced]-> [Perfomance Settings]-> [Show windows contents while dragging] is set
+ and resize the window while viewing a listbox or treebox.
1,109 asdf.lisp
@@ -0,0 +1,1109 @@
+;;; This is asdf: Another System Definition Facility. $Revision: 1.1 $
+;;;
+;;; Feedback, bug reports, and patches are all welcome: please mail to
+;;; <cclan-list@lists.sf.net>. But note first that the canonical
+;;; source for asdf is presently the cCLan CVS repository at
+;;; <URL:http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/>
+;;;
+;;; If you obtained this copy from anywhere else, and you experience
+;;; trouble using it, or find bugs, you may want to check at the
+;;; location above for a more recent version (and for documentation
+;;; and test files, if your copy came without them) before reporting
+;;; bugs. There are usually two "supported" revisions - the CVS HEAD
+;;; is the latest development version, whereas the revision tagged
+;;; RELEASE may be slightly older but is considered `stable'
+
+;;; Copyright (c) 2001-2003 Daniel Barlow and contributors
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; "Software"), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; the problem with writing a defsystem replacement is bootstrapping:
+;;; we can't use defsystem to compile it. Hence, all in one file
+
+(defpackage #:asdf
+ (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
+ #:system-definition-pathname #:find-component ; miscellaneous
+ #:hyperdocumentation #:hyperdoc
+
+ #:compile-op #:load-op #:load-source-op #:test-system-version
+ #:test-op
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
+
+ #:input-files #:output-files #:perform ; operation methods
+ #:operation-done-p #:explain
+
+ #:component #:source-file
+ #:c-source-file #:cl-source-file #:java-source-file
+ #:static-file
+ #:doc-file
+ #:html-file
+ #:text-file
+ #:source-file-type
+ #:module ; components
+ #:system
+ #:unix-dso
+
+ #:module-components ; component accessors
+ #:component-pathname
+ #:component-relative-pathname
+ #:component-name
+ #:component-version
+ #:component-parent
+ #:component-property
+ #:component-system
+
+ #:component-depends-on
+
+ #:system-description
+ #:system-long-description
+ #:system-author
+ #:system-maintainer
+ #:system-license
+
+ #:operation-on-warnings
+ #:operation-on-failure
+
+ ;#:*component-parent-pathname*
+ #:*system-definition-search-functions*
+ #:*central-registry* ; variables
+ #:*compile-file-warnings-behaviour*
+ #:*compile-file-failure-behaviour*
+ #:*asdf-revision*
+
+ #:operation-error #:compile-failed #:compile-warned #:compile-error
+ #:system-definition-error
+ #:missing-component
+ #:missing-dependency
+ #:circular-dependency ; errors
+
+ #:retry
+ #:accept ; restarts
+
+ )
+ (:use :cl))
+
+#+nil
+(error "The author of this file habitually uses #+nil to comment out forms. But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
+
+
+(in-package #:asdf)
+
+(defvar *asdf-revision* (let* ((v "$Revision: 1.1 $")
+ (colon (or (position #\: v) -1))
+ (dot (position #\. v)))
+ (and v colon dot
+ (list (parse-integer v :start (1+ colon)
+ :junk-allowed t)
+ (parse-integer v :start (1+ dot)
+ :junk-allowed t)))))
+
+(defvar *compile-file-warnings-behaviour* :warn)
+(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
+
+(defvar *verbose-out* nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utility stuff
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test)) (if it ,then ,else)))
+
+(defun pathname-sans-name+type (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME and TYPE components"
+ (make-pathname :name nil :type nil :defaults pathname))
+
+(define-modify-macro appendf (&rest args)
+ append "Append onto list")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; classes, condiitons
+
+(define-condition system-definition-error (error) ()
+ ;; [this use of :report should be redundant, but unfortunately it's not.
+ ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
+ ;; over print-object; this is always conditions::%print-condition for
+ ;; condition objects, which in turn does inheritance of :report options at
+ ;; run-time. fortunately, inheritance means we only need this kludge here in
+ ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
+ #+cmu (:report print-object))
+
+(define-condition formatted-system-definition-error (system-definition-error)
+ ((format-control :initarg :format-control :reader format-control)
+ (format-arguments :initarg :format-arguments :reader format-arguments))
+ (:report (lambda (c s)
+ (apply #'format s (format-control c) (format-arguments c)))))
+
+(define-condition circular-dependency (system-definition-error)
+ ((components :initarg :components :reader circular-dependency-components)))
+
+(define-condition missing-component (system-definition-error)
+ ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
+ (version :initform nil :reader missing-version :initarg :version)
+ (parent :initform nil :reader missing-parent :initarg :parent)))
+
+(define-condition missing-dependency (missing-component)
+ ((required-by :initarg :required-by :reader missing-required-by)))
+
+(define-condition operation-error (error)
+ ((component :reader error-component :initarg :component)
+ (operation :reader error-operation :initarg :operation))
+ (:report (lambda (c s)
+ (format s "~@<erred while invoking ~A on ~A~@:>"
+ (error-operation c) (error-component c)))))
+(define-condition compile-error (operation-error) ())
+(define-condition compile-failed (compile-error) ())
+(define-condition compile-warned (compile-error) ())
+
+(defclass component ()
+ ((name :accessor component-name :initarg :name :documentation
+ "Component name: designator for a string composed of portable pathname characters")
+ (version :accessor component-version :initarg :version)
+ (in-order-to :initform nil :initarg :in-order-to)
+ ;;; XXX crap name
+ (do-first :initform nil :initarg :do-first)
+ ;; methods defined using the "inline" style inside a defsystem form:
+ ;; need to store them somewhere so we can delete them when the system
+ ;; is re-evaluated
+ (inline-methods :accessor component-inline-methods :initform nil)
+ (parent :initarg :parent :initform nil :reader component-parent)
+ ;; no direct accessor for pathname, we do this as a method to allow
+ ;; it to default in funky ways if not supplied
+ (relative-pathname :initarg :pathname)
+ (operation-times :initform (make-hash-table )
+ :accessor component-operation-times)
+ ;; XXX we should provide some atomic interface for updating the
+ ;; component properties
+ (properties :accessor component-properties :initarg :properties
+ :initform nil)))
+
+;;;; methods: conditions
+
+(defmethod print-object ((c missing-dependency) s)
+ (format s "~@<~A, required by ~A~@:>"
+ (call-next-method c nil) (missing-required-by c)))
+
+(defun sysdef-error (format &rest arguments)
+ (error 'formatted-system-definition-error :format-control format :format-arguments arguments))
+
+;;;; methods: components
+
+(defmethod print-object ((c missing-component) s)
+ (format s "~@<component ~S not found~
+ ~@[ or does not match version ~A~]~
+ ~@[ in ~A~]~@:>"
+ (missing-requires c)
+ (missing-version c)
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
+
+(defgeneric component-system (component)
+ (:documentation "Find the top-level system containing COMPONENT"))
+
+(defmethod component-system ((component component))
+ (aif (component-parent component)
+ (component-system it)
+ component))
+
+(defmethod print-object ((c component) stream)
+ (print-unreadable-object (c stream :type t :identity t)
+ (ignore-errors
+ (prin1 (component-name c) stream))))
+
+(defclass module (component)
+ ((components :initform nil :accessor module-components :initarg :components)
+ ;; what to do if we can't satisfy a dependency of one of this module's
+ ;; components. This allows a limited form of conditional processing
+ (if-component-dep-fails :initform :fail
+ :accessor module-if-component-dep-fails
+ :initarg :if-component-dep-fails)
+ (default-component-class :accessor module-default-component-class
+ :initform 'cl-source-file :initarg :default-component-class)))
+
+(defgeneric component-pathname (component)
+ (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defun component-parent-pathname (component)
+ (aif (component-parent component)
+ (component-pathname it)
+ *default-pathname-defaults*))
+
+(defgeneric component-relative-pathname (component)
+ (:documentation "Extracts the relative pathname applicable for a particular component."))
+
+(defmethod component-relative-pathname ((component module))
+ (or (slot-value component 'relative-pathname)
+ (make-pathname
+ :directory `(:relative ,(component-name component))
+ :host (pathname-host (component-parent-pathname component)))))
+
+(defmethod component-pathname ((component component))
+ (let ((*default-pathname-defaults* (component-parent-pathname component)))
+ (merge-pathnames (component-relative-pathname component))))
+
+(defgeneric component-property (component property))
+
+(defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
+
+(defgeneric (setf component-property) (new-value component property))
+
+(defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties))))))
+
+(defclass system (module)
+ ((description :accessor system-description :initarg :description)
+ (long-description
+ :accessor system-long-description :initarg :long-description)
+ (author :accessor system-author :initarg :author)
+ (maintainer :accessor system-maintainer :initarg :maintainer)
+ (licence :accessor system-licence :initarg :licence)))
+
+;;; version-satisfies
+
+;;; with apologies to christophe rhodes ...
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ (flet ((is-ws (char) (find char ws)))
+ (nreverse
+ (let ((list nil) (start 0) (words 0) end)
+ (loop
+ (when (and max (>= words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
+
+(defgeneric version-satisfies (component version))
+
+(defmethod version-satisfies ((c component) version)
+ (unless (and version (slot-boundp c 'version))
+ (return-from version-satisfies t))
+ (let ((x (mapcar #'parse-integer
+ (split (component-version c) nil '(#\.))))
+ (y (mapcar #'parse-integer
+ (split version nil '(#\.)))))
+ (labels ((bigger (x y)
+ (cond ((not y) t)
+ ((not x) nil)
+ ((> (car x) (car y)) t)
+ ((= (car x) (car y))
+ (bigger (cdr x) (cdr y))))))
+ (and (= (car x) (car y))
+ (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding systems
+
+(defvar *defined-systems* (make-hash-table :test 'equal))
+(defun coerce-name (name)
+ (typecase name
+ (component (component-name name))
+ (symbol (string-downcase (symbol-name name)))
+ (string name)
+ (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+
+;;; for the sake of keeping things reasonably neat, we adopt a
+;;; convention that functions in this list are prefixed SYSDEF-
+
+(defvar *system-definition-search-functions*
+ '(sysdef-central-registry-search))
+
+(defun system-definition-pathname (system)
+ (some (lambda (x) (funcall x system))
+ *system-definition-search-functions*))
+
+(defvar *central-registry*
+ '(*default-pathname-defaults*
+ #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/"
+ #+nil "telent:asdf;systems;"))
+
+(defun sysdef-central-registry-search (system)
+ (let ((name (coerce-name system)))
+ (block nil
+ (dolist (dir *central-registry*)
+ (let* ((defaults (eval dir))
+ (file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local))))
+ (if (and file (probe-file file))
+ (return file)))))))
+
+
+(defun find-system (name &optional (error-p t))
+ (let* ((name (coerce-name name))
+ (in-memory (gethash name *defined-systems*))
+ (on-disk (system-definition-pathname name)))
+ (when (and on-disk
+ (or (not in-memory)
+ (< (car in-memory) (file-write-date on-disk))))
+ (let ((*package* (make-package (gensym (package-name #.*package*))
+ :use '(:cl :asdf))))
+ (format *verbose-out*
+ "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ ;; FIXME: This wants to be (ENOUGH-NAMESTRING
+ ;; ON-DISK), but CMUCL barfs on that.
+ on-disk
+ *package*)
+ (load on-disk)))
+ (let ((in-memory (gethash name *defined-systems*)))
+ (if in-memory
+ (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
+ (cdr in-memory))
+ (if error-p (error 'missing-component :requires name))))))
+
+(defun register-system (name system)
+ (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
+ (setf (gethash (coerce-name name) *defined-systems*)
+ (cons (get-universal-time) system)))
+
+(defun system-registered-p (name)
+ (gethash (coerce-name name) *defined-systems*))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; finding components
+
+(defgeneric find-component (module name &optional version)
+ (:documentation "Finds the component with name NAME present in the
+MODULE module; if MODULE is nil, then the component is assumed to be a
+system."))
+
+(defmethod find-component ((module module) name &optional version)
+ (if (slot-boundp module 'components)
+ (let ((m (find name (module-components module)
+ :test #'equal :key #'component-name)))
+ (if (and m (version-satisfies m version)) m))))
+
+
+;;; a component with no parent is a system
+(defmethod find-component ((module (eql nil)) name &optional version)
+ (let ((m (find-system name nil)))
+ (if (and m (version-satisfies m version)) m)))
+
+;;; component subclasses
+
+(defclass source-file (component) ())
+
+(defclass cl-source-file (source-file) ())
+(defclass c-source-file (source-file) ())
+(defclass java-source-file (source-file) ())
+(defclass static-file (source-file) ())
+(defclass doc-file (static-file) ())
+(defclass html-file (doc-file) ())
+
+(defgeneric source-file-type (component system))
+(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
+(defmethod source-file-type ((c c-source-file) (s module)) "c")
+(defmethod source-file-type ((c java-source-file) (s module)) "java")
+(defmethod source-file-type ((c html-file) (s module)) "html")
+(defmethod source-file-type ((c static-file) (s module)) nil)
+
+(defmethod component-relative-pathname ((component source-file))
+ (let* ((*default-pathname-defaults* (component-parent-pathname component))
+ (name-type
+ (make-pathname
+ :name (component-name component)
+ :type (source-file-type component
+ (component-system component)))))
+ (if (slot-value component 'relative-pathname)
+ (merge-pathnames
+ (slot-value component 'relative-pathname)
+ name-type)
+ name-type)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; operations
+
+;;; one of these is instantiated whenever (operate ) is called
+
+(defclass operation ()
+ ((forced :initform nil :initarg :force :accessor operation-forced)
+ (original-initargs :initform nil :initarg :original-initargs
+ :accessor operation-original-initargs)
+ (visited-nodes :initform nil :accessor operation-visited-nodes)
+ (visiting-nodes :initform nil :accessor operation-visiting-nodes)
+ (parent :initform nil :initarg :parent :accessor operation-parent)))
+
+(defmethod print-object ((o operation) stream)
+ (print-unreadable-object (o stream :type t :identity t)
+ (ignore-errors
+ (prin1 (operation-original-initargs o) stream))))
+
+(defmethod shared-initialize :after ((operation operation) slot-names
+ &key force
+ &allow-other-keys)
+ (declare (ignore slot-names force))
+ ;; empty method to disable initarg validity checking
+ )
+
+(defgeneric perform (operation component))
+(defgeneric operation-done-p (operation component))
+(defgeneric explain (operation component))
+(defgeneric output-files (operation component))
+(defgeneric input-files (operation component))
+
+(defun node-for (o c)
+ (cons (class-name (class-of o)) c))
+
+(defgeneric operation-ancestor (operation)
+ (:documentation "Recursively chase the operation's parent pointer until we get to the head of the tree"))
+
+(defmethod operation-ancestor ((operation operation))
+ (aif (operation-parent operation)
+ (operation-ancestor it)
+ operation))
+
+
+(defun make-sub-operation (c o dep-c dep-o)
+ (let* ((args (copy-list (operation-original-initargs o)))
+ (force-p (getf args :force)))
+ ;; note explicit comparison with T: any other non-NIL force value
+ ;; (e.g. :recursive) will pass through
+ (cond ((and (null (component-parent c))
+ (null (component-parent dep-c))
+ (not (eql c dep-c)))
+ (when (eql force-p t)
+ (setf (getf args :force) nil))
+ (apply #'make-instance dep-o
+ :parent o
+ :original-initargs args args))
+ ((subtypep (type-of o) dep-o)
+ o)
+ (t
+ (apply #'make-instance dep-o
+ :parent o :original-initargs args args)))))
+
+
+(defgeneric visit-component (operation component data))
+
+(defmethod visit-component ((o operation) (c component) data)
+ (unless (component-visited-p o c)
+ (push (cons (node-for o c) data)
+ (operation-visited-nodes (operation-ancestor o)))))
+
+(defgeneric component-visited-p (operation component))
+
+(defmethod component-visited-p ((o operation) (c component))
+ (assoc (node-for o c)
+ (operation-visited-nodes (operation-ancestor o))
+ :test 'equal))
+
+(defgeneric (setf visiting-component) (new-value operation component))
+
+(defmethod (setf visiting-component) (new-value operation component)
+ ;; MCL complains about unused lexical variables
+ (declare (ignorable new-value operation component)))
+
+(defmethod (setf visiting-component) (new-value (o operation) (c component))
+ (let ((node (node-for o c))
+ (a (operation-ancestor o)))
+ (if new-value
+ (pushnew node (operation-visiting-nodes a) :test 'equal)
+ (setf (operation-visiting-nodes a)
+ (remove node (operation-visiting-nodes a) :test 'equal)))))
+
+(defgeneric component-visiting-p (operation component))
+
+(defmethod component-visiting-p ((o operation) (c component))
+ (let ((node (cons o c)))
+ (member node (operation-visiting-nodes (operation-ancestor o))
+ :test 'equal)))
+
+(defgeneric component-depends-on (operation component))
+
+(defmethod component-depends-on ((o operation) (c component))
+ (cdr (assoc (class-name (class-of o))
+ (slot-value c 'in-order-to))))
+
+(defgeneric component-self-dependencies (operation component))
+
+(defmethod component-self-dependencies ((o operation) (c component))
+ (let ((all-deps (component-depends-on o c)))
+ (remove-if-not (lambda (x)
+ (member (component-name c) (cdr x) :test #'string=))
+ all-deps)))
+
+(defmethod input-files ((operation operation) (c component))
+ (let ((parent (component-parent c))
+ (self-deps (component-self-dependencies operation c)))
+ (if self-deps
+ (mapcan (lambda (dep)
+ (destructuring-bind (op name) dep
+ (output-files (make-instance op)
+ (find-component parent name))))
+ self-deps)
+ ;; no previous operations needed? I guess we work with the
+ ;; original source file, then
+ (list (component-pathname c)))))
+
+(defmethod input-files ((operation operation) (c module)) nil)
+
+(defmethod operation-done-p ((o operation) (c component))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c)))
+ (cond ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much
+ t)
+ ((not out-files)
+ (let ((op-done
+ (gethash (type-of o)
+ (component-operation-times c))))
+ (and op-done
+ (>= op-done
+ (or (apply #'max
+ (mapcar #'file-write-date in-files)) 0)))))
+ ((not in-files) nil)
+ (t
+ (and
+ (every #'probe-file out-files)
+ (> (apply #'min (mapcar #'file-write-date out-files))
+ (apply #'max (mapcar #'file-write-date in-files)) ))))))
+
+;;; So you look at this code and think "why isn't it a bunch of
+;;; methods". And the answer is, because standard method combination
+;;; runs :before methods most->least-specific, which is back to front
+;;; for our purposes. And CLISP doesn't have non-standard method
+;;; combinations, so let's keep it simple and aspire to portability
+
+(defgeneric traverse (operation component))
+(defmethod traverse ((operation operation) (c component))
+ (let ((forced nil))
+ (labels ((do-one-dep (required-op required-c required-v)
+ (let* ((dep-c (or (find-component
+ (component-parent c)
+ ;; XXX tacky. really we should build the
+ ;; in-order-to slot with canonicalized
+ ;; names instead of coercing this late
+ (coerce-name required-c) required-v)
+ (error 'missing-dependency :required-by c
+ :version required-v
+ :requires required-c)))
+ (op (make-sub-operation c operation dep-c required-op)))
+ (traverse op dep-c)))
+ (do-dep (op dep)
+ (cond ((eq op 'feature)
+ (or (member (car dep) *features*)
+ (error 'missing-dependency :required-by c
+ :requires (car dep) :version nil)))
+ (t
+ (dolist (d dep)
+ (cond ((consp d)
+ (assert (string-equal
+ (symbol-name (first d))
+ "VERSION"))
+ (appendf forced
+ (do-one-dep op (second d) (third d))))
+ (t
+ (appendf forced (do-one-dep op d nil)))))))))
+ (aif (component-visited-p operation c)
+ (return-from traverse
+ (if (cdr it) (list (cons 'pruned-op c)) nil)))
+ ;; dependencies
+ (if (component-visiting-p operation c)
+ (error 'circular-dependency :components (list c)))
+ (setf (visiting-component operation c) t)
+ (loop for (required-op . deps) in (component-depends-on operation c)
+ do (do-dep required-op deps))
+ ;; constituent bits
+ (let ((module-ops
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ (error nil))
+ (loop for kid in (module-components c)
+ do (handler-case
+ (appendf forced (traverse operation kid ))
+ (missing-dependency (condition)
+ (if (eq (module-if-component-dep-fails c) :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c) :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ (when (or forced module-ops
+ (not (operation-done-p operation c))
+ (let ((f (operation-forced (operation-ancestor operation))))
+ (and f (or (not (consp f))
+ (member (component-name
+ (operation-ancestor operation))
+ (mapcar #'coerce-name f)
+ :test #'string=)))))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (slot-value c 'do-first)))))
+ (loop for (required-op . deps) in do-first
+ do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c))))))
+ (setf (visiting-component operation c) nil)
+ (visit-component operation c (and forced t))
+ forced)))
+
+
+(defmethod perform ((operation operation) (c source-file))
+ (sysdef-error
+ "~@<required method PERFORM not implemented ~
+ for operation ~A, component ~A~@:>"
+ (class-of operation) (class-of c)))
+
+(defmethod perform ((operation operation) (c module))
+ nil)
+
+(defmethod explain ((operation operation) (component component))
+ (format *verbose-out* "~&;;; ~A on ~A~%" operation component))
+
+;;; compile-op
+
+(defclass compile-op (operation)
+ ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
+ (on-warnings :initarg :on-warnings :accessor operation-on-warnings
+ :initform *compile-file-warnings-behaviour*)
+ (on-failure :initarg :on-failure :accessor operation-on-failure
+ :initform *compile-file-failure-behaviour*)))
+
+(defmethod perform :before ((operation compile-op) (c source-file))
+ (map nil #'ensure-directories-exist (output-files operation c)))
+
+(defmethod perform :after ((operation operation) (c component))
+ (setf (gethash (type-of operation) (component-operation-times c))
+ (get-universal-time)))
+
+;;; perform is required to check output-files to find out where to put
+;;; its answers, in case it has been overridden for site policy
+(defmethod perform ((operation compile-op) (c cl-source-file))
+ #-:cormanlisp
+ (let ((source-file (component-pathname c))
+ (output-file (car (output-files operation c))))
+ (multiple-value-bind (output warnings-p failure-p)
+ (compile-file source-file
+ :output-file output-file)
+ ;(declare (ignore output))
+ (when warnings-p
+ (case (operation-on-warnings operation)
+ (:warn (warn
+ "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
+ operation c))
+ (:error (error 'compile-warned :component c :operation operation))
+ (:ignore nil)))
+ (when failure-p
+ (case (operation-on-failure operation)
+ (:warn (warn
+ "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+ operation c))
+ (:error (error 'compile-failed :component c :operation operation))
+ (:ignore nil)))
+ (unless output
+ (error 'compile-error :component c :operation operation)))))
+
+(defmethod output-files ((operation compile-op) (c cl-source-file))
+ #-:cormanlisp (list (compile-file-pathname (component-pathname c)))
+ #+:cormanlisp (list (component-pathname c)))
+
+(defmethod perform ((operation compile-op) (c static-file))
+ nil)
+
+(defmethod output-files ((operation compile-op) (c static-file))
+ nil)
+
+;;; load-op
+
+(defclass load-op (operation) ())
+
+(defmethod perform ((o load-op) (c cl-source-file))
+ (mapcar #'load (input-files o c)))
+
+(defmethod perform ((operation load-op) (c static-file))
+ nil)
+(defmethod operation-done-p ((operation load-op) (c static-file))
+ t)
+
+(defmethod output-files ((o operation) (c component))
+ nil)
+
+(defmethod component-depends-on ((operation load-op) (c component))
+ (cons (list 'compile-op (component-name c))
+ (call-next-method)))
+
+;;; load-source-op
+
+(defclass load-source-op (operation) ())
+
+(defmethod perform ((o load-source-op) (c cl-source-file))
+ (let ((source (component-pathname c)))
+ (setf (component-property c 'last-loaded-as-source)
+ (and (load source)
+ (get-universal-time)))))
+
+(defmethod perform ((operation load-source-op) (c static-file))
+ nil)
+
+(defmethod output-files ((operation load-source-op) (c component))
+ nil)
+
+;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
+(defmethod component-depends-on ((o load-source-op) (c component))
+ (let ((what-would-load-op-do (cdr (assoc 'load-op
+ (slot-value c 'in-order-to)))))
+ (mapcar (lambda (dep)
+ (if (eq (car dep) 'load-op)
+ (cons 'load-source-op (cdr dep))
+ dep))
+ what-would-load-op-do)))
+
+(defmethod operation-done-p ((o load-source-op) (c source-file))
+ (if (or (not (component-property c 'last-loaded-as-source))
+ (> (file-write-date (component-pathname c))
+ (component-property c 'last-loaded-as-source)))
+ nil t))
+
+(defclass test-op (operation) ())
+
+(defmethod perform ((operation test-op) (c component))
+ nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; invoking operations
+
+(defun opxx (operation-class system &rest args)
+ (let* ((op (apply #'make-instance operation-class
+ :original-initargs args args))
+ (*verbose-out*
+ (if (getf args :verbose t)
+ *trace-output*
+ (make-broadcast-stream)))
+ (system (if (typep system 'component) system (find-system system)))
+ (steps (traverse op system)))
+ (print steps)))
+
+(defun operate (operation-class system &rest args)
+ (let* ((op (apply #'make-instance operation-class
+ :original-initargs args args))
+ (*verbose-out*
+ (if (getf args :verbose t)
+ *trace-output*
+ (make-broadcast-stream)))
+ (system (if (typep system 'component) system (find-system system)))
+ (steps (traverse op system)))
+ (with-compilation-unit ()
+ (loop for (op . component) in steps do
+ (loop
+ (restart-case
+ (progn (perform op component)
+ (return))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s "~@<Retry performing ~S on ~S.~@:>"
+ op component)))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s
+ "~@<Continue, treating ~S on ~S as ~
+ having been successful.~@:>"
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return))))))))
+
+(defun oos (&rest args)
+ "Alias of OPERATE function"
+ (apply #'operate args))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; syntax
+
+(defun remove-keyword (key arglist)
+ (labels ((aux (key arglist)
+ (cond ((null arglist) nil)
+ ((eq key (car arglist)) (cddr arglist))
+ (t (cons (car arglist) (cons (cadr arglist)
+ (remove-keyword
+ key (cddr arglist))))))))
+ (aux key arglist)))
+
+(defmacro defsystem (name &body options)
+ (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
+ (let ((component-options (remove-keyword :class options)))
+ `(progn
+ ;; system must be registered before we parse the body, otherwise
+ ;; we recur when trying to find an existing system of the same name
+ ;; to reuse options (e.g. pathname) from
+ (let ((s (system-registered-p ',name)))
+ (cond ((and s (eq (type-of (cdr s)) ',class))
+ (setf (car s) (get-universal-time)))
+ (s
+ #+clisp
+ (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
+ #-clisp
+ (change-class (cdr s) ',class))
+ (t
+ (register-system (quote ,name)
+ (make-instance ',class :name ',name)))))
+ (parse-component-form nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ (or ,pathname
+ (pathname-sans-name+type
+ (resolve-symlinks *load-truename*))
+ *default-pathname-defaults*)
+ ',component-options))))))
+
+
+(defun class-for-type (parent type)
+ (let ((class (find-class
+ (or (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type) #.*package*)) nil)))
+ (or class
+ (and (eq type :file)
+ (or (module-default-component-class parent)
+ (find-class 'cl-source-file)))
+ (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
+
+(defun maybe-add-tree (tree op1 op2 c)
+ "Add the node C at /OP1/OP2 in TREE, unless it's there already.
+Returns the new tree (which probably shares structure with the old one)"
+ (let ((first-op-tree (assoc op1 tree)))
+ (if first-op-tree
+ (progn
+ (aif (assoc op2 (cdr first-op-tree))
+ (if (find c (cdr it))
+ nil
+ (setf (cdr it) (cons c (cdr it))))
+ (setf (cdr first-op-tree)
+ (acons op2 (list c) (cdr first-op-tree))))
+ tree)
+ (acons op1 (list (list op2 c)) tree))))
+
+(defun union-of-dependencies (&rest deps)
+ (let ((new-tree nil))
+ (dolist (dep deps)
+ (dolist (op-tree dep)
+ (dolist (op (cdr op-tree))
+ (dolist (c (cdr op))
+ (setf new-tree
+ (maybe-add-tree new-tree (car op-tree) (car op) c))))))
+ new-tree))
+
+
+(defun remove-keys (key-names args)
+ (loop for ( name val ) on args by #'cddr
+ unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ append (list name val)))
+
+(defvar *serial-depends-on*)
+
+(defun parse-component-form (parent options)
+ (destructuring-bind
+ (type name &rest rest &key
+ ;; the following list of keywords is reproduced below in the
+ ;; remove-keys form. important to keep them in sync
+ components pathname default-component-class
+ perform explain output-files operation-done-p
+ depends-on serial in-order-to
+ ;; list ends
+ &allow-other-keys) options
+ (check-component-input type name depends-on components in-order-to)
+ (let* ((other-args (remove-keys
+ '(components pathname default-component-class
+ perform explain output-files operation-done-p
+ depends-on serial in-order-to)
+ rest))
+ (ret
+ (or (find-component parent name)
+ (make-instance (class-for-type parent type)))))
+ (when (boundp '*serial-depends-on*)
+ (setf depends-on
+ (concatenate 'list *serial-depends-on* depends-on)))
+ (apply #'reinitialize-instance
+ ret
+ :name (coerce-name name)
+ :pathname pathname
+ :parent parent
+ other-args)
+ (when (typep ret 'module)
+ (setf (module-default-component-class ret)
+ (or default-component-class
+ (and (typep parent 'module)
+ (module-default-component-class parent))))
+ (let ((*serial-depends-on* nil))
+ (setf (module-components ret)
+ (loop for c-form in components
+ for c = (parse-component-form ret c-form)
+ collect c
+ if serial
+ do (push (component-name c) *serial-depends-on*)))))
+
+ (setf (slot-value ret 'in-order-to)
+ (union-of-dependencies
+ in-order-to
+ `((compile-op (compile-op ,@depends-on))
+ (load-op (load-op ,@depends-on))))
+ (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
+
+ (loop for (n v) in `((perform ,perform) (explain ,explain)
+ (output-files ,output-files)
+ (operation-done-p ,operation-done-p))
+ do (map 'nil
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m) (remove-method (symbol-function n) m))
+ (component-inline-methods ret))
+ when v
+ do (destructuring-bind (op qual (o c) &body body) v
+ (pushnew
+ (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret))))
+ ret)))
+
+(defun check-component-input (type name depends-on components in-order-to)
+ "A partial test of the values of a component."
+ (unless (listp depends-on)
+ (sysdef-error-component ":depends-on must be a list."
+ type name depends-on))
+ (unless (listp components)
+ (sysdef-error-component ":components must be NIL or a list of components."
+ type name components))
+ (unless (and (listp in-order-to) (listp (car in-order-to)))
+ (sysdef-error-component ":in-order-to must be NIL or a list of components."
+ type name in-order-to)))
+
+(defun sysdef-error-component (msg type name value)
+ (sysdef-error (concatenate 'string msg
+ "~&The value specified for ~(~A~) ~A is ~W")
+ type name value))
+
+(defun resolve-symlinks (path)
+ #-allegro (truename path)
+ #+allegro (excl:pathname-resolve-symbolic-links path)
+ )
+
+;;; optional extras
+
+;;; run-shell-command functions for other lisp implementations will be
+;;; gratefully accepted, if they do the same thing. If the docstring
+;;; is ambiguous, send a bug report
+
+(defun run-shell-command (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *verbose-out*. Returns the shell's exit code."
+ (let ((command (apply #'format nil control-string args)))
+ (format *verbose-out* "; $ ~A~%" command)
+ #+sbcl
+ (sb-impl::process-exit-code
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+
+ #+allegro
+ (excl:run-shell-command command :input nil :output *verbose-out*)
+
+ #+lispworks
+ (system:call-system-showing-output
+ command
+ :shell-type "/bin/sh"
+ :output-stream *verbose-out*)
+
+ #+clisp ;XXX not exactly *verbose-out*, I know
+ (ext:run-shell-command command :output :terminal :wait t)
+
+ #+openmcl
+ (nth-value 1
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output *verbose-out*
+ :wait t)))
+
+ #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+ (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ ))
+
+
+(defgeneric hyperdocumentation (package name doc-type))
+(defmethod hyperdocumentation ((package symbol) name doc-type)
+ (hyperdocumentation (find-package package) name doc-type))
+
+(defun hyperdoc (name doc-type)
+ (hyperdocumentation (symbol-package name) name doc-type))
+
+
+(pushnew :asdf *features*)
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
+ (pushnew :sbcl-hooks-require *features*)))
+
+#+(and sbcl sbcl-hooks-require)
+(progn
+ (defun module-provide-asdf (name)
+ (handler-bind ((style-warning #'muffle-warning))
+ (let* ((*verbose-out* (make-broadcast-stream))
+ (system (asdf:find-system name nil)))
+ (when system
+ (asdf:operate 'asdf:load-op name)
+ t))))
+
+ (pushnew
+ '(merge-pathnames "systems/"
+ (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ *central-registry*)
+
+ (pushnew
+ '(merge-pathnames "site-systems/"
+ (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ *central-registry*)
+
+ (pushnew
+ '(merge-pathnames ".sbcl/systems/"
+ (user-homedir-pathname))
+ *central-registry*)
+
+ (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+
+(provide 'asdf)
52 cells-gtk/#cells-gtk.asd#
@@ -0,0 +1,52 @@
+
+(in-package :common-lisp-user)
+
+(defpackage #:cells-gtk-asd
+ (:use :cl :asdf))
+
+(in-package :cells-gtk-asd)
+
+;;;
+;;; features
+;;;
+
+;;; run gtk in its own thread (requires bordeaux-threads)
+b(pushnew :cells-gtk-threads *features*)
+
+;;; drawing-area widget using cairo (requires cl-cairo2)
+(pushnew :cells-gtk-cairo *features*)
+
+;;; drawing-area widget using OpenGL (requires libgtkglext1)
+;(pushnew :cells-gtk-opengl *features*)
+
+(asdf:defsystem :cells-gtk
+ :name "cells-gtk"
+ :depends-on (:cells
+ :utils-kt
+ :pod-utils
+ :gtk-ffi
+ :ph-maths
+ #+cells-gtk-cairo :cl-cairo2
+ #+cells-gtk-threads :bordeaux-threads)
+ :serial t
+ :components
+ ((:file "packages")
+ (:file "conditions")
+ (:file "compat")
+ (:file "cells3-porting-notes" :depends-on ("packages"))
+ (:file "widgets" :depends-on ("conditions"))
+ (:file "layout" :depends-on ("widgets"))
+ (:file "display" :depends-on ("widgets"))
+ (:file "drawing-area" :depends-on ("widgets"))
+ #+cells-gtk-cairo (:file "cairo-drawing-area" :depends-on ("widgets"))
+ #+cells-gtk-opengl (:file "gl-drawing-area" :depends-on ("widgets"))
+ (:file "buttons" :depends-on ("widgets"))
+ (:file "entry" :depends-on ("widgets"))
+ (:file "tree-view" :depends-on ("widgets"))
+ (:file "menus" :depends-on ("widgets"))
+ (:file "dialogs" :depends-on ("widgets"))
+ (:file "textview" :depends-on ("widgets"))
+ (:file "addon" :depends-on ("widgets"))
+ (:file "gtk-app")
+ ))
+
771 cells-gtk/#tree-view.lisp#
@@ -0,0 +1,771 @@
+#|
+
+ Cells Gtk
+
+ Copyright (c) 2004 by Vasilis Margioulas <vasilism@sch.gr>
+
+ You have the right to distribute and use this software as governed by
+ the terms of the Lisp Lesser GNU Public License (LLGPL):
+
+ (http://opensource.franz.com/preamble.html)
+
+ This program 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
+ Lisp Lesser GNU Public License for more details.
+
+|#
+
+;;; Todo: separate tree-model/tree-store stuff into another file (used by combo box too).
+;;; BTW Tree-store implements the tree-model interface, among other things.
+
+(in-package :cgtk)
+
+(def-object list-store ()
+ ((item-types :accessor item-types :initarg :item-types :initform nil)
+ (of-tree :accessor of-tree :initform (c-in nil)))
+ ()
+ ()
+ :new-args (c_1 (list (item-types self))))
+
+(def-object tree-store ()
+ ((item-types :accessor item-types :initarg :item-types :initform nil)
+ (of-tree :accessor of-tree :initform (c-in nil)))
+ ()
+ ()
+ :new-args (c_1 (list (item-types self))))
+
+(defun tv-fail (&rest args) (declare (ignore args)))
+(defgeneric get-selection (none))
+
+(def-widget tree-view (container)
+ ((columns-def :accessor columns-def :initarg :columns :initform nil)
+ (column-types :accessor column-types :initform (c? (mapcar #'first (columns-def self))))
+ (column-inits :accessor column-inits :initform (c? (mapcar #'second (columns-def self))))
+ (column-render :accessor column-render
+ :initform (c? (loop for col-def in (columns-def self)
+ for pos from 0 append
+ (when (third col-def)
+ (list pos (third col-def))))))
+ (node-render :accessor node-render
+ :initform (c? (loop for col-def in (columns-def self)
+ for pos from 0 append
+ (when (fourth col-def)
+ (list pos (fourth col-def))))))
+ (columns :accessor columns
+ :initform (c? (mapcar #'(lambda (col-init)
+ (apply #'make-be 'tree-view-column
+ :container self
+ col-init))
+ (column-inits self))))
+ (select-if :unchanged-if #'tv-fail
+ :accessor select-if :initarg :select-if :initform (c-in nil))
+ (roots :accessor roots :initarg :roots :initform nil)
+ (print-fn :accessor print-fn :initarg :print-fn :initform #'identity)
+ (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil))
+ (selected-items-cache :cell nil :accessor selected-items-cache :initform nil)
+ (selection-mode :accessor selection-mode :initarg :selection-mode :initform :single)
+ (expand-all :accessor expand-all :initarg :expand-all :initform (c-in nil))
+ (on-select :accessor on-select :initarg :on-select :initform nil)
+ (on-edit :accessor on-edit :initarg :on-edit :initform nil)
+ (tree-model :owning t :accessor tree-model :initarg :tree-model :initform nil))
+ () ; gtk-slots
+ () ; signal-slots
+ :on-select (lambda (self widget event data)
+ (declare (ignore widget event data))
+ (with-integrity (:change 'tree-view-select-cb)
+ (setf (value self) (get-selection self)))))
+
+
+(defobserver tree-model ((self tree-view))
+ (when new-value
+ (gtk-tree-view-set-model (id self) (id new-value))
+ (with-integrity (:change 'tv-tree-model)
+ (setf (of-tree new-value) self))))
+
+(defobserver expand-all ((self tree-view))
+ (when new-value
+ (gtk-tree-view-expand-all (id self))))
+
+;;; Used by combo-box also, when it is using a tree model.
+(cffi:defcallback tree-view-items-selector :void
+ ((model :pointer) (path :pointer) (iter :pointer) (data :pointer))
+ (declare (ignore path data))
+ (let ((tree (of-tree (gtk-object-find model))))
+ (push (item-from-path (children-fn tree)
+ (roots tree)
+ (read-from-string
+ (gtk-tree-model-get-cell model iter (length (column-types tree)) :string)))
+ (selected-items-cache tree)))
+ 0)
+
+(defmethod get-selection ((self tree-view))
+ (let ((selection (gtk-tree-view-get-selection (id self)))
+ (cb (cffi:get-callback 'tree-view-items-selector)))
+ (setf (selected-items-cache self) nil)
+ (gtk-tree-selection-selected-foreach selection cb +c-null+)
+ (if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple
+ (copy-list (selected-items-cache self))
+ (first (selected-items-cache self)))))
+
+
+(defobserver selection-mode ((self tree-view))
+ (when new-value
+ (let ((sel (gtk-tree-view-get-selection (id self))))
+ (gtk-tree-selection-set-mode sel
+ (ecase (selection-mode self)
+ (:none 0)
+ (:single 1)
+ (:browse 2)
+ (:multiple 3))))))
+
+(cffi:defcallback tree-view-select-handler :void
+ ((column-widget :pointer) (event :pointer) (data :pointer))
+ (if-bind (tree-view (gtk-object-find column-widget))
+ (let ((cb (callback-recover tree-view :on-select)))
+ (funcall cb tree-view column-widget event data))
+ (trc "Clean up old widgets after runs" column-widget))
+ 0)
+
+;;; The check that previously was performed here (for a clos object) caused the handler
+;;; not to be registered (a problem of execution ordering?). Anyway, do we need such a check?
+(defobserver on-select ((self tree-view))
+ (when new-value
+ (let ((selected-widget (gtk-tree-view-get-selection (id self))))
+ (gtk-object-store selected-widget self) ;; tie column widget to clos tree-view
+ (callback-register self :on-select new-value)
+ (let ((cb (cffi:get-callback 'tree-view-select-handler)))
+ ;(trc nil "tree-view on-select pcb:" cb selected-widget "changed")
+ (gtk-signal-connect selected-widget "changed" cb)))))
+
+;;;
+;;; Listbox submodel
+;;;
+
+(defmodel listbox (tree-view)
+ ((roots :initarg :items)) ; alternate initarg for inherited slot
+ (:default-initargs
+ :tree-model (c? (make-instance 'list-store
+ :item-types (append (column-types self) (list :string))))))
+
+(defmethod items ((self listbox))
+ (roots self))
+
+(defmethod (setf items) (val (self listbox))
+ (setf (roots self) val))
+
+(defun mk-listbox (&rest inits)
+ (assert *parent*)
+ (let ((self (apply 'make-instance 'listbox (append inits (list :fm-parent *parent*)))))
+ (with-integrity (:change 'mk-listbox-of-tree)
+ (setf (of-tree (tree-model self)) self))
+ self))
+
+(defobserver select-if ((self listbox))
+ (when new-value
+ (with-integrity (:change 'listbox-select-if-observer)
+ (setf (value self) (remove-if-not new-value (roots self))))))
+
+(defobserver roots ((self listbox))
+ (when old-value
+ (gtk-list-store-clear (id (tree-model self))))
+ (when new-value
+ (gtk-list-store-set-items
+ (id (tree-model self))
+ (append (column-types self) (list :string))
+ (loop for item in new-value
+ for index from 0
+ collect (let ((i (funcall (print-fn self) item)))
+ ;(ukt:trc nil "items output: old,new" item i)
+ (append i
+ (list (format nil "(~d)" index))))))))
+
+;;;
+;;; Treebox submodel
+;;;
+
+(defmodel treebox (tree-view)
+ ()
+ (:default-initargs
+ :tree-model (c? (mk-tree-store
+ :item-types (append (column-types self) (list :string))))))
+
+(defun mk-treebox (&rest inits)
+ (assert *parent*)
+ (let ((self (apply 'make-instance 'treebox (append inits (list :fm-parent *parent*)))))
+ (with-integrity (:change 'mk-treebox-of-tree)
+ (setf (of-tree (tree-model self)) self))
+ self))
+
+(defobserver select-if ((self treebox))
+ (when new-value
+ (with-integrity (:change 'treebox-obs-select-if)
+ (setf (value self) (mapcan (lambda (item) (fm-collect-if item new-value))
+ (roots self))))))
+
+(defobserver roots ((self treebox))
+ (when old-value
+ (gtk-tree-store-clear (id (tree-model self))))
+ (when new-value
+ (loop for root in new-value
+ for index from 0 do
+ (gtk-tree-store-set-kids (id (tree-model self)) root +c-null+ index
+ (append (column-types self) (list :string))
+ (print-fn self) (children-fn self)))
+ (when (expand-all self)
+ (gtk-tree-view-expand-all (id self)))))
+
+;;; These look like ("Trimmed Text" "(0 0 )") for example where menu structure is "Text --> Trimmed Text"
+;;; Column-types is a list of :string, :float etc. used to reference g-value-set-string etc.
+(defun gtk-tree-store-set-kids (model val-tree parent-iter index column-types print-fn children-fn &optional path)
+ (with-tree-iter (iter)
+ (gtk-tree-store-append model iter parent-iter) ; sets iter
+ (gtk-tree-store-set model iter ; Not a gtk function!
+ column-types
+ (append
+ (funcall print-fn val-tree)
+ (list (format nil "(~{~d ~})" (reverse (cons index path))))))
+ (loop for sub-tree in (funcall children-fn val-tree)
+ for pos from 0 do
+ (gtk-tree-store-set-kids model sub-tree iter
+ pos column-types print-fn children-fn (cons index path)))))
+
+
+
+;;;
+;;; Cell rendering
+;;;
+
+(cffi:defcallback tree-view-render-cell-callback :int
+ ((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer)
+ (iter :pointer) (data :pointer))
+ (if-bind (self (gtk-object-find tree-column))
+ (let ((cb (callback-recover self :render-cell)))
+ (assert cb nil "no :render-cell callback for ~a" self)
+ (funcall cb tree-column cell-renderer tree-model iter data))
+ (trc nil "Clean up old widgets from prior runs." tree-column))
+ 1)
+
+(defun item-from-path (child-fn roots path)
+ (loop for index in path
+ for node = (nth index roots) then (nth index (if node (funcall child-fn node) (return nil)))
+ finally (return node)))
+
+(declaim (optimize (debug 3)))
+
+(defun gtk-tree-view-render-cell (col col-type cell-attrib-f &optional node-attrib-f)
+ (trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f)
+ (flet ((node-from-iter (model iter)
+ (when-bind* ((tree-model (gtk-object-find model))
+ (tree-view (of-tree tree-model))
+ (path (gtk-tree-model-get-cell model iter (length (column-types tree-view)) :string)))
+ (item-from-path (children-fn tree-view)
+ (roots tree-view)
+ (read-from-string path)))))
+ (lambda (tree-column cell-renderer model iter data)
+ (DECLARE (ignorable tree-column data))
+ (trc nil "gtv-render-cell (callback)> entry"
+ tree-column cell-renderer model iter data)
+ (let ((item-value (gtk-tree-model-get-typed-item-value model
+ iter
+ col
+ col-type))
+ (node (node-from-iter model iter)))
+ (trc nil "gtv-render-cell (callback)> rendering value"
+ col col-type ret$ item-value)
+
+ (apply #'gtk-object-set-property cell-renderer
+ (case col-type
+ (:boolean (list "active" 'boolean item-value))
+ (:icon (list "stock-id" 'c-string
+ (string-downcase (format nil "gtk-~a" item-value))))
+ (t (list "text" 'c-string
+ (case col-type
+ (:date (multiple-value-bind (sec min hour day month year)
+ (decode-universal-time (truncate item-value))
+ (format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D"
+ day month year hour min sec)))
+ (:string (if item-value (get-gtk-string item-value) ""))
+ (otherwise (format nil "~a" item-value)))))))
+
+
+ (when cell-attrib-f
+ (gtk-cell-renderer-set-attribs cell-renderer (funcall cell-attrib-f item-value)))
+ (when (and node node-attrib-f)
+ (gtk-cell-renderer-set-attribs cell-renderer (funcall node-attrib-f node))))
+ 1)))
+
+;;;
+;;; Editable cells
+;;;
+
+(defstruct renderer
+ tree-view col)
+
+;;; a hash table to keep track of the renderer objects
+
+(let ((renderers (make-hash-table)))
+ (defun register-renderer-data (renderer data)
+ (setf (gethash (cffi-sys:pointer-address renderer) renderers) data))
+ (defun recover-renderer-data (renderer)
+ (gethash (cffi-sys:pointer-address renderer) renderers)))
+
+;;; generic callback -- update treestore and call on-edit func
+
+(defun gtk-path-to-list (path)
+ "converts \"1:2\" to (1 2)"
+ (read-from-string (format nil "(~a)" (map 'string #'(lambda (c) (if (eql c #\:) #\space c)) path))))
+
+
+(defun tree-view-edit-cell-callback (renderer path new-value)
+ (if-bind (data (recover-renderer-data renderer))
+ (let* ((tree (renderer-tree-view data))
+ (model (id (tree-model tree)))
+ (col (renderer-col data))
+ (col-type (nth col (column-types tree)))
+ (fn (on-edit tree))
+ (path (cffi:foreign-string-to-lisp path))
+ (node (item-from-path #'kids (roots tree) (gtk-path-to-list path))))
+ #+msg (format t "~&Edited path ~a --> node ~a~%" (gtk-path-to-list path) (when node (md-name node)))
+ (when node
+ (with-tree-iter (iter)
+ (gtk-tree-model-get-iter-from-string (id (tree-model tree)) iter path)
+ (let ((new-val (case col-type
+ (:boolean (= 0 (gtk-tree-model-get-cell model iter col :boolean))) ; toggle boolean cell,
+ (t new-value))))
+ #+msg (format t "~&Setting value for ~a to ~a ..." node new-val)
+ (gtk-tree-store-set-cell model iter col col-type new-val)
+ (funcall fn node col new-val))) ; call setf function
+ #+msg (format t " done.~%")
+ (force-output)))
+ (warn (format nil "No callback registered "))))
+
+;;; a tribute to static typing
+
+(cffi:defcallback tree-view-edit-cell-callback-string :int
+ ((renderer :pointer) (path :pointer) (new-value :gtk-string))
+ (tree-view-edit-cell-callback renderer path new-value)
+ 1)
+
+(cffi:defcallback tree-view-edit-cell-callback-boolean :int
+ ((renderer :pointer) (path :pointer) (data :pointer))
+ (declare (ignore data))
+ (tree-view-edit-cell-callback renderer path nil)
+ 1)
+
+
+;;;
+;;; echo functions for tree-view
+;;;
+
+(defobserver columns ((self tree-view))
+ (when old-value
+ (loop for col in old-value do
+ (gtk-tree-view-remove-column (id self) (id col))
+ (gtk-object-forget (id col) col)))
+ (when new-value
+ (loop for col in new-value
+ for pos from 0
+ for item-renderer = (fourth (nth pos (columns-def self)))
+ for col-type = (nth pos (column-types self))
+ for renderer = (case col-type
+ (:boolean (gtk-cell-renderer-toggle-new))
+ (:icon (gtk-cell-renderer-pixbuf-new))
+ (t (gtk-cell-renderer-text-new))) do
+ (gtk-tree-view-column-pack-start (id col) renderer t)
+ (gtk-tree-view-column-set-cell-data-func (id col) renderer
+ (let ((cb (cffi:get-callback 'tree-view-render-cell-callback)))
+ ;(trc nil "tree-view columns pcb:" cb (id col) :render-cell)
+ (callback-register col :render-cell
+ (gtk-tree-view-render-cell pos
+ (nth pos (column-types self))
+ (getf (column-render self) pos)
+ (getf (node-render self) pos)))
+ cb)
+ +c-null+ +c-null+)
+ ;; register renderer for edit callback
+ (when (on-edit self)
+ (register-renderer-data renderer
+ (make-renderer :tree-view self
+ :col pos))
+ (case col-type
+ (:string (gtk-signal-connect renderer "edited" (cffi:get-callback 'tree-view-edit-cell-callback-string)))
+ (:boolean (gtk-signal-connect renderer "toggled" (cffi:get-callback 'tree-view-edit-cell-callback-boolean)))))
+ (gtk-tree-view-column-set-sort-column-id (id col) pos)
+ (gtk-tree-view-insert-column (id self) (id col) pos))))
+
+(def-object tree-view-column ()
+ ((title :accessor title :initarg :title :initform nil)
+ (visible :accessor visible :initarg :visible :initform t))
+ (spacing resizable fixed-width min-width max-width expand clickable
+ sort-column-id sort-indicator reorderable)
+ ()
+ :resizable t
+ :expand t
+ :reorderable t)
+
+(defobserver visible ((self tree-view-column))
+ (gtk-tree-view-column-set-visible (id self) new-value))
+
+(defobserver title ((self tree-view-column))
+ (when new-value
+ (gtk-tree-view-column-set-title (id self) new-value)))
+
+
+(defmacro def-columns (&body args)
+ "Convencience macro for defining tree-view columns. args has the form col-def*,
+where col-def ::= (type inits renderer item-renderer).
+
+type -- is :boolean, :icon, or :text (default)
+inits -- '(:title \"name\")
+renderer -- a fn of the cell value returning a plist. Allowed attribs are
+:font, :size, :strikethrough, :foreground, :background, :editable
+node-renderer -- the same, but a function of a node, not the print-fn value of it."
+ `(list ,@(loop for (type inits renderer node-renderer) in args collect
+ `(list ,type ',inits ,renderer ,node-renderer))))
+
+;;;
+;;; Tree observer tree view
+;;;
+
+;;; this is an alternative mode of operating a tree view -- instead of have it traverse roots once
+;;; and build the corresponding tree model, we create a family of observers that maps every node to
+;;; the corresponding row in the tree view, yielding a live update
+
+
+;;;
+;;; Debugging tool
+;;;
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defparameter *with-debug* t))
+
+(defmacro with-trc (form)
+ (if *with-debug*
+ (with-gensyms (res)
+ `(progn
+ (format t "~&eval ~a " ',form)
+ (let ((,res ,form))
+ (format t "--> ~a~%" ,res)
+ (force-output)
+ ,res)))
+ form))
+
+(defmacro with-trcs (&body body)
+ (if *with-debug*
+ `(progn
+ ,@(mapcar #'(lambda (f) `(with-trc ,f)) body))
+ `(progn ,@body)))
+
+
+;;; first the cells stuff -- base class
+
+(defun deadp (cell)
+ (eql (slot-value cell 'cells::.md-state) :eternal-rest))
+
+
+(defmethod mk-observer ((parent t) (source family) &rest initargs)
+ "Used internally by family-observer and its sublasses to create kids. Use (make-be 'your-observer :value source) to create a family observer.
+
+Creates an observer node observing source. To be specialized on subclasses of family observer and source"
+ (apply #'make-instance 'family-observer :value source :fm-parent *parent* initargs))
+
+(defmodel family-observer (family)
+ ;; we'll use the "value" slot for the observed
+ ()
+ (:default-initargs
+ :kids (kids-list?
+ (progn #+msg(print (list "CALCULATE KIDS for family observer" self "on" (^value) "-- parent" (upper self)))
+ (bwhen (val (^value)) ;; not sure why not
+ (unless (deadp val)
+ (trcx "creating kids" val (slot-value val 'cells::.md-state) (kids val))
+ (mapcar #'(lambda (src) (mk-observer self src)) (kids val))))))))
+
+;;; here do cleanup work, children get called before parents
+(defmethod not-to-be :before ((self family-observer))
+ #+msg (print (list "DESTROY family observer" self "on" (value self))))
+
+;;; this is too early -- upper self is not set yet
+(defmethod initialize-instance :after ((self family-observer) &rest initargs)
+ (declare (ignorable initargs))
+ #+msg (print (list "CREATE family observer" self "on" (value self) "-- parent" (upper self))))
+
+;;; this is too late, gets called for children before parent
+(defmethod md-awaken :after ((self family-observer))
+ #+msg (print (list "AWAKEN family observer" self "on" (value self) "-- parent" (upper self))))
+
+
+;;; then the cells stuff for observing slots
+
+(defmacro def-f-observer (name (&rest superclasses) (&optional (source 'family)) &body slots)
+ "create an observer derived from superclasses observing slots of objects of type source"
+ (multiple-value-bind (slot-defs output-fns)
+ (loop for slot in slots
+ for slot-def = (if (atom slot) (list slot) slot)
+ for slot-name = (car slot-def)
+ for slot-plist = (cdr slot-def)
+ for reader-fn = (getf slot-plist :reader-fn `#'(lambda (value) (identity value)))
+ for output-fn = (getf slot-plist :output-fn nil)
+ collecting `(,slot-name :reader ,slot-name :initform (c? (bwhen (val (^value)) (funcall ,reader-fn (,slot-name val))))) into slot-defs
+ if output-fn collecting `(defobserver ,slot-name ((self ,name))
+ (with-integrity (:change ',slot-name)
+ (funcall ,output-fn self new-value))) into output-fns
+ finally (return (values slot-defs output-fns)))
+ `(progn
+ (eval-now!
+ (defmodel ,name ,superclasses
+ ,slot-defs)
+ ,@output-fns)
+ (defmethod mk-observer ((parent ,name) (source ,source) &rest initargs)
+ (apply #'make-instance ',name :value source :fm-parent *parent* initargs)))))
+;;;
+;;; GTK tree row infrastructure
+;;;
+
+(defun tree-row-valid (&rest row-references)
+ (every #'(lambda (row) (and row (gtk-tree-row-reference-valid row))) row-references))
+
+(defmacro with-tree-row ((row &key (default-model nil default-model-p)) &body body)
+ "Executes body with iter and model/path pointing to row. When row is a null-pointer, model is bound to default-model --
+without default-pointer, body is not executed -- path and iter are null-pointer. When row is nil, the body is not executed."
+ `(when ,row
+ (if (not (cffi-sys:null-pointer-p ,row))
+ (if (tree-row-valid ,row)
+ (with-tree-iter (iter)
+ (let ((model (gtk-tree-row-reference-get-model ,row))
+ (path (gtk-tree-row-reference-get-path ,row)))
+ (gtk-tree-model-get-iter model iter path)
+ (unwind-protect
+ (progn ,@body)
+ (gtk-tree-path-free path))))
+ (format t "~&WARNING: with-tree-row called with invalid row-reference. body skipped~%"))
+ ,(when default-model-p
+ `(if ,default-model
+ (let ((model ,default-model) (path +c-null+) (iter +c-null+))
+ (declare (ignorable model path iter))
+ ,@body)
+ (format t "~&WARNING: with-tree-row called with null-pointer and no default model given. body is skipped~%"))))))
+
+(defun tree-row-create (parent-row-reference parent-gtk-id)
+ "creates a gtk row below parent and returns a row reference pointing to it."
+ (with-tree-row (parent-row-reference :default-model parent-gtk-id)
+ (with-tree-iter (i-new)
+ (gtk-tree-store-append model i-new iter)
+ #+msg (format t " row created ")
+ (gtk-tree-row-reference-new model (gtk-tree-model-get-path model i-new)))))
+
+(defun tree-row-set-cell (row-reference col data)
+ (with-tree-row (row-reference)
+ #+msg (format t " set cell ")
+ (unless (gtk-object-find model) (break))
+ (gtk-tree-store-set-cell model iter col (nth col (item-types (gtk-object-find model))) data)))
+
+(defun tree-row-get-cell (row-reference col)
+ (with-tree-row (row-reference)
+ #+msg (format t " get cell ")
+ (gtk-tree-model-get-cell model iter col (nth col (item-types (gtk-object-find model))))))
+
+(defun tree-row-set-path (row-reference parent-row-reference position)
+ "sets the path information by concatenating the path of parent-row and position"
+ (when (tree-row-valid row-reference)
+ #+msg (format t "~&setting path -- ")
+ (let* ((col (1- (length (item-types (gtk-object-find (gtk-tree-row-reference-get-model row-reference))))))
+ (path (write-to-string (concatenate 'list
+ (when (tree-row-valid parent-row-reference)
+ (read-from-string (tree-row-get-cell parent-row-reference col)))
+ (list position)))))
+ (tree-row-set-cell row-reference col path)
+ #+msg (format t " -- done.~%")
+ path)))
+
+(defun tree-row-destroy (row-reference)
+ "deletes the tree row referenced by row-reference and frees the reference"
+ (when (tree-row-valid row-reference)
+ (with-tree-row (row-reference)
+ (gtk-tree-store-remove model iter))
+ (gtk-tree-row-reference-free row-reference)
+ #+msg (format t " row deleted ")))
+
+
+;;;
+;;; the CELLS-TREE-NODE is a node mapping a CLOS object to a GTK tree row
+;;;
+
+(eval-when (:load-toplevel :execute)
+ (defmodel cells-tree-node (family-observer)
+ ((row :reader row :initarg :row))
+ (:default-initargs
+ :row (c? (when-bind* ((parent (upper self)) (pos (position self (kids parent))))
+ (unless (or (deadp parent) (deadp self))
+ #+msg (format t "~&create row for ~a (parent ~a) -- " (value self) (value parent))
+ (let ((new-row (tree-row-create (row parent) (id parent))))
+ (when (tree-row-valid new-row)
+ #+msg (format t " -- row for ~a is valid~%" (value self))
+ (tree-row-set-path new-row (row parent) pos)
+ new-row))))))))
+
+;;; gtk-object-forget is called recursively on all the children of tree-store
+(defmethod id ((self cells-tree-node))
+ (cffi-sys:null-pointer))
+
+;;; if the row changes, remove the old one
+(defobserver row ((self cells-tree-node))
+ (unless (deadp self)
+ (when old-value
+ #+msg (format t "~&destroying OLD row for ~a -- " (value self))
+ (tree-row-destroy old-value)
+ #+msg (trc "-- done"))))
+
+;;; not-to-be --> remove the row (:around runs on the way back up, thus deleting children before parents)
+(defmethod not-to-be :before ((self cells-tree-node))
+ (unless (deadp self)
+ #+msg (format t "~&destroying row for ~a -- " (value self))
+ (tree-row-destroy (row self))
+ #+msg (trc "-- done")))
+
+(defmacro def-cells-tree-node (name (&key (superclass 'cells-tree-node) (source-type 'family)) &body slots)
+ "create a cells-tree-node class with columns matching slots.
+For each slot you can specify :type, :reader-fn (value), :output-fn, :title, :render-fn"
+ (let ((slot-lists (mapcar #'(lambda (slot) (if (atom slot) (list slot) slot)) slots)))
+ `(def-f-observer ,name (,superclass) (,source-type)
+ ,@(loop for slot in slot-lists
+ for col from 0
+ for slot-name = (car slot)
+ collecting (destructuring-bind
+ (&key (type :string)
+ (reader-fn (case type
+ (:string `#'(lambda (value) (prin1-to-string value)))
+ (t `#'identity)))
+ output-fn
+ title
+ render-fn &allow-other-keys) (cdr slot)
+ (declare (ignorable title render-fn))
+ `(,slot-name
+ :reader-fn ,reader-fn
+ :output-fn #'(lambda (self new-value)
+ (unless (deadp self)
+ ,(when output-fn `(funcall ,output-fn self new-value))
+ (when (tree-row-valid (row self))
+ #+msg (format t ,(format nil "~~&updating slot ~a for ~~a " slot-name) (value self))
+ (tree-row-set-cell (row self) ,col new-value)
+ #+msg (format t "done~%"))))))))))
+
+;;;
+;;; the CELLS-TREE-STORE is a tree-store that is also a map for the source node
+;;;
+
+(defmodel cells-tree-store (family-observer tree-store)
+ ((row :reader row :initform +c-null+)))
+
+
+;;;
+;;; the CELLS-TREE-VIEW widget
+;;;
+
+(defmodel cells-tree-view (tree-view)
+ ((source :initform (c-in nil) :initarg :source :accessor source)
+ (tree-model :accessor tree-model :owning t :initarg :tree-model :initform (c-in nil))
+ (tree-model-type :initarg :tree-model-type :initform (error "supply a tree-model-type for cells-tree-view upon instantiation") :accessor tree-model-type)))
+
+(defobserver source ((self cells-tree-view))
+ (with-integrity (:change 'make-tree-model)
+ (setf (tree-model self) (make-instance (tree-model-type self) :value new-value))))
+
+(defmethod roots ((self cells-tree-view))
+ (and (tree-model self) (value (tree-model self)) (kids (value (tree-model self)))))
+
+
+(defmacro def-cells-tree-view (name (&key (super-node 'cells-tree-node) (source-type 'family)) &body slots)
+ "creates a cells-tree-view widget using cells-tree-nodes as if defined with def-cells-tree-node. The widget can be instantiated with mk-`name`"
+ (let ((node (intern (format nil "~a-NODE" name)))
+ (store (intern (format nil "~a-STORE" name)))
+ (on-edit-fn (intern (format nil "~a-ON-EDIT" name)))
+ (constructor (intern (format nil "MK-~a" name)))
+ (slots (mapcar #'(lambda (slot) (if (atom slot) (list slot) slot)) slots)))
+ `(progn
+ (def-cells-tree-node ,node (:superclass ,super-node :source-type ,source-type)
+ ,@slots)
+ (defmodel ,store (cells-tree-store)
+ ()
+ (:default-initargs
+ :item-types ',(append
+ (mapcar #'(lambda (slot) (getf (cdr slot) :type :string)) slots)
+ (list :string))))
+ (defmethod mk-observer ((parent ,store) (source ,source-type) &rest initargs)
+ (apply #'make-instance ',node :value source :fm-parent *parent* initargs))
+ ,@(loop
+ for slot in slots
+ for col from 0
+ for writer-fn = (getf (cdr slot) :writer-fn `#'identity)
+ collect `(defmethod ,on-edit-fn (node (col (eql ,col)) new-value) ; node is part of the source tree!
+ #+msg (format t ,(format nil "~~&setf'ing ~a on ~~a -- " (car slot)) node)
+ (with-integrity (:change 'setf-data)
+ (setf (,(car slot) node) (funcall ,writer-fn new-value)))
+ #+msg (format t " -- done.~%")))
+ (defun ,constructor (source &rest inits)
+ (apply #'make-instance 'cells-tree-view
+ :fm-parent *parent*
+ :source (c-in source)
+ :children-fn #'kids
+ :on-edit #',on-edit-fn
+ :tree-model-type ',store
+ :roots (c-in nil)
+ :columns (list ,@(mapcar #'(lambda (slot)
+ (destructuring-bind (&key (type :string)
+ (title (format nil "~:(~a~)" (car slot)))
+ render-fn &allow-other-keys)
+ (cdr slot)
+ `(list ,type (list :title ,title) nil ,render-fn))) slots))
+ inits)))))
+
+;;;
+;;; The object inspector
+;;;
+
+#|
+
+;;; under development
+
+(defmodel slot-inspector (cells-tree-node)
+ ()
+ (:default-initargs :kids (c-in nil)))
+
+(defobserver md-name ((self slot-inspector))
+ (when (tree-row-valid (row self))
+ (tree-row-set-cell (row self) 'col new-value)))
+
+(defobserver value ((self slot-inspector))
+ (when (tree-row-valid (row self))
+ (tree-row-set-cell (row self) 'col new-value)))
+
+
+
+(defmodel obj-inspector (cells-tree-node)
+ ()
+ (:default-initargs :kids (c-in nil)))
+
+(defmacro def-obj-inspector (object-type &body slots)
+ `(defmethod mk-obj-inspector (parent (obj ,object-type))
+ (push (make-instance 'obj-inspector
+ :kids (the-kids ,(loop for raw-slot in slots
+ for slot = (if (listp raw-slot) raw-slot (list raw-slot))
+ collecting (destructuring-bind (slot-name &key (title ))`(make-instance 'slot-inspector
+ :md-name 'sth
+ :value (c? ))))))
+ (kids parent))))
+
+(defmodel cells-inspector-store (tree-store)
+ ((row :reader row :initform +c-null+))
+ (:default-initargs :kids (c-in nil)))
+
+
+(defmodel cells-inspector (cells-tree-view)
+ ()
+ )
+
+(defmethod mk-obj-inspector ((object family) (parent cells-inspector)))
+
+(defmacro def-inspector-map (object &body slots)
+ )
+
+|#
81 cells-gtk/actions.lisp
@@ -0,0 +1,81 @@
+(in-package :cgtk)
+
+(def-object action ()
+ ((name :accessor name :initarg :name :initform nil)
+ (accel :accessor accel :initarg :accel :initform nil)
+ (visible :accessor visible :initarg :visible :initform (c-in t))
+ (sensitive :accessor sensitive :initarg :sensitive :initform (c-in t))
+ (label :accessor label :initarg :label :initform nil)
+ (tooltip :accessor tooltip :initarg :tooltip :initform nil)
+ (stock :accessor stock :initarg :stock :initform nil)
+ (stock-id :accessor stock-id :initform (c? (when (stock self)
+ (string-downcase (format nil "gtk-~a" (stock self)))))))
+ ()
+ ()
+ :new-args (c_1 (list (name self) nil nil (stock-id self))))
+
+(def-c-output visible ((self action))
+ (gtk-ffi::gtk-object-set-property (id self) "visible" 'boolean new-value))
+(def-c-output sensitive ((self action))
+ (gtk-ffi::gtk-object-set-property (id self) "sensitive" 'boolean new-value))
+
+(def-c-output label ((self action))
+ (when new-value
+ (gtk-ffi::with-gtk-string (str new-value)
+ (gtk-ffi::gtk-object-set-property (id self) "label" 'c-pointer str))))
+
+(def-c-output tooltip ((self action))
+ (when new-value
+ (gtk-ffi::with-gtk-string (str new-value)
+ (gtk-ffi::gtk-object-set-property (id self) "tooltip" 'c-pointer str))))
+
+(def-object action-group ()
+ ((name :accessor name :initarg :name :initform nil)
+ (visible :accessor visible :initarg :visible :initform (c-in t))
+ (sensitive :accessor sensitive :initarg :sensitive :initform (c-in t)))
+ ()
+ ()
+ :new-args (c_1 (list (name self))))
+
+(def-c-output sensitive ((self action-group))
+ (gtk-ffi::gtk-action-group-set-sensitive (id self) new-value))
+
+(def-c-output visible ((self action-group))
+ (gtk-ffi::gtk-action-group-set-visible (id self) new-value))
+
+(def-c-output .kids ((self action-group))
+ (dolist (kid old-value)
+ (gtk-ffi::gtk-action-group-remove-action (id self) (id kid)))
+ (dolist (kid new-value)
+ (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid)))
+ #+clisp (call-next-method))
+
+(def-object ui-manager ()
+ ((action-groups :accessor action-groups :initform (c-in nil))
+ (add-tearoffs :accessor tearoffs :initarg :tearoffs :initform nil))
+ ()
+ ())
+
+(def-c-output tearoffs ((self ui-manager))
+ (gtk-ffi::gtk-ui-manager-set-add-tearoffs (id self) new-value))
+
+(defmethod add-action-group ((self ui-manager) (group action-group) &optional pos)
+ (let ((grp (to-be group)))
+ (trc nil "ADD-ACTION-GROUP" grp) (force-output)
+ (gtk-ffi::gtk-ui-manager-insert-action-group (id self) (id group) (or pos (length (action-groups self))))
+ (push grp (action-groups self))))
+
+
+(defmodel test-actions (vbox)
+ ()
+ (:default-initargs
+ :action-group (mk-action-group
+ :name "Group 1"
+ :kids (kids-list?
+ (mk-action
+ :name "Action 1" :stock :cdrom :label "Action 1" :accel "<Control>a")
+ (mk-action
+ :name "Action 2" :stock :network :label "Action 2" :accel "<Control>b")))
+
+ :kids (kids-list?
+ (mk-label :text "Actions test"))))
74 cells-gtk/addon.lisp
@@ -0,0 +1,74 @@
+#|
+
+ Cells Gtk
+
+ Copyright (c) 2004 by Vasilis Margioulas <vasilism@sch.gr>
+
+ You have the right to distribute and use this software as governed by
+ the terms of the Lisp Lesser GNU Public License (LLGPL):
+
+ (http://opensource.franz.com/preamble.html)
+
+ This program 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
+ Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :cgtk)
+
+(def-widget calendar ()
+ ((init :accessor init :initarg :init :initform nil))
+ ()
+ (day-selected)
+ :on-day-selected (callback (widg signal data)
+ (setf (value self) (get-date self))))
+
+(defmethod get-date ((self calendar))
+ (uffi:with-foreign-objects ((year :int)(month :int)(day :int))
+ (gtk-calendar-get-date (id self) year month day)
+ (encode-universal-time 0 0 0 (uffi:deref-pointer day :int)
+ (1+ (uffi:deref-pointer month :int)) (uffi:deref-pointer year :int))))
+
+(defobserver init ((self calendar))
+ (when new-value
+ (multiple-value-bind (sec min hour day month year) (decode-universal-time new-value)
+
+ (declare (ignorable sec min hour))
+ (gtk-calendar-select-month (id self) (1- month) year)
+ (gtk-calendar-select-day (id self) day))
+ (setf (value self) new-value)))
+
+
+(def-widget arrow ()
+ ((type :accessor arrow-type :initarg :type :initform nil)
+ (type-id :accessor type-id
+ :initform (c? (case (arrow-type self)
+ (:up 0)
+ (:down 1)
+ (:left 2)
+ (:right 3)
+ (t 3))))
+ (shadow :accessor arrow-shadow :initarg :shadow :initform nil)
+ (shadow-id :accessor shadow-id
+ :initform (c? (case (arrow-shadow self)
+ (:none 0)
+ (:in 1)
+ (:out 2)
+ (:etched-in 3)
+ (:etched-out 4)
+ (t 2)))))
+ ()
+ ()
+ :new-args (c_1 (list (type-id self) (shadow-id self))))
+
+(defobserver type ((self arrow))
+ (when new-value
+ (gtk-arrow-set (id self) (type-id self) (shadow-id self))))
+
+(defobserver shadow ((self arrow))
+ (when new-value
+ (gtk-arrow-set (id self) (type-id self) (shadow-id self))))
+
103 cells-gtk/buttons.lisp
@@ -0,0 +1,103 @@
+#|
+
+ Cells Gtk
+
+ Copyright (c) 2004 by Vasilis Margioulas <vasilism@sch.gr>
+
+ You have the right to distribute and use this software as governed by
+ the terms of the Lisp Lesser GNU Public License (LLGPL):
+
+ (http://opensource.franz.com/preamble.html)
+
+ This program 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
+ Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cgtk)
+
+(def-widget button (container)
+ ((stock :accessor stock :initarg :stock :initform (c-in nil))
+ (markup :accessor markup :initarg :markup :initform nil)
+ (label :accessor label :initarg :label :initform (c-in nil)))
+ (relief use-stock)
+ (activate clicked enter leave pressed released)
+ :kids (c-in nil))
+
+(defobserver label ((self button))
+ (when new-value
+ (gtk-button-set-label (id self) new-value)))
+
+(defobserver markup ((self button))
+ (when new-value
+ (with-integrity (:change 'button-markup)
+ (setf (kids self) (the-kids (mk-label :markup new-value))))))
+
+(defobserver .kids ((self button))
+ (assert-bin self)
+ (dolist (kid (kids self))
+ (gtk-container-add (id self) (id kid)))
+ #+clisp (call-next-method))
+
+(defobserver stock ((self button))
+ (when new-value
+ (with-integrity (:change 'button-stock-observer)
+ (setf (label self) (string-downcase (format nil "gtk-~a" new-value)))
+ (trc nil "c-outputting stock" (label self)) (force-output)
+ (setf (use-stock self) t))))
+
+(def-widget toggle-button (button)
+ ((init :accessor init :initarg :init :initform nil))
+ (mode active)
+ (toggled)
+ :active (c-in nil)
+ :on-toggled (callback (widget event data)
+ ;;(print (list :toggle-button :on-toggled-cb widget))
+ (with-integrity (:change 'tggle-button-on-toggled-cb)
+ (let ((state (gtk-toggle-button-get-active widget)))
+ ;;(print (list :toggledstate state))
+ (setf (value self) state)))))
+
+#+test
+(DEF-GTK WIDGET TOGGLE-BUTTON (BUTTON) ((INIT :ACCESSOR INIT :INITARG :INIT :INITFORM NIL))
+ (MODE ACTIVE) (TOGGLED) :ACTIVE (C-IN NIL) :ON-TOGGLED
+ (CALLBACK (WIDGET EVENT DATA)
+ (LET ((STATE (GTK-TOGGLE-BUTTON-GET-ACTIVE WIDGET)))
+ (SETF (value SELF) STATE))))
+
+#+test
+(defobserver ACTIVE ((SELF TOGGLE-BUTTON))
+ (WHEN (OR NEW-VALUE OLD-VALUE)
+ (CONFIGURE SELF #'GTK-TOGGLE-BUTTON-SET-ACTIVE NEW-VALUE)))
+
+(defobserver init ((self toggle-button))
+ (setf (active self) new-value)
+ (setf (value self) new-value))
+
+(def-widget check-button (toggle-button)
+ () () ())
+
+(def-widget radio-button (check-button)
+ () () ()
+ :new-tail (c? (and (upper self box)
+ (not (eql (first (kids (fm-parent self))) self))
+ '-from-widget))
+
+ :new-args (c_1 (assert (upper self box))
+ (and (upper self box)
+ (list
+ (if (eql (first (kids .parent)) self)
+ +c-null+
+ (id (first (kids .parent)))))))
+ :on-toggled (callback (widget event data)
+ (with-integrity (:change 'radio-butt-on-tog)
+ (let ((state (gtk-toggle-button-get-active widget)))
+ (setf (value self) state)))))
+
+(defobserver .value ((self radio-button))
+ (when (and new-value (upper self box))
+ (with-integrity (:change 'radio-up-to-box)
+ (setf (value (upper self box)) (md-name self))))
+ #+clisp (call-next-method))
778 cells-gtk/cairo-drawing-area.lisp
@@ -0,0 +1,778 @@
+#|
+ Copyright (c) 2005 by Peter Denno <peter.denno@nist.gov>
+
+ You have the right to distribute and use this software as governed by
+ the terms of the Lisp Lesser GNU Public License (LLGPL):
+
+ (http://opensource.franz.com/preamble.html)
+
+ This program 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
+ Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :cgtk)
+
+;;;; ==========================================================================
+;;;; debug facility
+;;;; ==========================================================================
+
+(defparameter *debug* t)
+
+(defmacro deb (format-string &rest params)
+ `(when *debug*
+ (format t ,(concatenate 'string "~&" format-string "~%") ,@params)
+ (force-output)))
+
+
+;;;; ==========================================================================
+;;;; convenience macros
+;;;; ==========================================================================
+
+
+
+(defmacro defmodel2 (name (&rest superclasses) (&rest slots) &rest definitions)
+ "Defines a model like defmodel, with a few enhancements: Slots are by default provided with the corresponding
+accessors and initargs. If you provide more than two atoms, your slot definition is untouched.
+The optional definitions understand :kids-entries,
+:readers, :from-upper, :initialize-instance. :default-initargs is understood, buts its value
+neesds to be wrapped in parens."
+ (destructuring-bind
+ (&key kids-entries readers from-upper initialize-instance default-initargs) (car definitions)
+ (let ((slots (loop for slot in slots
+ for slot-name = (if (atom slot) slot (car slot))
+ for initform = (if (atom slot) nil (second slot))
+ if (cddr slot) collecting slot
+ else collecting `(,slot-name :initform (c-in ,initform)
+ :initarg ,(intern (string slot-name) :keyword)
+ :accessor ,slot-name)))
+ (reader-slots (loop for slot in readers
+ for slot-name = (car slot)
+ for initform = (second slot)
+ collecting `(,slot-name :initform (c? ,initform)
+ :reader ,slot-name)))
+ (from-upper-slots (loop for slot-name in from-upper
+ collecting `(,slot-name :initform (c? (,slot-name (upper self)))
+ :reader ,slot-name))))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmodel ,name (,@superclasses)
+ (,@slots
+ ,@reader-slots
+ ,@from-upper-slots)
+ ,(when default-initargs
+ `(:default-initargs ,@default-initargs)))
+ (eval-when (:load-toplevel :execute)
+ ,(when (or kids-entries initialize-instance)
+ (with-gensyms (rest)
+ `(defmethod initialize-instance ((self ,name) &rest ,rest)
+ (declare (ignorable ,rest))
+ (call-next-method-when)
+ ,@(when kids-entries
+ (loop for kid in kids-entries
+ collecting `(push ,(append kid '(:fm-parent self)) (kids self))))
+ ,@initialize-instance))))))))
+
+
+(defmacro call-next-method-when ()
+ "call-next-method if and only if there is one"
+ `(when (next-method-p)
+ (call-next-method)))
+
+(defmacro funcall-when (fn &rest params)
+ "funcalls fn if and only if fn is non-nil"
+ `(when ,fn
+ (funcall ,fn ,@params)))
+
+(defun true (val)
+ (if val t))
+
+(defmacro with-slot-accessors ((&rest slots) obj &body body)
+ "like with-slots, but using accessors, thus cell-safe"
+ `(with-accessors ,(loop for slot in slots collecting (list slot slot)) ,obj ,@body))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun strip-properties (plst keys)
+ "conses a fresh plist without the members of plist and their values"
+ (labels ((strip (lst) (when (consp lst)
+ (if (member (car lst) keys) (strip (cddr lst))
+ (cons (car lst) (cons (cadr lst) (strip (cddr lst))))))))
+ (strip plst))))
+
+
+;;;; ==========================================================================
+;;;; the drawing area widget
+;;;; ==========================================================================
+
+
+(defmodel cairo-drawing-area (drawing-area)
+ ((cairo-context :accessor cairo-context :cell nil :initform nil)
+ (canvas :accessor canvas :cell t :initform (c-in nil) :initarg :canvas)
+ (.canvas :accessor .canvas :initform (c-in nil))
+ (prims :reader prims :initform (c? (append (canvas self) (.canvas self))))
+ (widget :reader widget :cell t :initform (c? self))
+ ;; the primitive the mouse is currently hovering over
+ (hover :accessor hover :cell nil :initform nil)
+ (hover-history :accessor hover-history :cell nil :initform nil)
+ ;; callback (on-clicked [widget] [button] [primitive] [pos])
+ (on-clicked :accessor on-clicked :cell nil :initform nil :initarg :on-clicked)
+ ;; callback (on-dragged [widget] [button] [primtitive] [start] [end])
+ (on-dragged :accessor on-dragged :cell nil :initform nil :initarg :on-dragged)
+
+ (dragging :accessor dragging :cell t :initform (c-in nil))
+
+ (drag-start :accessor drag-start :cell nil :initform nil)
+ (drag-offset :accessor drag-offset :cell nil :initform nil)
+ (button-down-position :accessor button-down-position :cell nil :initform nil)
+ (select-box :accessor select-box :cell nil :initform nil)
+
+ (selection-color :accessor selection-color :cell nil :initform '(1 1 .27))
+ (drag-threshold :accessor drag-threshold :cell nil :initform 3 :initarg :drag-threshold)
+ (selection :accessor selection :cell t :initform (c-in nil)))
+ (:default-initargs
+ :on-pressed #'cairo-drawing-area-button-press
+ :on-released #'cairo-drawing-area-button-release
+ :on-moved #'cairo-drawing-area-motion
+ :on-draw #'cairo-drawing-area-draw))
+
+
+;;;; ==========================================================================
+;;;; graphic elements
+;;;; ==========================================================================
+
+;;; creates a primitve for use in a drawing area widget
+
+
+(defmacro defprimitive (name (&rest superclasses) (&rest slots) &rest definitions)
+ "Defines a graphic primitive based on SUPERCLASS with the given SLOTS. Accessors are
+created automatically. Furthermore listeners are created that toggle a REDRAW event
+when slot values are SETF'd."
+ (destructuring-bind
+ (&key no-redraw readers from-upper &allow-other-keys) (car definitions)
+ (let ((outputs (loop for slot in (append slots readers from-upper)
+ for slot-name = (if (atom slot) slot (car slot))
+ collecting (unless (member slot-name no-redraw)
+ `(defobserver ,slot-name ((self ,name) new-val)
+ (when-bind (widget (widget self))
+ (redraw widget))))))
+ (other-defs (strip-properties (car definitions) '(:no-redraw))))
+ `(progn
+ (defmodel2 ,name (,@(or superclasses '(primitive)))
+ ,slots
+ ,other-defs)
+ ,@outputs))))
+
+
+
+;;;; -----------------------------------------------------------
+;;;; drawing method
+;;;; -----------------------------------------------------------
+
+
+(defmacro defdraw (class-name (&rest slots) &body body)
+ "Defines a draw method on class CLASS-NAME. In the BODY, the SLOTS will be bound
+to the corresponding slot accessors of CLASS-NAME. Furthermore CONTEXT will be bound to
+a current cairo context and KIDS to the kids of CLASS-NAME. The method will automatically
+call NEXT-METHOD and finally map itself over all kids."
+ `(defmethod draw ((self ,class-name))
+ (when (widget self)
+ (with-accessors
+ (,@(loop for slot in slots collecting `(,slot ,slot))
+ (kids kids))
+ self
+ (let ((context (cairo-context (widget self))))
+ (declare (ignorable context))
+ ,@body
+ (call-next-method-when)
+ (trc nil "drawing kids?" kids (listp kids))
+ (when (listp kids)
+ (mapcar #'draw kids)))))))
+
+(defgeneric draw (element)
+ (:documentation "draws a primitive in the context stored in the cairo-context slot of the associated widget"))
+
+;; a handler if draw called on nil
+(defmethod draw (self))
+
+
+;;;; -----------------------------------------------------------
+;;;; export method
+;;;; -----------------------------------------------------------
+
+(defmethod export-to-file ((self cairo-drawing-area) file-name &key (type :ps) (width 500) (height 500))
+ (deb "Exporting to ~a" file-name)
+ (with-slots (cairo-context prims) self
+ (setf cairo-context
+ (funcall (case type
+ (:ps #'cl-cairo2:create-ps-context)
+ (:pdf #'cl-cairo2:create-pdf-context))
+ file-name
+ width height))
+ (mapcar #'draw prims)
+ (cl-cairo2:destroy cairo-context))
+ (deb "done."))
+
+
+;;;; -----------------------------------------------------------
+;;;; redraw method (called to trigger a refresh)
+;;;; -----------------------------------------------------------
+
+;;; a handler if redraw called on nil
+(defmethod redraw (self))
+
+(defmethod redraw ((self cairo-drawing-area))
+ "Queues a redraw with GTK. This is called whenever a primitve is modified"
+ (trc nil "queue redraw" self)
+ (gtk-ffi:gtk-widget-queue-draw (widget-id self)))
+
+
+(defobserver prims ((self cairo-drawing-area))
+ (redraw self))
+
+
+;;;; -----------------------------------------------------------
+;;;; modify method (to change several parameters at once)
+;;;; -----------------------------------------------------------
+
+;;;; ---- convenience macros for modify method -----------------
+
+(defmacro when-supplied-setf (place property-list property)
+ "if PROPERTY is supplied in the PROPERTY-LIST, the corresponding value is setf'd to PLACE"
+ (let ((value-sym (gensym)))
+ `(let ((,value-sym (getf ,property-list ,property)))
+ (when ,value-sym
+ (setf ,place ,value-sym)))))
+
+(defmacro property-list-setf ((object property-list) &rest properties)
+ "Calls accessors on OBJECT with the corresponding values given in PROPERTY-LIST. PROPERTIES is of