[clg] / examples / testgtk.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; 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.27 2005-04-18 10:39:32 espen Exp $

(defpackage "TESTGTK"
  (:use "COMMON-LISP" "GTK"))

(in-package "TESTGTK")

(defmacro define-toplevel (name (window title &rest initargs) &body body)
  `(let ((,window nil))
     (defun ,name ()
       (unless ,window
	 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
	 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
	 ,@body)
       
       (when ,window
	 (if (not (widget-visible-p ,window))
	     (widget-show ,window)
	   (widget-hide ,window))))))


(defmacro define-dialog (name (dialog title &optional (class 'dialog)
			       &rest initargs)
			 &body body)
  `(let ((,dialog nil))
     (defun ,name ()
       (unless ,dialog
	 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
	 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
	 ,@body)
       
       (when ,dialog
	 (if (not (widget-visible-p ,dialog))
	     (widget-show ,dialog)
	   (widget-hide ,dialog))))))


(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
  `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
    ,@body
    (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))


;;; Pixmaps used in some of the tests

(defvar gtk-mini-xpm
  #("15 20 17 1"
    "       c None"
    ".      c #14121F"
    "+      c #278828"
    "@      c #9B3334"
    "#      c #284C72"
    "$      c #24692A"
    "%      c #69282E"
    "&      c #37C539"
    "*      c #1D2F4D"
    "=      c #6D7076"
    "-      c #7D8482"
    ";      c #E24A49"
    ">      c #515357"
    ",      c #9B9C9B"
    "'      c #2FA232"
    ")      c #3CE23D"
    "!      c #3B6CCB"
    "               "
    "      ***>     "
    "    >.*!!!*    "
    "   ***....#*=  "
    "  *!*.!!!**!!# "
    " .!!#*!#*!!!!# "
    " @%#!.##.*!!$& "
    " @;%*!*.#!#')) "
    " @;;@%!!*$&)'' "
    " @%.%@%$'&)$+' "
    " @;...@$'*'*)+ "
    " @;%..@$+*.')$ "
    " @;%%;;$+..$)# "
    " @;%%;@$$$'.$# "
    " %;@@;;$$+))&* "
    "  %;;;@+$&)&*  "
    "   %;;@'))+>   "
    "    %;@'&#     "
    "     >%$$      "
    "      >=       "))

(defvar book-closed-xpm
  #("16 16 6 1"
    "       c None s None"
    ".      c black"
    "X      c red"
    "o      c yellow"
    "O      c #808080"
    "#      c white"
    "                "
    "       ..       "
    "     ..XX.      "
    "   ..XXXXX.     "
    " ..XXXXXXXX.    "
    ".ooXXXXXXXXX.   "
    "..ooXXXXXXXXX.  "
    ".X.ooXXXXXXXXX. "
    ".XX.ooXXXXXX..  "
    " .XX.ooXXX..#O  "
    "  .XX.oo..##OO. "
    "   .XX..##OO..  "
    "    .X.#OO..    "
    "     ..O..      "
    "      ..        "
    "                "))

(defvar mini-page-xpm
  #("16 16 4 1"
    "       c None s None"
    ".      c black"
    "X      c white"
    "o      c #808080"
    "                "
    "   .......      "
    "   .XXXXX..     "
    "   .XoooX.X.    "
    "   .XXXXX....   "
    "   .XooooXoo.o  "
    "   .XXXXXXXX.o  "
    "   .XooooooX.o  "
    "   .XXXXXXXX.o  "
    "   .XooooooX.o  "
    "   .XXXXXXXX.o  "
    "   .XooooooX.o  "
    "   .XXXXXXXX.o  "
    "   ..........o  "
    "    oooooooooo  "
    "                "))

(defvar book-open-xpm
  #("16 16 4 1"
    "       c None s None"
    ".      c black"
    "X      c #808080"
    "o      c white"
    "                "
    "  ..            "
    " .Xo.    ...    "
    " .Xoo. ..oo.    "
    " .Xooo.Xooo...  "
    " .Xooo.oooo.X.  "
    " .Xooo.Xooo.X.  "
    " .Xooo.oooo.X.  "
    " .Xooo.Xooo.X.  "
    " .Xooo.oooo.X.  "
    "  .Xoo.Xoo..X.  "
    "   .Xo.o..ooX.  "
    "    .X..XXXXX.  "
    "    ..X.......  "
    "     ..         "
    "                "))


;;; Button box

(defun create-bbox-in-frame (class frame-label spacing width height layout)
  (declare (ignore width height))
  (make-instance 'frame
   :label frame-label
   :child (make-instance class
	   :border-width 5 :layout-style layout :spacing spacing
	   :child (make-instance 'button :stock "gtk-ok")
	   :child (make-instance 'button :stock "gtk-cancel")
	   :child (make-instance 'button :stock "gtk-help"))))

(define-toplevel create-button-box (window "Button Boxes")
  (make-instance 'v-box
   :parent window :border-width 10 :spacing 10
   :child (make-instance 'frame
	   :label "Horizontal Button Boxes"
	   :child (make-instance 'v-box
		   :border-width 10 :spacing 10
		   :children (mapcar	
			      #'(lambda (args)
				  (apply #'create-bbox-in-frame 
				   'h-button-box args))
			      '(("Spread" 40 85 20 :spread) 
				("Edge" 40 85 20 :edge)
				("Start" 40 85 20 :start) 
				("End" 40 85 20 :end)))))
   :child (make-instance 'frame
	   :label "Vertical Button Boxes"
	   :child (make-instance 'h-box
		   :border-width 10 :spacing 10
		   :children (mapcar
			      #'(lambda (args)
				  (apply #'create-bbox-in-frame
				   'v-button-box args))
			      '(("Spread" 30 85 20 :spread) 
				("Edge" 30 85 20 :edge)
				("Start" 30 85 20 :start) 
				("End" 30 85 20 :end)))))))


;; Buttons

(define-simple-dialog create-buttons (dialog "Buttons")
  (let ((table (make-instance 'table
	        :n-rows 3 :n-columns 3 :homogeneous nil
		:row-spacing 5 :column-spacing 5 :border-width 10
		:parent dialog))
	  (buttons (loop
		    for n from 1 to 10
		    collect (make-instance 'button 
			     :label (format nil "button~D" (1+ n))))))

    (dotimes (column 3)
      (dotimes (row 3)
	(let ((button (nth (+ (* 3 row) column) buttons))
	      (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
	  (signal-connect button 'clicked
			  #'(lambda ()
			      (if (widget-visible-p button+1)
				  (widget-hide button+1)
				(widget-show button+1))))
	  (table-attach table button column (1+ column) row (1+ row)
			:options '(:expand :fill)))))))


;; Calenadar

(define-simple-dialog create-calendar (dialog "Calendar")
  (make-instance 'v-box
   :parent dialog :border-width 10
   :child (make-instance 'calendar)))


;;; Check buttons

(define-simple-dialog create-check-buttons (dialog "Check Buttons")
  (make-instance 'v-box
   :border-width 10 :spacing 10 :parent dialog
   :children (loop
	      for n from 1 to 3
	      collect (make-instance 'check-button
		       :label (format nil "Button~D" n)))))


;;; Color selection

(define-dialog create-color-selection (dialog "Color selection dialog" 
				       'color-selection-dialog
				       :allow-grow nil :allow-shrink nil
				       :show-children nil)
  (with-slots (colorsel) dialog
    (let ((button (make-instance 'check-button :label "Show Opacity")))
      (dialog-add-action-widget dialog button
       #'(lambda () 
 	  (setf 
 	   (color-selection-has-opacity-control-p colorsel)
 	   (toggle-button-active-p button)))))

    (let ((button (make-instance 'check-button :label "Show Palette")))
      (dialog-add-action-widget dialog button
       #'(lambda () 
 	  (setf 
 	   (color-selection-has-palette-p colorsel)
 	   (toggle-button-active-p button)))))

    (signal-connect dialog :ok
     #'(lambda ()
	 (let ((color (color-selection-current-color colorsel)))
	   (format t "Selected color: ~A~%" color)
	   (setf (color-selection-current-color colorsel) color)
	   (widget-hide dialog))))

    (signal-connect dialog :cancel #'widget-destroy :object t)))


;;; Cursors

(defun clamp (n min-val max-val)
  (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)
      (widget-get-size-allocation 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- (glib:enum-int :last-cursor 'gdk:cursor-type))
			       2 10 0)))
	(drawing-area (make-instance 'drawing-area
		       :width-request 80 :height-request 80
		       :events '(:exposure :button-press)))
	(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))
	   (3 (spin-button-spin spinner :step-backward)))
	 t))

    (signal-connect drawing-area 'scroll-event
     #'(lambda (event)
	 (case (gdk:event-direction event)
	   (:up (spin-button-spin spinner :step-forward))
	   (:down (spin-button-spin spinner :step-backward)))
	 t))

    (signal-connect spinner 'changed
     #'(lambda ()
	 (set-cursor spinner drawing-area label)))

    (make-instance 'v-box
     :parent dialog :border-width 10 :spacing 5
     :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
	     :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

(let ((dialog nil))
  (defun create-dialog ()
    (unless dialog
      (setq dialog (make-instance 'dialog 
		    :title "Dialog" :default-width 200 
		    :button "Toggle"
		    :button (list "gtk-ok" #'widget-destroy :object t)
		    :signal (list 'destroy 
			     #'(lambda () 
				 (setq dialog nil)))))

      (let ((label (make-instance 'label 
		    :label "Dialog Test" :xpad 10 :ypad 10 :visible t
		    :parent dialog)))
	(signal-connect dialog "Toggle"
	 #'(lambda ()
	     (if (widget-visible-p label)
		 (widget-hide label)
	       (widget-show label))))))

    (if (widget-visible-p dialog)
	(widget-hide dialog)
       (widget-show dialog))))


;; Entry

(define-simple-dialog create-entry (dialog "Entry")
  (let ((main (make-instance 'v-box 
	       :border-width 10 :spacing 10 :parent dialog)))

    (let ((entry (make-instance 'entry :text "hello world" :parent main)))
      (editable-select-region entry 0 5) ; this has no effect when 
					 ; entry is editable
;;     (editable-insert-text entry "great " 6)
;;     (editable-delete-text entry 6 12)
      
      (let ((combo (make-instance 'combo-box-entry 
		    :parent main
		    :content '("item0"
			       "item1 item1"
			       "item2 item2 item2"
			       "item3 item3 item3 item3"
			       "item4 item4 item4 item4 item4"
			       "item5 item5 item5 item5 item5 item5"
			       "item6 item6 item6 item6 item6"
			       "item7 item7 item7 item7"
			       "item8 item8 item8"
			       "item9 item9"))))
	(with-slots (child) combo 
	  (setf (editable-text child) "hello world")
	  (editable-select-region child 0)))

      (flet ((create-check-button (label slot)
	       (make-instance 'check-button
	        :label label :active t :parent main
		:signal (list 'toggled
			      #'(lambda (button)
				  (setf (slot-value entry slot)
					(toggle-button-active-p button)))
			      :object t))))
      
	(create-check-button "Editable" 'editable)
	(create-check-button "Visible" 'visibility)
	(create-check-button "Sensitive" 'sensitive)))))


;; Expander

(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
  (make-instance 'v-box
   :parent dialog :spacing 5 :border-width 5
   :child (create-label "Expander demo. Click on the triangle for details.")
   :child (make-instance 'expander
	   :label "Details"
	   :child (create-label "Details can be shown or hidden."))))


;; File chooser dialog

(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
  (file-chooser-add-filter dialog 
   (make-instance 'file-filter :name "All files" :pattern "*"))
  (file-chooser-add-filter dialog 
   (make-instance 'file-filter :name "Common Lisp source code" 
    :patterns '("*.lisp" "*.lsp")))

  (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
  (dialog-add-button dialog "gtk-ok" 
   #'(lambda ()
       (if (slot-boundp dialog 'filename)	   
	   (format t "Selected file: ~A~%" (file-chooser-filename dialog))
	 (write-line "No files selected"))
       (widget-destroy dialog))))


;; Font selection dialog

(define-toplevel create-font-selection (window "Font Button" :resizable nil)
  (make-instance 'h-box 
   :parent window :spacing 8 :border-width 8
   :child (make-instance 'label :label "Pick a font")
   :child (make-instance 'font-button 
           :use-font t :title "Font Selection Dialog")))


;;; Icon View

#+gtk2.6
(let ((file-pixbuf nil)
      (folder-pixbuf nil))
  (defun load-pixbufs ()
    (unless file-pixbuf
      (handler-case 
          (setf
	   file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	   folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	(glib:glib-error (condition)
	  (make-instance 'message-dialog 
	   :message-type :error :visible t
	   :text "<b>Failed to load an image</b>" 
	   :secondary-text (glib:gerror-message condition)
	   :signal (list :close #'widget-destroy :object t))
	  (return-from load-pixbufs nil))))
    t)

  (defun fill-store (store directory)
    (list-store-clear store)
    (let ((dir #+cmu(unix:open-dir directory)
	       #+sbcl(sb-posix:opendir directory)))
      (unwind-protect 
	  (loop
	   as filename = #+cmu(unix:read-dir dir)
	                 #+sbcl(let ((dirent (sb-posix:readdir dir)))
				 (unless (sb-grovel::foreign-nullp dirent)
				   (sb-posix:dirent-name dirent)))
	   while filename
	   unless (or (equal filename ".") (equal filename ".."))
	   do (let* ((pathname (format nil "~A~A" directory filename))
		     (directory-p
		      #+cmu(eq (unix:unix-file-kind pathname) :directory)
		      #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
		(list-store-append store 
		 (vector
		  filename 
		  (if directory-p folder-pixbuf file-pixbuf)
		  directory-p))))
	#+cmu(unix:close-dir dir)
	#+sbcl(sb-posix:closedir dir))))

  (defun sort-func (store a b)
    (let ((a-dir-p (tree-model-value store a 'directory-p))
	  (b-dir-p (tree-model-value store b 'directory-p))
	  (a-name (tree-model-value store a 'filename))
	  (b-name (tree-model-value store b 'filename)))
      (cond
       ((and a-dir-p (not b-dir-p)) :before)
       ((and (not a-dir-p) b-dir-p) :after)
       ((string< a-name b-name) :before)
       ((string> a-name b-name) :after)
       (t :equal))))

  (defun parent-dir (dir)
    (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
      (subseq dir 0 end)))

  (define-toplevel create-icon-view (window "Icon View demo"
				     :default-width 650 
				     :default-height 400)
    (if (not (load-pixbufs))
	(widget-destroy window)
      (let* ((directory "/")
	     (store (make-instance 'list-store 
		     :column-types '(string gdk:pixbuf boolean)
		     :column-names '(filename pixbuf directory-p)))
	     (icon-view (make-instance 'icon-view
			 :model store :selection-mode :multiple
			 :text-column 'filename :pixbuf-column 'pixbuf))
	     (up (make-instance 'tool-button 
		  :stock "gtk-go-up" :is-important t :sensitive nil))
	     (home (make-instance 'tool-button 
		    :stock  "gtk-home" :is-important t)))
	(tree-sortable-set-sort-func store :default #'sort-func)
	(tree-sortable-set-sort-column store :default :ascending)
	(fill-store store directory)

	(signal-connect icon-view 'item-activated
         #'(lambda (path)
	     (when (tree-model-value store path 'directory-p)
	       (setq directory
		     (concatenate 'string directory (tree-model-value store path 'filename) "/"))
	       (fill-store store directory)
	       (setf (widget-sensitive-p up) t))))

	(signal-connect up 'clicked
	 #'(lambda ()
	     (unless (string= directory "/")
	       (setq directory (parent-dir directory))
	       (fill-store store directory)
	       (setf 
		(widget-sensitive-p home)
		(not (string= directory (namestring (truename #p"clg:")))))
	       (setf (widget-sensitive-p up) (not (string= directory "/"))))))

	(signal-connect home 'clicked
         #'(lambda ()
	     (setq directory (namestring (truename #p"clg:")))
	     (fill-store store directory)
	     (setf (widget-sensitive-p up) t)
	     (setf (widget-sensitive-p home) nil)))
      
	(make-instance 'v-box 
         :parent window
	 :child (list
		 (make-instance 'toolbar :child up :child home)		 
		 :fill nil :expand nil)
	 :child (make-instance 'scrolled-window
	         :shadow-type :etched-in :policy :automatic
		 :child icon-view))))))


;;; Image

(define-toplevel create-image (window "Image" :resizable nil)
  (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))


;;; Labels
      
(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
  (flet ((create-label-in-frame (frame-label label-text &rest args)
	   (list 
	    (make-instance 'frame
	     :label frame-label
	     :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
	    :fill nil :expand nil)))
    (make-instance 'h-box
     :spacing 5 :parent window
     :child-args '(:fill nil :expand nil)
     :child (make-instance 'v-box
             :spacing 5
	     :child (create-label-in-frame "Normal Label" "This is a Normal label")
	     :child (create-label-in-frame "Multi-line Label"
"This is a Multi-line label.
Second line
Third line")
	     :child (create-label-in-frame "Left Justified Label"
"This is a Left-Justified
Multi-line.
Third line"
                      :justify :left)
	     :child (create-label-in-frame "Right Justified Label"
"This is a Right-Justified
Multi-line.
Third line"
                     :justify :right))
     :child (make-instance 'v-box
	     :spacing 5
	     :child (create-label-in-frame "Line wrapped label"
"This is an example of a line-wrapped label.  It should not be taking up the entire             width allocated to it, but automatically wraps the words to fit.  The time has come, for all good men, to come to the aid of their party.  The sixth sheik's six sheep's sick.
     It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
                      :wrap t)

	     :child (create-label-in-frame "Filled, wrapped label"
"This is an example of a line-wrapped, filled label.  It should be taking up the entire              width allocated to it.  Here is a seneance to prove my point.  Here is another sentence. Here comes the sun, do de do de do.
    This is a new paragraph.
    This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
                      :justify :fill :wrap t)

	     :child (create-label-in-frame "Underlined label"
(#+cmu glib:latin1-to-unicode #+sbcl identity
"This label is underlined!
Commit	Line	Data
560af5c5	1	;; Common Lisp bindings for GTK+ v2.0
787721b6	2	;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
560af5c5	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
9706ddd7	18	;; $Id: testgtk.lisp,v 1.27 2005-04-18 10:39:32 espen Exp $
560af5c5	19
58d925ab	20	(defpackage "TESTGTK"
58d925ab	21	(:use "COMMON-LISP" "GTK"))
704a1de4	22
58d925ab	23	(in-package "TESTGTK")
704a1de4	24
	25	(defmacro define-toplevel (name (window title &rest initargs) &body body)
	26	`(let ((,window nil))
560af5c5	27	(defun ,name ()
704a1de4	28	(unless ,window
f6ebddea	29	(setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
704a1de4	30	(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
560af5c5	31	,@body)
560af5c5	32
58d925ab	33	(when ,window
	34	(if (not (widget-visible-p ,window))
	35	(widget-show ,window)
	36	(widget-hide ,window))))))
704a1de4	37
560af5c5	38
704a1de4	39	(defmacro define-dialog (name (dialog title &optional (class 'dialog)
	40	&rest initargs)
	41	&body body)
	42	`(let ((,dialog nil))
560af5c5	43	(defun ,name ()
704a1de4	44	(unless ,dialog
f6ebddea	45	(setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
704a1de4	46	(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
704a1de4	47	,@body)
560af5c5	48
58d925ab	49	(when ,dialog
	50	(if (not (widget-visible-p ,dialog))
	51	(widget-show ,dialog)
	52	(widget-hide ,dialog))))))
560af5c5	53
560af5c5	54
704a1de4	55	(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
704a1de4	56	`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
bdc1babf	57	,@body
bdc1babf	58	(dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
560af5c5	59
560af5c5	60
560af5c5	61
	62	;;; Pixmaps used in some of the tests
	63
	64	(defvar gtk-mini-xpm
196fe1e9	65	#("15 20 17 1"
560af5c5	66	" c None"
	67	". c #14121F"
	68	"+ c #278828"
	69	"@ c #9B3334"
	70	"# c #284C72"
	71	"$ c #24692A"
	72	"% c #69282E"
	73	"& c #37C539"
	74	"* c #1D2F4D"
	75	"= c #6D7076"
	76	"- c #7D8482"
	77	"; c #E24A49"
	78	"> c #515357"
	79	", c #9B9C9B"
	80	"' c #2FA232"
	81	") c #3CE23D"
	82	"! c #3B6CCB"
	83	" "
	84	" ***> "
	85	" >.!!! "
	86	" **....#= "
	87	" !.!!!**!!# "
	88	" .!!#!#!!!!# "
	89	" @%#!.##.*!!$& "
	90	" @;%!.#!#')) "
	91	" @;;@%!!*$&)'' "
	92	" @%.%@%$'&)$+' "
	93	" @;...@$'')+ "
	94	" @;%..@$+*.')$ "
	95	" @;%%;;$+..$)# "
	96	" @;%%;@$$$'.$# "
	97	" %;@@;;$$+))&* "
	98	" %;;;@+$&)&* "
	99	" %;;@'))+> "
	100	" %;@'&# "
	101	" >%$$ "
	102	" >= "))
	103
	104	(defvar book-closed-xpm
196fe1e9	105	#("16 16 6 1"
560af5c5	106	" c None s None"
	107	". c black"
	108	"X c red"
	109	"o c yellow"
	110	"O c #808080"
	111	"# c white"
	112	" "
	113	" .. "
	114	" ..XX. "
	115	" ..XXXXX. "
	116	" ..XXXXXXXX. "
	117	".ooXXXXXXXXX. "
	118	"..ooXXXXXXXXX. "
	119	".X.ooXXXXXXXXX. "
	120	".XX.ooXXXXXX.. "
	121	" .XX.ooXXX..#O "
	122	" .XX.oo..##OO. "
	123	" .XX..##OO.. "
	124	" .X.#OO.. "
	125	" ..O.. "
	126	" .. "
	127	" "))
	128
	129	(defvar mini-page-xpm
196fe1e9	130	#("16 16 4 1"
560af5c5	131	" c None s None"
	132	". c black"
	133	"X c white"
	134	"o c #808080"
	135	" "
	136	" ....... "
	137	" .XXXXX.. "
	138	" .XoooX.X. "
	139	" .XXXXX.... "
	140	" .XooooXoo.o "
	141	" .XXXXXXXX.o "
	142	" .XooooooX.o "
	143	" .XXXXXXXX.o "
	144	" .XooooooX.o "
	145	" .XXXXXXXX.o "
	146	" .XooooooX.o "
	147	" .XXXXXXXX.o "
	148	" ..........o "
	149	" oooooooooo "
	150	" "))
	151
	152	(defvar book-open-xpm
196fe1e9	153	#("16 16 4 1"
560af5c5	154	" c None s None"
	155	". c black"
	156	"X c #808080"
	157	"o c white"
	158	" "
	159	" .. "
	160	" .Xo. ... "
	161	" .Xoo. ..oo. "
	162	" .Xooo.Xooo... "
	163	" .Xooo.oooo.X. "
	164	" .Xooo.Xooo.X. "
	165	" .Xooo.oooo.X. "
	166	" .Xooo.Xooo.X. "
	167	" .Xooo.oooo.X. "
	168	" .Xoo.Xoo..X. "
	169	" .Xo.o..ooX. "
	170	" .X..XXXXX. "
	171	" ..X....... "
	172	" .. "
	173	" "))
	174
	175
	176
	177	;;; Button box
	178
196fe1e9	179	(defun create-bbox-in-frame (class frame-label spacing width height layout)
704a1de4	180	(declare (ignore width height))
	181	(make-instance 'frame
	182	:label frame-label
	183	:child (make-instance class
	184	:border-width 5 :layout-style layout :spacing spacing
977a550d	185	:child (make-instance 'button :stock "gtk-ok")
	186	:child (make-instance 'button :stock "gtk-cancel")
	187	:child (make-instance 'button :stock "gtk-help"))))
704a1de4	188
	189	(define-toplevel create-button-box (window "Button Boxes")
	190	(make-instance 'v-box
f6ebddea	191	:parent window :border-width 10 :spacing 10
704a1de4	192	:child (make-instance 'frame
	193	:label "Horizontal Button Boxes"
	194	:child (make-instance 'v-box
	195	:border-width 10 :spacing 10
	196	:children (mapcar
	197	#'(lambda (args)
	198	(apply #'create-bbox-in-frame
	199	'h-button-box args))
	200	'(("Spread" 40 85 20 :spread)
	201	("Edge" 40 85 20 :edge)
	202	("Start" 40 85 20 :start)
	203	("End" 40 85 20 :end)))))
	204	:child (make-instance 'frame
	205	:label "Vertical Button Boxes"
	206	:child (make-instance 'h-box
	207	:border-width 10 :spacing 10
	208	:children (mapcar
	209	#'(lambda (args)
	210	(apply #'create-bbox-in-frame
	211	'v-button-box args))
	212	'(("Spread" 30 85 20 :spread)
	213	("Edge" 30 85 20 :edge)
	214	("Start" 30 85 20 :start)
	215	("End" 30 85 20 :end)))))))
196fe1e9	216
	217
	218	;; Buttons
	219
704a1de4	220	(define-simple-dialog create-buttons (dialog "Buttons")
196fe1e9	221	(let ((table (make-instance 'table
704a1de4	222	:n-rows 3 :n-columns 3 :homogeneous nil
196fe1e9	223	:row-spacing 5 :column-spacing 5 :border-width 10
704a1de4	224	:parent dialog))
	225	(buttons (loop
	226	for n from 1 to 10
	227	collect (make-instance 'button
	228	:label (format nil "button~D" (1+ n))))))
	229
196fe1e9	230	(dotimes (column 3)
196fe1e9	231	(dotimes (row 3)
704a1de4	232	(let ((button (nth (+ (* 3 row) column) buttons))
704a1de4	233	(button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
196fe1e9	234	(signal-connect button 'clicked
	235	#'(lambda ()
	236	(if (widget-visible-p button+1)
	237	(widget-hide button+1)
	238	(widget-show button+1))))
33f468b7	239	(table-attach table button column (1+ column) row (1+ row)
f6ebddea	240	:options '(:expand :fill)))))))
560af5c5	241
	242
	243	;; Calenadar
	244
704a1de4	245	(define-simple-dialog create-calendar (dialog "Calendar")
704a1de4	246	(make-instance 'v-box
f6ebddea	247	:parent dialog :border-width 10
704a1de4	248	:child (make-instance 'calendar)))
560af5c5	249
	250
	251	;;; Check buttons
	252
704a1de4	253	(define-simple-dialog create-check-buttons (dialog "Check Buttons")
704a1de4	254	(make-instance 'v-box
f6ebddea	255	:border-width 10 :spacing 10 :parent dialog
704a1de4	256	:children (loop
	257	for n from 1 to 3
	258	collect (make-instance 'check-button
	259	:label (format nil "Button~D" n)))))
560af5c5	260
	261
	262
	263	;;; Color selection
	264
704a1de4	265	(define-dialog create-color-selection (dialog "Color selection dialog"
704a1de4	266	'color-selection-dialog
f6ebddea	267	:allow-grow nil :allow-shrink nil
	268	:show-children nil)
	269	(with-slots (colorsel) dialog
	270	(let ((button (make-instance 'check-button :label "Show Opacity")))
	271	(dialog-add-action-widget dialog button
	272	#'(lambda ()
	273	(setf
	274	(color-selection-has-opacity-control-p colorsel)
	275	(toggle-button-active-p button)))))
	276
	277	(let ((button (make-instance 'check-button :label "Show Palette")))
	278	(dialog-add-action-widget dialog button
	279	#'(lambda ()
	280	(setf
	281	(color-selection-has-palette-p colorsel)
	282	(toggle-button-active-p button)))))
704a1de4	283
	284	(signal-connect dialog :ok
	285	#'(lambda ()
	286	(let ((color (color-selection-current-color colorsel)))
	287	(format t "Selected color: ~A~%" color)
	288	(setf (color-selection-current-color colorsel) color)
	289	(widget-hide dialog))))
560af5c5	290
704a1de4	291	(signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5	292
560af5c5	293
	294	;;; Cursors
	295
	296	(defun clamp (n min-val max-val)
	297	(declare (number n min-val max-val))
	298	(max (min n max-val) min-val))
	299
aa9ceddc	300	(defun set-cursor (spinner drawing-area label)
	301	(let ((cursor
	302	(glib:int-enum
	303	(logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
	304	'gdk:cursor-type)))
	305	(setf (label-label label) (string-downcase cursor))
	306	(setf (widget-cursor drawing-area) cursor)))
	307
	308	(defun cursor-expose (drawing-area event)
	309	(declare (ignore event))
	310	(multiple-value-bind (width height)
977a550d	311	(widget-get-size-allocation drawing-area)
aa9ceddc	312	(let* ((window (widget-window drawing-area))
	313	(style (widget-style drawing-area))
	314	(white-gc (style-white-gc style))
	315	(gray-gc (style-bg-gc style :normal))
	316	(black-gc (style-black-gc style)))
	317	(gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
	318	(gdk:draw-rectangle window black-gc t 0 (floor height 2) width
	319	(floor height 2))
	320	(gdk:draw-rectangle window gray-gc t (floor width 3)
	321	(floor height 3) (floor width 3)
	322	(floor height 3))))
	323	t)
	324
	325	(define-simple-dialog create-cursors (dialog "Cursors")
	326	(let ((spinner (make-instance 'spin-button
	327	:adjustment (adjustment-new
	328	0 0
d01ac6fc	329	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
aa9ceddc	330	2 10 0)))
	331	(drawing-area (make-instance 'drawing-area
	332	:width-request 80 :height-request 80
4280ef98	333	:events '(:exposure :button-press)))
aa9ceddc	334	(label (make-instance 'label :label "XXX")))
	335
	336	(signal-connect drawing-area 'expose-event #'cursor-expose :object t)
	337
	338	(signal-connect drawing-area 'button-press-event
	339	#'(lambda (event)
	340	(case (gdk:event-button event)
510fbcc1	341	(1 (spin-button-spin spinner :step-forward))
510fbcc1	342	(3 (spin-button-spin spinner :step-backward)))
aa9ceddc	343	t))
560af5c5	344
aa9ceddc	345	(signal-connect drawing-area 'scroll-event
	346	#'(lambda (event)
	347	(case (gdk:event-direction event)
510fbcc1	348	(:up (spin-button-spin spinner :step-forward))
510fbcc1	349	(:down (spin-button-spin spinner :step-backward)))
aa9ceddc	350	t))
560af5c5	351
aa9ceddc	352	(signal-connect spinner 'changed
	353	#'(lambda ()
	354	(set-cursor spinner drawing-area label)))
560af5c5	355
aa9ceddc	356	(make-instance 'v-box
f6ebddea	357	:parent dialog :border-width 10 :spacing 5
aa9ceddc	358	:child (list
	359	(make-instance 'h-box
	360	:border-width 5
	361	:child (list
	362	(make-instance 'label :label "Cursor Value : ")
	363	:expand nil)
	364	:child spinner)
	365	:expand nil)
	366	:child (make-instance 'frame
aa9ceddc	367	:label "Cursor Area" :label-xalign 0.5 :border-width 10
	368	:child drawing-area)
	369	:child (list label :expand nil))
	370
	371	(widget-realize drawing-area)
	372	(set-cursor spinner drawing-area label)))
560af5c5	373
	374
	375	;;; Dialog
	376
704a1de4	377	(let ((dialog nil))
	378	(defun create-dialog ()
	379	(unless dialog
	380	(setq dialog (make-instance 'dialog
	381	:title "Dialog" :default-width 200
	382	:button "Toggle"
	383	:button (list "gtk-ok" #'widget-destroy :object t)
	384	:signal (list 'destroy
	385	#'(lambda ()
	386	(setq dialog nil)))))
	387
	388	(let ((label (make-instance 'label
	389	:label "Dialog Test" :xpad 10 :ypad 10 :visible t
	390	:parent dialog)))
	391	(signal-connect dialog "Toggle"
	392	#'(lambda ()
	393	(if (widget-visible-p label)
	394	(widget-hide label)
	395	(widget-show label))))))
560af5c5	396
704a1de4	397	(if (widget-visible-p dialog)
	398	(widget-hide dialog)
	399	(widget-show dialog))))
560af5c5	400
	401
	402	;; Entry
	403
704a1de4	404	(define-simple-dialog create-entry (dialog "Entry")
	405	(let ((main (make-instance 'v-box
	406	:border-width 10 :spacing 10 :parent dialog)))
196fe1e9	407
704a1de4	408	(let ((entry (make-instance 'entry :text "hello world" :parent main)))
	409	(editable-select-region entry 0 5) ; this has no effect when
	410	; entry is editable
	411	;; (editable-insert-text entry "great " 6)
	412	;; (editable-delete-text entry 6 12)
196fe1e9	413
613fb570	414	(let ((combo (make-instance 'combo-box-entry
704a1de4	415	:parent main
613fb570	416	:content '("item0"
	417	"item1 item1"
	418	"item2 item2 item2"
	419	"item3 item3 item3 item3"
	420	"item4 item4 item4 item4 item4"
	421	"item5 item5 item5 item5 item5 item5"
	422	"item6 item6 item6 item6 item6"
	423	"item7 item7 item7 item7"
	424	"item8 item8 item8"
	425	"item9 item9"))))
	426	(with-slots (child) combo
	427	(setf (editable-text child) "hello world")
	428	(editable-select-region child 0)))
704a1de4	429
	430	(flet ((create-check-button (label slot)
	431	(make-instance 'check-button
	432	:label label :active t :parent main
	433	:signal (list 'toggled
	434	#'(lambda (button)
	435	(setf (slot-value entry slot)
	436	(toggle-button-active-p button)))
	437	:object t))))
	438
	439	(create-check-button "Editable" 'editable)
	440	(create-check-button "Visible" 'visibility)
f6ebddea	441	(create-check-button "Sensitive" 'sensitive)))))
560af5c5	442
560af5c5	443
96b68e83	444	;; Expander
	445
	446	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	447	(make-instance 'v-box
f6ebddea	448	:parent dialog :spacing 5 :border-width 5
96b68e83	449	:child (create-label "Expander demo. Click on the triangle for details.")
	450	:child (make-instance 'expander
	451	:label "Details"
	452	:child (create-label "Details can be shown or hidden."))))
	453
560af5c5	454
704a1de4	455	;; File chooser dialog
560af5c5	456
704a1de4	457	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
c5502496	458	(file-chooser-add-filter dialog
	459	(make-instance 'file-filter :name "All files" :pattern "*"))
	460	(file-chooser-add-filter dialog
	461	(make-instance 'file-filter :name "Common Lisp source code"
	462	:patterns '(".lisp" ".lsp")))
	463
704a1de4	464	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	465	(dialog-add-button dialog "gtk-ok"
	466	#'(lambda ()
842e5ffe	467	(if (slot-boundp dialog 'filename)
812dd869	468	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
812dd869	469	(write-line "No files selected"))
704a1de4	470	(widget-destroy dialog))))
560af5c5	471
560af5c5	472
3f315085	473	;; Font selection dialog
	474
	475	(define-toplevel create-font-selection (window "Font Button" :resizable nil)
	476	(make-instance 'h-box
	477	:parent window :spacing 8 :border-width 8
	478	:child (make-instance 'label :label "Pick a font")
	479	:child (make-instance 'font-button
	480	:use-font t :title "Font Selection Dialog")))
	481
560af5c5	482
58d925ab	483	;;; Icon View
	484
	485	#+gtk2.6
	486	(let ((file-pixbuf nil)
	487	(folder-pixbuf nil))
	488	(defun load-pixbufs ()
	489	(unless file-pixbuf
	490	(handler-case
	491	(setf
	492	file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	493	folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	494	(glib:glib-error (condition)
	495	(make-instance 'message-dialog
	496	:message-type :error :visible t
	497	:text "<b>Failed to load an image</b>"
	498	:secondary-text (glib:gerror-message condition)
	499	:signal (list :close #'widget-destroy :object t))
	500	(return-from load-pixbufs nil))))
	501	t)
	502
	503	(defun fill-store (store directory)
	504	(list-store-clear store)
	505	(let ((dir #+cmu(unix:open-dir directory)
	506	#+sbcl(sb-posix:opendir directory)))
	507	(unwind-protect
	508	(loop
	509	as filename = #+cmu(unix:read-dir dir)
	510	#+sbcl(let ((dirent (sb-posix:readdir dir)))
	511	(unless (sb-grovel::foreign-nullp dirent)
	512	(sb-posix:dirent-name dirent)))
	513	while filename
	514	unless (or (equal filename ".") (equal filename ".."))
	515	do (let* ((pathname (format nil "~A~A" directory filename))
	516	(directory-p
	517	#+cmu(eq (unix:unix-file-kind pathname) :directory)
	518	#+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
	519	(list-store-append store
	520	(vector
	521	filename
	522	(if directory-p folder-pixbuf file-pixbuf)
	523	directory-p))))
	524	#+cmu(unix:close-dir dir)
	525	#+sbcl(sb-posix:closedir dir))))
	526
	527	(defun sort-func (store a b)
	528	(let ((a-dir-p (tree-model-value store a 'directory-p))
	529	(b-dir-p (tree-model-value store b 'directory-p))
	530	(a-name (tree-model-value store a 'filename))
	531	(b-name (tree-model-value store b 'filename)))
	532	(cond
	533	((and a-dir-p (not b-dir-p)) :before)
	534	((and (not a-dir-p) b-dir-p) :after)
	535	((string< a-name b-name) :before)
	536	((string> a-name b-name) :after)
	537	(t :equal))))
	538
	539	(defun parent-dir (dir)
	540	(let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
	541	(subseq dir 0 end)))
	542
	543	(define-toplevel create-icon-view (window "Icon View demo"
	544	:default-width 650
	545	:default-height 400)
	546	(if (not (load-pixbufs))
547	(widget-destroy window)
548	(let* ((directory "/")
549	(store (make-instance 'list-store
550	:column-types '(string gdk:pixbuf boolean)
551	:column-names '(filename pixbuf directory-p)))
552	(icon-view (make-instance 'icon-view
553	:model store :selection-mode :multiple
554	:text-column 'filename :pixbuf-column 'pixbuf))
555	(up (make-instance 'tool-button
556	:stock "gtk-go-up" :is-important t :sensitive nil))
557	(home (make-instance 'tool-button
558	:stock "gtk-home" :is-important t)))
559	(tree-sortable-set-sort-func store :default #'sort-func)
560	(tree-sortable-set-sort-column store :default :ascending)
561	(fill-store store directory)
562
563	(signal-connect icon-view 'item-activated
564	#'(lambda (path)
565	(when (tree-model-value store path 'directory-p)
566	(setq directory
567	(concatenate 'string directory (tree-model-value store path 'filename) "/"))
568	(fill-store store directory)
569	(setf (widget-sensitive-p up) t))))
570
571	(signal-connect up 'clicked
572	#'(lambda ()
573	(unless (string= directory "/")
574	(setq directory (parent-dir directory))
575	(fill-store store directory)
576	(setf
577	(widget-sensitive-p home)
578	(not (string= directory (namestring (truename #p"clg:")))))
579	(setf (widget-sensitive-p up) (not (string= directory "/"))))))
580
581	(signal-connect home 'clicked
582	#'(lambda ()
583	(setq directory (namestring (truename #p"clg:")))
584	(fill-store store directory)
585	(setf (widget-sensitive-p up) t)
586	(setf (widget-sensitive-p home) nil)))
587
588	(make-instance 'v-box
589	:parent window
590	:child (list
591	(make-instance 'toolbar :child up :child home)
592	:fill nil :expand nil)
593	:child (make-instance 'scrolled-window
594	:shadow-type :etched-in :policy :automatic
595	:child icon-view))))))
596
597
704a1de4	598	;;; Image
560af5c5	599
40a3dac5	600	(define-toplevel create-image (window "Image" :resizable nil)
704a1de4	601	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5	602
	603
	604	;;; Labels
	605
704a1de4	606	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9	607	(flet ((create-label-in-frame (frame-label label-text &rest args)
	608	(list
	609	(make-instance 'frame
	610	:label frame-label
704a1de4	611	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9	612	:fill nil :expand nil)))
704a1de4	613	(make-instance 'h-box
	614	:spacing 5 :parent window
	615	:child-args '(:fill nil :expand nil)
	616	:child (make-instance 'v-box
	617	:spacing 5
	618	:child (create-label-in-frame "Normal Label" "This is a Normal label")
	619	:child (create-label-in-frame "Multi-line Label"
560af5c5	620	"This is a Multi-line label.
560af5c5	621	Second line
196fe1e9	622	Third line")
704a1de4	623	:child (create-label-in-frame "Left Justified Label"
560af5c5	624	"This is a Left-Justified
560af5c5	625	Multi-line.
196fe1e9	626	Third line"
704a1de4	627	:justify :left)
704a1de4	628	:child (create-label-in-frame "Right Justified Label"
560af5c5	629	"This is a Right-Justified
560af5c5	630	Multi-line.
196fe1e9	631	Third line"
704a1de4	632	:justify :right))
	633	:child (make-instance 'v-box
	634	:spacing 5
	635	:child (create-label-in-frame "Line wrapped label"
560af5c5	636	"This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.
196fe1e9	637	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4	638	:wrap t)
	639
	640	:child (create-label-in-frame "Filled, wrapped label"
560af5c5	641	"This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a seneance to prove my point. Here is another sentence. Here comes the sun, do de do de do.
560af5c5	642	This is a new paragraph.
196fe1e9	643	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4	644	:justify :fill :wrap t)
	645
	646	:child (create-label-in-frame "Underlined label"
d01ac6fc	647	(#+cmu glib:latin1-to-unicode #+sbcl identity
560af5c5	648	"This label is underlined!
d01ac6fc	649