[mcclim-cvs] CVS mcclim/Examples
ahefner
ahefner at common-lisp.net
Mon Feb 5 03:26:10 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Examples
In directory clnet:/tmp/cvs-serv9975
Added Files:
misc-tests.lisp
Log Message:
Miscellaneous graphical tests. Note that the test "Empty Records 3" is
currently broken. =)
--- /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/02/05 03:26:10 NONE
+++ /project/mcclim/cvsroot/mcclim/Examples/misc-tests.lisp 2007/02/05 03:26:10 1.1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*-
;;; Random McCLIM tests.
;;; Have some subtle stream/graphics/recording behavior which you'd
;;; like to ensure continues to work? Add a test for it here!
;;; (C) Copyright 2006 by Andy Hefner (ahefner at gmail.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-demo)
(defstruct misc-test-item name drawer description)
(define-application-frame misc-tests ()
()
(:panes
(output :application-pane)
(description :application-pane)
(selector :list-pane
:mode :exclusive
:name-key #'misc-test-item-name
:items (list
(make-misc-test-item :name "Empty Records 1"
:drawer 'misc-empty-records-1
:description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically exercises addition of empty children in recompute-extent-for-new-child.")
(make-misc-test-item :name "Empty Records 2"
:drawer 'misc-empty-records-2
:description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This specifically tests addition and deletion of an empty child, and failure may point to recompute-extent-for-new-child or recompute-extent-for-changed-child.")
(make-misc-test-item :name "Empty Records 3"
:drawer 'misc-empty-records-3
:description "Tests the effect of empty output records on their parent's bounding rectangle. If successful, you will see a circle enclosed in a square. The square should tightly fit the circle. If the rectangle extends all the way to the top/left edges of the pane, McCLIM is not handling this correctly. This test creates a new output record, fills it with content, then clears the record contents.")
(make-misc-test-item :name "Empty Borders"
:drawer 'misc-empty-bordering
:description "Tests handling of empty output records by surrounding-output-with-border. If successful, you will see twelve small circles arranged themselves in a larger circle. A likely failure mode will exhibit the circles piled on each other in the upper-left corner of the pane.")
(make-misc-test-item :name "Underlining"
:drawer 'misc-underlining-test
:description "Tests the underlining border style. You should see five lines of text, equally spaced, with the second and third lines having the phrase 'all live' underlined, first by a thick black line then by a thin dashed red line. If the lines are broken or the spacing is irregular, the :move-cursor nil key of surrounding-output-with-border may not have behaved as expected. "))
:value-changed-callback
(lambda (pane item)
(declare (ignore pane))
(let ((output (get-frame-pane *application-frame* 'output))
(description (get-frame-pane *application-frame* 'description)))
(window-clear output)
(window-clear description)
(with-text-style (description (make-text-style :sans-serif :roman :normal))
(write-string (misc-test-item-description item) description))
(funcall (misc-test-item-drawer item) output)))))
(:layouts
(default
(spacing (:thickness 3)
(horizontally ()
(spacing (:thickness 3) (clim-extensions:lowering () selector))
(vertically ()
(spacing (:thickness 3)
(clim-extensions:lowering ()
(scrolling (:width 600 :height 600) output)))
(spacing (:thickness 3)
(clim-extensions:lowering ()
(scrolling (:scroll-bar :vertical :height 200) description)))))))))
(defun misc-empty-records-1 (stream)
(surrounding-output-with-border (stream :shape :rectangle)
(draw-circle* stream 200 200 40)
(with-new-output-record (stream))))
(defun misc-empty-records-2 (stream)
(surrounding-output-with-border (stream :shape :rectangle)
(draw-circle* stream 200 200 40)
(let ((record (with-new-output-record (stream))))
(delete-output-record record (output-record-parent record)))))
(defun misc-empty-records-3 (stream)
(surrounding-output-with-border (stream :shape :rectangle)
(draw-circle* stream 200 200 40)
(let ((record (with-new-output-record (stream)
(draw-circle* stream 50 50 10))))
(clear-output-record record))))
(defun misc-empty-bordering (stream)
(with-room-for-graphics (stream :first-quadrant nil)
(with-text-style (stream (make-text-style :sans-serif :roman :small))
(loop with outer-radius = 180
with inner-radius = 27
with n = 12
for i from 0 below n do
(setf (stream-cursor-position stream)
(values (* outer-radius (sin (* i 2 pi (/ n))))
(* outer-radius (cos (* i 2 pi (/ n))))))
(surrounding-output-with-border (stream :shape :ellipse
:circle t
:min-radius inner-radius
:shadow +gray88+
:shadow-offset 7
:filled t
:line-thickness 1
:background +gray50+
:outline-ink +gray40+)
;(multiple-value-call #'draw-point* stream (stream-cursor-position stream))
#+NIL (print i stream))))))
(defun misc-underlining-test (stream)
(with-text-family (stream :sans-serif)
(format stream "~&We all live in a yellow subroutine.~%")
(format stream "~&We ")
(surrounding-output-with-border (stream :shape :underline
:line-thickness 2
:move-cursor nil)
(format stream "all live"))
(format stream " in a yellow subroutine.~%")
(format stream "~&We ")
(surrounding-output-with-border (stream :shape :underline
:ink +red+
:line-dashes t
:move-cursor nil)
(format stream "all live"))
(format stream " in a yellow subroutine.~%")
(format stream "~&We all live in a yellow subroutine.~%")
(format stream "~&We all live in a yellow subroutine.~%")))
More information about the Mcclim-cvs
mailing list