[clg] / examples / testdnd.lisp

;;;; Translation of dragndrop.py from the PyGTK 2.0 Tutorial

#+sbcl(require :gtk)
#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)

(defpackage "TESTDND"
  (:use "COMMON-LISP" "GTK")
  (:export "CREATE-TEST"))

(in-package "TESTDND")


(defvar gtk-xpm
  #("32 39 5 1"
    ".      c none"
    "+      c black"
    "@      c #3070E0"
    "#      c #F05050"
    "$      c #35E035"
    "................+..............."
    "..............+++++............."
    "............+++++@@++..........."
    "..........+++++@@@@@@++........."
    "........++++@@@@@@@@@@++........"
    "......++++@@++++++++@@@++......."
    ".....+++@@@+++++++++++@@@++....."
    "...+++@@@@+++@@@@@@++++@@@@+...."
    "..+++@@@@+++@@@@@@@@+++@@@@@++.."
    ".++@@@@@@+++@@@@@@@@@@@@@@@@@@++"
    ".+#+@@@@@@++@@@@+++@@@@@@@@@@@@+"
    ".+##++@@@@+++@@@+++++@@@@@@@@$@."
    ".+###++@@@@+++@@@+++@@@@@++$$$@."
    ".+####+++@@@+++++++@@@@@+@$$$$@."
    ".+#####+++@@@@+++@@@@++@$$$$$$+."
    ".+######++++@@@@@@@++@$$$$$$$$+."
    ".+#######+##+@@@@+++$$$$$$@@$$+."
    ".+###+++##+##+@@++@$$$$$$++$$$+."
    ".+###++++##+##+@@$$$$$$$@+@$$@+."
    ".+###++++++#+++@$$@+@$$@++$$$@+."
    ".+####+++++++#++$$@+@$$++$$$$+.."
    ".++####++++++#++$$@+@$++@$$$$+.."
    ".+#####+++++##++$$++@+++$$$$$+.."
    ".++####+++##+#++$$+++++@$$$$$+.."
    ".++####+++####++$$++++++@$$$@+.."
    ".+#####++#####++$$+++@++++@$@+.."
    ".+#####++#####++$$++@$$@+++$@@.."
    ".++####++#####++$$++$$$$$+@$@++."
    ".++####++#####++$$++$$$$$$$$+++."
    ".+++####+#####++$$++$$$$$$$@+++."
    "..+++#########+@$$+@$$$$$$+++..."
    "...+++########+@$$$$$$$$@+++...."
    ".....+++######+@$$$$$$$+++......"
    "......+++#####+@$$$$$@++........"
    ".......+++####+@$$$$+++........."
    ".........++###+$$$@++..........."
    "..........++##+$@+++............"
    "...........+++++++.............."
    ".............++++..............."))


(defvar *target-type-text* 80)
(defvar *target-type-image* 81)

(defvar from-image 
  (list
   (make-instance 'target-entry :target "text/plain" :id *target-type-text*)
   (make-instance 'target-entry :target "image/png" :id *target-type-image*)))
(defvar to-button 
  (make-instance 'target-entry :target "text/plain" :id *target-type-text*))
(defvar to-canvas 
  (make-instance 'target-entry :target "image/png" :id *target-type-image*))

(defun add-image (layout pixbuf xd yd)
  (let ((button (make-instance 'button
		 :child (make-instance 'image :pixbuf pixbuf))))
    (widget-show-all button)

    (signal-connect button 'drag-data-get
     #'(lambda (context selection target-type time)
	 (declare (ignore context time))
	 (cond
	  ((= target-type *target-type-text*)
	   (selection-data-set-text selection 
	    #+cmu(ext:format-universal-time nil (get-universal-time) :style :rfc1123 :print-timezone nil)
	    #+sbcl(sb-int:format-universal-time nil (get-universal-time) :style :abbreviated :print-timezone nil)
	    #+clisp(os:string-time "%x %X")
	    #-(or cmu sbcl clisp)(format nil "~D" (get-universal-time))))
	  ((= target-type *target-type-image*)
	   (selection-data-set-pixbuf selection pixbuf)))))
     
    (drag-source-set button :button1 from-image :copy)
 
    (with-slots (hadjustment vadjustment) layout
      (layout-put layout button
       (truncate (+ xd (adjustment-value hadjustment)))
       (truncate (+ yd (adjustment-value vadjustment)))))))


(defun create-layout (width height)
  (let* ((table (make-instance 'table
	         :n-rows 2 :n-columns 2 :homogeneous nil))
	 (layout (make-instance 'layout :width width :height height))
	 (vscrollbar (make-instance 'v-scrollbar 
		      :adjustment (layout-vadjustment layout)))
	 (hscrollbar (make-instance 'h-scrollbar
		      :adjustment (layout-hadjustment layout)))
	 (button (make-instance 'button :label "Text target")))
    (table-attach table layout 0 1 0 1 :options '(:fill :expand))
    (table-attach table vscrollbar 1 2 0 1 :options '(:fill :shrink))
    (table-attach table hscrollbar 0 1 1 2 :options '(:fill :shrink))

    (signal-connect layout 'drag-data-received
     #'(lambda (context x y selection target-type time)
	 (declare (ignore context time))
	 (when (= target-type *target-type-image*)
	   (add-image layout (selection-data-get-pixbuf selection) x y))))

    (drag-dest-set layout '(:motion :highlight :drop) to-canvas :copy)

    (add-image layout (gdk:pixbuf-new-from-xpm-data gtk-xpm) 0 0)

    (signal-connect button 'drag-data-received
     #'(lambda (context x y selection target-type time)
	 (declare (ignore context x y time))
	 (when (= target-type *target-type-text*)
	   (setf 
	    (button-label button) 
	    (selection-data-get-text selection)))))

    (drag-dest-set button '(:motion :highlight :drop) to-button :copy)
 
    (make-instance 'v-box 
     :children (list (list table :expand t :fill t)
		     (list button :expand nil :fill nil)))))


(defun create-test ()
  (make-instance 'window
   :title "Drag and Drop Test"
   :visible t :show-children t
   :default-width 300 :default-height 300
   :child (create-layout 600 600)))

(clg-init)
(within-main-loop (create-test))
Commit	Line	Data
d73e091e	1	;;;; Translation of dragndrop.py from the PyGTK 2.0 Tutorial
	2
	3	#+sbcl(require :gtk)
f86d1eb7	4	#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
d73e091e	5
	6	(defpackage "TESTDND"
	7	(:use "COMMON-LISP" "GTK")
	8	(:export "CREATE-TEST"))
	9
	10	(in-package "TESTDND")
	11
	12
	13	(defvar gtk-xpm
	14	#("32 39 5 1"
	15	". c none"
	16	"+ c black"
	17	"@ c #3070E0"
	18	"# c #F05050"
	19	"$ c #35E035"
	20	"................+..............."
	21	"..............+++++............."
	22	"............+++++@@++..........."
	23	"..........+++++@@@@@@++........."
	24	"........++++@@@@@@@@@@++........"
	25	"......++++@@++++++++@@@++......."
	26	".....+++@@@+++++++++++@@@++....."
	27	"...+++@@@@+++@@@@@@++++@@@@+...."
	28	"..+++@@@@+++@@@@@@@@+++@@@@@++.."
	29	".++@@@@@@+++@@@@@@@@@@@@@@@@@@++"
	30	".+#+@@@@@@++@@@@+++@@@@@@@@@@@@+"
	31	".+##++@@@@+++@@@+++++@@@@@@@@$@."
	32	".+###++@@@@+++@@@+++@@@@@++$$$@."
	33	".+####+++@@@+++++++@@@@@+@$$$$@."
	34	".+#####+++@@@@+++@@@@++@$$$$$$+."
	35	".+######++++@@@@@@@++@$$$$$$$$+."
	36	".+#######+##+@@@@+++$$$$$$@@$$+."
	37	".+###+++##+##+@@++@$$$$$$++$$$+."
	38	".+###++++##+##+@@$$$$$$$@+@$$@+."
	39	".+###++++++#+++@$$@+@$$@++$$$@+."
	40	".+####+++++++#++$$@+@$$++$$$$+.."
	41	".++####++++++#++$$@+@$++@$$$$+.."
	42	".+#####+++++##++$$++@+++$$$$$+.."
	43	".++####+++##+#++$$+++++@$$$$$+.."
	44	".++####+++####++$$++++++@$$$@+.."
	45	".+#####++#####++$$+++@++++@$@+.."
	46	".+#####++#####++$$++@$$@+++$@@.."
	47	".++####++#####++$$++$$$$$+@$@++."
	48	".++####++#####++$$++$$$$$$$$+++."
	49	".+++####+#####++$$++$$$$$$$@+++."
	50	"..+++#########+@$$+@$$$$$$+++..."
	51	"...+++########+@$$$$$$$$@+++...."
	52	".....+++######+@$$$$$$$+++......"
	53	"......+++#####+@$$$$$@++........"
	54	".......+++####+@$$$$+++........."
	55	".........++###+$$$@++..........."
	56	"..........++##+$@+++............"
	57	"...........+++++++.............."
	58	".............++++..............."))
	59
	60
	61	(defvar target-type-text 80)
	62	(defvar target-type-image 81)
	63
0beedfe6	64	(defvar from-image
d73e091e	65	(list
	66	(make-instance 'target-entry :target "text/plain" :id target-type-text)
	67	(make-instance 'target-entry :target "image/png" :id target-type-image)))
	68	(defvar to-button
	69	(make-instance 'target-entry :target "text/plain" :id target-type-text))
	70	(defvar to-canvas
	71	(make-instance 'target-entry :target "image/png" :id target-type-image))
	72
d73e091e	73	(defun add-image (layout pixbuf xd yd)
	74	(let ((button (make-instance 'button
	75	:child (make-instance 'image :pixbuf pixbuf))))
	76	(widget-show-all button)
	77
	78	(signal-connect button 'drag-data-get
	79	#'(lambda (context selection target-type time)
	80	(declare (ignore context time))
	81	(cond
	82	((= target-type target-type-text)
	83	(selection-data-set-text selection
	84	#+cmu(ext:format-universal-time nil (get-universal-time) :style :rfc1123 :print-timezone nil)
f86d1eb7	85	#+sbcl(sb-int:format-universal-time nil (get-universal-time) :style :abbreviated :print-timezone nil)
	86	#+clisp(os:string-time "%x %X")
	87	#-(or cmu sbcl clisp)(format nil "~D" (get-universal-time))))
d73e091e	88	((= target-type target-type-image)
	89	(selection-data-set-pixbuf selection pixbuf)))))
	90
	91	(drag-source-set button :button1 from-image :copy)
f86d1eb7	92
d73e091e	93	(with-slots (hadjustment vadjustment) layout
	94	(layout-put layout button
	95	(truncate (+ xd (adjustment-value hadjustment)))
	96	(truncate (+ yd (adjustment-value vadjustment)))))))
	97
	98
	99
	100	(defun create-layout (width height)
	101	(let* ((table (make-instance 'table
	102	:n-rows 2 :n-columns 2 :homogeneous nil))
	103	(layout (make-instance 'layout :width width :height height))
	104	(vscrollbar (make-instance 'v-scrollbar
	105	:adjustment (layout-vadjustment layout)))
	106	(hscrollbar (make-instance 'h-scrollbar
	107	:adjustment (layout-hadjustment layout)))
	108	(button (make-instance 'button :label "Text target")))
	109	(table-attach table layout 0 1 0 1 :options '(:fill :expand))
	110	(table-attach table vscrollbar 1 2 0 1 :options '(:fill :shrink))
	111	(table-attach table hscrollbar 0 1 1 2 :options '(:fill :shrink))
	112
	113	(signal-connect layout 'drag-data-received
	114	#'(lambda (context x y selection target-type time)
	115	(declare (ignore context time))
	116	(when (= target-type target-type-image)
	117	(add-image layout (selection-data-get-pixbuf selection) x y))))
	118
	119	(drag-dest-set layout '(:motion :highlight :drop) to-canvas :copy)
	120
	121	(add-image layout (gdk:pixbuf-new-from-xpm-data gtk-xpm) 0 0)
	122
	123	(signal-connect button 'drag-data-received
	124	#'(lambda (context x y selection target-type time)
	125	(declare (ignore context x y time))
d73e091e	126	(when (= target-type target-type-text)
	127	(setf
	128	(button-label button)
	129	(selection-data-get-text selection)))))
	130
	131	(drag-dest-set button '(:motion :highlight :drop) to-button :copy)
	132
	133	(make-instance 'v-box
	134	:children (list (list table :expand t :fill t)
	135	(list button :expand nil :fill nil)))))
	136
	137
	138
	139	(defun create-test ()
	140	(make-instance 'window
	141	:title "Drag and Drop Test"
	142	:visible t :show-children t
	143	:default-width 300 :default-height 300
	144	:child (create-layout 600 600)))
	145
	146	(clg-init)
ddcb3b7d	147	(within-main-loop (create-test))