git.chise.org Git - chise/xemacs-chise.git.1/blob - tests/glyph-test.el

   1 (set-extent-begin-glyph
   2  (make-extent (point) (point))
   3  (setq im (make-glyph [xbm :file "xemacsicon.xbm"])))
   4
   5 (set-extent-begin-glyph
   6  (make-extent (point) (point))
   7  (make-glyph [string :data "xemacs"]))
   8
   9 (defun foo ()
  10   (interactive)
  11   (setq ok-select (not ok-select)))
  12
  13 (defun fee () (interactive) (message "hello"))
  14
  15 ;; button in a group
  16 (setq ok-select nil)
  17 (set-extent-begin-glyph
  18  (make-extent (point) (point))
  19  (make-glyph
  20   (setq radio-button1
  21         [button :face widget
  22                 :descriptor ["ok1" (setq ok-select t)
  23                              :style radio :selected ok-select]])))
  24 ;; button in a group
  25 (set-extent-begin-glyph
  26  (make-extent (point) (point))
  27  (make-glyph
  28   (setq radio-button2
  29         [button :descriptor ["ok2" (setq ok-select nil) :style radio
  30                              :selected (not ok-select)]])))
  31 ;; toggle button
  32 (set-extent-begin-glyph
  33  (make-extent (point) (point))
  34  (setq tbutton
  35        (make-glyph [button :descriptor ["ok3" (setq ok-select nil)
  36                                         :style toggle
  37                                         :selected (not ok-select)]])))
  38 (set-extent-begin-glyph
  39  (make-extent (point) (point))
  40  (make-glyph
  41   (setq toggle-button
  42         [button :descriptor ["ok4" :style toggle
  43                              :callback
  44                              (setq ok-select (not ok-select))
  45                              :selected ok-select]])))
  46
  47 ;; normal pushbutton
  48 (set-extent-begin-glyph
  49  (make-extent (point) (point))
  50  (setq push-button
  51        (make-glyph [button :width 10 :height 2
  52                            :face modeline-mousable
  53                            :descriptor "ok" :callback foo
  54                            :selected t])))
  55 ;; tree view
  56 (set-extent-begin-glyph
  57  (make-extent (point) (point))
  58  (setq tree (make-glyph
  59              [tree-view :width 10
  60                         :descriptor "My Tree"
  61                         :items (["One" foo]
  62                                 (["Two" foo]
  63                                  ["Four" foo]
  64                                  "Six")
  65                                 "Three")])))
  66
  67 ;; tab control
  68 (set-extent-begin-glyph
  69  (make-extent (point) (point))
  70  (setq tab (make-glyph
  71             [tab-control :descriptor "My Tab"
  72                          :face highlight
  73                          :orientation right
  74                          :items (["One" foo :selected t]
  75                                  ["Two" fee :selected nil]
  76                                  ["Three" foo :selected nil])])))
  77
  78 ;; progress gauge
  79 (set-extent-begin-glyph
  80  (make-extent (point) (point))
  81  (setq pgauge (make-glyph
  82                [progress-gauge :width 10 :height 2 :value 0
  83                                :descriptor "ok"])))
  84 ;; progress the progress ...
  85 (let ((x 0))
  86   (while (<= x 100)
  87     (set-glyph-image pgauge `[progress-gauge :width 10 :height 2
  88                                              :descriptor "ok" :value ,x])
  89     (setq x (+ x 5))
  90     (sit-for 0.1)))
  91
  92 ;; progress gauge in the modeline
  93 (setq global-mode-string
  94       (cons (make-extent nil nil)
  95             (setq pg (make-glyph
  96                       [progress-gauge :width 5 :pixel-height 16
  97                                       :descriptor "ok"]))))
  98 ;; progress the progress ...
  99 (let ((x 0))
 100   (while (<= x 100)
 101     (set-glyph-image pg
 102                      `[progress-gauge :width 5 :pixel-height 16
 103                                       :descriptor "ok" :value ,x])
 104     (setq x (+ x 5))
 105     (redisplay-frame)
 106     (sit-for 0.1)))
 107
 108 (set-extent-begin-glyph
 109  (make-extent (point) (point))
 110  (make-glyph
 111   [button :face modeline-mousable
 112           :descriptor "ok" :callback foo
 113           :image [xpm :file "../etc/xemacs-icon.xpm"]]))
 114
 115 ;; normal pushbutton
 116 (set-extent-begin-glyph
 117  (make-extent (point) (point))
 118  (setq pbutton
 119        (make-glyph [button :descriptor ["A Big Button" foo ]])))
 120
 121 ;; edit box
 122 (set-extent-begin-glyph
 123  (make-extent (point) (point))
 124  (make-glyph (setq edit-field [edit-field :pixel-width 50 :pixel-height 30
 125                                           :face bold-italic
 126                                           :descriptor ["Hello"]])))
 127 ;; combo box
 128 (set-extent-begin-glyph
 129  (make-extent (point) (point))
 130  (make-glyph (setq combo-box
 131                    [combo-box :width 10 :descriptor ["Hello"]
 132                               :items ("One" "Two" "Three")])))
 133
 134 ;; label
 135 (set-extent-begin-glyph
 136  (make-extent (point) (point))
 137  (make-glyph (setq label [label :pixel-width 150 :descriptor "Hello"])))
 138
 139 ;; string
 140 (set-extent-begin-glyph
 141  (make-extent (point) (point))
 142  (make-glyph
 143   (setq str
 144         [string :data "Hello There"])))
 145
 146 ;; scrollbar
 147 ;(set-extent-begin-glyph
 148 ; (make-extent (point) (point))
 149 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]]))
 150
 151 ;; generic subwindow
 152 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 70]))
 153 (set-extent-begin-glyph (make-extent (point) (point)) sw)
 154
 155 ;; layout
 156 (setq layout
 157       (make-glyph
 158        `[layout :descriptor "The Layout"
 159                 :orientation vertical
 160                 :justify left
 161                 :border [string :data "Hello There Mrs"]
 162                 :items ([layout :orientation horizontal
 163                                 :items (,radio-button1 ,radio-button2)]
 164                         ,edit-field ,toggle-button ,label ,str)]))
 165 ;(set-glyph-face layout 'gui-element)
 166 (set-extent-begin-glyph
 167  (make-extent (point) (point)) layout)
 168
 169 ;; another test layout
 170 (set-extent-begin-glyph
 171  (make-extent (point) (point))
 172  (setq layout-2
 173        (make-glyph `[layout :descriptor "The Layout"
 174                             :orientation vertical
 175                             :items ([progress-gauge :value 0 :width 10 :height 2
 176                                                     :descriptor "ok"])])))
 177
 178 (set-glyph-image layout-2 `[layout :descriptor "The Layout"
 179                                    :orientation vertical
 180                                    :items ([progress-gauge :value 4 :width 10 :height 2
 181                                                            :descriptor "ok"])])
 182 (setq test-toggle-widget nil)
 183
 184 (defun test-toggle (widget)
 185   (set-extent-begin-glyph
 186    (make-extent (point) (point))
 187    (make-glyph (vector 'button
 188                        :descriptor "ok"
 189                        :style 'toggle
 190                        :selected `(funcall test-toggle-value
 191                                            ,widget)
 192                        :callback `(funcall test-toggle-action
 193                                            ,widget)))))
 194
 195 (defun test-toggle-action (widget &optional event)
 196   (if widget
 197       (message "Widget is t")
 198     (message "Widget is nil")))
 199
 200 (defun test-toggle-value (widget)
 201   (setq widget (not widget))
 202   (not widget))