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]