multichoice.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 scale (commander widget)
  22   ()
  23   (:tk-spec scale
  24     -activestyle  -background -borderwidth -cursor
  25     (tkfont -font) -foreground
  26     -highlightbackground -highlightcolor -highlightthickness
  27     -relief -state
  28     -takefocus -troughcolor -width -xscrollcommand -yscrollcommand
  29     -orient -repeatdelay
  30     -repeatinterval
  31     -bigincrement -command -digits -from
  32     (-tk-label -label) (-tk-length -length) -resolution
  33     -showvalue -sliderlength -sliderrelief
  34     -tickinterval -to (-tk-variable nil))
  35   (:default-initargs
  36       :id (gentemp "SCL")
  37       :value (c-in nil)
  38     :tk-variable nil ;;(c? (^path))
  39     :xscrollcommand (c-in nil)
  40     :yscrollcommand (c-in nil)
  41     :on-command (lambda (self value)
  42                   ;; (trc "hi scale" self value)
  43                   (setf (^value) (parse-integer value :junk-allowed t)))))
  44
  45 (defmethod make-tk-instance :after ((self scale))
  46   "Still necessary?"
  47   (when (^value)
  48     (tk-format `(:variable ,self) "~a set ~a"  (^path) (^value))))
  49
  50 ; --- listbox --------------------------------------------------------------
  51
  52 (deftk listbox (widget)
  53   ()
  54   (:tk-spec listbox
  55     -activestyle  -background -borderwidth -cursor
  56     -disabledforeground -exportselection (tkfont -font) -foreground
  57     -height -highlightbackground -highlightcolor -highlightthickness
  58     -listvariable -relief -selectmode -selectbackground
  59     -selectborderwidth -selectforeground -setgrid -state
  60     -takefocus -width -xscrollcommand -yscrollcommand)
  61   (:default-initargs
  62       :id (gentemp "LBX")
  63     :tile? nil
  64     :xscrollcommand (c-in nil)
  65     :yscrollcommand (c-in nil)
  66     :event-handler (lambda (self xe)
  67                      (case (tk-event-type (xsv type xe))
  68                        (:virtualevent
  69                         (trc ":virtualevent" (xsv name xe))
  70                         (case (read-from-string (string-upcase (xsv name xe)))
  71                           (ListboxSelect
  72                            (let ((selection (parse-integer (tk-eval "~a curselection" (^path)))))
  73                              (setf (selection (tk-selector self))
  74                                (value (elt (^kids) selection)))))))))))
  75
  76 (defmodel listbox-item (tk-object)
  77   ((item-text :initarg :item-text :accessor item-text
  78      :initform (c? (format nil "~a" (^value))))))
  79
  80 (defmethod make-tk-instance ((self listbox-item))
  81   (trc nil "make-tk-instance listbox-item insert" self)
  82   (tk-format `(:post-make-tk ,self) "~A insert end ~s" (path .parent) (^item-text)))
  83
  84 (defobserver .kids ((self listbox))
  85   (when old-value
  86     (tk-format `(:destroy ,self) "~A delete ~a ~a"
  87       (^path)
  88       0 (1- (length old-value)))))
  89
  90 ; --- spinbox ---------------------------------------------
  91
  92 (deftk spinbox (commander widget)
  93   ((initial-value :initform nil :initarg :initial-value :reader initial-value))
  94   (:tk-spec spinbox
  95     -activebackground -background -borderwidth -cursor
  96     -buttonbackground -buttoncursor -buttondownrelief -buttonuprelief
  97     -disabledforeground  -disabledbackground -exportselection
  98     (tkfont -font) (spin-format -format) -foreground -from
  99     -command -invalidcommand -increment
 100     -highlightbackground -highlightcolor -highlightthickness
 101     -insertbackground -insertborderwidth -insertofftime -insertontime
 102     -insertwidth -jump (tk-justify -justify) -orient
 103     -padx -pady -relief -repeatdelay
 104     -repeatinterval -selectbackground -selectborderwidth -selectforeground
 105     -readonlybackground -state -to
 106     -takefocus -text -textvariable
 107     -troughcolor -underline -xscrollcommand
 108     -validate -validatecommand (tk-values -values) -width -wrap)
 109   (:default-initargs
 110       :value (c-in nil)
 111       :id (gentemp "SPN")
 112       :textVariable (c? (^path))
 113     :tile? nil
 114     :xscrollcommand (c-in nil)
 115     :command (c? (format nil "do-on-command ~a %s" (^path)))
 116     :on-command (c? (lambda (self text)
 117                       (setf (^value) text)))))
 118
 119 (defobserver .value ((self spinbox))
 120   (when new-value
 121     (tk-format `(:variable ,self) "set ~a ~a" (^path) (tk-send-value new-value))))
 122
 123 (defobserver initial-value ((self spinbox))
 124   (when new-value
 125     (setf (^value) new-value)))
 126
 127