ltk-test.lisp

;;; -*- Coding: utf-8; Mode: Lisp; -*-

;; ltkのドキュメント
;; http://www.peter-herth.de/ltk/ltkdoc/

;; 逆引きCommon Lisp: Ltk
;; https://lisphub.jp/common-lisp/cookbook/index.cgi?Ltk

;; ライブラリ読み込み
(ql:quickload :ltk)

;; for debug
(ql:quickload :cl-debug-print)
(cl-syntax:use-syntax cl-debug-print:debug-print-syntax)

(in-package :ltk)

(setf *debug-tk* t) ; tにすると標準出力にTcl/Tkのデバッグメッセージが出る

;; demo
(ltktest)

(defun hello-0 ()
  (with-ltk ()
    (font-create "vlgothic" :family "\"VL Gothic\"" :size 36)
    (let ((label (make-instance 'label :text "Hello, World!!" :font "vlgothic")))
      (pack label))))

(hello-0)

;;; Tutorial
;; http://www.peter-herth.de/ltk/ltkdoc/node5.html
(defun hello-1 ()
  (with-ltk ()
    ;; TkではGUIの要素は木構造になっていて、masterで親要素を指定する
    ;; 例えば、大きな枠の中にボタンを置きたいときなどに枠のオブジェクトをmasterとして指定する
    ;; masterにnilを指定するとトップレベルに配置する
    (let ((b1 (make-instance 'button
                             :master nil
                             ;; ボタンに表示する文字列
                             :text "hello"
                             ;; command はボタンが押されたときに呼び出される関数
                             :command (lambda () (do-msg "Hello World!")))) ; メッセージボックスを出す
          (b2 (make-instance 'button
                             :master nil
                             :text "quit"
                             :command (lambda () (setf *exit-mainloop* t))))) ; ウインドウを閉じる
      ;; packは水平、または垂直にウィジェットを積み重ねる
      (pack b1)
      (pack b2)
      ;; (pack (list b1 b2) :side :top))) ; 縦に並べる(デフォルト)
      ;; (pack (list b1 b2) :side :left))) ; 横に並べる

      ;; 格子状に配置するgridもある。packとgridは同時には使えない
      
      )))

(hello-1)

(defun hello-2 ()
  ;; with-ltkのオプションはデバッグレベルを表す :debug や :serve-event :stream がある
  ;; serve-eventは別スレッドでmainloopを回すということで、例えばREPLでwith-ltkを:serve-event付きで呼ぶとREPLはブロックせずにすぐ次のプロンプトが出てくる。バックグラウンドで動いているスレッドをkillしないとGUIアプリは起動したままになる
  (with-ltk (:serve-event nil)
    (let* ((f (make-instance 'frame))
           (b1 (make-instance 'button
                              :master f ; 自動的にフレームfに詰め込まれる
                              :text "Button 1"
                              :command (lambda () (format t "Button1~&"))))
           (b2 (make-instance 'button
                              :master f
                              :text "Button 2"
                              :command (lambda () (format t "Button2~&")))))
      (pack (list f b1 b2) :side :left)
      ;; フレームfの外観をカスタマイズする。configureはどのtkオブジェクトに対しても汎用的に使える
      ;; 引数は設定オプションの名前と、値の2引数
      (configure f :borderwidth 10)
      (configure f :relief :sunken) ; fの周りが凹んだように見える
      ;;(configure f :relief :raised) ; fの周りが盛り上がったように見える
      ;;(configure f :relief :ridge)
      ;;(configure f :relief :groove)
      ;;(configure f :relief :flat)   ; フラット。これがデフォルト
      ;;(configure f :relief :solid)  ; 黒縁
      )))

(hello-2)

;; Packの並び方を制御する
;; https://lisphub.jp/common-lisp/cookbook/index.cgi?Ltk%3A%E3%83%9C%E3%82%BF%E3%83%B3%E3%82%92%E8%A1%A8%E7%A4%BA%E3%81%99%E3%82%8B
(defun ex4-02 ()
  (with-ltk ()
    (let* ((b1 (make-instance
                'button
                :text "ボタン１"
                :command (lambda ()
                           (format t "ボタン１を押しました"))))
           (b2 (make-instance
                'button
                :text "ボタン２"
                :command (lambda ()
                           (format t "ボタン２を押しました"))))
           (b3 (make-instance
                'button
                :text "終了"
                :command (lambda ()
                           (format t "終了")
                           (setf *exit-mainloop* t)))))
      ;;(pack (list b1 b2 b3) :side :top)         ; 通常の並び、順番に並ぶ。これがデフォルト
      ;;(pack (list b1 b2 b3) :side :left)        ; 指定されたオブジェクトを左から順番に並べる
      ;;(pack (list b1 b2 b3) :side :top :fill :x) ; fillを指定すると、Wiindowのハシをドラッグして伸ばしてもボタンが大きくなる。
      (pack (list b1 b2 b3) :side :top :fill :both :expand :yes) ; fill,both,expand,yesを指定すると、Wiindowのハシをドラッグして伸ばしても、ボタンが上下左右に大きくなる。
      )))

(ex4-02)

;;; ボタンの応用: 電卓アプリ
;; http://kaolin.unice.fr/STk/STk.html
;; STk-4.0.1/Demos/calc.stklos を参考にLTkへ移植

(defun digit? (s)
  (or (parse-integer s :junk-allowed T)
      (string= s ".")))

(defclass screen (entry)
  ;;LTkのentryでは -textvariable は直接アクセスさせないようなので、
  ;; screenというラッパークラスを定義
  ((result :initform 0 :accessor result)
   (previous-action :initform "" :accessor previous-action)
   (acc :initform 0 :accessor acc)
   (operator :initform #'+ :accessor operator)))

(defmethod (setf result) :after (val (obj screen))
  (setf (text obj) (slot-value obj 'result)))

(defmethod value ((obj screen))
  (read-from-string (text obj) nil 0))

(defmethod execute-action ((obj screen) str)
  (with-accessors ((operator operator)
                   (result result)
                   (acc acc)
                   (previous-action previous-action)
                   (value value)
                   (text text))
      obj
    (cond ((string= str "Off")  (setq *exit-mainloop* T))
          ((string= str "Sqrt") (setq result (sqrt value)))
          ((string= str "C")    (setq result 0))
          ((string= str "/")    (setq operator #'/))
          ((string= str "*")    (setq operator #'*))
          ((string= str "-")    (setq operator #'-))
          ((string= str "+")    (setq operator #'+))
          ((string= str "+/-")  (setq result (- value)))
          ((string= str "=")
           (setf result (funcall operator acc value)))
          ('ELSE
           (setq result (if (digit? previous-action)
                            (concatenate 'string text str)
                            (progn
                              (setq acc value)
                              str)))))
    (setq previous-action str)))

(defun calc ()
  (with-ltk ()
    (let ((screen (make-instance 'screen :text "0"))
          ;; Rows is a vector of 5 frames
          (rows (map-into (make-sequence 'vector 5)
                          (lambda () (make-instance 'frame)))))
      (mapc (let ((count 0))
              (lambda (text)
                (pack (make-instance 'button
                                     :text text 
                                     :master (aref rows (floor count 4))
                                     :width  6
                                     :command (lambda () 
                                                (execute-action screen text)))
                      :side :left :padx 4 :pady 2 :fill :both :expand :yes)
                (incf count)))
            '("Off"  "Sqrt"  "C"  "/"
              "7"    "8"    "9"  "*"
              "4"    "5"    "6"  "-"
              "1"    "2"    "3"  "+"
              "0"    "."   "+/-" "="))
      (pack screen :fill :x :padx 5 :pady 5 :ipadx 5 :ipady 5)
      (map nil 
           (lambda (row)
             (pack row :fill :both :expand :yes))
           rows))))

;; 実行
(calc)

;;; Special variables

;; *debug-tk* When t, the communication with wish is echoed to the standard output. Default value: t 
;; *wish-pathname* The path to the executable to wish. 
;; *wish-args* The arguments passed to the call to wish. Default value: ("-name" "LTK") 
;; *ltk-version* The version of the Ltk library. 

(defun print-valiables ()
  (with-ltk ()
    #>*debug-tk*
    #>*wish-pathname*
    ;; ウインドウが出ている状態で ps aux | grep wish すると *wish-args* 付きで起動されているプロセスがある
    #>*wish-args*
    #>*ltk-version*))

(print-valiables)

;;; Canvas

(defun canvastest ()
  (with-ltk ()
    (let* ((sc (make-instance 'scrolled-canvas))
           (c (canvas sc))
           (line (create-line c (list 100 100 400 50 700 150)))
           (image (create-image c 0 0 :image (make-instance 'photo-image :file #P"/home/wiz/renzuru-symbol-twitter-icon.png" :name "img")))
           (polygon (create-polygon c (list 50 150 250 160 250 300 50 330)))
           (text (create-text c 260 250 "Canvas test")))
      (pack sc :expand 1 :fill :both)
      ;; canvas要素に属性を付ける
      (itemconfigure c polygon "fill" "blue")
      (scrollregion c 0 0 800 800))))

(canvastest)

;; 簡易お絵描きアプリ: canvasに
(defun scribble ()
  (with-ltk ()
    (let* ((canvas (make-canvas nil :width 500 :height 500))
           (down nil)
           (b (make-instance 'button
                             :master nil
                             :text "clear"
                             :command (lambda () (clear canvas)))))
      ;; ウィジェットの配置
      (pack canvas)
      (pack b)

      ;; マウスイベントで関数を実行
      (bind canvas "<ButtonPress-1>"
            (lambda (evt)
              #>evt
              (setf down t)
              (create-oval canvas
                           (- (event-x evt) 2) (- (event-y evt) 2)
                           (+ (event-x evt) 2) (+ (event-y evt) 2))))
      (bind canvas "<ButtonRelease-1>" (lambda (evt)
                                         (declare (ignore evt))
                                         (setf down nil)))
      (bind canvas "<Motion>"
            (lambda (evt)
              (when down
                (create-oval canvas
                             (- (event-x evt) 2) (- (event-y evt) 2)
                             (+ (event-x evt) 2) (+ (event-y evt) 2))))))))

(scribble)

;; listboxのテスト

(with-ltk ()
  (let* ((f (make-instance 'frame))
         (test-list (make-instance 'listbox :master f))
         (tb (make-text f :height 2)))
    (pack f)
    (pack test-list :fill :both)
    (pack tb)
    
    ;; リストに選択肢を追加
    (listbox-append test-list '(a b c))
    (append-text tb (format nil "~A~%" (listbox-get-selection test-list)))

    (bind test-list "<ButtonPress-1>"
          (lambda (evt)
            ;; textの末尾に選択された要素のidを表示
            (append-text tb (format nil "~A~%" (listbox-get-selection test-list)))
            ))))


;;; フォントの利用

(with-ltk ()
  (wm-title *tk* "Window Title")
  (minsize *tk* 300 300) ; 300px X 300px

  #>(ltk:font-families) ; 利用可能なフォント一覧

  ;; フォントに名前を付ける
  (font-create "vlgothic" :family "\"VL Gothic\"" :size 18)
  
  (let* ((label (make-instance 'label
                               :master nil
                               :text "Hello world! こんにちは世界！！"
                               :font "vlgothic")))
    (pack label)))

;;; text widget

(defun main-text-input ()
  (with-ltk ()
    (wm-title *tk* "input text(entry)")
    (minsize *tk* 300 300)

    (let* ((msg (make-instance 'message
                               :text "input text"
                               :width 300
                               :background "gray"))
           (ledit (make-instance 'entry
                                 :width 300))
           (text (make-instance 'scrolled-text
                                :width 300))
           (b1 (make-instance 'button
                              :text "Close"
                              :command (lambda ()
                                         (format t "quit")
                                         (setf *exit-mainloop* t))))
           (b2 (make-instance 'button
                              :text "Add text"
                              :command (lambda ()
                                         (append-text text "foo")))))
      (pack msg
            :side :top
            :fill :x) ; fillを指定すると、Wiindowのハシをドラッグして伸ばしてもボタンが大きくなる。

      (pack ledit :side :top)
      (pack text :side :top)
      (pack b1
            :side :top
            :fill :x) ; fillを指定すると、Wiindowのハシをドラッグして伸ばしてもボタンが大きくなる。
      (pack b2
            :side :top
            :fill :x)

      ;; テキストメッセージを左寄せ（このconfigureを外すと中寄せになる）
      (configure msg :anchor :w))))

(main-text-input)

;; ltk-remote
;; with-ltkのリモート版: with-remote-ltk というマクロを代りに使うことで、Lispプログラムを動かしているサーバとは別のコンピュータでGUIを動かすことができる

(ql:quickload :ltk-remote)

#+(or)(with-remote-ltk 5050 ()
        (let ((b1 (make-instance 'button
                                 :master nil
                                 :text "hello"
                                 :command (lambda () (do-msg "Hello World!")))))
          (pack b1)))

;;; Menu widget

(defun menu-test ()
  (with-ltk ()
    (wm-title *tk* "Menu test")
    (let* ((mb (make-menubar))
           (mfile (make-menu mb "File" :underline 0))
           (mf-load (make-menubutton mfile "Load" (lambda () ;(error "asdf")
                                                    (format t "Load pressed~&")
                                                    (finish-output))
                                     :underline 0))
           (mf-save (make-menubutton mfile "Save" (lambda ()
                                                    (format t "Save pressed~&")
                                                    (finish-output))
                                     :underline 0))
           (mf-quit (make-menubutton mfile "Quit" (lambda ()
                                                    (setf *exit-mainloop* t))
                                     :underline 0)))
      (declare (ignore mf-load mf-save mf-quit)))))

(menu-test)

;; more text widget

(defun text-test ()
  (with-ltk ()
    (wm-title *tk* "Text widget test")
    (font-create "vlgothic" :family "\"VL Gothic\"" :size 12)
    ;; デフォルトのフォントを設定
    ;; https://stackoverflow.com/questions/827430/how-do-you-set-the-default-font-for-tk-widgets
    (format-wish "option add *font ~A" "vlgothic")
    (let* ((textbox (make-instance 'text :width 80 :height 24))
           (mb (make-menubar))
           ;; File menu
           (mfile (make-menu mb "File"))
           (mf-load (make-menubutton mfile "Load" (lambda ()
                                                    ;; textboxに設定
                                                    (setf (text textbox) "Loaded text")
                                                    (format t "Load pressed~&")
                                                    (finish-output))))
           (mf-save (make-menubutton mfile "Save" (lambda ()
                                                    ;; textboxの内容取得
                                                    #>(text textbox)
                                                    (format t "Save pressed~&")
                                                    (finish-output))))
           (mf-quit (make-menubutton mfile "Quit" (lambda ()
                                                    (setf *exit-mainloop* t))))
           ;; Edit menu
           (medit (make-menu mb "Edit" ))
           (mf-append-text (make-menubutton medit "Add foo"
                                            (lambda ()
                                              ;; カーソル位置関係なく、テキスト領域の末尾に追加する
                                              (append-text textbox "foo"))))
           (mf-insert-text (make-menubutton medit "Add bar to current pos"
                                            (lambda ()
                                              (insert-text-to-current-cursor textbox "bar"))))
           (mf-insert-tagged-text
             (make-menubutton medit "Add baz to current pos"
                              (lambda ()
                                (insert-text-to-current-cursor textbox "baz" :baztag))))
           (mf-append-newline (make-menubutton medit "Add newline"
                                               (lambda ()
                                                 ;; カーソル位置関係なく、テキスト領域の末尾に追加する
                                                 (append-newline textbox))))
           (mf-clear (make-menubutton medit "Clear"
                                      (lambda ()
                                        (clear-text textbox)))))
      (declare (ignore mf-load mf-save mf-quit
                       mf-append-text mf-insert-text mf-insert-tagged-text
                       mf-append-newline mf-clear))

      ;; text内のタグを付けてinsertした部分に属性を設定できる
      (tag-configure textbox :baztag :foreground "red")
      (tag-configure textbox :baztag :background "black")
      
      (pack textbox :side :top :fill :x))))

(text-test)

;; markとtagについて
;; mark: textウィジェット内の位置に名前(mark)を付けられる
;; tag: 指定した文字列に名前(タグ名)を付け、属性やバインディング(ハイパーテキスト的な)を付ける
;; See tag-configure, tag-bind

;; 参考: http://www.nct9.ne.jp/m_hiroi/tcl_tk_doc/tcltk204.html

;; 予約された特別なmark達
;; - カーソル位置を表す: insert
;; - マウスカーソル位置を表す: current
;; - textの最後の位置を表す: end

(defgeneric insert-text-to-current-cursor (txt text &rest tags))
(defmethod insert-text-to-current-cursor ((txt text) text &rest tags)
  ;; <ウィジェット名> insert <mark名> <挿入する文字列> <tags>
  (format-wish "~a insert insert \"~a\" {~{ ~(~a~)~}}" (widget-path txt) (tkescape text) tags)
  txt)

;; (defmethod tag-configure ((txt text) tag option value &rest others)
;; tag: string etc... => 小文字文字列に変換される
;; タグの新規定義はinsertの第三引数で行なわれる

;;; with-ltkなしでREPL上で対話的に開発するとき

(start-wish) ;; 別スレッドでwishを起動し、待機状態になる

(ltk:font-create "mynewfont" :family "\"BDF UM+ Outline\"" :size 12)

(defparameter f (make-instance 'frame))

;; textウィジェットの定義
(defparameter t1 (make-instance 'text
                                :master f
                                :width 80
                                :height 24
                                :font "mynewfont"))

(defparameter t2 (make-instance 'text
                                :master f
                                :background "gray"
                                :width 80
                                :height 24
                                :font "mynewfont"))

(pack f)
(pack t1)
(pack t2)

(pack-forget t2) ; t2を画面から消す。再度packすると

 ;; これを評価すると画面に反映される。この時点ではボタンを押してもイベントは実行されずにキューに積まれる

#|
キューに積まれたイベントを順次実行するイベントループ
実行されたスレッドをブロックするのでREPLで評価する
C-cで中断するとイベントループの監視はいったん解け、ボタンを押しても何も反応しなくなる
|#
(mainloop)

;; 終了時
(catch *wish*
  (exit-wish))