lotsa-widgets.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
  20 (in-package :celtk-user)
  21
  22 ;;; Creates a pathname with NAME and TYPE in the same
  23 ;;; directory/host/device/whatever as this lisp file. Tries to get
  24 ;;; that at compile time to cope with some useful ASDF extensions that
  25 ;;; place fasls in arbitrary places.
  26 (defun data-pathname (name type)
  27   (merge-pathnames (make-pathname :name name :type type)
  28                    #.(or *compile-file-truename* *load-truename*)))
  29
  30 (defmodel lotsa-widgets (window)
  31   ()
  32   (:default-initargs
  33       :kids (c? (the-kids
  34                  (demo-all-menubar)
  35
  36                  (mk-row (:packing (c?pack-self))
  37                    (mk-label :text "aaa"
  38                      :image-files (list (list 'kt (data-pathname "kt69" "gif")))
  39                      :height 400
  40                      :width 300
  41                      :image (c? (format nil "~(~a.~a~)" (ctk::^path) 'kt)))
  42
  43                    (assorted-canvas-items)
  44
  45                    (mk-row ()
  46                      (mk-stack ()
  47                        (style-by-edit-menu)
  48                        (mk-row ()
  49                          (mk-stack ()
  50                            (mk-text-widget
  51                             :id :my-text
  52                             :value (c?n "hello, world")
  53                             :height 8
  54                             :width 25)
  55
  56                            (spin-package-with-symbols))
  57
  58                          (mk-stack ()
  59                            (mk-row (:id :radio-ny :selection (c-in 'yes))
  60                              (mk-radiobutton-ex ("yes" 'yes))
  61                              (mk-radiobutton-ex ("no" 'no))
  62                              (mk-label :text (c? (string (selection (upper self tk-selector))))))
  63                            (mk-row ()
  64                              (mk-checkbutton :id :check-me
  65                                :text "Check Me"
  66                                :value (c-in t))
  67                              (mk-label :text (c? (if (fm^v :check-me) "checked" "unchecked"))))
  68                            (mk-row ()
  69                              (mk-button-ex ("Time now?" (setf (fm^v :push-time)
  70                                                           (get-universal-time))))
  71                              (mk-label :text (c? (time-of-day (^value)))
  72                                :id :push-time
  73                                :value (c-in (get-universal-time))))
  74                            (style-by-widgets)
  75
  76                            (mk-row (:layout-anchor 'sw)
  77                              (mk-entry :id :enter-me)
  78
  79                              (mk-label :text (c? (conc$ "echo " (fm^v :enter-me))))))
  80
  81                          (mk-stack ()
  82                            (duelling-scrolled-lists)
  83                            #+tcl-quicktime
  84                            (mk-row ()
  85                              (mk-button-ex ("Serious Demo" (plug-n-play-movie (fm^ :play-me)
  86                                                              "c:/0dev/celtk/demo.mov"))
  87                                :id :serious-demo)
  88                              (mk-button-ex ("Celtk?" (plug-n-play-movie (fm^ :play-me)
  89                                                        "c:/0dev/celtk/good-thing2.mov"))))
  90                            #+tcl-quicktime
  91                            (mk-movie :id :play-me
  92                              :loopstate (c-in 0) :palindromeloopstate (c-in 0)
  93                              :tk-file (c? (let ((entry (fm^v :enter-me)))
  94                                             (cond
  95                                              ((find entry '("bush" "war" "anger" "hate") :test 'string-equal)
  96                                               "c:/0dev/celtk/demo.mov")
  97                                              ((find entry '("sex" "drugs" "rock-n-roll" "peace") :test 'string-equal)
  98                                               "c:/0dev/celtk/good-thing2.mov")
  99                                              (t "c:/0dev/celtk/good-thing2.mov" #+not .cache))))))))))))))
 100
 101
 102 (defun style-by-edit-menu ()
 103   (mk-row ("Style by Edit Menu")
 104     (mk-label :text "Four score and seven years ago today"
 105       :wraplength 600
 106       :tkfont (c? (list
 107                    (selection (fm^ :app-font-face))
 108                    (selection (fm^ :app-font-size))
 109                    (if (fm^v :app-font-italic)
 110                        'italic 'roman)
 111                    (if (fm^v :app-font-bold)
 112                        'bold 'normal))))))
 113
 114 (defun spin-package-with-symbols ()
 115   (mk-stack ()
 116     (mk-spinbox
 117      :id :spin-pkg
 118      :value (cells::c?n "cells")
 119      :tk-values (mapcar 'down$
 120                   (sort (mapcar 'package-name
 121                           (list-all-packages))
 122                     'string>)))
 123     (mk-scrolled-list
 124      :id :spinpkg-sym-list
 125      :list-height 6
 126      :list-item-keys (c? (let* ((spinner (fm^ :spin-pkg))
 127                                 (item (when spinner (value spinner)))
 128                                 (pkg (find-package (string-upcase item))))
 129                            (when pkg
 130                              (loop for sym being the symbols in pkg
 131                                    for n below 25
 132                                    counting sym into symct
 133                                    collecting sym into syms
 134                                    finally (return syms)))))
 135      :list-item-factory (lambda (sym)
 136                           (make-instance 'listbox-item
 137                             :fm-parent *parent*
 138                             :value sym
 139                             :item-text (down$ (symbol-name sym)))))))
 140
 141 (defun duelling-scrolled-lists ()
 142   (mk-row ()
 143     (mk-scrolled-list
 144      :id :pkg-list
 145      :selection (c-in (find-package "ASDF"))
 146      :list-height 6
 147      :list-item-keys (list-all-packages)
 148      :list-item-factory (lambda (pkg)
 149                           (make-instance 'listbox-item
 150                             :fm-parent *parent*
 151                             :value pkg
 152                             :item-text (down$ (package-name pkg)))))
 153     (mk-scrolled-list
 154      :id :pkg-sym-list
 155      :list-height 6
 156      :list-item-keys (c? (bwhen (pkg (selection (fm^ :pkg-list)))
 157                            (loop  for sym being the present-symbols in pkg
 158                                  for n below 25
 159                                collecting sym)))
 160      :list-item-factory (lambda (sym)
 161                           (make-instance 'listbox-item
 162                             :value sym
 163                             :fm-parent *parent*
 164                             :item-text (down$ (symbol-name sym)))))))
 165
 166 (defun assorted-canvas-items ()
 167   (mk-canvas
 168    :height 350
 169    :kids (c? (the-kids
 170               (mk-bitmap :coords (list 140 140)
 171                 :bitmap (conc$ "@" (namestring (data-pathname "x1" "xbm"))))
 172               (mk-rectangle :coords (list 10 10 100 60)
 173                 :tk-fill "red")
 174               (mk-text-item :coords (list 100 80)
 175                 :text "i am an item"
 176                 :tk-fill 'blue)
 177               (mk-arc :coords (list 10 100 100 160)
 178                 :start 45
 179                 :tk-fill "orange")
 180               (mk-line :coords (list 250 10 300 40 250 70 400 100)
 181                 :width 8
 182                 :smooth 'bezier
 183                 :joinstyle 'miter
 184                 :arrow 'both
 185                 :tk-fill 'purple)
 186               (mk-oval :coords (list 10 200 100 260)
 187                 :tk-fill "yellow")
 188               (mk-polygon :coords (list 250 210 300 220 340 200 260 180)
 189                 :width 4
 190                 :tk-fill 'green
 191                 :smooth 'bezier
 192                 :joinstyle 'miter)
 193               (mk-arc :coords (list 10 300 100 360)
 194                 :start 45
 195                 :tk-fill "white")
 196               ))))
 197
 198 (defun style-by-widgets ()
 199   (mk-stack ("Style by Widgets" :id :widstyle)
 200     (mk-row (:id :stywid
 201               :packing-side 'left
 202               :layout-anchor 'sw)
 203       (mk-popup-menubutton
 204        :id :font-face
 205        :initial-value (c? (second (^entry-values)))
 206        :entry-values (c? (subseq (tk-eval-list "font families") 4 10)))
 207
 208       (mk-scale :id :font-size
 209         :value (c-in 14)
 210         :tk-label "Font Size"
 211         :from 7 :to 24
 212         :orient 'horizontal))
 213
 214
 215     (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..."
 216       :wraplength 200
 217       :tk-justify 'left
 218       :tkfont (c? (list
 219                  (selection (fm^ :font-face))
 220                  (value (fm^ :font-size)))))))
 221
 222 (defun demo-all-menubar ()
 223   (mk-menubar
 224    :id 'mbar
 225    :kids (c? (the-kids
 226               (mk-menu-entry-cascade
 227                :id 'file
 228                :label "File"
 229                :kids (c? (the-kids
 230                           (mk-menu
 231                            :id 'filemenu
 232                            :kids (c? (the-kids
 233                                       (mk-menu-entry-command :label "New" :command "tk_getOpenFile") ;; not quite right, is it?
 234                                       (mk-menu-entry-command :label "Open" :command "tk_getOpenFile")
 235                                       (mk-menu-entry-command :label "Close" :command "{destroy .}")
 236                                       (mk-menu-entry-separator)
 237                                       (mk-menu-entry-command :label "Quit"
 238                                         :state (c? (if t ;; (value (fm^ :check-me))
 239                                                        'normal 'disabled))
 240                                         :command "tk_getOpenFile"))))))) ;; 'exit' in production, but under dev would take out Lisp IDE
 241               (mk-menu-entry-cascade
 242                :id 'editcascade
 243                :label "Edit"
 244                :kids (c? (the-kids
 245                           (mk-menu
 246                            :id 'editmenu
 247                            :kids (c? (the-kids
 248                                       (mk-menu-entry-command :label "Undo"
 249                                         :on-command  (lambda (self)
 250                                                          (trc "edit menu undo" self)))
 251                                       (mk-menu-entry-separator)
 252                                       (mk-menu-entry-command :label "Cut" :command "exit")
 253                                       (mk-menu-entry-command :label "Copy" :command "exit")
 254                                       (mk-menu-entry-command :label "Paste" :command "exit")
 255                                       (mk-menu-entry-command :label "Clear" :command "exit")
 256                                       (mk-menu-entry-separator)
 257                                       (mk-menu-radio-group :id :app-font-face
 258                                         :selection (c-in "courier")
 259                                         :kids (c? (the-kids
 260                                                    (mk-menu-entry-radiobutton :label "Times" :value "times")
 261                                                    (mk-menu-entry-radiobutton :label "Courier" :value "courier")
 262                                                    (mk-menu-entry-radiobutton :label "Helvetica" :value "helvetica"))))
 263                                       (mk-menu-entry-separator)
 264                                       (mk-menu-entry-cascade
 265                                        :id :app-font-size
 266                                        :label "Font Size"
 267                                        :menu (c? (path (kid1 self)))
 268                                        :selection (c-in 12)
 269                                        :kids (c? (the-kids
 270                                                   (mk-menu
 271                                                    :id :fsztoff
 272                                                    :tearoff 1
 273                                                    :kids (c? (the-kids
 274                                                               (loop for (label value) in '(("9" 9)("12" 12)("14"  14))
 275                                                                   collecting (mk-menu-entry-radiobutton :label label :value value))))))))
 276                                       (mk-menu-entry-separator)
 277                                       (mk-menu-entry-checkbutton :id :app-font-italic :label "Italic")
 278                                       (mk-menu-entry-checkbutton :id :app-font-bold :label "Bold" :value (c-in t))))))))))))
 279
 280