label.lisp

   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