[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.28 2005/04/19 08:17:06 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
0d07716f	1	;; Common Lisp bindings for GTK+ v2.0
8179fd68	2	;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
0d07716f	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
d8046c5f	18	;; $Id: testgtk.lisp,v 1.28 2005/04/19 08:17:06 espen Exp $
0d07716f	19
582a125f	20	(defpackage "TESTGTK"
582a125f	21	(:use "COMMON-LISP" "GTK"))
35ec512c	22
582a125f	23	(in-package "TESTGTK")
35ec512c	24
	25	(defmacro define-toplevel (name (window title &rest initargs) &body body)
	26	`(let ((,window nil))
0d07716f	27	(defun ,name ()
35ec512c	28	(unless ,window
6490e9f1	29	(setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
35ec512c	30	(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f	31	,@body)
0d07716f	32
582a125f	33	(when ,window
	34	(if (not (widget-visible-p ,window))
	35	(widget-show ,window)
	36	(widget-hide ,window))))))
35ec512c	37
0d07716f	38
35ec512c	39	(defmacro define-dialog (name (dialog title &optional (class 'dialog)
	40	&rest initargs)
	41	&body body)
	42	`(let ((,dialog nil))
0d07716f	43	(defun ,name ()
35ec512c	44	(unless ,dialog
6490e9f1	45	(setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
35ec512c	46	(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
35ec512c	47	,@body)
0d07716f	48
582a125f	49	(when ,dialog
	50	(if (not (widget-visible-p ,dialog))
	51	(widget-show ,dialog)
	52	(widget-hide ,dialog))))))
0d07716f	53
0d07716f	54
35ec512c	55	(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
35ec512c	56	`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b	57	,@body
e025589b	58	(dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f	59
0d07716f	60
0d07716f	61
	62	;;; Pixmaps used in some of the tests
	63
	64	(defvar gtk-mini-xpm
4fb50b71	65	#("15 20 17 1"
0d07716f	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
4fb50b71	105	#("16 16 6 1"
0d07716f	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
4fb50b71	130	#("16 16 4 1"
0d07716f	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
4fb50b71	153	#("16 16 4 1"
0d07716f	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
4fb50b71	179	(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c	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
8804934b	185	:child (make-instance 'button :stock "gtk-ok")
	186	:child (make-instance 'button :stock "gtk-cancel")
	187	:child (make-instance 'button :stock "gtk-help"))))
35ec512c	188
	189	(define-toplevel create-button-box (window "Button Boxes")
	190	(make-instance 'v-box
6490e9f1	191	:parent window :border-width 10 :spacing 10
35ec512c	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)))))))
4fb50b71	216
	217
	218	;; Buttons
	219
35ec512c	220	(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71	221	(let ((table (make-instance 'table
35ec512c	222	:n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71	223	:row-spacing 5 :column-spacing 5 :border-width 10
35ec512c	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
4fb50b71	230	(dotimes (column 3)
4fb50b71	231	(dotimes (row 3)
35ec512c	232	(let ((button (nth (+ (* 3 row) column) buttons))
35ec512c	233	(button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71	234	(signal-connect button 'clicked
	235	#'(lambda ()
	236	(if (widget-visible-p button+1)
	237	(widget-hide button+1)
	238	(widget-show button+1))))
81f2aa93	239	(table-attach table button column (1+ column) row (1+ row)
6490e9f1	240	:options '(:expand :fill)))))))
0d07716f	241
	242
	243	;; Calenadar
	244
35ec512c	245	(define-simple-dialog create-calendar (dialog "Calendar")
35ec512c	246	(make-instance 'v-box
6490e9f1	247	:parent dialog :border-width 10
35ec512c	248	:child (make-instance 'calendar)))
0d07716f	249
	250
	251	;;; Check buttons
	252
35ec512c	253	(define-simple-dialog create-check-buttons (dialog "Check Buttons")
35ec512c	254	(make-instance 'v-box
6490e9f1	255	:border-width 10 :spacing 10 :parent dialog
35ec512c	256	:children (loop
	257	for n from 1 to 3
	258	collect (make-instance 'check-button
	259	:label (format nil "Button~D" n)))))
0d07716f	260
	261
	262
	263	;;; Color selection
	264
35ec512c	265	(define-dialog create-color-selection (dialog "Color selection dialog"
35ec512c	266	'color-selection-dialog
6490e9f1	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)))))
35ec512c	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))))
0d07716f	290
35ec512c	291	(signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f	292
0d07716f	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
af5eb952	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)
8804934b	311	(widget-get-size-allocation drawing-area)
af5eb952	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
e7020c53	329	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
af5eb952	330	2 10 0)))
	331	(drawing-area (make-instance 'drawing-area
	332	:width-request 80 :height-request 80
8f0159a6	333	:events '(:exposure :button-press)))
af5eb952	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)
45314d76	341	(1 (spin-button-spin spinner :step-forward))
45314d76	342	(3 (spin-button-spin spinner :step-backward)))
af5eb952	343	t))
0d07716f	344
af5eb952	345	(signal-connect drawing-area 'scroll-event
	346	#'(lambda (event)
	347	(case (gdk:event-direction event)
45314d76	348	(:up (spin-button-spin spinner :step-forward))
45314d76	349	(:down (spin-button-spin spinner :step-backward)))
af5eb952	350	t))
0d07716f	351
af5eb952	352	(signal-connect spinner 'changed
	353	#'(lambda ()
	354	(set-cursor spinner drawing-area label)))
0d07716f	355
af5eb952	356	(make-instance 'v-box
6490e9f1	357	:parent dialog :border-width 10 :spacing 5
af5eb952	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
af5eb952	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)))
0d07716f	373
	374
	375	;;; Dialog
	376
35ec512c	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))))))
0d07716f	396
35ec512c	397	(if (widget-visible-p dialog)
	398	(widget-hide dialog)
	399	(widget-show dialog))))
0d07716f	400
	401
	402	;; Entry
	403
35ec512c	404	(define-simple-dialog create-entry (dialog "Entry")
	405	(let ((main (make-instance 'v-box
	406	:border-width 10 :spacing 10 :parent dialog)))
4fb50b71	407
35ec512c	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)
4fb50b71	413
e52cf822	414	(let ((combo (make-instance 'combo-box-entry
35ec512c	415	:parent main
e52cf822	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)))
35ec512c	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)
6490e9f1	441	(create-check-button "Sensitive" 'sensitive)))))
0d07716f	442
0d07716f	443
36c95ad8	444	;; Expander
	445
	446	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	447	(make-instance 'v-box
6490e9f1	448	:parent dialog :spacing 5 :border-width 5
36c95ad8	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
0d07716f	454
35ec512c	455	;; File chooser dialog
0d07716f	456
35ec512c	457	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
d5e2ce7c	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
35ec512c	464	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	465	(dialog-add-button dialog "gtk-ok"
	466	#'(lambda ()
ab652f5f	467	(if (slot-boundp dialog 'filename)
7c1f9a1e	468	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
7c1f9a1e	469	(write-line "No files selected"))
35ec512c	470	(widget-destroy dialog))))
0d07716f	471
0d07716f	472
b9d3ad20	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
0d07716f	482
582a125f	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
35ec512c	598	;;; Image
0d07716f	599
c1f1a833	600	(define-toplevel create-image (window "Image" :resizable nil)
35ec512c	601	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f	602
	603
	604	;;; Labels
	605
35ec512c	606	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71	607	(flet ((create-label-in-frame (frame-label label-text &rest args)
	608	(list
	609	(make-instance 'frame
	610	:label frame-label
35ec512c	611	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
4fb50b71	612	:fill nil :expand nil)))
35ec512c	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"
0d07716f	620	"This is a Multi-line label.
0d07716f	621	Second line
4fb50b71	622	Third line")
35ec512c	623	:child (create-label-in-frame "Left Justified Label"
0d07716f	624	"This is a Left-Justified
0d07716f	625	Multi-line.
4fb50b71	626	Third line"
35ec512c	627	:justify :left)
35ec512c	628	:child (create-label-in-frame "Right Justified Label"
0d07716f	629	"This is a Right-Justified
0d07716f	630	Multi-line.
4fb50b71	631	Third line"
35ec512c	632	:justify :right))
	633	:child (make-instance 'v-box
	634	:spacing 5
	635	:child (create-label-in-frame "Line wrapped label"
0d07716f	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.
4fb50b71	637	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c	638	:wrap t)
	639
	640	:child (create-label-in-frame "Filled, wrapped label"
0d07716f	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.
0d07716f	642	This is a new paragraph.
4fb50b71	643	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c	644	:justify :fill :wrap t)
	645
	646	:child (create-label-in-frame "Underlined label"
e7020c53	647	(#+cmu glib:latin1-to-unicode #+sbcl identity
0d07716f	648	"This label is underlined!
e7020c53	649