1;; Copyright (C) 2004 Patrick Bernaud 2;; GNU General Public License version 2 or later. No warrantee. 3 4(define-module (demos appwindow) 5 :use-module (oop goops) 6 :use-module (gnome gobject) 7 :use-module (gnome gtk) 8 :use-module (gnome gtk gdk-event)) 9 10 11(define window #f) 12 13 14(define (activate-action action) 15 (let* ((name (get-name action)) 16 (dialog (make <gtk-message-dialog> 17 :transient-for window 18 :destroy-with-parent #t 19 :message-type 'info 20 :buttons 'close 21 :text (format 22 #f 23 "You activated action: \"~A\" of type \"~A\"" 24 name (class-of action))))) 25 ;; close dialog on user response 26 (connect dialog 'response (lambda (d arg1) 27 (gtk-widget-destroy dialog))) 28 29 (show dialog))) 30 31(define (activate-radio-action action current) 32 (if (get-active current) 33 (let ((dialog (make <gtk-message-dialog> 34 :transient-for window 35 :destroy-with-parent #t 36 :message-type 'info 37 :buttons 'close 38 :text (format 39 #f 40 "You activated radio action: \"~A\" of type \"~A\".\nCurrent value: ~A" 41 (get-name current) 42 (class-of action) 43 (get-current-value current))))) 44 ;; close dialog on user response 45 (connect dialog 'response (lambda (d arg1) 46 (destroy dialog))) 47 48 (show dialog)))) 49 50 51(define entries 52 `(("FileMenu" #f "_File") ; name, stock id, label 53 ("PreferencesMenu" #f "_Preferences") ; name, stock id, label 54 ("ColorMenu" #f "_Color") ; name, stock id, label 55 ("ShapeMenu" #f "_Shape") ; name, stock id, label 56 ("HelpMenu" #f "_Help") ; name, stock id, label 57 ("New" ,(gtk-stock-id 'new) "_New" ; name, stock id, label 58 "<control>N" ; accelerator 59 "Create a new file" ; tooltip 60 ,activate-action) 61 ("Open" ,(gtk-stock-id 'open) "_Open" ; name, stock id, label 62 "<control>O" ; accelerator 63 "Open a file" ; tooltip 64 ,activate-action) 65 ("Save" ,(gtk-stock-id 'save) "_Save" ; name, stock id, label 66 "<control>S" ; accelerator 67 "Save current file" ; tooltip 68 ,activate-action) 69 ("SaveAs" ,(gtk-stock-id 'save) "Save _As..." ; name, stock id, label 70 #f ; accelerator 71 "Save to a file" ; tooltip 72 ,activate-action) 73 ("Quit" ,(gtk-stock-id 'quit) "_Quit" ; name, stock id, label 74 "<control>Q" ; accelerator 75 "Quit" ; tooltip 76 ,activate-action) 77 ("About" #f "_About" ; name, stock id, label 78 "<control>A" ; accelerator 79 "About" ; tooltip 80 ,activate-action) 81 ("Logo" "demo-gtk-logo" #f ; name, stock id, label 82 #f ; accelerator 83 "GTK+" ; tooltip 84 ,activate-action))) 85 86(define toggle-entries 87 `(("Bold" ,(gtk-stock-id 'bold) "_Bold" ; name, stock id, label 88 "<control>B" ; accelerator 89 "Bold" ; tooltip 90 ,activate-action 91 #t) ; is_active 92 )) 93 94(define color-red 0) 95(define color-green 1) 96(define color-blue 2) 97 98(define color-entries 99 `(("Red" #f "_Red" ; name, stock id, label 100 "<control>R" ; accelerator 101 "Blood" ,color-red) ; tooltip, value 102 ("Green" #f "_Green" ; name, stock id, label 103 "<control>G" ; label, accelerator 104 "Grass" ,color-green) ; tooltip, value 105 ("Blue" #f "_Blue" ; name, stock id, label 106 "<control>B" ; label, accelerator 107 "Sky" ,color-blue) ; tooltip, value 108 )) 109 110(define shape-square 0) 111(define shape-rectangle 1) 112(define shape-oval 2) 113 114(define shape-entries 115 `(("Square" #f "_Square" ; name, stock id, label 116 "<control>S" ; accelerator 117 "Square" ,shape-square) ; tooltip, value 118 ("Rectangle" #f "_Rectangle" ; name, stock id, label 119 "<control>R" ; accelerator 120 "Rectangle" ,shape-rectangle) ; tooltip, value 121 ("Oval" #f "_Oval" ; name, stock id, label 122 "<control>O" ; accelerator 123 "Egg" ,shape-oval) ; tooltip, value 124 )) 125 126(define ui-info " 127<ui> 128 <menubar name='MenuBar'> 129 <menu action='FileMenu'> 130 <menuitem action='New'/> 131 <menuitem action='Open'/> 132 <menuitem action='Save'/> 133 <menuitem action='SaveAs'/> 134 <separator/> 135 <menuitem action='Quit'/> 136 </menu> 137 <menu action='PreferencesMenu'> 138 <menu action='ColorMenu'> 139 <menuitem action='Red'/> 140 <menuitem action='Green'/> 141 <menuitem action='Blue'/> 142 </menu> 143 <menu action='ShapeMenu'> 144 <menuitem action='Square'/> 145 <menuitem action='Rectangle'/> 146 <menuitem action='Oval'/> 147 </menu> 148 <menuitem action='Bold'/> 149 </menu> 150 <menu action='HelpMenu'> 151 <menuitem action='About'/> 152 </menu> 153 </menubar> 154 <toolbar name='ToolBar'> 155 <toolitem action='Open'/> 156 <toolitem action='Quit'/> 157 <separator action='Sep1'/> 158 <toolitem action='Logo'/> 159 </toolbar> 160</ui> 161") 162 163(define (main) 164 165 (define (update-statusbar buffer statusbar) 166 (let ((iter (get-iter-at-mark buffer (get-insert buffer)))) 167 ;; clear any previous message, underflow is allowed 168 (pop statusbar 0) 169 (push statusbar 0 170 (format #f "Cursor at row ~A column ~A - ~A chars in document" 171 (gtk-text-iter-get-line iter) 172 (gtk-text-iter-get-line-offset iter) 173 (get-char-count buffer))))) 174 175 (define (update-resize-grip widget event statusbar) 176 (let ((changed-mask (gdk-event-window-state:changed-mask event)) 177 (new-window-state (gdk-event-window-state:new-window-state event))) 178 (or (memq 'maximized changed-mask) 179 (memq 'fullscreen changed-mask) 180 (set-has-resize-grip statusbar 181 (not 182 (or (memq 'maximized new-window-state) 183 (memq 'fullscreen new-window-state)))))) 184 #f) 185 186 ;; create window, etc 187 (set! window (make <gtk-window> 188 :type 'toplevel :title "Application Window" 189 :default-width 200 :default-height 200)) 190 (let* ((table (make <gtk-table> 191 :n-rows 1 :n-columns 4 :homogeneous #f)) 192 (actions (make <gtk-action-group> :name "AppWindowActions")) 193 (merge (make <gtk-ui-manager>)) 194 ;; create document 195 (sw (make <gtk-scrolled-window> 196 :hscrollbar-policy 'automatic 197 :vscrollbar-policy 'automatic 198 :shadow-type 'in)) 199 (contents (make <gtk-text-view>)) 200 (buffer (get-buffer contents)) 201 ;; create statusbar 202 (statusbar (make <gtk-statusbar>))) 203 204 (add window table) 205 206 (add-actions actions entries) 207 (add-toggle-actions actions toggle-entries) 208 (add-radio-actions actions color-entries color-red activate-radio-action) 209 (add-radio-actions actions shape-entries shape-oval activate-radio-action) 210 211 (insert-action-group merge actions 0) 212 (add-accel-group window (get-accel-group merge)) 213 214 (add-ui-from-string merge ui-info) 215 216 (let ((bar1 (get-widget merge "/MenuBar")) 217 (bar2 (get-widget merge "/ToolBar"))) 218 (show bar1) 219 (attach table bar1 220 ; X direction ; Y direction 221 0 1 0 1 222 '(expand fill) 0 223 0 0) 224 225 (set-tooltips bar2 #t) 226 (show bar2) 227 (attach table bar2 228 ; X direction ; Y direction 229 0 1 1 2 230 '(expand fill) 0 231 0 0)) 232 233 (attach table sw 234 ; X direction ; Y direction 235 0 1 2 3 236 '(expand fill) '(expand fill) 237 0 0) 238 239 (grab-focus contents) 240 241 (add sw contents) 242 243 (attach table statusbar 244 ; X direction ; Y direction 245 0 1 3 4 246 '(expand fill) 0 247 0 0) 248 ;; show text widget info in the statusbar 249 (connect buffer 'changed 250 (lambda (buffer) (update-statusbar buffer statusbar))) 251 (connect buffer 'mark-set 252 (lambda (buffer l m) (update-statusbar buffer statusbar))) 253 (connect window 'window-state-event 254 (lambda (w e) (update-resize-grip w e statusbar))) 255 256 (connect window 'delete-event 257 (lambda (w e) 258 (destroy w) #f)) 259 260 (update-statusbar buffer statusbar) 261 262 (show-all window))) 263 264 265(define name "Application main window") 266(define description 267 (string-append 268 "Demonstrates a typical application window, with menubar, toolbar, " 269 "statusbar.")) 270