[graphic-forms-cvs] r178 - in trunk: . src/demos/textedit src/demos/unblocked src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Jul 5 19:37:19 UTC 2006
Author: junrue
Date: Wed Jul 5 15:37:18 2006
New Revision: 178
Added:
trunk/src/demos/textedit/
trunk/src/demos/textedit/about.bmp (contents, props changed)
trunk/src/demos/textedit/textedit-window.lisp
Modified:
trunk/graphic-forms-tests.asd
trunk/src/demos/unblocked/tiles-panel.lisp
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/uitoolkit/widgets/heap-layout.lisp
Log:
started new demo called textedit
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Wed Jul 5 15:37:18 2006
@@ -41,6 +41,7 @@
#:run-image-tester
#:run-layout-tester
#:run-windlg
+ #:textedit
#:unblocked))
(print "Graphic-Forms UI Toolkit Tests")
@@ -58,7 +59,10 @@
:components
((:module "demos"
:components
- ((:module "unblocked"
+ ((:module "textedit"
+ :components
+ ((:file "textedit-window")))
+ (:module "unblocked"
:components
((:file "tiles")
(:file "unblocked-model")
Added: trunk/src/demos/textedit/about.bmp
==============================================================================
Binary file. No diff available.
Added: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- (empty file)
+++ trunk/src/demos/textedit/textedit-window.lisp Wed Jul 5 15:37:18 2006
@@ -0,0 +1,172 @@
+;;;;
+;;;; textedit-window.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)
+
+(defvar *textedit-control* nil)
+(defvar *textedit-win* nil)
+(defvar *textedit-startup-dir* nil)
+
+(defun new-textedit-doc (disp item time rect)
+ (declare (ignore disp item time rect))
+ (if *textedit-control*
+ (setf (gfw:text *textedit-control*) "")))
+
+(defun quit-textedit (disp item time rect)
+ (declare (ignore disp item time rect))
+ (setf *textedit-control* nil)
+ (gfs:dispose *textedit-win*)
+ (setf *textedit-win* nil)
+ (gfw:shutdown 0))
+
+(defclass textedit-win-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((disp textedit-win-events) window time)
+ (declare (ignore window time))
+ (quit-textedit disp nil nil nil))
+
+(defmethod gfw:event-focus-gain ((self textedit-win-events) window time)
+ (declare (ignore window time))
+ (if *textedit-control*
+ (gfw:give-focus *textedit-control*)))
+
+(defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time)
+ (declare (ignore time))
+ (call-next-method)
+ (gfs:dispose dlg))
+
+(defun about-textedit (disp item time rect)
+ (declare (ignore disp item time rect))
+ (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*)))
+ (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 time rect)
+ (declare (ignore disp btn time rect))
+ (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)))
+
+(defun textedit-startup ()
+#+clisp
+ (setf *textedit-startup-dir* (ext:cd))
+#+lispworks
+ (setf *textedit-startup-dir* (hcl:get-working-directory))
+ (let ((menubar (gfw:defmenu ((:item "&File"
+ :submenu ((:item "&New" :callback #'new-textedit-doc)
+ (:item "&Open...")
+ (:item "&Save")
+ (:item "Save &As...")
+ (:item "" :separator)
+ (:item "E&xit" :callback #'quit-textedit)))
+ (:item "&Edit"
+ :submenu ((:item "&Undo")
+ (:item "" :separator)
+ (:item "Cu&t")
+ (:item "&Copy")
+ (:item "&Paste")
+ (:item "De&lete")
+ (:item "" :separator)
+ (:item "&Find...")
+ (:item "Find &Next")
+ (:item "&Replace...")
+ (:item "&Go To...")
+ (:item "" :separator)
+ (:item "Select &All")))
+ (:item "F&ormat"
+ :submenu ((:item "&Font...")
+ (:item "&Word Wrap")))
+ (:item "&Help"
+ :submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
+ (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)
+ :layout (make-instance 'gfw:heap-layout)
+ :style '(:frame)))
+ (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win*
+ :style '(:multi-line
+ :auto-hscroll :auto-vscroll
+ :horizontal-scrollbar
+ :vertical-scrollbar
+ :want-return)))
+ (setf (gfw:menu-bar *textedit-win*) menubar)
+ (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500))
+ (gfw:show *textedit-win* t)))
+
+(defun textedit ()
+ (gfw:startup "TextEdit" #'textedit-startup))
Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp (original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp Wed Jul 5 15:37:18 2006
@@ -89,9 +89,10 @@
(loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp"
"green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp")
do (let ((image (make-instance 'gfg:image)))
- (gfg:load image (complete-pathname (concatenate 'string
- "src/demos/unblocked/"
- filename)))
+ (gfg:load image (merge-pathnames (concatenate 'string
+ "src/demos/unblocked/"
+ filename)
+ (unblocked-startup-dir)))
(setf (gethash kind table) image)
(incf kind)))))
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Jul 5 15:37:18 2006
@@ -43,8 +43,8 @@
(defvar *tiles-panel* nil)
(defvar *unblocked-win* nil)
-(defun complete-pathname (path-segment)
- (merge-pathnames path-segment *unblocked-startup-dir*))
+(defun unblocked-startup-dir ()
+ *unblocked-startup-dir*)
(defun get-tiles-panel ()
*tiles-panel*)
@@ -107,7 +107,7 @@
(defun about-unblocked (disp item time rect)
(declare (ignore disp item time rect))
- (let* ((image (make-instance 'gfg:image :file (complete-pathname "src/demos/unblocked/about.bmp")))
+ (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*)))
(dlg (make-instance 'gfw:dialog :owner *unblocked-win*
:dispatcher (make-instance 'unblocked-about-dialog-events)
:layout (make-instance 'gfw:flow-layout
@@ -124,7 +124,7 @@
:parent dlg))
(line1 (make-instance 'gfw:label
:parent text-panel
- :text "UnBlocked version 0.4"))
+ :text "UnBlocked version 0.5"))
(line2 (make-instance 'gfw:label
:parent text-panel
:text " "))
@@ -160,9 +160,6 @@
(gfs:dispose image))
(gfw:pack dlg)
(gfw:center-on-owner dlg)
- ;; FIXME: Close button not getting initial focus; looks like
- ;; labels or panels are getting it, because I can tab to the
- ;; button with enough tabs
(gfw:show dlg t)))
(defun unblocked-startup ()
Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/heap-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/heap-layout.lisp Wed Jul 5 15:37:18 2006
@@ -74,6 +74,8 @@
(top (top-child-of self)))
(when (layout-p container)
(setf kids (compute-layout self container width-hint height-hint))
+ (unless top
+ (setf top (car (first kids))))
(setf hdwp (gfs::begin-defer-window-pos (length kids)))
(loop for k in kids
do (let* ((rect (cdr k))
More information about the Graphic-forms-cvs
mailing list