;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: testgtk.lisp,v 1.10 2004-12-05 13:57:10 espen Exp $
+;; $Id: testgtk.lisp,v 1.13 2004-12-26 12:01:10 espen Exp $
;;; Some of the code in this file are really outdatet, but it is
(if (widget-visible-p button+1)
(widget-hide button+1)
(widget-show button+1))))
- (table-attach table button column (1+ column) row (1+ row)))))
+ (table-attach table button column (1+ column) row (1+ row)
+ :options '(:expand :fill)))))
(widget-show-all table)))
(declare (number n min-val max-val))
(max (min n max-val) min-val))
+(defun set-cursor (spinner drawing-area label)
+ (let ((cursor
+ (glib:int-enum
+ (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
+ 'gdk:cursor-type)))
+ (setf (label-label label) (string-downcase cursor))
+ (setf (widget-cursor drawing-area) cursor)))
+
+(defun cursor-expose (drawing-area event)
+ (declare (ignore event))
+ (multiple-value-bind (width height)
+ (drawing-area-get-size drawing-area)
+ (let* ((window (widget-window drawing-area))
+ (style (widget-style drawing-area))
+ (white-gc (style-white-gc style))
+ (gray-gc (style-bg-gc style :normal))
+ (black-gc (style-black-gc style)))
+ (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
+ (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
+ (floor height 2))
+ (gdk:draw-rectangle window gray-gc t (floor width 3)
+ (floor height 3) (floor width 3)
+ (floor height 3))))
+ t)
+
+(define-simple-dialog create-cursors (dialog "Cursors")
+ (let ((spinner (make-instance 'spin-button
+ :adjustment (adjustment-new
+ 0 0
+ (1- (enum-int :last-cursor 'gdk:cursor-type))
+ 2 10 0)))
+ (drawing-area (make-instance 'drawing-area
+ :width-request 80 :height-request 80
+ :events '(:exposure-mask :button-press-mask)))
+ (label (make-instance 'label :label "XXX")))
+
+ (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
+
+ (signal-connect drawing-area 'button-press-event
+ #'(lambda (event)
+ (case (gdk:event-button event)
+ (1 (spin-button-spin spinner :step-forward 0.0))
+ (3 (spin-button-spin spinner :step-backward 0.0)))
+ t))
+
+ (signal-connect drawing-area 'scroll-event
+ #'(lambda (event)
+ (case (gdk:event-direction event)
+ (:up (spin-button-spin spinner :step-forward 0.0))
+ (:down (spin-button-spin spinner :step-backward 0.0)))
+ t))
+
+ (signal-connect spinner 'changed
+ #'(lambda ()
+ (set-cursor spinner drawing-area label)))
-;; (defun set-cursor (spinner drawing-area label)
-;; (let ((cursor
-;; (glib:int-enum
-;; (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
-;; 'gdk:cursor-type)))
-;; (setf (label-text label) (string-downcase cursor))
-;; (setf (widget-cursor drawing-area) cursor)))
-
-
-; (define-standard-dialog create-cursors "Cursors"
-; (setf (container-border-width main-box) 10)
-; (setf (box-spacing main-box) 5)
-; (let* ((hbox (hbox-new nil 0))
-; (label (create-label "Cursor Value : "))
-; (adj (adjustment-new 0 0 152 2 10 0))
-; (spinner (spin-button-new adj 0 0)))
-; (setf (container-border-width hbox) 5)
-; (box-pack-start main-box hbox nil t 0)
-; (setf (misc-xalign label) 0)
-; (setf (misc-yalign label) 0.5)
-; (box-pack-start hbox label nil t 0)
-; (box-pack-start hbox spinner t t 0)
-
-; (let ((frame (make-frame
-; :shadow-type :etched-in
-; :label-xalign 0.5
-; :label "Cursor Area"
-; :border-width 10
-; :parent main-box
-; :visible t))
-; (drawing-area (drawing-area-new)))
-; (setf (widget-width drawing-area) 80)
-; (setf (widget-height drawing-area) 80)
-; (container-add frame drawing-area)
-; (signal-connect
-; drawing-area 'expose-event
-; #'(lambda (event)
-; (declare (ignore event))
-; (multiple-value-bind (width height)
-; (drawing-area-size drawing-area)
-; (let* ((drawable (widget-window drawing-area))
-; (style (widget-style drawing-area))
-; (white-gc (style-get-gc style :white))
-; (gray-gc (style-get-gc style :background :normal))
-; (black-gc (style-get-gc style :black)))
-; (gdk:draw-rectangle
-; drawable white-gc t 0 0 width (floor height 2))
-; (gdk:draw-rectangle
-; drawable black-gc t 0 (floor height 2) width (floor height 2))
-; (gdk:draw-rectangle
-; drawable gray-gc t (floor width 3) (floor height 3)
-; (floor width 3) (floor height 3))))
-; t))
-; (setf (widget-events drawing-area) '(:exposure :button-press))
-; (signal-connect
-; drawing-area 'button-press-event
-; #'(lambda (event)
-; (when (and
-; (eq (gdk:event-type event) :button-press)
-; (or
-; (= (gdk:event-button event) 1)
-; (= (gdk:event-button event) 3)))
-; (spin-button-spin
-; spinner
-; (if (= (gdk:event-button event) 1)
-; :step-forward
-; :step-backward)
-; 0)
-; t)))
-; (widget-show drawing-area)
-
-; (let ((label (make-label
-; :visible t
-; :label "XXX"
-; :parent main-box)))
-; (setf (box-child-expand-p #|main-box|# label) nil)
-; (signal-connect
-; spinner 'changed
-; #'(lambda ()
-; (set-cursor spinner drawing-area label)))
-
-; (widget-realize drawing-area)
-; (set-cursor spinner drawing-area label)))))
+ (make-instance 'v-box
+ :parent dialog :border-width 10 :spacing 5 :show-all t
+ :child (list
+ (make-instance 'h-box
+ :border-width 5
+ :child (list
+ (make-instance 'label :label "Cursor Value : ")
+ :expand nil)
+ :child spinner)
+ :expand nil)
+ :child (make-instance 'frame
+; :shadow-type :etched-in
+ :label "Cursor Area" :label-xalign 0.5 :border-width 10
+ :child drawing-area)
+ :child (list label :expand nil))
+ (widget-realize drawing-area)
+ (set-cursor spinner drawing-area label)))
;;; Dialog
(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
(dialog-add-button dialog "gtk-ok"
#'(lambda ()
- (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+ (if (slot-boundp dialog 'filename)
+ (format t "Selected file: ~A~%" (file-chooser-filename dialog))
+ (write-line "No files selected"))
(widget-destroy dialog))))
;;; Layout
-;; (defun layout-expose (layout event)
-;; (with-slots (window x-offset y-offset) layout
-;; (with-slots (x y width height) event
-;; (let ((imin (truncate (+ x-offset x) 10))
-;; (imax (truncate (+ x-offset x width 9) 10))
-;; (jmin (truncate (+ y-offset y) 10))
-;; (jmax (truncate (+ y-offset y height 9) 10)))
-;; (declare (fixnum imin imax jmin jmax))
-;; (gdk:window-clear-area window x y width height)
-
-;; (let ((window (layout-bin-window layout))
-;; (gc (style-get-gc (widget-style layout) :black)))
-;; (do ((i imin (1+ i)))
-;; ((= i imax))
-;; (declare (fixnum i))
-;; (do ((j jmin (1+ j)))
-;; ((= j jmax))
-;; (declare (fixnum j))
-;; (unless (zerop (mod (+ i j) 2))
-;; (gdk:draw-rectangle
-;; window gc t
-;; (- (* 10 i) x-offset) (- (* 10 j) y-offset)
-;; (1+ (mod i 10)) (1+ (mod j 10))))))))))
-;; t)
-
+(defun layout-expose (layout event)
+ (when (eq (gdk:event-window event) (layout-bin-window layout))
+ (with-slots (gdk:x gdk:y gdk:width gdk:height) event
+ (let ((imin (truncate gdk:x 10))
+ (imax (truncate (+ gdk:x gdk:width 9) 10))
+ (jmin (truncate gdk:y 10))
+ (jmax (truncate (+ gdk:y gdk:height 9) 10)))
+
+ (let ((window (layout-bin-window layout))
+ (gc (style-black-gc (widget-style layout))))
+ (loop
+ for i from imin below imax
+ do (loop
+ for j from jmin below jmax
+ unless (zerop (mod (+ i j) 2))
+ do (gdk:draw-rectangle
+ window gc t (* 10 i) (* 10 j)
+ (1+ (mod i 10)) (1+ (mod j 10)))))))))
+ nil)
(define-toplevel create-layout (window "Layout" :default-width 200
:default-height 200)
(let ((layout (make-instance 'layout
:parent (make-instance 'scrolled-window :parent window)
:width 1600 :height 128000 :events '(:exposure-mask)
-;; :signal (list 'expose-event #'layout-expose :object t)
+ :signal (list 'expose-event #'layout-expose :object t)
)))
(with-slots (hadjustment vadjustment) layout
;;; Panes
(defun toggle-resize (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child (not resize) shrink)
- (paned-pack2 paned child (not resize) shrink)))))
+ (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
(defun toggle-shrink (child)
- (let* ((paned (widget-parent child))
- (is-child1-p (eq child (paned-child1 paned))))
- (multiple-value-bind (child resize shrink)
- (if is-child1-p
- (paned-child1 paned)
- (paned-child2 paned))
- (container-remove paned child)
- (if is-child1-p
- (paned-pack1 paned child resize (not shrink))
- (paned-pack2 paned child resize (not shrink))))))
+ (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
(defun create-pane-options (paned frame-label label1 label2)
- (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
- (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
- :parent frame)))
-
- (table-attach table (create-label label1) 0 1 0 1)
+ (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
+ (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
(let ((check-button (make-instance 'check-button :label "Resize")))
- (table-attach table check-button 0 1 1 2)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
- (table-attach table check-button 0 1 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
-
- (table-attach table (create-label label2) 1 2 0 1)
- (let ((check-button (make-instance 'check-button :label "Resize")))
- (table-attach table check-button 1 2 1 2)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
- (table-attach table check-button 1 2 2 3)
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
- frame))
+ (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child1 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
+ (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child1 paned)))
+
+ (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
+ (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
+ (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-resize :object (paned-child2 paned)))
+ (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
+ (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
+ (signal-connect check-button 'toggled
+ #'toggle-shrink :object (paned-child2 paned)))
+ (make-instance 'frame :label frame-label :border-width 4 :child table)))
(define-toplevel create-panes (window "Panes")
(let* ((hpaned (make-instance 'h-paned
:child1 (make-instance 'frame
:width-request 60 :height-request 60
:shadow-type :in
- :child (make-instance 'buttun :label "Hi there"))
+ :child (make-instance 'button :label "Hi there"))
:child2 (make-instance 'frame
:width-request 80 :height-request 60
:shadow-type :in)))
;;; Progress bar
-
+
;;; Radio buttons
(widget-events window)
'(:pointer-motion-mask :pointer-motion-hint-mask))
- (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
- (let ((ruler (make-instance 'h-ruler
+ (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
+ (h-ruler (make-instance 'h-ruler
:metric :centimeters :lower 100.0d0 :upper 0.0d0
- :position 0.0d0 :max-size 20.0d0)))
- (signal-connect window 'motion-notify-event #'widget-event :object ruler)
- (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
- (let ((ruler (make-instance 'v-ruler
+ :position 0.0d0 :max-size 20.0d0))
+ (v-ruler (make-instance 'v-ruler
:lower 5.0d0 :upper 15.0d0
:position 0.0d0 :max-size 20.0d0)))
- (signal-connect window 'motion-notify-event #'widget-event :object ruler)
- (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
-
+ (signal-connect window 'motion-notify-event
+ #'(lambda (event)
+ (widget-event h-ruler event)
+ (widget-event v-ruler event)))
+ (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
+ (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
;;; Scrolled window
(widget-show-all scrolled-window)))
+;;; Size group
+
+(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
+ (let ((size-group (make-instance 'size-group)))
+ (flet ((create-frame (label rows)
+ (let ((table (make-instance 'table
+ :n-rows (length rows) :n-columns 2 :homogeneous nil
+ :row-spacing 5 :column-spacing 10 :border-width 5)))
+ (loop
+ for row in rows
+ for i from 0
+ do (table-attach table
+ (create-label (first row) :xalign 0 :yalign 1)
+ 0 1 i (1+ i) :x-options '(:expand :fill))
+ (let ((combo (make-instance 'combo-box
+ :content (rest row) :active 0)))
+ (size-group-add-widget size-group combo)
+ (table-attach table combo 1 2 i (1+ i))))
+ (make-instance 'frame :label label :child table))))
+
+ (make-instance 'v-box
+ :parent dialog :border-width 5 :spacing 5 :show-all t
+ :child (create-frame "Color Options"
+ '(("Foreground" "Red" "Green" "Blue")
+ ("Background" "Red" "Green" "Blue")))
+ :child (create-frame "Line Options"
+ '(("Dashing" "Solid" "Dashed" "Dotted")
+ ("Line ends" "Square" "Round" "Arrow")))
+ :child (create-check-button "Enable grouping"
+ #'(lambda (active)
+ (setf
+ (size-group-mode size-group)
+ (if active :horizontal :none)))
+ t)))))
+
+
;;; Shapes
;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
(define-simple-dialog create-text (dialog "Text" :default-width 400
:default-height 400)
- (make-instance 'text-view :border-width 10 :parent dialog :visible t))
+ (let* ((text-view (make-instance 'text-view
+ :border-width 10 :visible t :wrap-mode :word))
+ (buffer (text-view-buffer text-view))
+ (active-tags ()))
+
+ (text-buffer-create-tag buffer "Bold" :weight :bold)
+ (text-buffer-create-tag buffer "Italic" :style :italic)
+ (text-buffer-create-tag buffer "Underline" :underline :single)
+
+ (flet ((create-toggle-callback (tag-name)
+ (let ((tag (text-tag-table-lookup
+ (text-buffer-tag-table buffer) tag-name)))
+ #'(lambda (active)
+ (unless (eq (and (find tag active-tags) t) active)
+ ;; user activated
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (multiple-value-bind (start end)
+ (text-buffer-get-selection-bounds buffer)
+ (if active
+ (text-buffer-apply-tag buffer tag start end)
+ (text-buffer-remove-tag buffer tag start end))))))))
+
+ (let* ((actions
+ (make-instance 'action-group
+ :action (create-toggle-action
+ "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
+ (create-toggle-callback "Bold"))
+ :action (create-toggle-action
+ "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
+ (create-toggle-callback "Italic"))
+ :action (create-toggle-action
+ "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
+ (create-toggle-callback "Underline"))))
+ (ui (make-instance 'ui-manager)))
+
+ (ui-manager-insert-action-group ui actions)
+ (ui-manager-add-ui ui
+ '((:toolbar "ToolBar"
+ (:toolitem "Bold")
+ (:toolitem "Italic")
+ (:toolitem "Underline"))))
+
+ ;; Callback to activate/deactivate toolbar buttons when cursor
+ ;; is moved
+ (signal-connect buffer 'mark-set
+ #'(lambda (location mark)
+ (declare (ignore mark))
+ (text-tag-table-foreach (text-buffer-tag-table buffer)
+ #'(lambda (tag)
+ (let ((active
+ (or
+ (and
+ (text-iter-has-tag-p location tag)
+ (not (text-iter-begins-tag-p location tag)))
+ (text-iter-ends-tag-p location tag))))
+ (unless (eq active (and (find tag active-tags) t))
+ (if active
+ (push tag active-tags)
+ (setq active-tags (delete tag active-tags)))
+ (setf
+ (toggle-action-active-p
+ (action-group-get-action actions (text-tag-name tag)))
+ active)))))))
+
+ ;; Callback to apply active tags when a character is inserted
+ (signal-connect buffer 'insert-text
+ #'(lambda (iter &rest args)
+ (declare (ignore args))
+ (let ((before (text-buffer-get-iter-at-offset buffer
+ (1- (text-iter-offset iter)))))
+ (loop
+ for tag in active-tags
+ do (text-buffer-apply-tag buffer tag before iter))))
+ :after t)
+
+ (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
+ (container-add dialog text-view)))))
+
;;; Toggle buttons
;;; Toolbar test
-;; TODO: style properties
(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
(let ((toolbar (make-instance 'toolbar :parent window)))
-; (setf (toolbar-relief toolbar) :none)
;; Insert a stock item
(toolbar-append toolbar "gtk-quit"
(make-instance 'v-box
:parent dialog :border-width 10 :spacing 10 :show-all t
:child (create-button "button1" "This is button 1" "ContextHelp/button/1")
- :child (create-button "button2" "This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))
-
- (let ((close-button (first (container-children (dialog-action-area dialog)))))
- (tooltips-set-tip tooltips close-button "Push this button to close window"
- "ContextHelp/buttons/Close"))))
+ :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
;;; UI Manager
(:separator "Sep1")
(:toolitem "Logo"))))
-(define-simple-dialog create-ui-manager (dialog "UI Manager")
+(define-toplevel create-ui-manager (window "UI Manager")
(let ((actions
(make-instance 'action-group
:name "Actions"
:action (create-action "ShapeMenu" nil "_Shape")
:action (create-action "HelpMenu" nil "_Help")
:action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
- :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
+ :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
:action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
:action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
- :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
+ :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
:action (create-action "About" nil "_About" "<control>A" "About")
:action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
:action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
(ui-manager-insert-action-group ui actions)
(ui-manager-add-ui ui *ui-description*)
- (window-add-accel-group dialog (ui-manager-accel-group ui))
+ (window-add-accel-group window (ui-manager-accel-group ui))
(make-instance 'v-box
- :parent dialog :show-all t
+ :parent window :show-all t
:child (list
(ui-manager-get-widget ui "/MenuBar")
:expand nil :fill nil)
("calendar" create-calendar)
("check buttons" create-check-buttons)
("color selection" create-color-selection)
-;; ("cursors" #|create-cursors|#)
+ ("cursors" create-cursors)
("dialog" create-dialog)
;; ; ("dnd")
("entry" create-entry)
;; ("font selection")
;; ("handle box" create-handle-box)
("image" create-image)
-;; ("item factory")
("labels" create-labels)
("layout" create-layout)
("list" create-list)
("rulers" create-rulers)
;; ("saved position")
("scrolled windows" create-scrolled-windows)
+ ("size group" create-size-group)
;; ("shapes" create-shapes)
("spinbutton" create-spins)
("statusbar" create-statusbar)
:signal (list 'clicked #'widget-destroy
:object main-window))))
+ (setf (window-icon main-window) #p"clg:examples;gtk.png")
+
;; Main box
(make-instance 'v-box
:parent main-window
~mdw / clg / blobdiff