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