[mcclim-cvs] CVS mcclim/Examples
ahefner
ahefner at common-lisp.net
Mon Feb 5 03:25:09 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Examples
In directory clnet:/tmp/cvs-serv9839
Added Files:
bordered-output-examples.lisp
Log Message:
Examples/tests of bordered output.
--- /project/mcclim/cvsroot/mcclim/Examples/bordered-output-examples.lisp 2007/02/05 03:25:09 NONE
+++ /project/mcclim/cvsroot/mcclim/Examples/bordered-output-examples.lisp 2007/02/05 03:25:09 1.1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*-
;;; Test surrounding-output-with-border with various shapes and keywords.
;;; (c) Copyright 2007 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)
(define-presentation-type border-style ())
(define-application-frame bordered-output ()
((shapes :initform (append (reverse climi::*border-types*)
(list
(list :rectangle
:ink +gray80+
:padding 0
:padding-left 24
:line-thickness 4)
(list :rectangle
:ink +gray50+
:line-dashes t)
(list :oval
:ink +white+
:highlight-background +white+
:line-thickness 3)
(list :oval
:line-dashes t)
(list :oval
:ink nil
:background +white+)
(list :underline :ink +red+ :line-thickness 2)
(list :underline :ink +red+ :line-dashes t)
(list :rectangle
:ink +gray50+
:background +white+
:filled t)
(list :oval
:ink +gray60+
:background +gray85+
:filled t)
(list :oval
:ink (make-ihs-color 0.8 1.0 0.5)
:line-thickness 3
:background (make-ihs-color 1.0 0.0 0.5)
;; FIXME, breaks on ovals. =(
;:highlight-background (make-ihs-color 1.5 0.0 0.5)
:shadow-offset 8
:shadow +gray80+
:filled t)
(list :drop-shadow
:ink +black+
:padding 10
:padding-left 20
:background +gray70+
:shadow +gray80+
:shadow-offset 8
:filled t)
(list :rectangle :shadow +grey80+ :background +white+)
(list :rounded
:padding-x 27
:padding-top 17
:padding-bottom 27)
(list :rounded
:line-dashes t)
(list :rounded
:padding 13
:line-thickness 2
:ink +gray70+)
(list :rounded
:padding 13
:line-thickness 2
:shadow +gray80+
:background +white+
:ink +red+)
(list :ellipse
:line-dashes t
:circle t)
(list :ellipse
:line-thickness 2
:outline-ink +red+
:background +white+)
(list :ellipse
:shadow +gray80+
:outline-ink +gray60+
:background +white+)
;; These are just my tests that the literal corner cases of draw-rounded-rectangle*
;; work correctly.
(list :rounded :highlight-background +yellow+
:radius 27 :radius-top 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-left 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-right 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-bottom 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-y 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-x 0 :outline-ink +red+
:background +white+ :shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-right 0 :radius-top 0
:outline-ink +red+ :background +white+
:shadow +gray80+)
(list :rounded :highlight-background +yellow+
:radius 27 :radius-bottom 0 :radius-left 0
:outline-ink +red+ :background +white+
:shadow +gray80+)))
:reader shapes-of))
(:pane
(scrolling (:width 600 :height 700)
(make-pane :application-pane
:end-of-line-action :allow
:end-of-page-action :allow ; Why isn't this working?
:background +gray90+
:name :border-examples
:display-function
(lambda (frame stream)
(format-items (shapes-of frame)
:stream stream
:presentation-type 'border-style
:cell-align-x :center
:cell-align-y :center
:y-spacing 16
:x-spacing 16
:printer
(lambda (shape stream)
(let ((shape-name-style (make-text-style :sans-serif :bold :normal))
(keywords-style (make-text-style :sans-serif :roman :small)))
(flet ((show (stream)
(with-text-style (stream shape-name-style)
(if (listp shape)
(progn
(format stream "~A" (first shape))
(with-text-style (stream keywords-style)
(format stream "~{~% ~W ~W~}" (rest shape))))
(princ shape stream)))))
(if (listp shape)
(apply #'climi::invoke-surrounding-output-with-border
stream #'show (cons :shape shape))
(surrounding-output-with-border (stream :shape shape)
(show stream)))))))
(terpri stream))))))
;;; Define a dummy command, just to get highlighting of the border styles.
(define-bordered-output-command (com-do-nothing)
((style 'border-style :gesture :select))
(declare (ignore style))
#+NIL (clouseau:inspector (stream-output-history *standard-output*)))
More information about the Mcclim-cvs
mailing list