[cells-cvs] CVS cells-gtk3/cells-gtk/test-gtk
phildebrandt
phildebrandt at common-lisp.net
Sun Apr 13 10:59:23 UTC 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]
More information about the Cells-cvs
mailing list