[cells-cvs] CVS cells-gtk/test-gtk
ktilton
ktilton at common-lisp.net
Tue Jan 29 00:00:41 UTC 2008
Update of /project/cells/cvsroot/cells-gtk/test-gtk
In directory clnet:/tmp/cvs-serv9292/test-gtk
Added Files:
cells3-porting-notes.lisp test-addon.lisp test-buttons.lisp
test-dialogs.lisp test-display.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:
--- /project/cells/cvsroot/cells-gtk/test-gtk/cells3-porting-notes.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/cells3-porting-notes.lisp 2008/01/29 00:00:40 1.1
#|
1. TRC is now back in the cells package. pod-utils no longer exports TRC. use pod::trc to get to it.
We could probably just drop TRC from pod-utils.
2. def-c-output is now defobserver. name change only.
3. md-value/.md-value is now value/.value
4. Use :owning option on cell slot to handle things like:
popup
tree-model
|#
(in-package :cells-gtk)
(export '(make-be))
(defun make-be (class &rest args)
(md-awaken (apply 'make-instance class args)))
(defun to-be (x) (md-awaken x))--- /project/cells/cvsroot/cells-gtk/test-gtk/test-addon.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-addon.lisp 2008/01/29 00:00:40 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-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:40 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)
(error 'gtk-continuable-error :text "Oops!")))
(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-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:40 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)
(let ((dialog
(to-be
(mk-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-aupdate t)))))
(setf (text (fm^ :message-response)) (value 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? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib))))))))))))))
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-display.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-display.lisp 2008/01/29 00:00:40 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-gtk/test-gtk/test-entry.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-entry.lisp 2008/01/29 00:00:40 1.1
(in-package :test-gtk)
(defmodel test-entry (vbox)
()
(:default-initargs
:kids (kids-list?
(mk-vbox
:kids (test-entry-1))
(mk-check-button :md-name :cool
:init t
:label "Cool")
(mk-frame
:kids (test-entry-2))
(mk-hbox
:kids (kids-list?
(mk-spin-button :md-name :spin
:init 10)))
(mk-hbox
:kids (kids-list?
(mk-label :text "Entry completion test (press i)")
(mk-entry
:max-length 20
:completion (loop for i from 1 to 10 collect
(format nil "Item ~d" i))))))))
(defun test-entry-1 ()
(c? (the-kids
(mk-label
:expand t :fill t
:markup (c? (with-markup (:font-desc "24")
(with-markup (:foreground :blue
:font-family "Arial"
:font-desc (if (value (fm-other :spin))
(truncate (value (fm-other :spin)))
10))
(value (fm-other :entry)))
(with-markup (:underline :double
:weight :bold
:foreground :red
:font-desc (if (value (fm-other :hscale))
(truncate (value (fm-other :hscale)))
10))
"is")
(with-markup (:strikethrough (value (fm^ :cool)))
"boring")
(with-markup (:strikethrough (not (value (fm^ :cool))))
"cool!")))
:selectable t)
(mk-entry :md-name :entry :auto-aupdate t :init "Testing"))))
(defun test-entry-2 ()
(c? (the-kids
(mk-vbox
:kids (c? (the-kids
(mk-hbox
:kids (kids-list?
(mk-check-button :md-name :sensitive
:label "Sensitive")
(mk-check-button :md-name :visible
:init t
:label "Visible")))
(mk-hscale :md-name :hscale
:visible (c? (value (fm^ :visible)))
:sensitive (c? (value (fm^ :sensitive)))
:expand t :fill t
:min 0 :max 100
:init 10)))))))
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.asd 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.asd 2008/01/29 00:00:40 1.1
(asdf:defsystem :test-gtk
:name "test-gtk"
:depends-on (:cells-gtk)
:serial t
:components
((:file "test-gtk")
(:file "test-layout")
(:file "test-display")
(:file "test-buttons")
(:file "test-entry")
(:file "test-tree-view")
(:file "test-menus")
(:file "test-dialogs")
(:file "test-textview")
(:file "test-addon")
))
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:40 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:40 1.1
(defpackage :test-gtk
(:use :common-lisp :pod :cells :gtk-ffi :cells-gtk)
(:export gtk-demo))
(in-package :test-gtk)
(defvar *test-img-dir*
(make-pathname :name nil :type nil :version nil
:defaults (merge-pathnames
(make-pathname :directory '(:relative :back :back "test-images"))
(parse-namestring *load-truename*))))
(defvar *splash-image*
(make-pathname :name "splash" :type "png"
:defaults *test-img-dir*))
(defvar *small-image*
(make-pathname :name "small" :type "png"
:defaults *test-img-dir*))
(defvar *stock-icon-image*
(make-pathname :name "my-g" :type "png"
:defaults *test-img-dir*))
(defvar *tst-image*
(make-pathname :name "tst" :type "gif"
:defaults *test-img-dir*))
(defmodel test-gtk (gtk-app)
()
(:default-initargs
:title "GTK Testing"
;;:tooltips nil ;;dkwt
;;:tooltips-enable nil ;;dkwt
:icon (namestring *small-image*)
:stock-icons (list (list :my-g (namestring *stock-icon-image*)))
:position :center
:splash-screen-image (namestring *splash-image*)
:width 650 :height 550
:kids (c? (the-kids
(let ((tabs '("Buttons"
"Display"
"Layout"
"Menus"
"Textview"
"Dialogs"
"Addon"
"Entry"
"Tree-view"
)))
(list (mk-notebook
:tab-labels tabs
:kids (c? (the-kids
(loop for test-name in tabs
collect (make-instance
(intern (string-upcase
(format nil "test-~a" test-name))
:test-gtk)
:fm-parent *parent*)))))))))))
(defun test-gtk-app ()
(start-app 'test-gtk)
#+clisp (ext:exit))
(defun gtk-demo (&optional dbg)
(ukt:test-prep)
(cells-gtk-init)
(cells-gtk:start-app 'test-gtk::test-gtk :debug dbg))
;(ext:saveinitmem "test-gtk.mem" :init-function 'test-gtk::test-gtk-app)
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lpr 2008/01/29 00:00:41 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lpr 2008/01/29 00:00:41 1.1
;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
(defpackage :TEST-GTK
(:export #:gtk-demo))
(define-project :name :test-gtk
:modules (list (make-instance 'module :name "test-gtk.lisp")
(make-instance 'module :name "test-layout.lisp")
[35 lines skipped]
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-layout.lisp 2008/01/29 00:00:41 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-layout.lisp 2008/01/29 00:00:41 1.1
[99 lines skipped]
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:41 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:41 1.1
[259 lines skipped]
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-textview.lisp 2008/01/29 00:00:41 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-textview.lisp 2008/01/29 00:00:41 1.1
[341 lines skipped]
--- /project/cells/cvsroot/cells-gtk/test-gtk/test-tree-view.lisp 2008/01/29 00:00:41 NONE
+++ /project/cells/cvsroot/cells-gtk/test-gtk/test-tree-view.lisp 2008/01/29 00:00:41 1.1
[532 lines skipped]
More information about the Cells-cvs
mailing list