Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 123 lines (102 sloc) 5.159 kb
8630194 @kennytilton Moved to github, ported to Linux (almost)
authored
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 (width :initarg :width :accessor width :initform (c-in 20))
43 (activestyle :initarg :activestyle :accessor activestyle :initform (c-in nil))
44 (selectforeground :initarg :selectforeground
45 :accessor selectforeground :initform (c-in "black"))
46 (selectbackground :initarg :selectbackground
47 :accessor selectbackground :initform (c-in nil))
48 (selectmode :initarg :selectmode
49 :accessor selectmode :initform (c-in 'single))
50
51 )
52 (:default-initargs
53 :list-height (c? (max 1 (length (^list-item-keys))))
54 :kids-packing nil
55 :kids (c? (the-kids
56 (mk-listbox :id :list-me
57 :kids (c? (the-kids
58 (mapcar (list-item-factory .parent)
59 (list-item-keys .parent))))
60 :tkfont (c? (tkfont .parent))
61 :width (c? (width .parent))
62 :activestyle (c? (activestyle .parent))
63 :selectforeground (c? (selectforeground .parent))
64 :selectbackground (c? (selectbackground .parent))
65 :selectmode (c? (selectmode .parent))
66 :state (c? (if (enabled .parent) 'normal 'disabled))
67 :takefocus (c? (if (enabled .parent) 1 0))
68 :height (c? (list-height .parent))
69 :packing (c? (format nil "pack ~a -side left -fill both -expand 1" (^path)))
70 :yscrollcommand (c? (when (enabled .parent)
71 (format nil "~a set" (path (nsib))))))
72 (mk-scrollbar :id :vscroll
73 :packing (c?pack-self "-side right -fill y")
74 :command (c? (format nil "~a yview" (path (psib)))))))))
75
76 (defmethod tk-output-selection :after ((self scrolled-list) new-value old-value old-value-boundp)
77 (declare (ignorable old-value old-value-boundp))
78 (trc nil "scrolled-list selection output" self new-value)
79 (when new-value
80 (let ((lb (car (^kids)))
81 (item-no (position new-value (^list-item-keys) :test 'equal)))
82 (trc nil "tk-output selection: lb | item-no | path of lb " lb item-no (path lb))
83
84 (if item-no
85 (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no)
86 (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys))))))
87
88
89 ;--- scroller (of canvas; need to generalize this) ----------
90
91 (defmodel scroller (grid-manager frame)
92 ((canvas :initarg :canvas :accessor canvas :initform nil))
93 (:default-initargs
94 :id :cv-scroller
95 :kids-packing nil
96 :gridding '(:columns ("-weight {1}" "-weight {0}")
97 :rows ("-weight {1}" "-weight {0}"))
98 :kids (c? (the-kids
99 (^canvas)
100 (mk-scrollbar :id :hscroll
101 :orient "horizontal"
102 :gridding "-row 1 -column 0 -sticky we"
103 :command (c? (format nil "~a xview" (path (kid1 .parent)))))
104 (mk-scrollbar :id :vscroll
105 :orient "vertical"
106 :gridding "-row 0 -column 1 -sticky ns"
107 :command (c? (format nil "~a yview" (path (kid1 .parent)))))))))
108
109 (defmacro mk-scroller (&rest iargs)
110 `(make-instance 'scroller
111 :fm-parent self
112 ,@iargs))
113
114 (defmethod initialize-instance :after ((self scroller) &key)
115 ;
116 ; Tk does not do late binding on widget refs, so the canvas cannot mention the scrollbars
117 ; in x/y scrollcommands since the canvas gets made first
118 ;
119 (with-integrity (:client `(:post-make-tk ,self))
120 (setf (xscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :hscroll))))
121 (setf (yscrollcommand (kid1 self)) (format nil "~a set" (path (fm! :vscroll))))))
122
Something went wrong with that request. Please try again.