[cells-cvs] CVS cells-gtk3/cells-gtk
phildebrandt
phildebrandt at common-lisp.net
Mon Jun 2 13:38:21 UTC 2008
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 , at 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))
More information about the Cells-cvs
mailing list