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     (sit-for 0.1)))
 106
 107 (set-extent-begin-glyph
 108  (make-extent (point) (point))
 109  (make-glyph
 110   [button :face modeline-mousable
 111           :descriptor "ok" :callback foo
 112           :image [xpm :file "../etc/xemacs-icon.xpm"]]))
 113
 114 ;; normal pushbutton
 115 (set-extent-begin-glyph
 116  (make-extent (point) (point))
 117  (setq pbutton
 118        (make-glyph [button :descriptor ["A Big Button" foo ]])))
 119
 120 ;; edit box
 121 (set-extent-begin-glyph
 122  (make-extent (point) (point))
 123  (make-glyph (setq edit-field [edit-field :pixel-width 50 :pixel-height 30
 124                                           :face bold-italic
 125                                           :descriptor ["Hello"]])))
 126 ;; combo box
 127 (set-extent-begin-glyph
 128  (make-extent (point) (point))
 129  (make-glyph (setq combo-box
 130                    [combo-box :width 10 :descriptor ["Hello"]
 131                               :items ("One" "Two" "Three")])))
 132
 133 ;; label
 134 (set-extent-begin-glyph
 135  (make-extent (point) (point))
 136  (make-glyph (setq label [label :pixel-width 150 :descriptor "Hello"])))
 137
 138 ;; string
 139 (set-extent-begin-glyph
 140  (make-extent (point) (point))
 141  (make-glyph
 142   (setq str
 143         [string :data "Hello There"])))
 144
 145 ;; scrollbar
 146 ;(set-extent-begin-glyph
 147 ; (make-extent (point) (point))
 148 ; (make-glyph [scrollbar :width 50 :height 20 :descriptor ["Hello"]]))
 149
 150 ;; generic subwindow
 151 (setq sw (make-glyph [subwindow :pixel-width 50 :pixel-height 70]))
 152 (set-extent-begin-glyph (make-extent (point) (point)) sw)
 153
 154 ;; layout
 155 (setq layout
 156       (make-glyph
 157        `[layout :descriptor "The Layout"
 158                 :orientation vertical
 159                 :justify left
 160                 :border [string :data "Hello There Mrs"]
 161                 :items ([layout :orientation horizontal
 162                                 :items (,radio-button1 ,radio-button2)]
 163                         ,edit-field ,toggle-button ,label ,str)]))
 164 ;(set-glyph-face layout 'gui-element)
 165 (set-extent-begin-glyph
 166  (make-extent (point) (point)) layout)
 167
 168 ;; another test layout
 169 (set-extent-begin-glyph
 170  (make-extent (point) (point))
 171  (setq layout-2
 172        (make-glyph `[layout :descriptor "The Layout"
 173                             :orientation vertical
 174                             :items ([progress-gauge :value 0 :width 10 :height 2
 175                                                     :descriptor "ok"])])))
 176
 177 (set-glyph-image layout-2 `[layout :descriptor "The Layout"
 178                                    :orientation vertical
 179                                    :items ([progress-gauge :value 4 :width 10 :height 2
 180                                                            :descriptor "ok"])])
 181 (setq test-toggle-widget nil)
 182
 183 (defun test-toggle (widget)
 184   (set-extent-begin-glyph
 185    (make-extent (point) (point))
 186    (make-glyph (vector 'button
 187                        :descriptor "ok"
 188                        :style 'toggle
 189                        :selected `(funcall test-toggle-value
 190                                            ,widget)
 191                        :callback `(funcall test-toggle-action
 192                                            ,widget)))))
 193
 194 (defun test-toggle-action (widget &optional event)
 195   (if widget
 196       (message "Widget is t")
 197     (message "Widget is nil")))
 198
 199 (defun test-toggle-value (widget)
 200   (setq widget (not widget))
 201   (not widget))