From: espen <espen>
Date: Mon, 6 Feb 2006 18:14:45 +0000 (+0000)
Subject: Initial checkin
X-Git-Tag: clg-0-92~80
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/commitdiff_plain/2215b974a5d173c481616875af3d79cf49647961?hp=49674546698d86ce9cfb64db8193877644228b47

Initial checkin
---

diff --git a/examples/testdnd.lisp b/examples/testdnd.lisp
new file mode 100644
index 0000000..2e6c656
--- /dev/null
+++ b/examples/testdnd.lisp
@@ -0,0 +1,148 @@
+;;;; Translation of dragndrop.py from the PyGTK 2.0 Tutorial
+
+#+sbcl(require :gtk)
+#+cmu(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)
+
+(setq 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)))
+	  ((= 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))
+	 (print 'her)
+	 (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)
+(create-test)