;; 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.11 2004-12-17 00:45:00 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
(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))
-;; (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)))
-
+ (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)))
-; (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)))
-
+ (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 :options '(:expand :fill))
- (signal-connect
- check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
- (let ((check-button (make-instance 'check-button :label "Shrink")))
+ (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))
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
+ (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")))
+ (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
(table-attach table check-button 1 2 1 2 :options '(:expand :fill))
- (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")))
+ (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))
- (setf (toggle-button-active-p check-button) t)
- (signal-connect
- check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
- frame))
+ (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
;;; 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")))))
+ :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
("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)
: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