Update of /project/cells/cvsroot/cells-gtk3/cells-gtk In directory clnet:/tmp/cvs-serv29766/cells-gtk
Modified Files: actions.lisp addon.lisp buttons.lisp callback.lisp cells-gtk.asd dialogs.lisp display.lisp entry.lisp gl-drawing-area.lisp layout.lisp menus.lisp textview.lisp widgets.lisp Log Message: Ingo's patches: activate features in test-gtk.asd, clisp fixes, cells2 leftovers
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/06/02 13:38:15 1.2 @@ -14,17 +14,17 @@ () :new-args (c_1 (list (name self) nil nil (stock-id self))))
-(def-c-output visible ((self action)) +(defobserver visible ((self action)) (gtk-ffi::gtk-object-set-property (id self) "visible" 'boolean new-value)) -(def-c-output sensitive ((self action)) +(defobserver sensitive ((self action)) (gtk-ffi::gtk-object-set-property (id self) "sensitive" 'boolean new-value))
-(def-c-output label ((self action)) +(defobserver 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)) +(defobserver 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)))) @@ -37,18 +37,17 @@ () :new-args (c_1 (list (name self))))
-(def-c-output sensitive ((self action-group)) +(defobserver sensitive ((self action-group)) (gtk-ffi::gtk-action-group-set-sensitive (id self) new-value))
-(def-c-output visible ((self action-group)) +(defobserver visible ((self action-group)) (gtk-ffi::gtk-action-group-set-visible (id self) new-value))
-(def-c-output .kids ((self action-group)) +(defobserver .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)) + (gtk-ffi::gtk-action-group-add-action-with-accel (id self) (id kid) (accel kid))))
(def-object ui-manager () ((action-groups :accessor action-groups :initform (c-in nil)) @@ -56,7 +55,7 @@ () ())
-(def-c-output tearoffs ((self ui-manager)) +(defobserver 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) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/06/02 13:38:15 1.2 @@ -42,7 +42,7 @@ (setf (value self) new-value)))
-(def-widget arrow () +(def-widget arrow (widget misc) ((type :accessor arrow-type :initarg :type :initform nil) (type-id :accessor type-id :initform (c? (case (arrow-type self) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/20 13:05:02 1.4 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/06/02 13:38:15 1.5 @@ -38,8 +38,7 @@ (defobserver .kids ((self button)) (assert-bin self) (dolist (kid (kids self)) - (gtk-container-add (id self) (id kid))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid))))
(defobserver stock ((self button)) (when new-value @@ -98,5 +97,4 @@ (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)) + (setf (value (upper self box)) (md-name self))))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:16 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/06/02 13:38:15 1.2 @@ -29,7 +29,7 @@ (format nil "gtk_server_connect(~A, ~A, :callback ~A)" (id self) event (register-callback self event fn)))
-(def-c-output bindings () ;;; (w widget) event fun) +(defobserver bindings () ;;; (w widget) event fun) (loop for binding in new-value do (destructuring-bind (event . fn) binding (declare (ignorable event)) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/14 16:43:42 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/06/02 13:38:15 1.3 @@ -11,13 +11,13 @@ ;;;
;;; run gtk in its own thread (requires bordeaux-threads) -(pushnew :cells-gtk-threads *features*) +;;(pushnew :cells-gtk-threads *features*)
;;; drawing-area widget using cairo (requires cl-cairo2) -(pushnew :cells-gtk-cairo *features*) +;;(pushnew :cells-gtk-cairo *features*)
;;; drawing-area widget using OpenGL (requires libgtkglext1) -(pushnew :cells-gtk-opengl *features*) +;;(pushnew :cells-gtk-opengl *features*)
(asdf:defsystem :cells-gtk :name "cells-gtk" --- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/20 13:05:02 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/06/02 13:38:15 1.3 @@ -169,5 +169,15 @@ +c-null+)))
(defun file-chooser (&rest inits) - (apply #'show-dialog 'file-chooser-dialog inits)) + (bwhen (fn-string (apply #'show-dialog 'file-chooser-dialog inits)) + (let ((fn (parse-namestring fn-string)) + (action (getf inits :action))) + (flet ((fail (format-string &rest format-args) + (show-message (apply #'format nil format-string format-args) + :title (format nil "File ~(~a~) error" action)) + nil)) + (case action + (:open (or (and (file-namestring fn) (probe-file fn)) + (fail ""~a" is not a valid filename." fn-string))) + (t fn-string))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/06/02 13:38:15 1.2 @@ -49,14 +49,43 @@ `(format nil "~a ~a </span>" ,markup-start (format nil "~{~a~}" (list ,@rest))))))
-(def-widget label () +;;; +;;; misc +;;; + +;;; adds padding and alignment to label, arrow, image, and (pixmap) + +(defmd misc () + xalign :xalign (c-in .5) + yalign :yalign (c-in .5) + xpad :xpad (c-in 0.0) + ypad :ypad (c-in 0.0)) + +(defobserver xalign ((self misc)) + (gtk-misc-set-alignment (id self) (^xalign) (^yalign))) + +(defobserver yalign ((self misc)) + (gtk-misc-set-alignment (id self) (^xalign) (^yalign))) + +(defobserver xpad ((self misc)) + (gtk-misc-set-padding (id self) (^xpad) (^ypad))) + +(defobserver ypad ((self misc)) + (gtk-misc-set-padding (id self) (^xpad) (^ypad))) + +;;; +;;; label +;;; + +(def-widget label (widget misc) ((markup :accessor markup :initarg :markup :initform nil) (text :accessor text :initarg :text :initform nil)) (line-wrap selectable use-markup) () :text (c-in nil) :use-markup (c? (not (null (markup self)))) - :new-args (c_1 (list nil))) + :new-args (c_1 (list nil)) + :xalign (c-in 0.0))
(defobserver text ((self label)) (when new-value @@ -72,7 +101,7 @@ () :id (c_1 (gtk-accel-label-new (text self))))
-(def-widget image () +(def-widget image (widget misc) ((filename :accessor filename :initarg :filename :initform nil) (stock :accessor stock :initarg :stock :initform nil) (stock-id :accessor stock-id --- /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/06/02 13:38:15 1.2 @@ -38,22 +38,23 @@ (init :accessor init :initarg :init :initform nil)) (editable has-frame max-length) (changed activate) - :on-changed (callback-if (auto-update self) + :on-changed (callback-if (auto-update self) ; this is broken and never gets called (widget event data) (with-integrity (:change 'entry-changed-cb) + (trc "entry on-changed") (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) - (trc nil "ENTRY (ON-CHANGED)" txt) (force-output) + (trc "ENTRY (ON-CHANGED)" txt) (force-output) (setf (value self) txt)))) - :on-activate (callback-if (not (auto-update self)) + :on-activate (callback-if (not (auto-update self)) ; this is called on pressing enter (widget event data) + (trc "entry on-activate") (with-integrity (:change 'entry-activate-cb) (let ((txt (get-gtk-string (gtk-entry-get-text widget)))) (trc nil "ENTRY (ON-ACTIVATE)" txt) (force-output) (setf (value self) (if (equal txt "") nil txt))))))
(defobserver text ((self entry)) - (when new-value - (gtk-entry-set-text (id self) new-value))) + (gtk-entry-set-text (id self) (or new-value "")))
(defobserver init ((self entry)) (when (stringp new-value) ;; could be null or numeric for spin button --- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/14 16:43:42 1.2 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/06/02 13:38:15 1.3 @@ -1,4 +1,4 @@ - +
(in-package :cgtk)
@@ -24,6 +24,7 @@
(defun gl-init () (gtk-gl-init +c-null+ +c-null+) + (glut:init) (setf *gl-config* (get-gl-config)))
@@ -66,12 +67,22 @@ (defun %resize (self) (let ((width (allocated-width self)) (height (allocated-height self))) - (when (and (plusp width) (plusp height)) - (trc "%resize to" width height) - (with-gl-context (self) - (gl:viewport 0 0 width height) - (bwhen (resize-fn (resize self)) - (funcall resize-fn self)))))) + (when (and (plusp width) (plusp height)) + (trc "%resize to" width height) + (with-gl-context (self) + (gl:viewport 0 0 width height) + + ;; set projection to account for aspect + (gl:matrix-mode :projection) + (gl:load-identity) + (glu:perspective 90 (/ width height) 0.5 20) ; 90 degrees field of view y, clip 0.5-20 z + + ;; set modelview to identity + (gl:matrix-mode :modelview) + (gl:load-identity) + + (bwhen (resize-fn (resize self)) + (funcall resize-fn self))))))
;;; ;;; Widget --- /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/06/02 13:38:15 1.2 @@ -30,8 +30,7 @@ (when new-value (dolist (kid new-value) (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))) - #+clisp (call-next-method))) + (expand? kid) (fill? kid) (padding? kid)))))
(def-widget hbox (box) () () () @@ -93,8 +92,7 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (kids-list? (cadr new-value))))))) - #+clisp (call-next-method)) + :kids (kids-list? (cadr new-value))))))))
(def-widget vpaned () ((divider-pos :accessor divider-pos :initarg :divider-pos :initform (c-in 0))) @@ -113,9 +111,7 @@ (and (cadr new-value) (gtk-paned-add2 (id self) (id (make-be 'frame :shadow 'in - :kids (kids-list? (cadr new-value))))))) - #+clisp (call-next-method)) - + :kids (kids-list? (cadr new-value))))))))
(def-widget frame (container) ((shadow :accessor shadow? :initarg :shadow :initform nil) @@ -143,8 +139,7 @@ (defobserver .kids ((self frame)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid))))
(def-widget aspect-frame (frame) ((xalign :accessor xalign :initarg :xalign :initform 0.5) @@ -178,8 +173,7 @@ (defobserver .kids ((self expander)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid))))
(def-widget scrolled-window (container) () @@ -194,20 +188,25 @@ (dolist (kid new-value) (if (member (class-name (class-of kid)) '(listbox treebox tree-view text-view layout) :test #'equal) (gtk-container-add (id self) (id kid)) - (gtk-scrolled-window-add-with-viewport (id self) (id kid)))) - #+clisp (call-next-method)) + (gtk-scrolled-window-add-with-viewport (id self) (id kid)))))
(def-widget notebook (container) ((tab-labels :accessor tab-labels :initarg :tab-labels :initform (c-in nil)) (tab-labels-widgets :accessor tab-labels-widgets :initform (c-in nil)) (show-page :accessor show-page :initarg :show-page :initform (c-in 0)) - (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil))) + (tab-pos :accessor tab-pos :initarg :tab-pos :initform (c-in nil)) + (selected-page :accessor selected-page :initform (c-in nil))) (current-page show-tabs show-border scrollable tab-border homogeneous-tabs) - () + (select-page) :current-page (c-in nil) - :show-tabs (c-in t)) - + :show-tabs (c-in t) + :on-select-page (callback (w e d) + (with-integrity (:change :selected-page) + (trc "on select page is called" self (when self (kids self))) + (when (and self (kids self)) + (setf (selected-page self) + (nth (gtk-notebook-get-current-page (id self)) (kids self)))))))
(defobserver tab-pos ((self notebook)) (when new-value @@ -243,8 +242,7 @@ (loop for page from 0 to (length new-value) do (setf (current-page self) page)) (when (and (show-page self) (>= (show-page self) 0) (< (show-page self) (length new-value))) - (setf (current-page self) (show-page self))) - #+clisp (call-next-method))) + (setf (current-page self) (show-page self)))))
(defobserver show-tabs ((self notebook)) (gtk-notebook-set-show-tabs (id self) new-value)) @@ -304,5 +302,4 @@ (defobserver .kids ((self alignment)) (assert-bin self) (dolist (kid new-value) - (gtk-container-add (id self) (id kid))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid)))) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/06/02 13:38:15 1.2 @@ -160,8 +160,7 @@ (assert-bin self) (when new-value (dolist (kid new-value) - (gtk-container-add (id self) (id kid)))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid)))))
(def-widget separator-tool-item (tool-item) () @@ -202,8 +201,7 @@ (defobserver .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid)))) - #+clisp (call-next-method)) + (gtk-menu-shell-append (id self) (id kid)))))
(def-widget menu-bar (menu-shell) () () ()) @@ -295,8 +293,7 @@ (defobserver .value ((self radio-menu-item)) (with-integrity (:change 'radio-menu-item-value) (when (and new-value (upper self menu-item)) - (setf (value (upper self menu-item)) (md-name self)))) - #+clisp (call-next-method)) + (setf (value (upper self menu-item)) (md-name self)))))
(def-widget image-menu-item (menu-item) ((stock :accessor stock :initarg :stock :initform nil) --- /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:17 1.1 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/06/02 13:38:15 1.2 @@ -151,7 +151,7 @@ (buf (gtk-text-view-get-buffer view))) (with-text-iters (s-iter) (gtk-text-buffer-get-iter-at-offset buf s-iter pos) - (gtk-text-view-scroll-to-iter view s-iter 0.0 nil 0.0 0.0)))) + (gtk-text-view-scroll-to-iter view s-iter 0.0d0 nil 0.0d0 0.0d0))))
;;; The next two can be used to check and clear the the modified flag. ;;; The event is registered when you use :on-modified-changed on a text-buffer. --- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/05/19 10:18:34 1.5 +++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/06/02 13:38:15 1.6 @@ -190,6 +190,7 @@ (def-gtk-event-handler delete-event) (def-gtk-event-handler destroy-event) (def-gtk-event-handler modified-changed) +(def-gtk-event-handler select-page)
(defparameter *widget-callbacks* (list (cons 'clicked (cffi:get-callback 'clicked-handler)) @@ -201,7 +202,8 @@ (cons 'toggled (cffi:get-callback 'toggled-handler)) (cons 'delete-event (cffi:get-callback 'delete-event-handler)) (cons 'destroy-event (cffi:get-callback 'destroy-event-handler)) - (cons 'modified-changed (cffi:get-callback 'modified-changed-handler)))) + (cons 'modified-changed (cffi:get-callback 'modified-changed-handler)) + (cons 'select-page (cffi:get-callback 'select-page-handler))))
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -311,7 +313,7 @@ r)))) (c-id (cffi:foreign-alloc :int :initial-element id))) (trc nil "timeout-add > passing cb data, *data" c-id (cffi:mem-aref c-id :int 0)) - (g-timeout-add milliseconds (cffi:get-callback 'timeout-handler-callback) c-id))) + (g-timeout-add (floor milliseconds) (cffi:get-callback 'timeout-handler-callback) c-id)))
(def-object widget () ((tooltip :accessor tooltip :initarg :tooltip :initform (c-in nil)) @@ -473,8 +475,7 @@ (dolist (kid new-value) ; (when *gtk-debug* (format t "~% window ~A has kid ~A" self kid)) (when *gtk-debug* (trc "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) - (gtk-container-add (id self) (id kid))) - #+clisp (call-next-method)) + (gtk-container-add (id self) (id kid))))
(def-widget event-box (container) ((visible-window :accessor visible-window :initarg :visible-window :initform nil))