[graphic-forms-cvs] r225 - in trunk: . src/demos src/demos/textedit src/demos/unblocked src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Aug 21 03:03:54 UTC 2006
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
More information about the Graphic-forms-cvs
mailing list