/[cells]/Celtk/label.lisp
ViewVC logotype

Contents of /Celtk/label.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Jan 29 06:48:41 2007 UTC (7 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +9 -0 lines
Rough Tile support and first primitive QuickTimeTcl stuff.
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 #|
3
4 Celtk -- Cells, Tcl, and Tk
5
6 Copyright (C) 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :Celtk)
20
21 (deftk label (widget)
22 ()
23 (:tk-spec label
24 -activebackground -activeforeground -anchor
25 -background -bitmap -borderwidth -compound -cursor
26 -disabledforeground (tkfont -font) -foreground
27 -highlightbackground -highlightcolor -highlightthickness -image
28 (tk-justify -justify)
29 -padx -pady -relief -takefocus -text -textvariable -underline
30 -height -state -width -wraplength)
31 (:default-initargs
32 :id (gentemp "LBL")))
33
34 ;;; --- images -------------------------------------------------------
35
36 (defobserver image-files ()
37 (loop for (name file-pathname) in (set-difference new-value old-value :key 'car)
38 do (tk-format `(:pre-make-tk ,self)
39 "image create photo ~(~a.~a~) -file {~a} -height ~a -width ~a"
40 (^path) name (namestring file-pathname)
41 (^height)(^width))))
42
43 ;--------------------------------------------------------------------------
44
45 (deftk message (widget)
46 ()
47 (:tk-spec message
48 -activebackground -activeforeground -anchor
49 -background -bitmap -borderwidth -compound -cursor
50 -disabledforeground (tkfont -font) -foreground
51 -highlightbackground -highlightcolor -highlightthickness -image
52 (tk-justify -justify)
53 -padx -pady -relief
54 -takefocus -text -textvariable
55 -underline -wraplength -width -state -height)
56 (:default-initargs
57 :id (gentemp "MSG")))
58

  ViewVC Help
Powered by ViewVC 1.1.5