| 560af5c5 |
1 | ;; Common Lisp bindings for GTK+ v2.0 |
| 2 | ;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no> |
| 3 | ;; |
| 4 | ;; This library is free software; you can redistribute it and/or |
| 5 | ;; modify it under the terms of the GNU Lesser General Public |
| 6 | ;; License as published by the Free Software Foundation; either |
| 7 | ;; version 2 of the License, or (at your option) any later version. |
| 8 | ;; |
| 9 | ;; This library is distributed in the hope that it will be useful, |
| 10 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 11 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 12 | ;; Lesser General Public License for more details. |
| 13 | ;; |
| 14 | ;; You should have received a copy of the GNU Lesser General Public |
| 15 | ;; License along with this library; if not, write to the Free Software |
| 16 | ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
| 17 | |
| 18 | ;; $Id: testgtk.lisp,v 1.1 2000-08-14 16:44:26 espen Exp $ |
| 19 | |
| 20 | |
| 21 | (use-package "GTK") |
| 22 | |
| 23 | (defmacro define-test-window (name title &body body) |
| 24 | `(let ((window nil)) |
| 25 | (defun ,name () |
| 26 | (unless window |
| 27 | (setq window (window-new :toplevel)) |
| 28 | (signal-connect |
| 29 | window 'destroy #'(lambda () (widget-destroyed window))) |
| 30 | (setf (window-title window) ,title) |
| 31 | (setf (container-border-width window) 0) |
| 32 | ,@body) |
| 33 | |
| 34 | (if (not (widget-visible-p window)) |
| 35 | (widget-show-all window) |
| 36 | (widget-destroy window))))) |
| 37 | |
| 38 | |
| 39 | (defmacro define-test-dialog (name title &body body) |
| 40 | `(let ((window nil)) |
| 41 | (defun ,name () |
| 42 | (unless window |
| 43 | (setq window (dialog-new)) |
| 44 | (signal-connect |
| 45 | window 'destroy #'(lambda () (widget-destroyed window))) |
| 46 | (setf (window-title window) ,title) |
| 47 | (setf (container-border-width window) 0) |
| 48 | (let ((main-box (vbox-new nil 0)) |
| 49 | (action-area (dialog-action-area window))) |
| 50 | (box-pack-start (dialog-vbox window) main-box t t 0) |
| 51 | ,@body)) |
| 52 | |
| 53 | (if (not (widget-visible-p window)) |
| 54 | (widget-show-all window) |
| 55 | (widget-destroy window))))) |
| 56 | |
| 57 | |
| 58 | (defmacro define-standard-dialog (name title &body body) |
| 59 | `(define-test-dialog ,name ,title |
| 60 | (let ((close-button (button-new "close"))) |
| 61 | (signal-connect close-button 'clicked #'widget-destroy :object window) |
| 62 | (setf (widget-can-default-p close-button) t) |
| 63 | (box-pack-start action-area close-button t t 0) |
| 64 | (widget-grab-default close-button) |
| 65 | ,@body))) |
| 66 | |
| 67 | |
| 68 | (defun build-option-menu (items history) |
| 69 | (let ((option-menu (option-menu-new)) |
| 70 | (menu (menu-new))) |
| 71 | (labels ((create-menu (items i group) |
| 72 | (when items |
| 73 | (let* ((item (first items)) |
| 74 | (menu-item (radio-menu-item-new group (first item)))) |
| 75 | (signal-connect |
| 76 | menu-item 'activate |
| 77 | #'(lambda () |
| 78 | (when (widget-mapped-p menu-item) |
| 79 | (funcall (second item))))) |
| 80 | |
| 81 | (menu-append menu menu-item) |
| 82 | (when (= i history) |
| 83 | (setf (check-menu-item-active-p menu-item) t)) |
| 84 | (widget-show menu-item) |
| 85 | (create-menu |
| 86 | (rest items) (1+ i) (radio-menu-item-group menu-item)))))) |
| 87 | (create-menu items 0 nil)) |
| 88 | (setf (option-menu-menu option-menu) menu) |
| 89 | (setf (option-menu-history option-menu) history) |
| 90 | option-menu)) |
| 91 | |
| 92 | |
| 93 | |
| 94 | ;;; Pixmaps used in some of the tests |
| 95 | |
| 96 | (defvar gtk-mini-xpm |
| 97 | '("15 20 17 1" |
| 98 | " c None" |
| 99 | ". c #14121F" |
| 100 | "+ c #278828" |
| 101 | "@ c #9B3334" |
| 102 | "# c #284C72" |
| 103 | "$ c #24692A" |
| 104 | "% c #69282E" |
| 105 | "& c #37C539" |
| 106 | "* c #1D2F4D" |
| 107 | "= c #6D7076" |
| 108 | "- c #7D8482" |
| 109 | "; c #E24A49" |
| 110 | "> c #515357" |
| 111 | ", c #9B9C9B" |
| 112 | "' c #2FA232" |
| 113 | ") c #3CE23D" |
| 114 | "! c #3B6CCB" |
| 115 | " " |
| 116 | " ***> " |
| 117 | " >.*!!!* " |
| 118 | " ***....#*= " |
| 119 | " *!*.!!!**!!# " |
| 120 | " .!!#*!#*!!!!# " |
| 121 | " @%#!.##.*!!$& " |
| 122 | " @;%*!*.#!#')) " |
| 123 | " @;;@%!!*$&)'' " |
| 124 | " @%.%@%$'&)$+' " |
| 125 | " @;...@$'*'*)+ " |
| 126 | " @;%..@$+*.')$ " |
| 127 | " @;%%;;$+..$)# " |
| 128 | " @;%%;@$$$'.$# " |
| 129 | " %;@@;;$$+))&* " |
| 130 | " %;;;@+$&)&* " |
| 131 | " %;;@'))+> " |
| 132 | " %;@'&# " |
| 133 | " >%$$ " |
| 134 | " >= ")) |
| 135 | |
| 136 | (defvar book-closed-xpm |
| 137 | '("16 16 6 1" |
| 138 | " c None s None" |
| 139 | ". c black" |
| 140 | "X c red" |
| 141 | "o c yellow" |
| 142 | "O c #808080" |
| 143 | "# c white" |
| 144 | " " |
| 145 | " .. " |
| 146 | " ..XX. " |
| 147 | " ..XXXXX. " |
| 148 | " ..XXXXXXXX. " |
| 149 | ".ooXXXXXXXXX. " |
| 150 | "..ooXXXXXXXXX. " |
| 151 | ".X.ooXXXXXXXXX. " |
| 152 | ".XX.ooXXXXXX.. " |
| 153 | " .XX.ooXXX..#O " |
| 154 | " .XX.oo..##OO. " |
| 155 | " .XX..##OO.. " |
| 156 | " .X.#OO.. " |
| 157 | " ..O.. " |
| 158 | " .. " |
| 159 | " ")) |
| 160 | |
| 161 | (defvar mini-page-xpm |
| 162 | '("16 16 4 1" |
| 163 | " c None s None" |
| 164 | ". c black" |
| 165 | "X c white" |
| 166 | "o c #808080" |
| 167 | " " |
| 168 | " ....... " |
| 169 | " .XXXXX.. " |
| 170 | " .XoooX.X. " |
| 171 | " .XXXXX.... " |
| 172 | " .XooooXoo.o " |
| 173 | " .XXXXXXXX.o " |
| 174 | " .XooooooX.o " |
| 175 | " .XXXXXXXX.o " |
| 176 | " .XooooooX.o " |
| 177 | " .XXXXXXXX.o " |
| 178 | " .XooooooX.o " |
| 179 | " .XXXXXXXX.o " |
| 180 | " ..........o " |
| 181 | " oooooooooo " |
| 182 | " ")) |
| 183 | |
| 184 | (defvar book-open-xpm |
| 185 | '("16 16 4 1" |
| 186 | " c None s None" |
| 187 | ". c black" |
| 188 | "X c #808080" |
| 189 | "o c white" |
| 190 | " " |
| 191 | " .. " |
| 192 | " .Xo. ... " |
| 193 | " .Xoo. ..oo. " |
| 194 | " .Xooo.Xooo... " |
| 195 | " .Xooo.oooo.X. " |
| 196 | " .Xooo.Xooo.X. " |
| 197 | " .Xooo.oooo.X. " |
| 198 | " .Xooo.Xooo.X. " |
| 199 | " .Xooo.oooo.X. " |
| 200 | " .Xoo.Xoo..X. " |
| 201 | " .Xo.o..ooX. " |
| 202 | " .X..XXXXX. " |
| 203 | " ..X....... " |
| 204 | " .. " |
| 205 | " ")) |
| 206 | |
| 207 | |
| 208 | |
| 209 | ;;; Button box |
| 210 | |
| 211 | (defun create-bbox (class title spacing child-w child-h layout) |
| 212 | (let* ((frame (make-instance 'frame :title title)) |
| 213 | (bbox (make-instance 'class |
| 214 | :border-width 5 |
| 215 | :layout layout |
| 216 | :spacing spacing |
| 217 | :childrent |
| 218 | (list |
| 219 | (make-instance 'button :label "OK") |
| 220 | (make-instance 'button :label "Cancel") |
| 221 | (make-instance 'button :label "Help")) |
| 222 | :parent frame))) |
| 223 | (setf (button-box-child-size bbox) (vector child-w child-h)) |
| 224 | frame)) |
| 225 | |
| 226 | |
| 227 | (define-test-window create-button-box "Button Boxes" |
| 228 | (setf (container-border-width window) 10) |
| 229 | (let ((main-box (vbox-new nil 0))) |
| 230 | (let ((frame (frame-new "Horizontal Button Boxes")) |
| 231 | (box (vbox-new nil 0))) |
| 232 | (container-add window main-box) |
| 233 | (box-pack-start main-box frame t t 10) |
| 234 | (setf (container-border-width box) 10) |
| 235 | (container-add frame box) |
| 236 | (box-pack-start |
| 237 | box (create-bbox #'hbutton-box-new "Spread" 40 85 20 :spread) t t 0) |
| 238 | (box-pack-start |
| 239 | box (create-bbox #'hbutton-box-new "Edge" 40 85 20 :edge) t t 0) |
| 240 | (box-pack-start |
| 241 | box (create-bbox #'hbutton-box-new "Start" 40 85 20 :start) t t 0) |
| 242 | (box-pack-start |
| 243 | box (create-bbox #'hbutton-box-new "End" 40 85 20 :end) t t 0)) |
| 244 | |
| 245 | (let ((frame (frame-new "Vertical Button Boxes")) |
| 246 | (box (hbox-new nil 0))) |
| 247 | (box-pack-start main-box frame t t 10) |
| 248 | (setf (container-border-width box) 10) |
| 249 | (container-add frame box) |
| 250 | (box-pack-start |
| 251 | box (create-bbox #'vbutton-box-new "Spread" 30 85 20 :spread) t t 5) |
| 252 | (box-pack-start |
| 253 | box (create-bbox #'vbutton-box-new "Edge" 30 85 20 :edge) t t 5) |
| 254 | (box-pack-start |
| 255 | box (create-bbox #'vbutton-box-new "Start" 30 85 20 :start) t t 5) |
| 256 | (box-pack-start |
| 257 | box (create-bbox #'vbutton-box-new "End" 30 85 20 :end) t t 5)))) |
| 258 | |
| 259 | |
| 260 | |
| 261 | (define-standard-dialog create-buttons "Buttons" |
| 262 | (let ((table (table-new 3 3 nil)) |
| 263 | (buttons `((,(button-new "button1") 0 1 0 1) |
| 264 | (,(button-new "button2") 1 2 1 2) |
| 265 | (,(button-new "button3") 2 3 2 3) |
| 266 | (,(button-new "button4") 0 1 2 3) |
| 267 | (,(button-new "button5") 2 3 0 1) |
| 268 | (,(button-new "button6") 1 2 2 3) |
| 269 | (,(button-new "button7") 1 2 0 1) |
| 270 | (,(button-new "button8") 2 3 1 2) |
| 271 | (,(button-new "button9") 0 1 1 2)))) |
| 272 | (setf (table-row-spacings table) 5) |
| 273 | (setf (table-column-spacings table) 5) |
| 274 | (setf (container-border-width table) 10) |
| 275 | (box-pack-start main-box table t t 0) |
| 276 | (do ((tmp buttons (rest tmp))) |
| 277 | ((endp tmp)) |
| 278 | (let ((button (first tmp)) |
| 279 | (widget (or (first (second tmp)) |
| 280 | (first (first buttons))))) |
| 281 | (signal-connect (first button) 'clicked |
| 282 | #'(lambda () |
| 283 | (if (widget-visible-p widget) |
| 284 | (widget-hide widget) |
| 285 | (widget-show widget)))) |
| 286 | (apply #'table-attach table button))))) |
| 287 | |
| 288 | |
| 289 | ;; Calenadar |
| 290 | |
| 291 | (define-standard-dialog create-calendar "Calendar" |
| 292 | (setf (container-border-width main-box) 10) |
| 293 | (box-pack-start main-box (calendar-new) t t 0)) |
| 294 | |
| 295 | |
| 296 | |
| 297 | ;;; Check buttons |
| 298 | |
| 299 | (define-standard-dialog create-check-buttons "GtkCheckButton" |
| 300 | (setf (container-border-width main-box) 10) |
| 301 | (setf (box-spacing main-box) 10) |
| 302 | (box-pack-start main-box (check-button-new "button1") t t 0) |
| 303 | (box-pack-start main-box (check-button-new "button2") t t 0) |
| 304 | (box-pack-start main-box (check-button-new "button3") t t 0)) |
| 305 | |
| 306 | |
| 307 | |
| 308 | ;;; CList |
| 309 | |
| 310 | (let ((style1 nil) |
| 311 | (style2 nil) |
| 312 | (style3 nil)) |
| 313 | (defun insert-row-clist (clist) |
| 314 | (let* ((text '("This" "is" "an" "inserted" "row" |
| 315 | "This" "is" "an" "inserted" "row" |
| 316 | "This" "is" "an" "inserted" "row" |
| 317 | "This" "is" "an" "inserted" "row")) |
| 318 | (row |
| 319 | (if (clist-focus-row clist) |
| 320 | (clist-insert clist (clist-focus-row clist) text) |
| 321 | (clist-prepend clist text)))) |
| 322 | |
| 323 | (unless style1 |
| 324 | (let ((color1 '#(0 56000 0)) |
| 325 | (color2 '#(32000 0 56000))) |
| 326 | (setq style1 (style-copy (widget-style clist))) |
| 327 | (setf |
| 328 | (style-base style1 :normal) color1 |
| 329 | (style-base style1 :selected) color2) |
| 330 | |
| 331 | (setq style2 (style-copy (widget-style clist))) |
| 332 | (setf |
| 333 | (style-fg style2 :normal) color1 |
| 334 | (style-fg style2 :selected) color2) |
| 335 | |
| 336 | (setq style3 (style-copy (widget-style clist))) |
| 337 | (setf |
| 338 | (style-fg style3 :normal) color1 |
| 339 | (style-base style3 :normal) color2 |
| 340 | (style-font style3) "-*-courier-medium-*-*-*-*-120-*-*-*-*-*-*"))) |
| 341 | |
| 342 | (setf (clist-cell-style clist row 3) style1) |
| 343 | (setf (clist-cell-style clist row 4) style2) |
| 344 | (setf (clist-cell-style clist row 0) style3)))) |
| 345 | |
| 346 | |
| 347 | (define-standard-dialog create-clist "clist" |
| 348 | (let* ((titles '("auto resize" "not resizeable" "max width 100" |
| 349 | "min width 50" "hide column" "Title 5" "Title 6" |
| 350 | "Title 7" "Title 8" "Title 9" "Title 10" |
| 351 | "Title 11" "Title 12" "Title 13" "Title 14" |
| 352 | "Title 15" "Title 16" "Title 17" "Title 18" |
| 353 | "Title 19")) |
| 354 | (clist (clist-new titles)) |
| 355 | (scrolled-window (scrolled-window-new nil nil))) |
| 356 | |
| 357 | (setf (container-border-width scrolled-window) 5) |
| 358 | (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic) |
| 359 | (container-add scrolled-window clist) |
| 360 | |
| 361 | (signal-connect |
| 362 | clist 'click-column |
| 363 | #'(lambda (column) |
| 364 | (cond |
| 365 | ((= column 4) |
| 366 | (setf (clist-column-visible-p clist column) nil)) |
| 367 | ((= column (clist-sort-column clist)) |
| 368 | (if (eq (clist-sort-type clist) :ascending) |
| 369 | (setf (clist-sort-type clist) :descending) |
| 370 | (setf (clist-sort-type clist) :ascending))) |
| 371 | (t |
| 372 | (setf (clist-sort-column clist) column))) |
| 373 | (clist-sort clist))) |
| 374 | |
| 375 | (let ((box2 (hbox-new nil 5))) |
| 376 | (setf (container-border-width box2) 5) |
| 377 | (box-pack-start main-box box2 nil nil 0) |
| 378 | |
| 379 | (let ((button (button-new "Insert Row"))) |
| 380 | (box-pack-start box2 button t t 0) |
| 381 | (signal-connect |
| 382 | button 'clicked #'insert-row-clist :object clist)) |
| 383 | |
| 384 | (let ((button (button-new "Add 1,000 Rows With Pixmaps"))) |
| 385 | (box-pack-start box2 button t t 0) |
| 386 | (signal-connect |
| 387 | button 'clicked |
| 388 | #'(lambda () |
| 389 | (multiple-value-bind (pixmap mask) |
| 390 | (gdk:pixmap-create gtk-mini-xpm) |
| 391 | (let ((texts (do ((i 4 (1+ i)) |
| 392 | (texts '(nil "Center" "Right"))) |
| 393 | ((= i (length titles)) (reverse texts)) |
| 394 | (push (format nil "Column ~D" i) texts)))) |
| 395 | (clist-freeze clist) |
| 396 | (dotimes (i 1000) |
| 397 | (let ((row |
| 398 | (clist-append |
| 399 | clist |
| 400 | (cons (format nil "CListRow ~D" (random 1000)) |
| 401 | texts)))) |
| 402 | (clist-set-cell-pixtext |
| 403 | clist row 3 "gtk+" 5 (list pixmap mask)))) |
| 404 | (clist-thaw clist)))))) |
| 405 | |
| 406 | (let ((button (button-new "Add 10,000 Rows"))) |
| 407 | (box-pack-start box2 button t t 0) |
| 408 | (signal-connect |
| 409 | button 'clicked |
| 410 | #'(lambda () |
| 411 | (let ((texts (do ((i 3 (1+ i)) |
| 412 | (texts '("Center" "Right"))) |
| 413 | ((= i (length titles)) (reverse texts)) |
| 414 | (push (format nil "Column ~D" i) texts)))) |
| 415 | (clist-freeze clist) |
| 416 | (dotimes (i 10000) |
| 417 | (clist-append |
| 418 | clist (cons (format nil "CListRow ~D" (random 1000)) texts))) |
| 419 | (clist-thaw clist)))))) |
| 420 | |
| 421 | |
| 422 | (let ((box2 (hbox-new nil 5))) |
| 423 | (setf (container-border-width box2) 5) |
| 424 | (box-pack-start main-box box2 nil nil 0) |
| 425 | |
| 426 | (let ((button (button-new "Clear List"))) |
| 427 | (box-pack-start box2 button t t 0) |
| 428 | (signal-connect |
| 429 | button 'clicked |
| 430 | #'(lambda () |
| 431 | (clist-clear clist)))) |
| 432 | |
| 433 | (let ((button (button-new "Remove Selection"))) |
| 434 | (box-pack-start box2 button t t 0) |
| 435 | (signal-connect |
| 436 | button 'clicked |
| 437 | #'(lambda () |
| 438 | (clist-freeze clist) |
| 439 | (let ((selection-mode (clist-selection-mode clist))) |
| 440 | (labels ((remove-selection () |
| 441 | (let ((selection (clist-selection clist))) |
| 442 | (when selection |
| 443 | (clist-remove clist (first selection)) |
| 444 | (unless (eq selection-mode :browse) |
| 445 | (remove-selection)))))) |
| 446 | (remove-selection)) |
| 447 | |
| 448 | (when (and |
| 449 | (eq selection-mode :extended) |
| 450 | (not (clist-selection clist)) |
| 451 | (clist-focus-row clist)) |
| 452 | (clist-select-row clist (clist-focus-row clist)))) |
| 453 | (clist-thaw clist)))) |
| 454 | |
| 455 | (let ((button (button-new "Undo Selection"))) |
| 456 | (box-pack-start box2 button t t 0) |
| 457 | (signal-connect |
| 458 | button 'clicked #'clist-undo-selection :object clist)) |
| 459 | |
| 460 | (let ((button (button-new "Warning Test"))) |
| 461 | (box-pack-start box2 button t t 0) |
| 462 | (signal-connect button 'clicked #'(lambda ())))) |
| 463 | |
| 464 | |
| 465 | (let ((box2 (hbox-new nil 5))) |
| 466 | (setf (container-border-width box2) 5) |
| 467 | (box-pack-start main-box box2 nil nil 0) |
| 468 | |
| 469 | (let ((button (check-button-new "Show Title Buttons"))) |
| 470 | (box-pack-start box2 button t t 0) |
| 471 | (signal-connect |
| 472 | button 'clicked |
| 473 | #'(lambda () |
| 474 | (if (toggle-button-active-p button) |
| 475 | (clist-column-titles-show clist) |
| 476 | (clist-column-titles-hide clist)))) |
| 477 | (setf (toggle-button-active-p button) t)) |
| 478 | |
| 479 | (let ((button (check-button-new "Reorderable"))) |
| 480 | (box-pack-start box2 button nil t 0) |
| 481 | (signal-connect |
| 482 | button 'clicked |
| 483 | #'(lambda () |
| 484 | (setf |
| 485 | (clist-reorderable-p clist) (toggle-button-active-p button)))) |
| 486 | (setf (toggle-button-active-p button) t)) |
| 487 | |
| 488 | (box-pack-start box2 (label-new "Selection Mode : ") nil t 0) |
| 489 | (let ((option-menu |
| 490 | (build-option-menu |
| 491 | `(("Single" |
| 492 | ,#'(lambda () (setf (clist-selection-mode clist) :single))) |
| 493 | ("Browse" |
| 494 | ,#'(lambda () (setf (clist-selection-mode clist) :browse))) |
| 495 | ("Multiple" |
| 496 | ,#'(lambda () (setf (clist-selection-mode clist) :multiple))) |
| 497 | ("Extended" |
| 498 | ,#'(lambda () (setf (clist-selection-mode clist) :extended)))) |
| 499 | 3))) |
| 500 | (box-pack-start box2 option-menu nil t 0))) |
| 501 | |
| 502 | (box-pack-start main-box scrolled-window t t 0) |
| 503 | (setf (clist-row-height clist) 18) |
| 504 | (setf (widget-height clist) 300) |
| 505 | |
| 506 | (dotimes (i (length titles)) |
| 507 | (setf (clist-column-width clist i) 80)) |
| 508 | |
| 509 | (setf (clist-column-auto-resize-p clist 0) t) |
| 510 | (setf (clist-column-resizeable-p clist 1) nil) |
| 511 | (setf (clist-column-max-width clist 2) 100) |
| 512 | (setf (clist-column-min-width clist 3) 50) |
| 513 | (setf (clist-selection-mode clist) :extended) |
| 514 | (setf (clist-column-justification clist 1) :right) |
| 515 | (setf (clist-column-justification clist 2) :center) |
| 516 | |
| 517 | (let ((style (style-new)) |
| 518 | (texts (do ((i 3 (1+ i)) |
| 519 | (texts '("Center" "Right"))) |
| 520 | ((= i (length titles)) (reverse texts)) |
| 521 | (push (format nil "Column ~D" i) texts)))) |
| 522 | (setf |
| 523 | (style-font style) "-adobe-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*" |
| 524 | (style-fg style :normal) '#(56000 0 0) |
| 525 | (style-base style :normal) '#(0 56000 32000)) |
| 526 | |
| 527 | (dotimes (i 10) |
| 528 | (clist-append clist (cons (format nil "CListRow ~D" i) texts)) |
| 529 | (if (= (mod i 4) 2) |
| 530 | (setf (clist-row-style clist i) style) |
| 531 | (setf (clist-cell-style clist i (mod i 4)) style)))))) |
| 532 | |
| 533 | |
| 534 | |
| 535 | ;;; Color selection |
| 536 | |
| 537 | (let ((color-dialog nil)) |
| 538 | (defun create-color-selection () |
| 539 | (unless color-dialog |
| 540 | (setq color-dialog |
| 541 | (color-selection-dialog-new "color selection dialog")) |
| 542 | |
| 543 | (setf (window-position color-dialog) :mouse) |
| 544 | (signal-connect |
| 545 | color-dialog 'destroy #'(lambda () (widget-destroyed color-dialog))) |
| 546 | |
| 547 | (let ((colorsel (color-selection-dialog-colorsel color-dialog))) |
| 548 | (setf (color-selection-use-opacity-p colorsel) t) |
| 549 | (setf (color-selection-policy colorsel) :continuous) |
| 550 | |
| 551 | ; (signal-connect colorsel 'color-changed #'(lambda () nil)) |
| 552 | |
| 553 | (let ((button (color-selection-dialog-ok-button color-dialog))) |
| 554 | (signal-connect |
| 555 | button 'clicked |
| 556 | #'(lambda () |
| 557 | (let ((color (color-selection-color colorsel))) |
| 558 | (format t "Selected color: ~A~%" color) |
| 559 | (setf (color-selection-color colorsel) color)))))) |
| 560 | |
| 561 | (let ((button (color-selection-dialog-cancel-button color-dialog))) |
| 562 | (signal-connect |
| 563 | button 'clicked #'widget-destroy :object color-dialog))) |
| 564 | |
| 565 | (if (not (widget-visible-p color-dialog)) |
| 566 | (widget-show-all color-dialog) |
| 567 | (widget-destroy color-dialog)))) |
| 568 | |
| 569 | |
| 570 | |
| 571 | ;;; CTree |
| 572 | |
| 573 | (let ((total-pages 0) |
| 574 | (total-books 0) |
| 575 | (status-labels) |
| 576 | (style1) |
| 577 | (style2) |
| 578 | (pixmap1) |
| 579 | (pixmap2) |
| 580 | (pixmap3)) |
| 581 | |
| 582 | (defun after-press (ctree &rest data) |
| 583 | (declare (ignore data)) |
| 584 | (setf |
| 585 | (label-text (svref status-labels 0)) |
| 586 | (format nil "~D" total-books)) |
| 587 | (setf |
| 588 | (label-text (svref status-labels 1)) |
| 589 | (format nil "~D" total-pages)) |
| 590 | (setf |
| 591 | (label-text (svref status-labels 2)) |
| 592 | (format nil "~D" (length (clist-selection ctree)))) |
| 593 | (setf |
| 594 | (label-text (svref status-labels 3)) |
| 595 | (format nil "~D" (clist-n-rows ctree))) |
| 596 | nil) |
| 597 | |
| 598 | (defun build-recursive (ctree parent current-depth depth books pages) |
| 599 | (let ((sibling nil)) |
| 600 | (do ((i (+ pages books) (1- i))) |
| 601 | ((= i books)) |
| 602 | (declare (fixnum i)) |
| 603 | (incf total-pages) |
| 604 | (setq |
| 605 | sibling |
| 606 | (ctree-insert-node |
| 607 | ctree parent sibling |
| 608 | (list |
| 609 | (format nil "Page ~D" (random 100)) |
| 610 | (format nil "Item ~D-~D" current-depth i)) |
| 611 | 5 :pixmap pixmap3 :leaf t)) |
| 612 | (when (and parent (eq (ctree-line-style ctree) :tabbed)) |
| 613 | (setf |
| 614 | (ctree-row-style ctree sibling) |
| 615 | (ctree-row-style ctree parent)))) |
| 616 | |
| 617 | (unless (= current-depth depth) |
| 618 | (do ((i books (1- i))) |
| 619 | ((zerop i)) |
| 620 | (incf total-books) |
| 621 | (setq |
| 622 | sibling |
| 623 | (ctree-insert-node |
| 624 | ctree parent sibling |
| 625 | (list |
| 626 | (format nil "Book ~D" (random 100)) |
| 627 | (format nil "Item ~D-~D" current-depth i)) |
| 628 | 5 :closed pixmap1 :opened pixmap2)) |
| 629 | |
| 630 | (let ((style (style-new)) |
| 631 | (color (case (mod current-depth 3) |
| 632 | (0 (vector |
| 633 | (* 10000 (mod current-depth 6)) |
| 634 | 0 |
| 635 | (- 65535 (mod (* i 10000) 65535)))) |
| 636 | (1 (vector |
| 637 | (* 10000 (mod current-depth 6)) |
| 638 | (- 65535 (mod (* i 10000) 65535)) |
| 639 | 0)) |
| 640 | (t (vector |
| 641 | (- 65535 (mod (* i 10000) 65535)) |
| 642 | 0 |
| 643 | (* 10000 (mod current-depth 6))))))) |
| 644 | (setf (style-base style :normal) color) |
| 645 | (ctree-set-node-data ctree sibling style #'style-unref) |
| 646 | |
| 647 | (when (eq (ctree-line-style ctree) :tabbed) |
| 648 | (setf (ctree-row-style ctree sibling) style))) |
| 649 | |
| 650 | (build-recursive |
| 651 | ctree sibling (1+ current-depth) depth books pages))))) |
| 652 | |
| 653 | (defun rebuild-tree (ctree depth books pages) |
| 654 | (let ((n (* (/ (1- (expt books depth)) (1- books)) (1+ pages)))) |
| 655 | (if (> n 10000) |
| 656 | (format t "~D total items? Try less~%" n) |
| 657 | (progn |
| 658 | (clist-freeze ctree) |
| 659 | (clist-clear ctree) |
| 660 | (setq total-books 1) |
| 661 | (setq total-pages 0) |
| 662 | (let ((parent |
| 663 | (ctree-insert-node |
| 664 | ctree nil nil '("Root") 5 |
| 665 | :closed pixmap1 :opened pixmap2 :expanded t)) |
| 666 | (style (style-new))) |
| 667 | (setf (style-base style :normal) '#(0 45000 55000)) |
| 668 | (ctree-set-node-data ctree parent style #'style-unref) |
| 669 | |
| 670 | (when (eq (ctree-line-style ctree) :tabbed) |
| 671 | (setf (ctree-row-style ctree parent) style)) |
| 672 | |
| 673 | (build-recursive ctree parent 1 depth books pages) |
| 674 | (clist-thaw ctree) |
| 675 | (after-press ctree)))))) |
| 676 | |
| 677 | (let ((export-window) |
| 678 | (export-ctree)) |
| 679 | (defun export-tree (ctree) |
| 680 | (unless export-window |
| 681 | (setq export-window (window-new :toplevel)) |
| 682 | (signal-connect |
| 683 | export-window 'destroy |
| 684 | #'(lambda () |
| 685 | (widget-destroyed export-window))) |
| 686 | |
| 687 | (setf (window-title export-window) "Exported ctree") |
| 688 | (setf (container-border-width export-window) 5) |
| 689 | |
| 690 | (let ((vbox (vbox-new nil 0))) |
| 691 | (container-add export-window vbox) |
| 692 | |
| 693 | (let ((button (button-new "Close"))) |
| 694 | (box-pack-end vbox button nil t 0) |
| 695 | (signal-connect |
| 696 | button 'clicked #'widget-destroy :object export-window)) |
| 697 | |
| 698 | (box-pack-end vbox (hseparator-new) nil t 10) |
| 699 | |
| 700 | (setq export-ctree (ctree-new '("Tree" "Info"))) |
| 701 | (setf (ctree-line-style export-ctree) :dotted) |
| 702 | |
| 703 | (let ((scrolled-window (scrolled-window-new))) |
| 704 | (container-add scrolled-window export-ctree) |
| 705 | (setf |
| 706 | (scrolled-window-scrollbar-policy scrolled-window) :automatic) |
| 707 | (box-pack vbox scrolled-window) |
| 708 | (setf (clist-selection-mode export-ctree) :extended) |
| 709 | (setf (clist-column-width export-ctree 0) 200) |
| 710 | (setf (clist-column-width export-ctree 1) 200) |
| 711 | (setf (widget-width export-ctree) 300) |
| 712 | (setf (widget-height export-ctree) 200)))) |
| 713 | |
| 714 | (unless (widget-visible-p export-window) |
| 715 | (widget-show-all export-window)) |
| 716 | |
| 717 | (clist-clear export-ctree) |
| 718 | (let ((node (ctree-nth-node ctree (clist-focus-row ctree)))) |
| 719 | (when node |
| 720 | (let ((tree-list |
| 721 | (list (ctree-map-to-list ctree node #'(lambda (node) node))))) |
| 722 | (ctree-insert-from-list |
| 723 | export-ctree nil tree-list |
| 724 | #'(lambda (export-ctree-node ctree-node) |
| 725 | (multiple-value-bind |
| 726 | (text spacing pixmap-closed bitmap-closed pixmap-opened |
| 727 | bitmap-opened leaf expanded) |
| 728 | (ctree-node-info ctree ctree-node) |
| 729 | (ctree-set-node-info |
| 730 | export-ctree export-ctree-node text spacing |
| 731 | :closed (list pixmap-closed bitmap-closed) |
| 732 | :opened (list pixmap-opened bitmap-opened) |
| 733 | :leaf leaf :expanded expanded)) |
| 734 | (unless (eq (ctree-cell-type ctree ctree-node 1) :empty) |
| 735 | (setf |
| 736 | (ctree-cell-text export-ctree export-ctree-node 1) |
| 737 | (ctree-cell-text ctree ctree-node 1)))))))))) |
| 738 | |
| 739 | |
| 740 | (define-test-window create-ctree "CTree" |
| 741 | (let ((vbox (vbox-new nil 0)) |
| 742 | (ctree (ctree-new '("Tree" "Info")))) |
| 743 | |
| 744 | (container-add window vbox) |
| 745 | |
| 746 | (let ((hbox (hbox-new nil 5))) |
| 747 | (setf (container-border-width hbox) 5) |
| 748 | (box-pack-start vbox hbox nil t 0) |
| 749 | |
| 750 | (let ((spin1 (spin-button-new (adjustment-new 4 1 10 1 5 0) 0 0)) |
| 751 | (spin2 (spin-button-new (adjustment-new 3 1 20 1 5 0) 0 0)) |
| 752 | (spin3 (spin-button-new (adjustment-new 5 1 20 1 5 0) 0 0))) |
| 753 | |
| 754 | (box-pack-start hbox (label-new "Depth :") nil t 0) |
| 755 | (box-pack-start hbox spin1 nil t 5) |
| 756 | (box-pack-start hbox (label-new "Books :") nil t 0) |
| 757 | (box-pack-start hbox spin2 nil t 5) |
| 758 | (box-pack-start hbox (label-new "Pages :") nil t 0) |
| 759 | (box-pack-start hbox spin3 nil t 5) |
| 760 | |
| 761 | (let ((button (button-new "Rebuild Tree"))) |
| 762 | (box-pack-start hbox button t t 0) |
| 763 | (signal-connect |
| 764 | button 'clicked |
| 765 | #'(lambda () |
| 766 | (let ((depth (spin-button-value-as-int spin1)) |
| 767 | (books (spin-button-value-as-int spin2)) |
| 768 | (pages (spin-button-value-as-int spin3))) |
| 769 | (rebuild-tree ctree depth books pages)))))) |
| 770 | |
| 771 | (let ((button (button-new "Close"))) |
| 772 | (box-pack-end hbox button t t 0) |
| 773 | (signal-connect button 'clicked #'widget-destroy :object window))) |
| 774 | |
| 775 | (let ((scrolled-window (scrolled-window-new))) |
| 776 | (setf (container-border-width scrolled-window) 5) |
| 777 | (setf (scrolled-window-hscrollbar-policy scrolled-window) :automatic) |
| 778 | (setf (scrolled-window-vscrollbar-policy scrolled-window) :always) |
| 779 | (box-pack-start vbox scrolled-window t t 0) |
| 780 | |
| 781 | (container-add scrolled-window ctree) |
| 782 | (setf (clist-column-auto-resize-p ctree 0) t) |
| 783 | (setf (clist-column-width ctree 1) 200) |
| 784 | (setf (clist-selection-mode ctree) :extended) |
| 785 | (setf (ctree-line-style ctree) :dotted)) |
| 786 | |
| 787 | (signal-connect |
| 788 | ctree 'click-column |
| 789 | #'(lambda (column) |
| 790 | (cond |
| 791 | ((/= column (clist-sort-column ctree)) |
| 792 | (setf (clist-sort-column ctree) column)) |
| 793 | ((eq (clist-sort-type ctree) :ascending) |
| 794 | (setf (clist-sort-type ctree) :descending)) |
| 795 | (t (setf (clist-sort-type ctree) :ascending))) |
| 796 | (ctree-sort-recursive ctree))) |
| 797 | |
| 798 | (signal-connect |
| 799 | ctree 'button-press-event #'after-press :object t :after t) |
| 800 | (signal-connect |
| 801 | ctree 'button-release-event #'after-press :object t :after t) |
| 802 | (signal-connect |
| 803 | ctree 'tree-move #'after-press :object t :after t) |
| 804 | (signal-connect |
| 805 | ctree 'end-selection #'after-press :object t :after t) |
| 806 | (signal-connect |
| 807 | ctree 'toggle-focus-row #'after-press :object t :after t) |
| 808 | (signal-connect |
| 809 | ctree 'select-all #'after-press :object t :after t) |
| 810 | (signal-connect |
| 811 | ctree 'unselect-all #'after-press :object t :after t) |
| 812 | (signal-connect |
| 813 | ctree 'scroll-vertical #'after-press :object t :after t) |
| 814 | |
| 815 | (let ((bbox (hbox-new nil 5))) |
| 816 | (setf (container-border-width bbox) 5) |
| 817 | (box-pack-start vbox bbox nil t 0) |
| 818 | |
| 819 | (let ((mbox (vbox-new t 5))) |
| 820 | (box-pack bbox mbox :expand nil) |
| 821 | (box-pack mbox (label-new "Row Height :") :expand nil :fill nil) |
| 822 | (box-pack mbox (label-new "Indent :") :expand nil :fill nil) |
| 823 | (box-pack mbox (label-new "Spacing :") :expand nil :fill nil)) |
| 824 | |
| 825 | (let ((mbox (vbox-new t 5))) |
| 826 | (box-pack bbox mbox :expand nil) |
| 827 | |
| 828 | (let* ((adjustment (adjustment-new 20 12 100 1 10 0)) |
| 829 | (spinner (spin-button-new adjustment 0 0))) |
| 830 | (box-pack mbox spinner :expand nil :fill nil :padding 5) |
| 831 | (flet ((set-row-height () |
| 832 | (setf |
| 833 | (clist-row-height ctree) |
| 834 | (spin-button-value-as-int spinner)))) |
| 835 | (signal-connect adjustment 'value-changed #'set-row-height) |
| 836 | (set-row-height))) |
| 837 | |
| 838 | (let* ((adjustment (adjustment-new 20 0 60 1 10 0)) |
| 839 | (spinner (spin-button-new adjustment 0 0))) |
| 840 | (box-pack mbox spinner :expand nil :fill nil :padding 5) |
| 841 | (flet ((set-indent () |
| 842 | (setf |
| 843 | (ctree-indent ctree) |
| 844 | (spin-button-value-as-int spinner)))) |
| 845 | (signal-connect adjustment 'value-changed #'set-indent) |
| 846 | (set-indent))) |
| 847 | |
| 848 | (let* ((adjustment (adjustment-new 5 0 60 1 10 0)) |
| 849 | (spinner (spin-button-new adjustment 0 0))) |
| 850 | (box-pack mbox spinner :expand nil :fill nil :padding 5) |
| 851 | (flet ((set-spacing () |
| 852 | (setf |
| 853 | (ctree-spacing ctree) |
| 854 | (spin-button-value-as-int spinner)))) |
| 855 | (signal-connect adjustment 'value-changed #'set-spacing) |
| 856 | (set-spacing)))) |
| 857 | |
| 858 | |
| 859 | (let ((mbox (vbox-new t 5))) |
| 860 | (box-pack bbox mbox :expand nil) |
| 861 | |
| 862 | (let ((hbox (hbox-new nil 5))) |
| 863 | (box-pack mbox hbox :expand nil :fill nil) |
| 864 | |
| 865 | (let ((button (button-new "Expand All"))) |
| 866 | (box-pack hbox button) |
| 867 | (signal-connect |
| 868 | button 'clicked |
| 869 | #'(lambda () |
| 870 | (ctree-expand-recursive ctree nil) |
| 871 | (after-press ctree)))) |
| 872 | |
| 873 | (let ((button (button-new "Collapse All"))) |
| 874 | (box-pack hbox button) |
| 875 | (signal-connect |
| 876 | button 'clicked |
| 877 | #'(lambda () |
| 878 | (ctree-collapse-recursive ctree nil) |
| 879 | (after-press ctree)))) |
| 880 | |
| 881 | (let ((button (button-new "Change Style"))) |
| 882 | (box-pack hbox button) |
| 883 | (signal-connect |
| 884 | button 'clicked |
| 885 | #'(lambda () |
| 886 | (let ((node (ctree-nth-node |
| 887 | ctree (or (clist-focus-row ctree) 0)))) |
| 888 | (when node |
| 889 | (unless style1 |
| 890 | (let ((color1 '#(0 56000 0)) |
| 891 | (color2 '#(32000 0 56000))) |
| 892 | (setq style1 (style-new)) |
| 893 | (setf (style-base style1 :normal) color1) |
| 894 | (setf (style-fg style1 :selected) color2) |
| 895 | |
| 896 | (setq style2 (style-new)) |
| 897 | (setf (style-base style2 :selected) color2) |
| 898 | (setf (style-base style2 :normal) color2) |
| 899 | (setf (style-fg style2 :normal) color1) |
| 900 | (setf |
| 901 | (style-font style2) |
| 902 | "-*-courier-medium-*-*-*-*-300-*-*-*-*-*-*"))) |
| 903 | (setf (ctree-cell-style ctree node 1) style1) |
| 904 | (setf (ctree-cell-style ctree node 0) style2) |
| 905 | |
| 906 | (when (ctree-node-child node) |
| 907 | (setf |
| 908 | (ctree-row-style ctree (ctree-node-child node)) |
| 909 | style2))))))) |
| 910 | |
| 911 | (let ((button (button-new "Export Tree"))) |
| 912 | (box-pack hbox button) |
| 913 | (signal-connect button 'clicked #'export-tree :object ctree))) |
| 914 | |
| 915 | (let ((hbox (hbox-new nil 5))) |
| 916 | (box-pack mbox hbox :expand nil :fill nil) |
| 917 | |
| 918 | (let ((button (button-new "Select All"))) |
| 919 | (box-pack hbox button) |
| 920 | (signal-connect |
| 921 | button 'clicked |
| 922 | #'(lambda () |
| 923 | (ctree-select-recursive ctree nil) |
| 924 | (after-press ctree)))) |
| 925 | |
| 926 | (let ((button (button-new "Unselect All"))) |
| 927 | (box-pack hbox button) |
| 928 | (signal-connect |
| 929 | button 'clicked |
| 930 | #'(lambda () |
| 931 | (ctree-unselect-recursive ctree nil) |
| 932 | (after-press ctree)))) |
| 933 | |
| 934 | (let ((button (button-new "Remove Selection"))) |
| 935 | (box-pack hbox button) |
| 936 | (signal-connect |
| 937 | button 'clicked |
| 938 | #'(lambda () |
| 939 | (clist-freeze ctree) |
| 940 | (let ((selection-mode (clist-selection-mode ctree))) |
| 941 | (labels |
| 942 | ((remove-selection () |
| 943 | (let ((node (first (ctree-selection ctree)))) |
| 944 | (when node |
| 945 | |
| 946 | (ctree-apply-post-recursive |
| 947 | ctree node |
| 948 | #'(lambda (node) |
| 949 | (if (ctree-node-leaf-p node) |
| 950 | (decf total-pages) |
| 951 | (decf total-books)))) |
| 952 | |
| 953 | (ctree-remove-node ctree node) |
| 954 | (unless (eq selection-mode :browse) |
| 955 | (remove-selection)))))) |
| 956 | (remove-selection)) |
| 957 | |
| 958 | (when (and |
| 959 | (eq selection-mode :extended) |
| 960 | (not (clist-selection ctree)) |
| 961 | (clist-focus-row ctree)) |
| 962 | (ctree-select |
| 963 | ctree |
| 964 | (ctree-nth-node ctree (clist-focus-row ctree))))) |
| 965 | (clist-thaw ctree) |
| 966 | (after-press ctree)))) |
| 967 | |
| 968 | (let ((button (check-button-new "Reorderable"))) |
| 969 | (box-pack hbox button :expand nil) |
| 970 | (signal-connect |
| 971 | button 'clicked |
| 972 | #'(lambda () |
| 973 | (setf |
| 974 | (clist-reorderable-p ctree) |
| 975 | (toggle-button-active-p button)))) |
| 976 | (setf (toggle-button-active-p button) t))) |
| 977 | |
| 978 | (let ((hbox (hbox-new nil 5))) |
| 979 | (box-pack mbox hbox :expand nil :fill nil) |
| 980 | |
| 981 | (flet |
| 982 | ((set-line-style (line-style) |
| 983 | (let ((current-line-style (ctree-line-style ctree))) |
| 984 | (when (or |
| 985 | (and |
| 986 | (eq current-line-style :tabbed) |
| 987 | (not (eq line-style :tabbed))) |
| 988 | (and |
| 989 | (not (eq current-line-style :tabbed)) |
| 990 | (eq line-style :tabbed))) |
| 991 | (ctree-apply-pre-recursive |
| 992 | ctree nil |
| 993 | #'(lambda (node) |
| 994 | (let |
| 995 | ((style |
| 996 | (cond |
| 997 | ((eq (ctree-line-style ctree) :tabbed) nil) |
| 998 | ((not (ctree-node-leaf-p node)) |
| 999 | (ctree-node-data ctree node)) |
| 1000 | ((ctree-node-parent node) |
| 1001 | (ctree-node-data |
| 1002 | ctree (ctree-node-parent node)))))) |
| 1003 | (setf (ctree-row-style ctree node) style)))) |
| 1004 | (setf (ctree-line-style ctree) line-style))))) |
| 1005 | |
| 1006 | (let ((option-menu |
| 1007 | (build-option-menu |
| 1008 | `(("No lines" ,#'(lambda () (set-line-style :none))) |
| 1009 | ("Solid" ,#'(lambda () (set-line-style :solid))) |
| 1010 | ("Dotted" ,#'(lambda () (set-line-style :dotted))) |
| 1011 | ("Tabbed" ,#'(lambda () (set-line-style :tabbed)))) |
| 1012 | 2))) |
| 1013 | (box-pack hbox option-menu :expand nil))) |
| 1014 | |
| 1015 | (let ((option-menu |
| 1016 | (build-option-menu |
| 1017 | `(("None" |
| 1018 | ,#'(lambda () |
| 1019 | (setf (ctree-expander-style ctree) :none))) |
| 1020 | ("Square" |
| 1021 | ,#'(lambda () |
| 1022 | (setf (ctree-expander-style ctree) :square))) |
| 1023 | ("Triangle" |
| 1024 | ,#'(lambda () |
| 1025 | (setf (ctree-expander-style ctree) :triangle))) |
| 1026 | ("Circular" |
| 1027 | ,#'(lambda () |
| 1028 | (setf (ctree-expander-style ctree) :circular)))) |
| 1029 | 1))) |
| 1030 | (box-pack hbox option-menu :expand nil)) |
| 1031 | |
| 1032 | (let ((option-menu |
| 1033 | (build-option-menu |
| 1034 | `(("Left" |
| 1035 | ,#'(lambda () |
| 1036 | (setf |
| 1037 | (clist-column-justification ctree 0) :left))) |
| 1038 | ("Right" |
| 1039 | ,#'(lambda () |
| 1040 | (setf |
| 1041 | (clist-column-justification ctree 0) :right)))) |
| 1042 | 0))) |
| 1043 | (box-pack hbox option-menu :expand nil)) |
| 1044 | |
| 1045 | (flet ((set-sel-mode (mode) |
| 1046 | (setf (clist-selection-mode ctree) mode) |
| 1047 | (after-press ctree))) |
| 1048 | (let ((option-menu |
| 1049 | (build-option-menu |
| 1050 | `(("Single" ,#'(lambda () (set-sel-mode :single))) |
| 1051 | ("Browse" ,#'(lambda () (set-sel-mode :browse))) |
| 1052 | ("Multiple" ,#'(lambda () (set-sel-mode :multiple))) |
| 1053 | ("Extended" ,#'(lambda () (set-sel-mode :extended)))) |
| 1054 | 3))) |
| 1055 | (box-pack hbox option-menu :expand nil)))))) |
| 1056 | |
| 1057 | (let ((frame (frame-new))) |
| 1058 | (setf (container-border-width frame) 0) |
| 1059 | (setf (frame-shadow-type frame) :out) |
| 1060 | (box-pack vbox frame :expand nil) |
| 1061 | |
| 1062 | (let ((hbox (hbox-new t 2))) |
| 1063 | (setf (container-border-width hbox) 2) |
| 1064 | (container-add frame hbox) |
| 1065 | |
| 1066 | (setq |
| 1067 | status-labels |
| 1068 | (map 'vector |
| 1069 | #'(lambda (text) |
| 1070 | (let ((frame (frame-new)) |
| 1071 | (hbox2 (hbox-new nil 0))) |
| 1072 | (setf (frame-shadow-type frame) :in) |
| 1073 | (box-pack hbox frame :expand nil) |
| 1074 | (setf (container-border-width hbox2) 2) |
| 1075 | (container-add frame hbox2) |
| 1076 | (box-pack hbox2 (label-new text) :expand nil) |
| 1077 | (let ((label (label-new ""))) |
| 1078 | (box-pack-end hbox2 label nil t 5) |
| 1079 | label))) |
| 1080 | '("Books :" "Pages :" "Selected :" "Visible :"))))) |
| 1081 | |
| 1082 | (widget-realize window) |
| 1083 | (let ((gdk:window (widget-window window))) |
| 1084 | (setq pixmap1 (multiple-value-list |
| 1085 | (gdk:pixmap-create book-closed-xpm :window gdk:window))) |
| 1086 | (setq pixmap2 (multiple-value-list |
| 1087 | (gdk:pixmap-create book-open-xpm :window gdk:window))) |
| 1088 | (setq pixmap3 (multiple-value-list |
| 1089 | (gdk:pixmap-create mini-page-xpm :window gdk:window)))) |
| 1090 | (setf (widget-height ctree) 300) |
| 1091 | |
| 1092 | (rebuild-tree ctree 4 3 5)))) |
| 1093 | |
| 1094 | |
| 1095 | |
| 1096 | ;;; Cursors |
| 1097 | |
| 1098 | (defun clamp (n min-val max-val) |
| 1099 | (declare (number n min-val max-val)) |
| 1100 | (max (min n max-val) min-val)) |
| 1101 | |
| 1102 | (defun set-cursor (spinner drawing-area label) |
| 1103 | (let ((cursor |
| 1104 | (gforeign:int-enum |
| 1105 | (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE) |
| 1106 | 'gdk:cursor-type))) |
| 1107 | (setf (label-text label) (string-downcase (symbol-name cursor))) |
| 1108 | (setf (widget-cursor drawing-area) cursor))) |
| 1109 | |
| 1110 | |
| 1111 | (define-standard-dialog create-cursors "Cursors" |
| 1112 | (setf (container-border-width main-box) 10) |
| 1113 | (setf (box-spacing main-box) 5) |
| 1114 | (let* ((hbox (hbox-new nil 0)) |
| 1115 | (label (label-new "Cursor Value : ")) |
| 1116 | (adj (adjustment-new 0 0 152 2 10 0)) |
| 1117 | (spinner (spin-button-new adj 0 0))) |
| 1118 | (setf (container-border-width hbox) 5) |
| 1119 | (box-pack-start main-box hbox nil t 0) |
| 1120 | (setf (misc-xalign label) 0) |
| 1121 | (setf (misc-yalign label) 0.5) |
| 1122 | (box-pack-start hbox label nil t 0) |
| 1123 | (box-pack-start hbox spinner t t 0) |
| 1124 | |
| 1125 | (let ((frame (make-frame |
| 1126 | :shadow-type :etched-in |
| 1127 | :label-xalign 0.5 |
| 1128 | :label "Cursor Area" |
| 1129 | :border-width 10 |
| 1130 | :parent main-box |
| 1131 | :visible t)) |
| 1132 | (drawing-area (drawing-area-new))) |
| 1133 | (setf (widget-width drawing-area) 80) |
| 1134 | (setf (widget-height drawing-area) 80) |
| 1135 | (container-add frame drawing-area) |
| 1136 | (signal-connect |
| 1137 | drawing-area 'expose-event |
| 1138 | #'(lambda (event) |
| 1139 | (declare (ignore event)) |
| 1140 | (multiple-value-bind (width height) |
| 1141 | (drawing-area-size drawing-area) |
| 1142 | (let* ((drawable (widget-window drawing-area)) |
| 1143 | (style (widget-style drawing-area)) |
| 1144 | (white-gc (style-get-gc style :white)) |
| 1145 | (gray-gc (style-get-gc style :background :normal)) |
| 1146 | (black-gc (style-get-gc style :black))) |
| 1147 | (gdk:draw-rectangle |
| 1148 | drawable white-gc t 0 0 width (floor height 2)) |
| 1149 | (gdk:draw-rectangle |
| 1150 | drawable black-gc t 0 (floor height 2) width (floor height 2)) |
| 1151 | (gdk:draw-rectangle |
| 1152 | drawable gray-gc t (floor width 3) (floor height 3) |
| 1153 | (floor width 3) (floor height 3)))) |
| 1154 | t)) |
| 1155 | (setf (widget-events drawing-area) '(:exposure :button-press)) |
| 1156 | (signal-connect |
| 1157 | drawing-area 'button-press-event |
| 1158 | #'(lambda (event) |
| 1159 | (when (and |
| 1160 | (eq (gdk:event-type event) :button-press) |
| 1161 | (or |
| 1162 | (= (gdk:event-button event) 1) |
| 1163 | (= (gdk:event-button event) 3))) |
| 1164 | (spin-button-spin |
| 1165 | spinner |
| 1166 | (if (= (gdk:event-button event) 1) |
| 1167 | :step-forward |
| 1168 | :step-backward) |
| 1169 | 0) |
| 1170 | t))) |
| 1171 | (widget-show drawing-area) |
| 1172 | |
| 1173 | (let ((label (make-label |
| 1174 | :visible t |
| 1175 | :label "XXX" |
| 1176 | :parent main-box))) |
| 1177 | (setf (box-child-expand-p #|main-box|# label) nil) |
| 1178 | (signal-connect |
| 1179 | spinner 'changed |
| 1180 | #'(lambda () |
| 1181 | (set-cursor spinner drawing-area label))) |
| 1182 | |
| 1183 | (widget-realize drawing-area) |
| 1184 | (set-cursor spinner drawing-area label))))) |
| 1185 | |
| 1186 | |
| 1187 | |
| 1188 | ;;; Dialog |
| 1189 | |
| 1190 | (define-test-dialog create-dialog "Dialog" |
| 1191 | (setf (widget-width window) 200) |
| 1192 | (setf (widget-height window) 110) |
| 1193 | |
| 1194 | (let ((button (button-new "OK"))) |
| 1195 | (signal-connect button 'clicked #'(lambda () (widget-destroy window))) |
| 1196 | (setf (widget-can-default-p button) t) |
| 1197 | (box-pack-start action-area button t t 0) |
| 1198 | (widget-grab-default button) |
| 1199 | (widget-show button)) |
| 1200 | |
| 1201 | (let ((button (button-new "Toggle")) |
| 1202 | (label nil)) |
| 1203 | (signal-connect |
| 1204 | button 'clicked |
| 1205 | #'(lambda () |
| 1206 | (if (not label) |
| 1207 | (progn |
| 1208 | (setq label (label-new "Dialog Test")) |
| 1209 | (signal-connect label 'destroy #'widget-destroy :object label) |
| 1210 | (setf (misc-xpad label) 10) |
| 1211 | (setf (misc-ypad label) 10) |
| 1212 | (box-pack-start main-box label t t 0) |
| 1213 | (widget-show label)) |
| 1214 | (progn |
| 1215 | (widget-destroy label) |
| 1216 | (setq label nil))))) |
| 1217 | (setf (widget-can-default-p button) t) |
| 1218 | (box-pack-start action-area button t t 0) |
| 1219 | (widget-grab-default button) |
| 1220 | (widget-show button))) |
| 1221 | |
| 1222 | |
| 1223 | |
| 1224 | ;; Entry |
| 1225 | |
| 1226 | (define-standard-dialog create-entry "Entry" |
| 1227 | (setf (container-border-width main-box) 10) |
| 1228 | (setf (box-spacing main-box) 10) |
| 1229 | (let ((entry (make-instance 'entry |
| 1230 | :test "hello world" |
| 1231 | :visible t |
| 1232 | :parent (list main-box :fill t :expand t)))) |
| 1233 | (entry-select-region entry 0 5) |
| 1234 | |
| 1235 | (let ((combo (make-instance 'combo |
| 1236 | :visible t |
| 1237 | :parent (list main-box :expand t :fill t)))) |
| 1238 | (setf |
| 1239 | (combo-popdown-strings combo) |
| 1240 | '("item0" |
| 1241 | "item1 item1" |
| 1242 | "item2 item2 item2" |
| 1243 | "item3 item3 item3 item3" |
| 1244 | "item4 item4 item4 item4 item4" |
| 1245 | "item5 item5 item5 item5 item5 item5" |
| 1246 | "item6 item6 item6 item6 item6" |
| 1247 | "item7 item7 item7 item7" |
| 1248 | "item8 item8 item8" |
| 1249 | "item9 item9")) |
| 1250 | (editable-select-region entry 0 5)) |
| 1251 | |
| 1252 | (let ((check-button (check-button-new "Editable"))) |
| 1253 | (box-pack-start main-box check-button nil t 0) |
| 1254 | (signal-connect |
| 1255 | check-button 'toggled |
| 1256 | #'(lambda () |
| 1257 | (setf |
| 1258 | (editable-editable-p entry) |
| 1259 | (toggle-button-active-p check-button)))) |
| 1260 | (setf (toggle-button-active-p check-button) t) |
| 1261 | (widget-show check-button)) |
| 1262 | |
| 1263 | (let ((check-button (check-button-new "Visible"))) |
| 1264 | (box-pack-start main-box check-button nil t 0) |
| 1265 | (signal-connect |
| 1266 | check-button 'toggled |
| 1267 | #'(lambda () |
| 1268 | (setf |
| 1269 | (entry-visible-p entry) |
| 1270 | (toggle-button-active-p check-button)))) |
| 1271 | (setf (toggle-button-active-p check-button) t) |
| 1272 | (widget-show check-button)) |
| 1273 | |
| 1274 | (let ((check-button (check-button-new "Sensitive"))) |
| 1275 | (box-pack-start main-box check-button nil t 0) |
| 1276 | (signal-connect |
| 1277 | check-button 'toggled |
| 1278 | #'(lambda () |
| 1279 | (setf |
| 1280 | (widget-sensitive-p entry) |
| 1281 | (toggle-button-active-p check-button)))) |
| 1282 | (setf (toggle-button-active-p check-button) t) |
| 1283 | (widget-show check-button)))) |
| 1284 | |
| 1285 | |
| 1286 | |
| 1287 | ;; File selecetion dialog |
| 1288 | |
| 1289 | (let ((filesel nil)) |
| 1290 | (defun create-file-selection () |
| 1291 | (unless filesel |
| 1292 | (setq filesel (file-selection-new "file selection dialog")) |
| 1293 | (file-selection-hide-fileop-buttons filesel) |
| 1294 | (setf (window-position filesel) :mouse) |
| 1295 | (signal-connect |
| 1296 | filesel 'destroy #'(lambda () (widget-destroyed filesel))) |
| 1297 | (signal-connect |
| 1298 | (file-selection-ok-button filesel) 'clicked |
| 1299 | #'(lambda () |
| 1300 | (format |
| 1301 | t "Selected file: ~A~%" (file-selection-filename filesel)) |
| 1302 | (widget-destroy filesel))) |
| 1303 | (signal-connect |
| 1304 | (file-selection-cancel-button filesel) 'clicked |
| 1305 | #'widget-destroy :object filesel) |
| 1306 | |
| 1307 | (let ((button (button-new "Hide Fileops"))) |
| 1308 | (signal-connect |
| 1309 | button 'clicked |
| 1310 | #'file-selection-hide-fileop-buttons :object filesel) |
| 1311 | (box-pack-start (file-selection-action-area filesel) button nil nil 0) |
| 1312 | (widget-show button)) |
| 1313 | |
| 1314 | (let ((button (button-new "Show Fileops"))) |
| 1315 | (signal-connect |
| 1316 | button 'clicked |
| 1317 | #'file-selection-show-fileop-buttons :object filesel) |
| 1318 | (box-pack-start (file-selection-action-area filesel) button nil nil 0) |
| 1319 | (widget-show button))) |
| 1320 | |
| 1321 | (if (not (widget-visible-p filesel)) |
| 1322 | (widget-show-all filesel) |
| 1323 | (widget-destroy filesel)))) |
| 1324 | |
| 1325 | |
| 1326 | |
| 1327 | ;;; Handle box |
| 1328 | |
| 1329 | (defun create-handle-box-toolbar () |
| 1330 | (let ((toolbar (toolbar-new :horizontal :both))) |
| 1331 | (toolbar-append-item |
| 1332 | toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm") |
| 1333 | :tooltip-text "Horizontal toolbar layout" |
| 1334 | :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal))) |
| 1335 | |
| 1336 | (toolbar-append-item |
| 1337 | toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm") |
| 1338 | :tooltip-text "Vertical toolbar layout" |
| 1339 | :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical))) |
| 1340 | |
| 1341 | (toolbar-append-space toolbar) |
| 1342 | |
| 1343 | (toolbar-append-item |
| 1344 | toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm") |
| 1345 | :tooltip-text "Only show toolbar icons" |
| 1346 | :callback #'(lambda () (setf (toolbar-style toolbar) :icons))) |
| 1347 | |
| 1348 | (toolbar-append-item |
| 1349 | toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm") |
| 1350 | :tooltip-text "Only show toolbar text" |
| 1351 | :callback #'(lambda () (setf (toolbar-style toolbar) :text))) |
| 1352 | |
| 1353 | (toolbar-append-item |
| 1354 | toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm") |
| 1355 | :tooltip-text "Show toolbar icons and text" |
| 1356 | :callback #'(lambda () (setf (toolbar-style toolbar) :both))) |
| 1357 | |
| 1358 | (toolbar-append-space toolbar) |
| 1359 | |
| 1360 | (toolbar-append-item |
| 1361 | toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm") |
| 1362 | :tooltip-text "Use small spaces" |
| 1363 | :callback #'(lambda () (setf (toolbar-space-size toolbar) 5))) |
| 1364 | |
| 1365 | (toolbar-append-item |
| 1366 | toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm") |
| 1367 | :tooltip-text "Use big spaces" |
| 1368 | :callback #'(lambda () (setf (toolbar-space-size toolbar) 10))) |
| 1369 | |
| 1370 | (toolbar-append-space toolbar) |
| 1371 | |
| 1372 | (toolbar-append-item |
| 1373 | toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm") |
| 1374 | :tooltip-text "Enable tooltips" |
| 1375 | :callback #'(lambda () (toolbar-enable-tooltips toolbar))) |
| 1376 | |
| 1377 | (toolbar-append-item |
| 1378 | toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm") |
| 1379 | :tooltip-text "Disable tooltips" |
| 1380 | :callback #'(lambda () (toolbar-disable-tooltips toolbar))) |
| 1381 | |
| 1382 | (toolbar-append-space toolbar) |
| 1383 | |
| 1384 | (toolbar-append-item |
| 1385 | toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm") |
| 1386 | :tooltip-text "Show borders" |
| 1387 | :callback #'(lambda () (setf (toolbar-relief toolbar) :normal))) |
| 1388 | |
| 1389 | (toolbar-append-item |
| 1390 | toolbar "Borderless" (pixmap-new "cl-gtk:src;test.xpm") |
| 1391 | :tooltip-text "Hide borders" |
| 1392 | :callback #'(lambda () (setf (toolbar-relief toolbar) :none))) |
| 1393 | |
| 1394 | toolbar)) |
| 1395 | |
| 1396 | |
| 1397 | (defun handle-box-child-signal (handle-box child action) |
| 1398 | (format t "~S: child ~S ~A~%" handle-box child action)) |
| 1399 | |
| 1400 | |
| 1401 | (define-test-window create-handle-box "Handle Box Test" |
| 1402 | (setf (window-allow-grow-p window) t) |
| 1403 | (setf (window-allow-shrink-p window) t) |
| 1404 | (setf (window-auto-shrink-p window) nil) |
| 1405 | (setf (container-border-width window) 20) |
| 1406 | (let ((vbox (vbox-new nil 0))) |
| 1407 | (container-add window vbox) |
| 1408 | |
| 1409 | (container-add vbox (label-new "Above")) |
| 1410 | (container-add vbox (hseparator-new)) |
| 1411 | |
| 1412 | (let ((hbox (hbox-new nil 10))) |
| 1413 | (container-add vbox hbox) |
| 1414 | |
| 1415 | (let ((handle-box (handle-box-new))) |
| 1416 | (box-pack-start hbox handle-box nil nil 0) |
| 1417 | (signal-connect |
| 1418 | handle-box 'child-attached |
| 1419 | #'(lambda (child) |
| 1420 | (handle-box-child-signal handle-box child "attached"))) |
| 1421 | (signal-connect |
| 1422 | handle-box 'child-detached |
| 1423 | #'(lambda (child) |
| 1424 | (handle-box-child-signal handle-box child "detached"))) |
| 1425 | (container-add handle-box (create-handle-box-toolbar))) |
| 1426 | |
| 1427 | (let ((handle-box (handle-box-new))) |
| 1428 | (box-pack-start hbox handle-box nil nil 0) |
| 1429 | (signal-connect |
| 1430 | handle-box 'child-attached |
| 1431 | #'(lambda (child) |
| 1432 | (handle-box-child-signal handle-box child "attached"))) |
| 1433 | (signal-connect |
| 1434 | handle-box 'child-detached |
| 1435 | #'(lambda (child) |
| 1436 | (handle-box-child-signal handle-box child "detached"))) |
| 1437 | |
| 1438 | (let ((handle-box2 (handle-box-new))) |
| 1439 | (container-add handle-box handle-box2) |
| 1440 | (signal-connect |
| 1441 | handle-box2 'child-attached |
| 1442 | #'(lambda (child) |
| 1443 | (handle-box-child-signal handle-box child "attached"))) |
| 1444 | (signal-connect |
| 1445 | handle-box2 'child-detached |
| 1446 | #'(lambda (child) |
| 1447 | (handle-box-child-signal handle-box child "detached"))) |
| 1448 | (container-add handle-box2 (label-new "Foo!"))))) |
| 1449 | |
| 1450 | (container-add vbox (hseparator-new)) |
| 1451 | (container-add vbox (label-new "Below")))) |
| 1452 | |
| 1453 | |
| 1454 | |
| 1455 | ;;; Labels |
| 1456 | |
| 1457 | (define-test-window create-labels "Labels" |
| 1458 | (setf (container-border-width window) 5) |
| 1459 | (let ((hbox (hbox-new nil 5))) |
| 1460 | (container-add window hbox) |
| 1461 | (let ((vbox (vbox-new nil 5))) |
| 1462 | (box-pack-start hbox vbox nil nil 0) |
| 1463 | |
| 1464 | (let ((frame (frame-new "Normal Label"))) |
| 1465 | (container-add frame (label-new "This is a Normal label")) |
| 1466 | (box-pack-start vbox frame nil nil 0)) |
| 1467 | |
| 1468 | (let ((frame (frame-new "Multi-line Label"))) |
| 1469 | (container-add frame (label-new |
| 1470 | "This is a Multi-line label. |
| 1471 | Second line |
| 1472 | Third line")) |
| 1473 | (box-pack-start vbox frame nil nil 0)) |
| 1474 | |
| 1475 | (let ((frame (frame-new "Left Justified Label")) |
| 1476 | (label (label-new |
| 1477 | "This is a Left-Justified |
| 1478 | Multi-line. |
| 1479 | Third line"))) |
| 1480 | (setf (label-justify label) :left) |
| 1481 | (container-add frame label) |
| 1482 | (box-pack-start vbox frame nil nil 0)) |
| 1483 | |
| 1484 | (let ((frame (frame-new "Right Justified Label")) |
| 1485 | (label (label-new |
| 1486 | "This is a Right-Justified |
| 1487 | Multi-line. |
| 1488 | Third line"))) |
| 1489 | (setf (label-justify label) :right) |
| 1490 | (container-add frame label) |
| 1491 | (box-pack-start vbox frame nil nil 0))) |
| 1492 | |
| 1493 | (let ((vbox (vbox-new nil 5))) |
| 1494 | (box-pack-start hbox vbox nil nil 0) |
| 1495 | |
| 1496 | (let ((frame (frame-new "Line wrapped label")) |
| 1497 | (label (label-new |
| 1498 | "This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick. |
| 1499 | It supports multiple paragraphs correctly, and correctly adds many extra spaces. "))) |
| 1500 | (setf (label-wrap-p label) t) |
| 1501 | (container-add frame label) |
| 1502 | (box-pack-start vbox frame nil nil 0)) |
| 1503 | |
| 1504 | (let ((frame (frame-new "Filled, wrapped label")) |
| 1505 | (label (label-new |
| 1506 | "This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do. |
| 1507 | This is a new paragraph. |
| 1508 | This is another newer, longer, better paragraph. It is coming to an end, unfortunately."))) |
| 1509 | (setf (label-justify label) :fill) |
| 1510 | (setf (label-wrap-p label) t) |
| 1511 | (container-add frame label) |
| 1512 | (box-pack-start vbox frame nil nil 0)) |
| 1513 | |
| 1514 | (let ((frame (frame-new "Underlined label")) |
| 1515 | (label (label-new |
| 1516 | "This label is underlined! |
| 1517 |
~mdw / clg / blame