[clg] / examples / testgtk.lisp

;; Common Lisp bindings for GTK+ v2.x
;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
;;
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
;; without limitation the rights to use, copy, modify, merge, publish,
;; distribute, sublicense, and/or sell copies of the Software, and to
;; permit persons to whom the Software is furnished to do so, subject to
;; the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;; Parts of this file are direct translations of code from 'testgtk.c'
;; distributed with the Gtk+ library, and thus covered by the GNU
;; Lesser General Public License and copyright Peter Mattis, Spencer
;; Kimball, Josh MacDonald and others.


;; $Id: testgtk.lisp,v 1.34 2006/02/26 23:46:55 espen Exp $

#+sbcl(require :gtk)
#+sbcl(require :sb-posix)
#+cmu(asdf:oos 'asdf:load-op :gtk)

(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 (Note: using the drawing function in Gdk is considered
;;; deprecated in clg, new code should use Cairo instead)

(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!