;;; LTKのbind

(ql:quickload :ltk)

(defpackage :ex4-24
  (:use :common-lisp :ltk))

(in-package :ex4-24)

(defun keybind-1 ()
  (with-ltk ()
    (wm-title *tk* "キーバインド")
    (minsize *tk* 600 500)
    (let* ((msg (make-instance 'message
                               :text "キーバインドのテスト: Alt-qで終了"
                               :width 1000
                               :background "#FFFFFF"))
           (quit-button (make-instance 'button
                                       :text "Quit"
                                       :command (lambda ()
                                                  (setf *exit-mainloop* t)))))
      (bind *tk* "<Alt-q>"
            (lambda (event)
              (declare (ignore event))
              (funcall (command quit-button))))
      (pack msg :side :top :fill :x)
      (pack quit-button :side :bottom :fill :x))))

(keybind-1)

(ql:quickload :ltk)

(defpackage :ltkdoc-bind
  (:use :common-lisp :ltk))

(in-package :ltkdoc-bind)

(defun scribble ()
  (with-ltk ()
    (wm-title *tk* "Bindのテスト")

    ;;オブジェクト定義
    (let* ((msg (make-instance 'message
                               :text "Ctrl-r 赤色、Ctrl-b 青色、 Ctrl-g 緑色、Alt-qで終了"
                               :width 1000
                               :background "#FFFFFF"))
           (stat (make-instance 'message
                                :text ""
                                :width 1000
                                :background "#FFFFFF"))
           (canvas (make-instance 'canvas :background :black))
           (down nil)
           (color :white))
      (pack msg :side :top :fill :x)
      (pack stat :side :top :fill :x)
      (pack canvas)
      ;;マウスボタン定義
      (bind canvas
            "<ButtonPress-1>"
            (lambda (evt)
              (setf down t)
              (setf (text stat) "<ButtonPress-1>")
              (itemConfigure canvas
                             (create-oval canvas
                                          (- (event-x evt) 10) (- (event-y evt) 10)
                                          (+ (event-x evt) 10) (+ (event-y evt) 10))
                             "fill" color)))
      (bind canvas
            "<ButtonRelease-1>"
            (lambda (evt)
              (declare (ignore evt))
              (setf (text stat) "<ButtonRelease-1>")
              (setf down nil)))
      (bind canvas 
            "<Motion>"
            (lambda (evt)
              (when down
                (setf (text stat) "<ButtonPress-1> + <Motion>")
                (itemConfigure canvas
                               (create-oval canvas
                                            (- (event-x evt) 10) (- (event-y evt) 10)
                                            (+ (event-x evt) 10) (+ (event-y evt) 10))
                               "outline" color))))
      ;;キーバインド定義
      (bind *tk* "<Alt-q>"              ; 終了
            (lambda (event)
              (declare (ignore event))
              (setf *exit-mainloop* t)))
      (bind *tk* "<Control-b>"          ; 青色にする
            (lambda (event)
              (declare (ignore event))
              (configure canvas :background :blue)))
      (bind *tk* "<Control-r>"          ; 赤色にする
            (lambda (event)
              (declare (ignore event))
              (configure canvas :background :red)))
      (bind *tk* "<Control-g>"          ; 緑色にする
            (lambda (event)
              (declare (ignore event))
              (configure canvas :background :green))))))

(scribble)