layout.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 ;;;  --- packing ---------------------------------------------------------
  22
  23 (defobserver packing ()
  24   (when new-value
  25     (assert (null (kids-packing .parent)) ()
  26       "Do not specify packing (here for ~a) unless parent leaves kids-packing unspecified.
  27 This parent is ~a, kids-packing ~a" self (list .parent (type-of .parent)) (kids-packing .parent)))
  28   ;
  29   ; This use next of the parent instead of self is pretty tricky. It has to do with getting
  30   ; the pack commands out with nested widgets pacing before parents. The pack command issued on behalf
  31   ; of a top frame is sorted on the parent. Now we have to pack the top frame. If we associate
  32   ; the command with the frame, the sort is a tie and either might go first. So we continue
  33   ; the theme and associate /this/ pack with this top frame's parent. Note that we cannot go the
  34   ; normal route and pack the kids in their own context, because multiple kids get packed
  35   ; in one pack statement (and we cannot arbitrarily pack with the first kid because this is a nested
  36   ; deal and any kid might have kids, so each family packs associated with itself)
  37   ;
  38   (when (and new-value (not (typep .parent 'panedwindow)))
  39     (tk-format `(:pack ,(fm-parent self)) new-value)))
  40
  41 (defmacro c?pack-self (&optional (modifier$ ""))
  42   `(c? (format nil "pack ~a ~a" (path self) ,modifier$)))
  43
  44 ;;; --- grids -------------------------------------------------------------------------
  45
  46 (defmodel grid-manager ()())
  47
  48 (defobserver gridding ((self grid-manager))
  49   (when new-value
  50     (loop for k in (^kids)
  51           when (gridding k)
  52           do (tk-format `(:grid ,k) (format nil "grid ~a ~a" (path k) (gridding k))))
  53     (destructuring-bind (&key columns rows) new-value
  54       (when columns
  55         (loop for config in columns
  56               for idx upfrom 0
  57               do (tk-format `(:grid ,self) (format nil "grid columnconfigure ~a ~a ~a" (^path) idx config))))
  58       (when columns
  59         (loop for config in rows
  60               for idx upfrom 0
  61               do (tk-format `(:grid ,self) (format nil "grid rowconfigure ~a ~a ~a" (^path) idx config)))))))