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