[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk - cells-cvs@common-lisp.net - mailman3.common-lisp.net

13 Apr 2008


      Update of /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk
In directory clnet:/tmp/cvs-serv5005/cells-gtk/test-gtk
Added Files:
    test-addon.lisp test-buttons.lisp test-dialogs.lisp 
    test-display.lisp test-drawing-old.lisp test-drawing.lisp 
    test-drawing2.lisp test-entry.lisp test-gtk.asd test-gtk.lisp 
    test-gtk.lpr test-layout.lisp test-menus.lisp 
    test-textview.lisp test-tree-view.lisp 
Log Message:
cells-gtk3 initial.
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-addon.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-addon.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
(defmodel test-addon (notebook)
  ()
  (:default-initargs
      :tab-labels (list "Calendar" "Arrows")
    :kids (kids-list?
           (mk-vbox
            :kids (kids-list?
                   (mk-calendar :md-name :calendar
                     :init (encode-universal-time 0 0 0 6 3 1971))
                   (mk-label
                    :text (c? (when (value (fm^ :calendar))
                                (multiple-value-bind (sec min hour day month year) 
                                    (decode-universal-time (value (fm^ :calendar)))
                                    (declare (ignorable sec min hour))
                                  (format nil "Day selected ~a/~a/~a" day month year)))))))
           (mk-vbox
            :kids (kids-list?
                   (mk-arrow 
                    :type (c? (value (fm^ :type))))
                   (mk-frame
                    :label "Arrow type"
                    :kids (kids-list?
                           (mk-hbox
                            :md-name :type
                            :kids (kids-list?
                                   (mk-radio-button :md-name :up :label "Up")
                                   (mk-radio-button :md-name :down :label "Down")
                                   (mk-radio-button :md-name :left :label "Left")
                                   (mk-radio-button :md-name :right :label "Right" :init t))))))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-buttons.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
(defmodel test-buttons (vbox)
  ((nclics :accessor nclics :initform (c-in 0)))
  (:default-initargs
      :kids (c? (the-kids
                 (mk-label :text (c? (format nil "Toggled button active = ~a" 
                                       (value (fm-other :toggled-button)))))
                 (mk-hseparator)
                 (mk-label :text (c? (format nil "Check button checked = ~a" 
                                       (value (fm-other :check-button)))))
                 (mk-hseparator)
                 (mk-label :text (c? (format nil "Radio button selected = ~a" 
                                       (value (fm-other :radio-group)))))
                 (mk-hseparator)
                 (mk-label :text (c? (format nil "Button clicked ~a times" 
                                       (nclics (upper self test-buttons))))
                   :selectable t)
                 (mk-hseparator)
(mk-hbox
                  :kids (c? (the-kids
                             (mk-button :stock :apply
                               :tooltip "Click ....."
                               :on-clicked (callback (widget event data)
                                             (incf (nclics (upper self test-buttons)))))
                             (mk-button :label "Continuable error"
                               :on-clicked (callback (widget event data)
                                             (trc "issuing continuable error" widget event)
                                             (error 'gtk-continuable-error :text "Oops!")))
    		     (mk-button :label "Lisp error (Div 0)"
    			:on-clicked (callback (widget event data)
    					      (print (/ 3 0))))
                             (mk-toggle-button :md-name :toggled-button
                               :markup (c? (with-markup (:foreground (if (value self) :red :blue))
                                             "_Toggled Button")))
                             (mk-check-button :md-name :check-button				      
                               :markup (with-markup (:foreground :green)
                                         "_Check Button")))))
                 (mk-hbox
                  :md-name :radio-group
                  :kids (c? (the-kids
                             (mk-radio-button :md-name :radio-1
                               :label "Radio 1")
                             (mk-radio-button :md-name :radio-2
                               :label "Radio 2" :init t)
                             (mk-radio-button :md-name :radio-3
                               :label "Radio 3"))))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-dialogs.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-dialogs.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
(defmodel test-message (button)
  ((message-type :accessor message-type :initarg :message-type :initform nil))
  (:default-initargs      
      :label (c? (string-downcase (symbol-name (message-type self))))
      :on-clicked (callback (widget signal data)
    	     (setf (text (fm^ :message-response))
    		   (format nil "Dialog response ~a"
    			   (show-message (format nil "~a message" (label self)) :message-type (message-type self)))))))
(defmodel test-file-chooser-dialog (button)
  ((action :accessor action :initarg :action :initform nil))
  (:default-initargs
      :stock (c? (action self))
;      :label (c? (string-downcase (symbol-name (action self))))
      :on-clicked (callback (widget signal data)
                    (with-integrity (:change 'on-click-cb)
                      (setf (text (fm^ :file-chooser-response))
                        (format nil "File chooser response ~a"
                          (file-chooser :title (format nil "~a dialog" (action self))
                            :select-multiple (value (fm^ :select-multiple-files))
                            :action (action self))))))))
    		    
(defmodel test-dialogs (vbox)
  ()
  (:default-initargs
      :kids (kids-list?
         (mk-hbox
          :kids (kids-list?
    	     (append
    	      #-libcellsgtk nil
    	      #+libcellsgtk 
    	      (list 
    	       (mk-button :label "Query for text"
    			  :on-clicked 
    			  (callback (w e d)
    				    (with-integrity (:change 'q4text)
    				      (let ((dialog
    					     (show-message-dialog     
    					      :md-name :rule-name-dialog
    					      :message "Type something:"
    					      :title "My Title"
    					      :message-type :question
    					      :buttons-type :ok-cancel
    					      :content-area (mk-entry :auto-update t))))
    					(setf (text (fm^ :message-response)) dialog))))))
    	      (loop for message-type in '(:info :warning :question :error) collect
    		   (make-kid 'test-message :message-type message-type)))))
             (mk-label :md-name :message-response)
             (mk-hbox
              :kids (kids-list?
                     (mk-check-button :md-name :select-multiple-files
    			      :label "Select multiple")
                     (loop for action in '(:open :save :select-folder :create-folder) collect
    		  (make-kid 'test-file-chooser-dialog :action action))))
             (mk-label :md-name :file-chooser-response)
             (mk-notebook
              :expand t :fill t
              :tab-labels (list "Open" "Save" "Select folder" "Create folder")
              :kids (kids-list?
                     (loop for action in '(:open :save :select-folder :create-folder) collect
    		  (mk-vbox
    		   :kids (kids-list?
    			  (mk-file-chooser-widget :md-name action
    						  :action action 
    						  :expand t :fill t
    						  :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) 
    						  :select-multiple (c? (value (fm^ :multiple))))
    			  (mk-check-button :label "Select multiple" :md-name :multiple)
    			  (mk-label :text (c? (string (value (psib (psib))))))))))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-display.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
(defmodel test-display (vbox)
  ()                 
  (:default-initargs ;; g_timeout_add a function that will move the bar until the "Pulse" toggle is false.
      :value (c? (when (value (fm-other :pulse))
                   (timeout-add (value (fm-other :timeout))
                     (lambda ()
                       (pulse (fm-other :pbar2))
                       (value (fm-other :pulse))))))
    :expand t :fill t
    :kids (kids-list?
           (mk-hbox
            :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) 
                      collect (mk-image :stock :harddisk :icon-size icon-size)
                      collect (mk-image :stock :my-g :icon-size icon-size)))
           (mk-hseparator)
           (mk-aspect-frame 
            :ratio 1
            :kids (kids-list? 
                   (mk-image :width 200 :height 250
                     :filename (namestring *tst-image*))))
           (mk-hseparator)
           (mk-hbox 
            :kids (kids-list?							    
                   (mk-progress-bar :md-name :pbar
                     :fraction (c? (value (fm^ :fraction-value))))
                   (mk-hscale :md-name :fraction-value
                     :value-type 'single-float
                     :min 0 :max 1
                     :step 0.01
                     :init 0.5)
                   (mk-button :label "Show in status bar"
                     :on-clicked 
                     (callback (widget event data)
                       (push-message (fm-other :statusbar)
                         (format nil "~a" (fraction (fm-other :pbar))))))))
           (mk-hbox
            :kids (kids-list?
                   (mk-progress-bar :md-name :pbar2				      
                     :pulse-step (c? (value (fm^ :step)))
                     :fraction (c-in .1))
                   (mk-toggle-button :md-name :pulse :label "Pulse")
                   (mk-label :text "Interval")
                   (mk-spin-button :md-name :timeout
                     :sensitive (c? (not (value (fm^ :pulse))))
                     :min 10 :max 1000
                     :init 100)
                   (mk-label :text "Pulse step")
                   (mk-spin-button :md-name :step
                     :value-type 'single-float
                     :min 0.01 :max 1 :step 0.01				     
                     :init 0.1)
                   (mk-image :md-name :pulse-image
                     :stock (c? (if (value (fm^ :pulse)) :yes :no)))))
           (mk-alignment 
            :expand t :fill t
            :xalign 0 :yalign 1
            :xscale 1
            :kids (c? (the-kids
                       (mk-statusbar :md-name :statusbar)))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing-old.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing-old.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
;;;
;;; auxiliary color funcs
;;;
(defun highlight-col (rgb)
  (mapcar #'(lambda (val) (min 1 (+ val .3))) rgb))
(defun select-col (rgb)
  (mapcar #'(lambda (val) (max 0 (- val .3))) rgb))
(defmacro rgb? (rgb)
  (with-gensyms (col)
    `(c?
       (let ((,col ,rgb))
    (cond
      ((mouse-over-p self) (highlight-col ,col))
      ((selected-p self) (select-col ,col))
      (t ,col))))))
(defmacro alpha? (alpha)
  (with-gensyms (a)
    `(c? (let ((,a ,alpha))
       (cond
         ((dragged-p self) .3)
         (t ,a))))))
;;;
;;; random generators
;;;
(defun rnd (min max)
  (+ min (random max)))
(defun random-point (min-x min-y max-x max-y)
  (2d:v (rnd min-x max-x) (rnd min-y max-y)))
(defun random-color ()
  (loop for i from 0 below 3 collect (random 1.0)))
;;;
;;; the dialog
;;;
(defmodel test-cairo-drawing (vbox)
  ((new-prim :accessor new-prim :initform (c-in nil)))
  (:default-initargs
      :md-name :test-drawing
    :kids (kids-list?
       (mk-hbox :fill t :expand t
    	    :kids (kids-list?
    		   (make-instance 'cairo-drawing-area :md-name :draw :expand t :fill t
    				  :width 500 :height 500)
    		   (mk-vbox
    		    :kids (kids-list?
    			   (mk-button :label "Draw Box"
    				      :on-clicked (callback (w e d)
    						    (let* ((p1 (random-point 10 10 480 480))
    							   (p2 (2d:v+ p1 (random-point 10 10 40 40)))
    							   (col1 (random-color))
    							   (col2 (random-color)))
    						      (trcx "rect" p1 p2 col1 col2)
    						      (mk-primitive (fm-other :draw) :rectangle
    								    :p1 (c-in p1)
    								    :p2 (c-in p2)
    								    :rgb (rgb? col1)
    								    :fill-rgb (rgb? col2)
    								    :alpha (alpha? 1)
    								    :filled t
    								    :draggable t
    								    :selectable t))))
    			   (mk-button :label "Draw Arc"
    				      :on-clicked (callback (w e d)
    						    (let* ((p (random-point 10 10 480 480))
    							   (radius (rnd 10 40))
    							   (col1 (random-color))
    							   (col2 (random-color)))
    						      (mk-primitive (fm-other :draw) :arc
    								    :p (c-in p)
    								    :radius (c-in radius)
    								    :rgb (rgb? col1)
    								    :fill-rgb (rgb? col2)
    								    :alpha (alpha? 1)
    								    :filled t
    								    :draggable t
    								    :selectable t))))
    			   )))))))
;;;
;;; a test-drawing tab
;;;
(defmodel test-drawing (notebook)
  ()
  (:default-initargs
      :tab-labels (list "Cairo")
    :kids (kids-list?
       (make-instance 'test-cairo-drawing))))
(defparameter *da* nil)
(defun test-cairo-drawing ()
  (setf *da* (first (kids (first (kids (start-win 'test-cairo-drawing)))))))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing.lisp	2008/04/13 10:59:21	1.1
(in-package :test-gtk)
;;;
;;; auxiliary color funcs
;;;
(defun highlight-col (rgb)
  (mapcar #'(lambda (val) (min 1 (+ val .3))) rgb))
(defun select-col (rgb)
  (mapcar #'(lambda (val) (max 0 (- val .3))) rgb))
(defmacro rgb? (rgb)
  (with-gensyms (col)
    `(c?
       (let ((,col ,rgb))
    (cond
      ((mouse-over-p self) (highlight-col ,col))
      ((selected-p self) (select-col ,col))
      (t ,col))))))
(defmacro alpha? (alpha)
  (with-gensyms (a)
    `(c? (let ((,a ,alpha))
       (cond
         ((dragged-p self) .3)
         (t ,a))))))
;;;
;;; random generators
;;;
(defun rnd (min max)
  (+ min (random max)))
(defun random-point (min-x min-y max-x max-y)
  (2d:v (rnd min-x max-x) (rnd min-y max-y)))
(defun random-color ()
  (loop for i from 0 below 3 collect (random 1.0)))
;;;
;;; drag'n'drop test
;;;
(defmodel test-cairo-dragging (hbox)
  ()
  (:default-initargs
      :fill t :expand t
      :kids (kids-list?
         (make-instance 'cairo-drawing-area :md-name :draw :expand t :fill t
    		    :fm-parent *parent*
    		    :width 500 :height 500)
         (mk-vbox
          :kids (kids-list?
    	     (list
    	      (mk-button :label "Draw Box"
    			 :on-clicked (callback (w e d)
    				       (let* ((p1 (random-point 10 10 480 480))
    					      (p2 (2d:v+ p1 (random-point 10 10 40 40)))
    					      (col1 (random-color))
    					      (col2 (random-color)))
    					 (trcx "rect" p1 p2 col1 col2)
    					 (mk-primitive (fm-other :draw) :rectangle
    						       :p1 (c-in p1)
    						       :p2 (c-in p2)
    						       :rgb (rgb? col1)
    						       :fill-rgb (rgb? col2)
    						       :alpha (alpha? 1)
    						       :filled t
    						       :draggable t
    						       :selectable t))))
    	      (mk-button :label "Draw Arc"
    			 :on-clicked (callback (w e d)
    				       (let* ((p (random-point 10 10 480 480))
    					      (radius (rnd 10 40))
    					      (col1 (random-color))
    					      (col2 (random-color)))
    					 (mk-primitive (fm-other :draw) :arc
    						       :p (c-in p)
    						       :radius (c-in radius)
    						       :rgb (rgb? col1)
[88 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing2.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-drawing2.lisp	2008/04/13 10:59:21	1.1
[225 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-entry.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-entry.lisp	2008/04/13 10:59:21	1.1
[294 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.asd	2008/04/13 10:59:21	1.1
[311 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lisp	2008/04/13 10:59:21	1.1
[386 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lpr	2008/04/13 10:59:21	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-gtk.lpr	2008/04/13 10:59:21	1.1
[429 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-layout.lisp	2008/04/13 10:59:22	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-layout.lisp	2008/04/13 10:59:22	1.1
[494 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-menus.lisp	2008/04/13 10:59:23	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-menus.lisp	2008/04/13 10:59:23	1.1
[669 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-textview.lisp	2008/04/13 10:59:23	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-textview.lisp	2008/04/13 10:59:23	1.1
[751 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp	2008/04/13 10:59:23	NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/test-gtk/test-tree-view.lisp	2008/04/13 10:59:23	1.1
[1051 lines skipped]