chiark - git - mdw - clg/blob - examples/testdnd.lisp

   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))