Author: junrue Date: Sun Aug 20 23:03:53 2006 New Revision: 225
Added: trunk/src/demos/demo-utils.lisp trunk/src/demos/textedit/textedit.ico (contents, props changed) trunk/src/demos/unblocked/unblocked.ico (contents, props changed) Modified: trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-document.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: fixed bug in extract-foreign-strings function; removal of Cells usage from textedit demo; implemented shared about dialog for demo programs
Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 20 23:03:53 2006 @@ -61,13 +61,16 @@ :components ((:module "demos" :components - ((:module "textedit" + ((:file "demo-utils") + (:module "textedit" :serial t + :depends-on ("demo-utils") :components ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" :serial t + :depends-on ("demo-utils") :components ((:file "tiles") (:file "unblocked-model")
Added: trunk/src/demos/demo-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/demo-utils.lisp Sun Aug 20 23:03:53 2006 @@ -0,0 +1,96 @@ +;;;; +;;;; demo-utils.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defclass demo-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp demo-about-dialog-events) (dlg gfw:dialog)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-demo (owner image-path title desc) + (let* ((image (make-instance 'gfg:image :file image-path)) + (dlg (make-instance 'gfw:dialog :owner owner + :dispatcher (make-instance 'demo-about-dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 8) + :style '(:owner-modal) + :text title)) + (label (make-instance 'gfw:label :parent dlg)) + (text-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 2 + :style '(:vertical)) + :parent dlg)) + (line1 (make-instance 'gfw:label + :parent text-panel + :text desc)) + (line2 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line3 (make-instance 'gfw:label + :parent text-panel + :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + (line4 (make-instance 'gfw:label + :parent text-panel + :text "All Rights Reserved.")) + (line5 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line6 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (btn-panel (make-instance 'gfw:panel + :parent dlg + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 0 + :style '(:vertical :normalize)))) + (close-btn (make-instance 'gfw:button + :callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfs:dispose dlg)) + :style '(:cancel-button) + :text "Close" + :parent btn-panel))) + (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) + (unwind-protect + (gfg:with-image-transparency (image (gfs:make-point)) + (setf (gfw:image label) image)) + (gfs:dispose image)) + (gfw:pack dlg) + (gfw:center-on-owner dlg) + (gfw:show dlg t)))
Modified: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-document.lisp (original) +++ trunk/src/demos/textedit/textedit-document.lisp Sun Aug 20 23:03:53 2006 @@ -33,18 +33,13 @@
(in-package :graphic-forms.uitoolkit.tests)
-(cells:defmodel textedit-document () - ((content-replaced - :cell :ephemeral - :accessor content-replaced - :initform (cells:c-in nil)) - (content-modified - :cell :ephemeral - :accessor content-modified - :initform (cells:c-in nil)) +(defclass textedit-document () + ((content-modified + :accessor content-modified-of + :initform nil) (file-path - :accessor file-path - :initform (cells:c-in nil)))) + :accessor file-path-of + :initform nil)))
(defvar *textedit-model* (make-instance 'textedit-document))
@@ -57,7 +52,7 @@ (if (zerop (length line)) (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline))) (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline)))))) - (setf (content-replaced *textedit-model*) buffer))) + buffer))
(defun save-textedit-doc (path buffer) (with-open-file (output path :direction :output :if-exists :supersede)
Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 20 23:03:53 2006 @@ -39,16 +39,21 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*")))
+(defvar *textedit-new-title* "new file - TextEdit") + + (defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) + (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0)))
(defun textedit-file-new (disp item) (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) - (setf (file-path *textedit-model*) nil))) + (setf (file-path-of *textedit-model*) nil) + (setf (gfw:text *textedit-win*) *textedit-new-title*)))
(defun textedit-file-open (disp item) (declare (ignore disp item)) @@ -57,14 +62,16 @@ paths :filters *textedit-file-filters*) (when paths - (load-textedit-doc (first paths)) - (setf (file-path *textedit-model*) (namestring (first paths)))))) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (setf (file-path-of *textedit-model*) (namestring (first paths))) + (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths))))))
(defun textedit-file-save (disp item) - (if (file-path *textedit-model*) - (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) + (if (file-path-of *textedit-model*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) (textedit-file-save-as disp item)) - (setf (gfw:text-modified-p *textedit-control*) nil)) + (if (file-path-of *textedit-model*) + (setf (gfw:text-modified-p *textedit-control*) nil)))
(defun textedit-file-save-as (disp item) (declare (ignore disp item)) @@ -75,8 +82,9 @@ :text "Save As") (when paths (save-textedit-doc (first paths) (gfw:text *textedit-control*)) - (setf (file-path *textedit-model*) (namestring (first paths))) - (setf (gfw:text-modified-p *textedit-control*) nil)))) + (setf (file-path-of *textedit-model*) (namestring (first paths)) + (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)) + (gfw:text-modified-p *textedit-control*) nil))))
(defun textedit-file-quit (disp item) (declare (ignore disp item)) @@ -143,80 +151,11 @@ (declare (ignore window)) (textedit-file-quit disp nil))
-(defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-textedit (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *textedit-win* - :dispatcher (make-instance 'textedit-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About TextEdit"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "TextEdit version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) - -(cells:defobserver content-replaced ((self textedit-document)) - (if *textedit-control* - (setf (gfw:text *textedit-control*) (content-replaced self)))) - -(cells:defobserver content-modified ((self textedit-document))) - -(cells:defobserver file-path ((self textedit-document)) - (if *textedit-win* - (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self))) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5")))
(defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu @@ -252,9 +191,11 @@ :auto-vscroll :vertical-scrollbar :want-return))) - (setf (gfw:menu-bar *textedit-win*) menubar) - (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit") + (setf (gfw:menu-bar *textedit-win*) menubar + (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500) + (gfw:text *textedit-win*) *textedit-new-title*) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) + (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) (gfw:show *textedit-win* t)))
(defun textedit ()
Added: trunk/src/demos/textedit/textedit.ico ============================================================================== Binary file. No diff available.
Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 20 23:03:53 2006 @@ -94,79 +94,21 @@ (declare (ignore timer)) (update-panel *tiles-panel*))
-(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-unblocked (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *unblocked-win* - :dispatcher (make-instance 'unblocked-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About UnBlocked"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "UnBlocked version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5")))
(defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "&New" :callback #'new-unblocked) - (:item "&Restart" :callback #'restart-unblocked) - (:item "Reveal &Move" :callback #'reveal-unblocked) - (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked))) + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))) (:item "&Help" - :submenu ((:item "&About" :callback #'about-unblocked)))))) + :submenu ((:item "&About UnBlocked" :callback #'about-unblocked)))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) @@ -189,14 +131,16 @@ :style '(:border) :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) - (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (setf (gfw:text *unblocked-win*) "UnBlocked")
(setf (gfw:resizable-p *unblocked-win*) nil) (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size) - (setf (gfw:maximum-size *unblocked-win*) size)) + (setf (gfw:minimum-size *unblocked-win*) size + (gfw:maximum-size *unblocked-win*) size))
(new-unblocked nil nil) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) + (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t)))
(defun unblocked ()
Added: trunk/src/demos/unblocked/unblocked.ico ============================================================================== Binary file. No diff available.
Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Aug 20 23:03:53 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory