demos.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-user)
  20
  21
  22 (defmodel my-test (window)
  23  ((my-mode :accessor my-mode :initform (c? (evenp (selection (fm! :my-selector))))))
  24  (:default-initargs
  25      :id :my-test-id
  26    :kids (c? (the-kids
  27               (mk-stack ("stack"  :packing (c?pack-self "-side bottom") :relief 'ridge)
  28                         (mk-entry :id :my-entry
  29                                   :value (c-in "abc"))
  30                         (mk-row ( "row"  #| :packing (c?pack-self "-side bottom") |# :relief 'ridge)
  31                                 (mk-label :text (c? (format nil "selection: ~a"  (selection (fm^ :my-selector)))))
  32                               (mk-label :text "Labeltext")
  33                               (mk-button-ex ("Reset" (setf (selection (fm^ :my-selector)) 1)))
  34                               (mk-stack ((c? (format nil "current selection: ~a" (^selection))) :id :my-selector :selection (c-in 1) :relief 'ridge)
  35                                         (mk-radiobutton-ex ("selection 1" 1))
  36                                         (mk-radiobutton-ex ("selection 2" 2))
  37                                         (mk-radiobutton-ex ("selection 3" 3))
  38                                         (mk-radiobutton-ex ("selection 4" 4)))
  39                               (mk-label :text (c? (format nil "selection: ~a"  (selection (fm^ :my-selector)))))
  40                               ))))))
  41
  42 (defobserver my-mode ((self my-test) new-value old-value old-value-bound-p)
  43  (format t "~% mode changed from ~a to ~a" old-value new-value))
  44
  45 (defun ctk::franks-test ()
  46   (run-window 'my-test))
  47
  48 #+test
  49 (ctk::franks-test)
  50
  51 (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
  52   (test-window
  53    ;;'place-test
  54    ;; 'one-button-window
  55    ;;'ltktest-cells-inside
  56    ;;'menu-button-test
  57    ;;'spinbox-test
  58    'lotsa-widgets
  59    ;; Now in Gears project 'gears-demo
  60   ))
  61
  62 (defmodel place-test (window)
  63   ()
  64   (:default-initargs
  65       :kids (c? (the-kids
  66                  (mk-label :text "hi, Mom"
  67                    :parent-x 100
  68                    :py 20)))))
  69
  70 (defmodel one-button-window (window)
  71   ()
  72   (:default-initargs
  73       :kids (c? (the-kids
  74                  #+shhhh (mk-menubar
  75                   :kids (c? (the-kids
  76                              (mk-menu-entry-cascade-ex (:label "File")
  77                                (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
  78                                (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed"))))))
  79                  (mk-frame-stack
  80                   :packing (c?pack-self)
  81                   :kids (c? (the-kids
  82                              (mk-text-widget
  83                               :id :my-text
  84                               :value (c?n "[bzbzbzbz]")
  85                               :height 8
  86                               :width 25)
  87                              (make-instance 'entry
  88                                :id :entree
  89                                :fm-parent *parent*
  90                                :value (c-in "Boots")))))))))
  91
  92 (defun one-deep-menubar ()
  93   (mk-menubar
  94    :id 'mbar
  95    :kids (c? (the-kids
  96               (mk-menu-entry-cascade-ex (:label "File")
  97                             (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
  98                             (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))
  99               (mk-menu-entry-cascade
 100                :id 'editcascade
 101                :label "Edit"
 102                :kids (c? (the-kids
 103                           (mk-menu
 104                            :id 'editmenu
 105                            :kids (c? (the-kids
 106                                       (mk-menu-radio-group :id :app-font-face
 107                                         :selection (c-in "courier")
 108                                         :kids (c? (the-kids
 109                                                    (mk-menu-entry-radiobutton :label "Times" :value "times")
 110                                                    (mk-menu-entry-radiobutton :label "Courier" :value "courier")
 111                                                    (mk-menu-entry-radiobutton :label "Helvetica" :value "helvetica"))))))))))))))
 112
 113 (defmodel spinbox-test (window)
 114   ()
 115   (:default-initargs
 116       :kids (c? (the-kids
 117                  (mk-stack (:packing (c?pack-self))
 118                    (mk-spinbox
 119                     :id :spin-pkg
 120                     :value (c-in "cells") ;;(cells::c?n "cells")
 121                     :tk-values (mapcar 'down$
 122                                  (sort (mapcar 'package-name
 123                                          (list-all-packages))
 124                                    'string>)))
 125                    (mk-scrolled-list
 126                     :id :spinpkg-sym-list
 127                     :list-height 6
 128                     :list-item-keys (c? (trc "enter item keys" self (fm^ :spin-pkg))
 129                                       (let* ((spinner (fm^ :spin-pkg))
 130                                                (item (when spinner (value spinner)))
 131                                                (pkg (find-package (string-upcase item))))
 132                                           (when pkg
 133                                             (loop for sym being the symbols in pkg
 134                                                 for n below 5
 135                                                 counting sym into symct
 136                                                 collecting sym into syms
 137                                                 finally (return syms)))))
 138                     :list-item-factory (lambda (sym)
 139                                          (make-instance 'listbox-item
 140                                            :fm-parent *parent*
 141                                            :value sym
 142                                            :item-text (down$ (symbol-name sym)))))
 143                    (mk-label :text (c? (selection (fm^ :spinpkg-sym-list)))))))))
 144
 145
 146 (defmodel menu-button-test (window)
 147   ()
 148   (:default-initargs
 149       :kids (c? (the-kids
 150                  (mk-stack ("Style by Widgets" :id :widstyle :packing (c?pack-self))
 151                    (mk-popup-menubutton
 152                     :id :font-face
 153                     :initial-value (c? (second (^entry-values)))
 154                     :entry-values (c? (subseq (tk-eval-list "font families") 4 10)))
 155                    (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..."
 156                      :wraplength 200
 157                      :tk-justify 'left
 158                      :tkfont (c? (list
 159                                   (selection (fm^ :font-face))
 160                                   14))))))))
 161
 162 (defmodel font-view-2 (window)
 163   ()
 164   (:default-initargs
 165       :kids (c? (the-kids
 166                  (mk-panedwindow
 167                   :packing (c?pack-self)
 168                   :orient 'vertical
 169                   :kids  (c? (the-kids
 170                               (loop repeat 2
 171                                   collecting (make-instance 'font-view :fm-parent *parent*)))))))))
 172
 173 (defun mk-font-view ()
 174   (make-instance 'font-view))
 175
 176 (defmodel font-view (frame-stack)
 177   ()
 178   (:default-initargs
 179       :value (c? (tk-eval-list "font families"))
 180     :pady 2 :padx 4
 181     :packing-side 'left
 182     :layout-anchor 'nw
 183     :kids (c? (the-kids
 184                (mk-spinbox :id :font-face
 185                  :value (c-in (car (^value)))
 186                  :tk-values (c? (value .parent)))
 187                (mk-scale :id :font-size
 188                  :value (c-in 14)
 189                  :tk-label "Font Size"
 190                  :from 7 :to 24
 191                  :orient 'horizontal)
 192                (mk-label :id :txt
 193                  :text "Four score seven years ago today"
 194                  :wraplength 600
 195                  :tkfont (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24}
 196                             (value (fm^ :font-face))
 197                             (value (fm^ :font-size)))))))))
 198
 199 #| 06-02-14 following stuff not resurrected after latest revisions to Celtk
 200
 201 ;;; ---- toplevel --------------------------------
 202
 203
 204
 205
 206 (defmodel file-open (toplevel)
 207   ()
 208   (:default-initargs
 209     :value (c? (directory "\\windows\\fonts\\*.ttf"))
 210     :pady 2 :padx 4
 211     :kids  (c? (the-kids
 212                 (mk-spinbox :id :font-face
 213                   :value (c-in (car (^value)))
 214                  :tk-values (c? (mapcar 'pathname-name (value .parent))))
 215                 (mk-button-ex ("Open" (progn
 216                                      (tk-format `(:destroy ,self) "destroy ~a" (path (upper self toplevel)))
 217                                      (not-to-be (upper self toplevel))))
 218                  :underline 0)))))
 219
 220 |#