button.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 ;--- button ----------------------------------------------
  22
  23 (deftk button (commander widget)
  24   ()
  25   (:tk-spec button
  26     -activebackground  -activeforeground  -anchor
  27     -background -bitmap -borderwidth -cursor
  28     -disabledforeground    (tkfont -font) -foreground
  29     -highlightbackground -highlightcolor -highlightthickness -image
  30     (tk-justify -justify)
  31     -padx -pady -relief -repeatdelay
  32     -repeatinterval -takefocus -text -textvariable
  33     -underline -wraplength
  34     -command -compound -default -height -overrelief -state -width)
  35   (:default-initargs
  36       :id (gentemp "B")))
  37
  38
  39
  40 (defmacro mk-button-ex ((text command) &rest initargs)
  41   `(make-instance 'button
  42      :fm-parent *parent*
  43      :text ,text
  44      :on-command (c? (lambda (self)
  45                        (declare (ignorable self))
  46                        ,command))
  47      ,@initargs))
  48
  49 ; --- checkbutton ---------------------------------------------
  50
  51 (deftk radiocheck (commander widget)
  52   ()
  53   (:tk-spec radiocheck
  54     -activebackground  -activeforeground  -anchor
  55     -background -bitmap -borderwidth -compound -cursor
  56     -disabledforeground   (tkfont -font) -foreground
  57     -highlightbackground -highlightcolor -highlightthickness -image
  58     (tk-justify -justify) -padx -pady -relief -takefocus -text -textvariable
  59     -underline -wraplength
  60     -command -height -indicatoron -offrelief
  61     -overrelief -selectcolor -selectimage -state -tristateimage
  62     -tristatevalue (tk-variable -variable) -width))
  63
  64
  65 (deftk checkbutton (radiocheck)
  66   ()
  67   (:tk-spec checkbutton
  68     -offvalue -onvalue)
  69   (:default-initargs
  70       :id (gentemp "CK")
  71     :value (c-in nil)
  72     :tk-variable (c? (^path))
  73     :on-command (lambda (self)
  74                   (setf (^value) (not (^value))))))
  75
  76 (defobserver .value ((self checkbutton))
  77   (tk-format `(:variable ,self) "set ~(~a~) ~a" (path self) (if new-value 1 0)))
  78
  79 ; --- radiobutton -------------------------------------
  80
  81 (deftk radiobutton (radiocheck)
  82   ()
  83   (:tk-spec radiobutton
  84     -value)
  85   (:default-initargs
  86       :id (gentemp "RB")
  87       :tk-variable (c? (path (upper self tk-selector)))
  88       :on-command (lambda (self)
  89                  (setf (selection (upper self tk-selector)) (value self)))))
  90
  91 (defmacro mk-radiobutton-ex ((text value) &rest initargs)
  92   `(make-instance 'radiobutton
  93      :fm-parent *parent*
  94      :text ,text
  95      :value ,value
  96      ,@initargs))