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))