;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2008-09-27 13:43:34 madhu>
;;;   Touched: Wed Sep 24 11:12:58 2008 +0530 <enometh@net.meer>
;;;   Bugs-To: enometh@net.meer
;;;   Status: Experimental.  Do not redistribute
;;;   Copyright (C) 2008 Madhu.  All Rights Reserved.
;;;
;;; Celtk support for the ttk::treeview Hierarchical multicolumn data display
;;; widget. See man ttk_treeview(n). This implementation was based on Tk 8.5.2
;;; on linux.
;;;
(in-package "CTK")


;;; ----------------------------------------------------------------------
;;;
;;; TREEVIEW-ITEM: Interface to the ttk::treeview widget `item' command. This
;;; object is in Celtk only, not present in Tk. Each object represents a
;;; hierarchical item contained in treeview. The Cells family model is used to
;;; specify the hierarchy.  The root of the tree is a treeview object. See
;;; TREEVIEW.

(deftk treeview-item (tk-object family)
  ((idx :cell nil :initarg :idx :accessor idx :initform nil)
   (on-select :initarg :on-select :initform nil :accessor on-select)
   (on-close :initarg :on-close :initform nil :accessor on-close)
   (on-open :initarg :on-open :initform nil :accessor on-open))
  (:tk-spec treeview-item -text -image (values-lst -values) (openp -open) -tags)
  (:default-initargs :id (gentemp "TVI")))

(defmethod tk-configure ((self treeview-item) option value)
  (assert (idx self) () "cannot configure ~a ~a until instantiated with id."
	  (tk-class self) self)
  (tk-format `(:configure ,self ,option) "~a item ~a ~a ~a" (path .parent)
	     (idx self) (down$ option) (tk-send-value value)))

(defmethod make-tk-instance :around ((self treeview-item))
  (when (upper self treeview)
    (call-next-method)))

(defmethod make-tk-instance ((self treeview-item))
  (with-integrity (:client `(:make-tk ,self))
    (setf (idx self) (tk-eval "~a insert ~a end  ~{~(~a~) ~a~^ ~}"
			      (path (upper self treeview))
			      (let ((parent (fm-parent self)))
				(etypecase parent
				  (treeview-item (idx parent))
				  (treeview "{}")))
			      (tk-configurations self)))))

(defmethod not-to-be :after ((self treeview-item))
  (unless (find .tkw *windows-destroyed*)
    (tk-format `(:delete ,self) "~a delete ~a" (path (upper self treeview))
	       (idx self))))

(defun rearrange-treeview-items (self oldkids newkids)
  (declare (type (or treeview-item treeview ) self))
  (bwhen (root (upper self treeview))
    (loop for k in oldkids
	  do (tk-format `(:post-make-tk ,self) "~a detach ~a" (path root)
			(idx k)))
    (loop for k in newkids for i from 0
	  do (tk-format `(:post-make-tk ,self) "~a move ~a ~a ~d" (path root)
			(idx k) (idx self) i))))

(defobserver .kids ((self treeview-item))
  (rearrange-treeview-items self old-value new-value))

(defun find-treeview-item (family idx)
  (loop for k in (kids family)
	when (etypecase k
		    (treeview-item
		     (if (string= idx (idx k))
			 k
			 (find-treeview-item k idx))))
	return it))



;;; ----------------------------------------------------------------------
;;;
;;; TREEVIEW-HEADING: Interface to the ttk::treeview widget `heading' command
;;; for configuring titles of the multicolumn treeview widget.  Each object
;;; represents a heading.  This object is in CTK only, not in Tk.  This is not
;;; a family model but we fake a fm-parent slot to store the parent treeview.
;;;

(defmodel treeview-colspec-mixin ()
  ((treeview :initform nil :initarg :fm-parent :accessor fm-parent)  ;evil
   (column :initform nil :initarg :treeview-column-id :accessor treeview-column-id)))

(deftk treeview-heading (tk-object treeview-colspec-mixin)
  ()
  (:tk-spec treeview-heading -text -image -anchor -command)
  (:default-initargs :id (gentemp "TVH")))

(defmethod make-tk-instance ((self treeview-heading))
  (assert (^treeview-column-id) () "~a: currently cannot make ~a without specifying column id." (tk-class self) self)
  (tk-format `(:post-make-tk ,self) "~a heading ~a ~{~(~a~) ~a~^ ~}"
	     (path .parent) (^treeview-column-id) (tk-configurations self)))

(defmethod tk-configure ((self treeview-heading) option value)
  (assert (path .parent) () "~a: cannot configure heading ~a without parent." self)
  (assert (^treeview-column-id))
  (assert (find (^treeview-column-id) (column-ids .parent) :test #'equal))
  (tk-format `(:configure ,self ,option)
	     "~a heading ~a ~a ~a " (path .parent) ;; (^treeview-column-id)
	     (down$ option) (tk-send-value value)))


;;; ----------------------------------------------------------------------
;;;
;;; TREEVIEW-COLUMN. Interface to the ttk::treeview widget `column' command
;;; for configuring columns of the multicolumn treeview widget.  Each object
;;; represnts a column. This object is in CTK only, not in Tk. This is not a
;;; family model but we fake a fm-parent slot to store the treeview. -id is a
;;; readonly option of the command, so we do not specify it in tk-spec.
;;;

(deftk treeview-column (tk-object treeview-colspec-mixin)
  ()
  (:tk-spec treeview-column -anchor -minwidth -stretch -width)
  (:default-initargs :id (gentemp "TVC")))

(defmethod make-tk-instance ((self treeview-column))
  (assert (^treeview-column-id) () "~a: currently cannot make ~a without specifying column id." (tk-class self) self)
  (tk-format `(:post-make-tk ,self) "~a column ~a ~{~(~a~) ~a~^ ~}"
	     (path .parent) (^treeview-column-id) (tk-configurations self)))

(defmethod tk-configure ((self treeview-column) option value)
  (assert (path .parent) () "cannot configure heading ~a without parent." self)
  (assert (^treeview-column-id))
  (assert (find (^treeview-column-id) (column-ids .parent) :test #'equal))
  (tk-format `(:configure ,self ,option) "~a heading ~a ~a ~a "
	     (path .parent) (^treeview-column-id) (down$ option) (tk-send-value value)))


;;; ----------------------------------------------------------------------
;;;
;;; TREEVIEW: ttk::treeview - Hierarchical multicolumn data display widget.
;;; Kids of a treeview object are treeview-item objects.  Use column-ids to
;;; specify column identifiers.  The values-lst of a treeview-item object is a
;;; list of data values, each in a one to one correspondance with column
;;; identifiers in column-ids.  The on-XXX commands of treeview-item are
;;; invoked in response to treeview virtual events.  Each on-XXX command is
;;; either nil or a function which takes a single argument, a treeview-item
;;; object.
;;;

(deftk treeview (widget)
  ((treeview-headings :initform nil :accessor treeview-headings :initarg :treeview-headings)
   (treeview-columns :initform nil :accessor treeview-columns :initarg :treeview-columns))
  (:tk-spec treeview (ttk-class -class) -cursor -takefocus -style
	    -xscrollcommand -yscrollcommand ; TODO
	    (column-ids -columns) -displaycolumns
	    -height -width  -padding -selectmode -show)
  (:default-initargs :id (gentemp "TVIEW") :on-command #'treeview-on-command))

(defmethod make-tk-instance ((self treeview))
  (setf (gethash (^path) (dictionary .tkw)) self)
  (tk-format `(:make-tk ,self) "ttk::treeview ~a ~{~(~a~) ~a~^ ~}" (^path)
	     (tk-configurations self))
  (tk-format `(:pack ,self) "pack ~a -expand yes -fill both" (^path))
  (tk-format `(:bind ,self) "bind ~a <<TreeviewOpen>> {do-on-command %W OPEN [%W focus]}" (^path))
  (tk-format `(:bind ,self) "bind ~a <<TreeviewClose>> {do-on-command %W CLOSE [%W focus]}" (^path))
  (tk-format `(:bind ,self) "bind ~a <<TreeviewSelect>> {do-on-command %W SELECT [%W selection]}" (^path)))

(defobserver .kids ((self treeview))
  (rearrange-treeview-items self old-value new-value))

(defun treeview-on-command (self event target)
  (trc nil "treeview-on-command self event target" self event target)
  (cond ((string= event "OPEN")
	 (bwhen (target-item (find-treeview-item self target))
	   (bwhen (cmd (on-open target-item))
	     (funcall cmd target-item))))
	((string= event "CLOSE")
	 (bwhen (target-item (find-treeview-item self target))
	   (bwhen (cmd (on-close target-item))
	     (funcall cmd target-item))))
	((string= event "SELECT")
	 (loop for target in (parse-tcl-list-result target) do
	       (bwhen (target-item (find-treeview-item self target))
		 (bwhen (cmd (on-select target-item))
		   (funcall cmd target)))))))


#+nil
(test-window 'window t :title$ "Test-tree-view" :height (c-in 200) :width (c-in 200)
	     :kids (c? (the-kids
 (mk-treeview
  :displaycolumns "\#all"
  :column-ids '("COL1XYZ" "COL2ABC" "COL3")
  :treeview-headings (c? (the-kids
			  (mk-treeview-heading :treeview-column-id "\#0" :text "Name")
			  (mapcar (lambda (c)
				    (unless (stringp c)
				      (setq c (princ-to-string c)))
				    (mk-treeview-heading
				     :treeview-column-id c :text c))
				  (^column-ids))))
  :treeview-columns (c? (the-kids
			 (mk-treeview-column
			  :treeview-column-id "\#0" :stretch "0" :width 100)
			 (mapcar (lambda (c)
				   (mk-treeview-column
				    :treeview-column-id c))
				 (^column-ids))))
  :kids (c? (the-kids
	     (mk-treeview-item
	      :text "root1"
	      :openp t
	      :on-select (lambda (s) (warn "select ~S" s))
	      :values-lst '("foo1" "bar1" "car1")
	      :kids (c? (the-kids
			 (mk-treeview-item
			  :text "level1 A"
			  :values-lst '("foo2" "bar2" "car2")
			  :kids (c? (the-kids
				     (mk-treeview-item
				      :text "level2"
				      :values-lst '("foo3" "bar3" "car3")))))
			 (mk-treeview-item
			  :text "level1 B"
			  :values-lst '("foo4" "bar4" "car4")))))
		      (mk-treeview-item
		       :text "root2"
		       :values-lst '("foo5" "bar5" "car5"))))))))
