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) |
147 | (create-test) |