| 1 | ;;;; Translation of dragndrop.py from the PyGTK 2.0 Tutorial |
| 2 | |
| 3 | #+sbcl(require :gtk) |
| 4 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk) |
| 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 | |
| 64 | (defvar from-image |
| 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 | |
| 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) |
| 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)))) |
| 88 | ((= target-type *target-type-image*) |
| 89 | (selection-data-set-pixbuf selection pixbuf))))) |
| 90 | |
| 91 | (drag-source-set button :button1 from-image :copy) |
| 92 | |
| 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)) |
| 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 | (within-main-loop (create-test)) |