scroll.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
  22 ; --- scroll bars ----------------------------------------
  23
  24 (deftk scrollbar (widget)
  25   ()
  26   (:tk-spec scrollbar
  27     -activebackground -activerelief
  28     -background -borderwidth -command -cursor
  29     -elementborderwidth
  30     -highlightbackground -highlightcolor -highlightthickness
  31     -jump -orient -relief -repeatdelay
  32     -repeatinterval  -takefocus
  33     -troughcolor -width)
  34   (:default-initargs
  35       :id (gentemp "SBAR")))
  36
  37 (deftk scrolled-list (row-mixin frame-selector)
  38   ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil)
  39    (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil)
  40    (list-height :initarg :list-height :accessor list-height :initform nil)
  41    (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9))))
  42   (:default-initargs
  43       :list-height (c? (max 1 (length (^list-item-keys))))
  44     :kids-packing nil
  45       :kids (c? (the-kids
  46                  (mk-listbox :id :list-me
  47                    :kids (c? (the-kids
  48                               (mapcar (list-item-factory .parent)
  49                                 (list-item-keys .parent))))
  50                    :tkfont (c? (tkfont .parent))
  51                    :state (c? (if (enabled .parent) 'normal 'disabled))
  52                    :takefocus (c? (if (enabled .parent) 1 0))
  53                    :height (c? (list-height .parent))
  54                    :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path)))
  55                    :yscrollcommand (c? (when (enabled .parent)
  56                                          (format nil "~a set" (path (nsib))))))
  57                  (mk-scrollbar :id :vscroll
  58                      :packing (c?pack-self "-side right -fill y")
  59                      :command (c? (format nil "~a yview" (path (psib)))))))))
  60
  61 (defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp)
  62   (declare (ignorable old-value old-value-boundp))
  63   (trc nil "scrolled-list selection output" self new-value)
  64   (when new-value
  65     (let ((lb (car (^kids)))
  66           (item-no (position new-value (^list-item-keys) :test 'equal)))
  67       (if item-no
  68           (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no)
  69         (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys))))))
  70
  71
  72 ;--- scroller (of canvas; need to generalize this) ----------
  73
  74 (defmodel scroller (grid-manager frame)
  75   ((canvas :initarg :canvas :accessor canvas :initform nil))
  76   (:default-initargs
  77       :id :cv-scroller
  78     :kids-packing nil
  79     :gridding '(:columns ("-weight {1}" "-weight {0}")
  80                  :rows ("-weight {1}" "-weight {0}"))
  81     :kids (c? (the-kids
  82                (^canvas)
  83                (mk-scrollbar :id :hscroll
  84                  :orient "horizontal"
  85                  :gridding "-row 1 -column 0 -sticky we"
  86                  :command (c? (format nil "~a xview" (path (kid1 .parent)))))
  87                (mk-scrollbar :id :vscroll
  88                  :orient "vertical"
  89                  :gridding "-row 0 -column 1 -sticky ns"
  90                  :command (c? (format nil "~a yview" (path (kid1 .parent)))))))))
  91
  92 (defmacro mk-scroller (&rest iargs)
  93   `(make-instance 'scroller
  94      :fm-parent self
  95      ,@iargs))
  96
  97 (defmethod initialize-instance :after ((self scroller) &key)
  98   ;
  99   ; Tk does not do late binding on widget refs, so the canvas cannot mention the scrollbars
 100   ; in x/y scrollcommands since the canvas gets made first
 101   ;
 102   (with-integrity (:client `(:post-make-tk ,self))
 103     (setf (xscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :hscroll))))
 104     (setf (yscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :vscroll))))))
 105