;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2009-09-25 09:50:31 IST>
;;;   Status: Experimental. Do Not Redistribute.
;;;   Copyright 2006, 2007 (C) Madhu. All Rights Reserved.
;;;
;;; $Id: fileset.lisp,v 1.3 2007/09/26 06:53:14 madhu Exp madhu $
;;; ----------------------------------------------------------------------
;;; 1.1 Forked from rpmtar.lisp
;;;
;;; 1.2 Rewritten: A FILSET-TRIE is a trie of paths at some root.  The Keys
;;; are the decomposed pathnames relative to the root.  Values are property
;;; lists.
;;;
(defpackage "FILESET-TRIE"
  (:use "CL")
  (:export
   "DECOMPOSE-PATH"
   "UNDECOMPOSE-PATH"
   "ADD-TO-FILESET-TRIE"
   "MAKE-FILESET-TRIE-FROM-FILESYSTEM" ; TODO DEPRECATE
   "MAKE-FILESET-TRIE-FROM-LIST"
   "FILESET-TRIE-GETF"
   "FILESET-TRIE-REMF"))
(in-package "FILESET-TRIE")

(defvar *dirsep* #\/)
(defvar *strings-trie* (TRIE:MAKE-TRIE))

(defun decompose-path (string  &key (start 0) end (sep *dirsep*)
		       (strings-trie *strings-trie*))
  "STRING is a pathname seperated by SEP. Second value is non-NIL if STRING is
terminated with SEP, indicating that the pathname is a directory.
STRINGS-TRIE is for interning strings so they can be compared with EQ."
  (if (zerop (length string)) (return-from decompose-path (list string)))
  (loop with last-position = (or end (length string))
	for begin = (position sep string :start start :end end :test-not #'eql)
	then (or (position sep string :start pos :end end :test-not #'eql)
		 (loop-finish))
	for pos = (position sep string :start begin :end last-position)
	collect (TRIE:INTERN-SEQ string strings-trie :start begin
				 :end (or pos last-position))
	into elems while pos finally
	(return (values elems (eql (elt string (1- last-position)) sep)))))

(defun cl-user::udcp-aux (stream &rest args)
  "Internal."
  (declare (ignore args))
  (write-char *dirsep* stream))

(defun undecompose-path (list directory-p &key stream
			      ((:sep *dirsep*) *dirsep*))
  "If STREAM is NIL returns a string.  Writes the pathname components as a SEP
separated pathname."
  (when list
    (format stream  "~{~A~^~:*~/udcp-aux/~}~@[~:*~/udcp-aux/~]"
	    (coerce list 'list) directory-p)))


;;; ----------------------------------------------------------------------
;;;
;;;

(defun default-dirval-fn (path)
  (declare (ignore path))
  (values (list :directory-p t) t))

(defun default-fileval-fn (path)
  (declare (ignore path)) ;
  (values (list :directory-p nil) t))

(defvar *default-dirval-fn* #'default-dirval-fn)

(defvar *default-fileval-fn* #'default-fileval-fn)

(defun add-to-fileset-trie (pathname fileset-trie
			    &key root-directory
				 (strings-trie *strings-trie*)
				 (dirval-fn *default-dirval-fn*)
				 (fileval-fn *default-fileval-fn*)
				 (sep *dirsep*)
				 (directory-p nil directory-p-supplied-p)
				 dont-barf-on-directory-p)
  "Keys in the TRIE are pathnames (decomposed to a sequence of dirname
components and file-namestring).  DIRVAL-FN and FILEVAL-FN each take a
pathname argument and are expected to return two values: If the second value
is non-NIL, the first value is stored against the key in the trie.  The first
value returned should typically be a property list.  The default behaviour is
to add all files and directories and set a single :DIRECTORY-P property which
is true for directories."
  (when root-directory (setq root-directory (pathname root-directory))) ;
  (multiple-value-bind (key dirp)
      (decompose-path (if root-directory
			  (enough-namestring pathname root-directory)
			  (namestring pathname))
		      :sep sep :strings-trie strings-trie)
    (unless directory-p-supplied-p ;; XXX infer-directory-p-from-pathname CLEANME
      (setq directory-p dirp))
    (cond (dirp
	   (unless directory-p
	     (unless dont-barf-on-directory-p
	       (cerror "Ignore" "ADD-TO-FILESET-TRIE: DECOMPOSE-PATH MISMATCH. ~S was marked DIRECTORY-P" pathname)))
	   (when dirval-fn
	     (multiple-value-bind (val keep)
		 (funcall dirval-fn pathname)
	       (when keep
		 (setf (TRIE:GETTRIE key fileset-trie) val)))))
	  (t (unless (not directory-p)
	       (unless dont-barf-on-directory-p
		 (cerror "Ignore" "ADD-TO-FILESET-TRIE: DECOMPOSE-PATH MISMATCH. ~S was NOT marked as DIRECTORY-P" pathname)))
	     (when fileval-fn
	       (multiple-value-bind (val keep)
		   (funcall fileval-fn pathname)
		 (when keep
		   (setf (TRIE:GETTRIE key fileset-trie)
			 val))))))))

(defun make-fileset-trie-from-filesystem
       (root-directory &rest args &key maxdepth &allow-other-keys)
  "Internal.  Recursively descend ROOT-DIRECTORY and return a FILESET-TRIE.
Keyword Arguments are passed to ADD-FILESET-TRIE, which see.  MAXDEPTH passed
t to USER:DIRED, can be NIL (no maximum depth), or a number or a function
which takes a directory pathname and its descend-depth and should return
non-NIL if that directory is to be descended."
  (let ((root (truename root-directory))
	(start-time (get-universal-time))
	(fileset-trie (TRIE:MAKE-TRIE))
	(exclude-root-hack nil)
	(USER::*DIRED-TRUENAMEP* NIL)
	(USER::*DIRED-FOLLOW-LINKS* NIL))
    (remf args :maxdepth)
    (flet ((add-entry (pathname depth directory-p)
	     (declare (ignorable depth))
	     (unless exclude-root-hack
	       (when (equalp root pathname)
		 (assert directory-p)
		 (setq exclude-root-hack t)
		 (return-from add-entry NIL)))
	     (apply #'add-to-fileset-trie (append (list pathname fileset-trie)
						  args))))
      (USER::DIRED root #'add-entry 0 maxdepth))
    (let ((props (list :file-write-start-time start-time
		       :file-write-end-time (get-universal-time)
		       :root-namestring (namestring root))))
      (setf (TRIE:GETTRIE nil fileset-trie)
	    props))
    fileset-trie))


;;;----------------------------------------------------------------------
;;;
;;;
;;;

(defun make-fileset-trie-from-list
       (list-of-pathnames &rest args &key &allow-other-keys)
  "LIST-OF-PATHNAMES is a sequence of PATHNAMES. ARGS are keyword arguments
that are passed to ADD-TO-FILESET-TRIE, which see."
  (let ((fileset-trie (TRIE:MAKE-trie)))
    (map nil
	 (lambda (path)
	   (apply #'add-to-fileset-trie (append (list path fileset-trie) args)))
	 list-of-pathnames)
    fileset-trie))


;;; ----------------------------------------------------------------------
;;;
;;;

(defun fileset-trie-map (fileset-trie f &key (sep *dirsep*))
  "INTERNAL. F is called with 2 arguments, a string denoting the pathname, and
the value which is a expected to be a property list.  Undecomposes non-nil
fileset-trie keys to a path based on a DIRECTORY-P property."
  (trie:maptrie (lambda (k v)
		  (when k
		    (let ((key (undecompose-path k (getf v :directory-p)
						 :sep sep)))
		      (funcall f key v))))
		fileset-trie 'list))

(defun fileset-trie-list (fileset-trie &key (sep *dirsep*) test)
  "TEST if non NIL is called with 2 arguments: a path and the value of path in
the fileset-trie (typically a property list). If TEST returns NON-NIL, it is
included in the resuly."
  (let (x)
    (fileset-trie-map fileset-trie
		      (lambda (path v)
			(tagbody
			  (if (and test (not (funcall test path v)))
			      (go done))
			  (push path x) done))
		      :sep sep)
    (nreverse x)))

#+nil
(defun fileset-trie-print (fileset-trie &optional (stream *standard-output*))
  "INTERNAL. DEBUG"
  (trie:maptrie (lambda (path props) (format stream "~S => ~S~&" path props))
		fileset-trie
		'list))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;

(defvar *%fileset-trie-prop-cache* nil)	; TODO - cache last access.

(defun %fileset-trie-prop
    (fileset-trie key indicator default &optional op new-value
     &rest property-list)
  (setq key
    (let ((path key))
      (etypecase path
	(string (decompose-path path))
	(pathname (decompose-path (namestring path)))
	(sequence path))))
  (ecase op
    ((nil :getf) (getf (TRIE:GETTRIE key fileset-trie) indicator default))
    (:remf (if (null indicator)
	       (TRIE:REMTRIE key fileset-trie)
	       (multiple-value-bind (props present-p)
		   (TRIE:GETTRIE key fileset-trie)
		 (when present-p
		   (etypecase indicator
		     (atom (remf props indicator))
		     (cons (dolist (i indicator) (remf props i))))
		   (setf (TRIE:GETTRIE key fileset-trie) props)))))
    (:setf (multiple-value-bind (props present-p)
	       (TRIE:GETTRIE key fileset-trie)
	     (setf (TRIE:GETTRIE key fileset-trie)
	       (if (not present-p)
		   (list* indicator new-value property-list) ; XXX share!
		   (nconc props (list* indicator new-value property-list)))))
	   new-value)))

(defun fileset-trie-getf (fileset-trie path indicator &optional default)
  "Retrieve property named INDICATOR from plist of PATH."
  (%fileset-trie-prop fileset-trie path indicator default))

(defsetf fileset-trie-getf (fileset-trie path indicator &optional default)
    (new-value)
  "Set property named INDICATOR from plist of PATH to NEW-VALUE.  PATH will be
added if not present."
  `(%fileset-trie-prop ,fileset-trie ,path ,indicator ,default :setf
		       ,new-value))

(defun fileset-trie-remf (fileset-trie path &rest indicators)
  "If no INDICATORS are supplied, completely remove PATH from FILESET-TRIE.
Otherwise remove the property named by INDICATORS from plist of PATH. PATH
will be added if not present.  TODO Canonicalize return value."
  (%fileset-trie-prop fileset-trie path indicators NIL :remf))


;;; ----------------------------------------------------------------------
;;;
;;; CHANGE DETECTION AND PRESENTATION
;;;

(defvar *compare-indicators* nil)
(defvar *omit-indicators* nil)
(defvar *if-indicator-does-not-exist* :exclude)

(defun compare-props (props1 props2)
  "PROPS1 PROPS2 are property lists.  Returns NIL if properties specified in
*COMPARE-INDICATORS* (but not in *OMIT-INDICATORS* are EQUAL in PROPS1 and
PROPS2."
  (let (ep1 ep2 alist) ; (indicator value-in-props1 value-in-props2)
    (loop for indicator in
	  (cond ((listp *compare-indicators*) *compare-indicators*)
		((or (eq *compare-indicators* t)
		     (eq *compare-indicators* :all))
		 (union (loop for (k) on props1 by #'cddr collect k)
			(loop for (k) on props2 by #'cddr collect k)))
		(t (error "*COMPARE-INDICATORS* not a list or :ALL: ~S."
			  *compare-indicators*)))
	  unless (find indicator *omit-indicators*)
	  do
	  (let ((val1 (getf props1 indicator '%%doesnotexist))
		(val2 (getf props2 indicator '%%doesnotexist)))
	    (if (or (eq val1 '%%doesnotexist)
		    (eq val2 '%%doesnotexist))
		(ecase *if-indicator-does-not-exist*
		  ((:soft nil :ignore :exclude))
		  (:include ;XXX
		   (push (list indicator val1 val2) alist))
		  (:error
		   (when (eq val1 '%%doesnotexist) (pushnew indicator ep1))
		   (when (eq val2 '%%doesnotexist) (pushnew indicator ep2))))
		(unless (equal val1 val2)
		  (push (list indicator val1 val2) alist)))))
    (when (or ep1 ep2)
      (assert (eq *if-indicator-does-not-exist* :error))
      (error "~@[Indicator~P missing in plist~D: ~S~&~]~@[Indicator~P missing in plist~D: ~S~]."
	     (and ep1 (length ep1) 1 ep1) (and ep2 (length ep2) 2 ep2)))
    alist))

(defvar *compare-props* #'compare-props
  "A function of 2 arguments, Suitable as the TEST keyword argument for
COMPARE-FILESETS.  Arguments are property lists.  Returns NIL if the two are
considered equivalent.  Otherwise return a list representing the changes.")

(defclass fileset-change-compared ()
  ((elem-1 :initarg :elem-1 :accessor change-compared-elem-1 :initform nil)
   (elem-2 :initarg :elem-2 :accessor change-compared-elem-2 :initform nil)
   (uniq-1 :initarg :comm-23 :accessor change-comm-23 :initform nil
	   :reader uniq-1)
   (uniq-2 :initarg :comm-13 :accessor change-comm-13 :initform nil
	   :reader uniq-2)
   (comm   :initarg :comm-12 :accessor change-comm-12 :initform nil
	   :reader comm)))

(defmethod print-object ((condition fileset-change-compared) stream)
  (print-unreadable-object (condition stream :type t :identity t)
    (format stream "Change Detected.~
		       ~@[~%Compared 1:~T~A~]~@[~%With 2:~T~A:~]~
		       ~@[~%Unique to 1: ~A~]~
		       ~@[~%Unique to 2: ~A~]~
		       ~@[~%Changed items: ~A~]"
	    (change-compared-elem-1 condition)
	    (change-compared-elem-2 condition)
	    (and (change-comm-23 condition)
		 (length (change-comm-23 condition)))
	    (and (change-comm-13 condition)
		 (length (change-comm-13 condition)))
	    (and (change-comm-12 condition)
		 (length (change-comm-12 condition))))))

(defun compare-fileset-tries (fileset-1 fileset-2 &key (test *compare-props*))
  (let (uniq1 uniq2 comm x1 x2 x3)
    (flet ((comm-23 (k v)
	     (unless x1
	       (unless k
		 (setq x1 t)
		 (return-from comm-23 nil)))
	     (setq uniq1 (acons k v uniq1)))
	   (comm-13 (k v)
	     (unless x2
	       (unless k
		 (setq x2 t)
		 (return-from comm-13 nil)))
	     (setq uniq2 (acons k v uniq2)))
	   (comm-12 (k v1 v2)
	     (unless x3
	       (unless k
		 (setq x3 t)
		 (return-from comm-12 nil)))
	     (let ((changes (funcall test v1 v2)))
	       (when changes
		 (setq comm (acons k changes comm))))))
      (TRIE:COMM-TRIES fileset-1 fileset-2
		       :comm-23 #'comm-23
		       :comm-13 #'comm-13
		       :comm-12 #'comm-12
		       :skip-subtries t)
      (when (or uniq1 uniq2 comm)
	(make-instance 'fileset-change-compared
	  :elem-1 fileset-1
	  :elem-2 fileset-2
	  :comm-23 uniq1
	  :comm-13 uniq2
	  :comm-12 comm)))))


;;;----------------------------------------------------------------------
;;;
;;;
;;;

(defun fileset-trie-annotate-stat2  (fileset-trie)
  (fileset-trie-map
   fileset-trie
   (lambda (pathname v)
     (declare (ignorable v))
     (with-simple-restart (Ignore-This-Error "Ignore; Skip this file: ~S." pathname)
       (USER:stat2 pathname
       
         (%fileset-trie-prop fileset-trie pathname
                             :total-size 'unused-default :setf
                             user::total-size
                             :mode user::mode
                             :atime user::atime
                             :mtime user::mtime
                             :ctime user::ctime))
       #+nil
       (warn "k=~S v=~S mode=~S" pathname v
             (%fileset-trie-prop fileset-trie pathname :mode 'unset-mode))))))

(defun tostring (x)
  (if (or (symbolp x) (stringp x))
      x
      (princ-to-string x)))


;;; ----------------------------------------------------------------------
;;;
;;; RUDIMENTART GUI
;;; (ALLEGRO -- using the `outline' widget). fixme: dont trie this except with
;;; clos-trie.
;;;

#+(and allegro cg)
(defun make-subtrie-item-recursively (trie)
  (when trie
    (make-instance 'cg:outline-item
      :value trie
      :state :open
      :range (mapcar #'make-subtrie-item-recursively
		     (trie::trie-sub-tries trie)))))

#+(and allegro cg)
(defclass plist-view (cg:list-view) ;to show a property list on right pane
  ()
  (:default-initargs
   :left 420 :top 20 :width 280 :height 280
   :left-attachment :scale
   :right-attachment :right
   :bottom-attachment :bottom
   :range nil :value nil
   :scrollbars t
   :resizable t
   :columns (list
	     (make-instance 'cg:list-view-column
	       :name :property
	       :title "Property"
	       :width 120
	       :justification :left
;;	       :on-sort-key #'tostring
;; allegro 8.1 bug cg:list-view :on-sort-key gets called with two arguments
;; instead of 1 as documented,
	       :on-sort-predicate
	       (lambda (a b) (string< (tostring a) (tostring b))))
	     (make-instance 'cg:list-view-column
	       :name :value
	       :title "Value"
	       :width 160
	       :justification :left
	       :on-sort-predicate
	       (lambda (a b) (string< (tostring a) (tostring b)))))))

#+(and allegro cg)
(defclass fileset-trie-outline (cg:outline)
  ((list-view1 :initform (make-instance 'plist-view)))
  (:default-initargs
   :left 20 :top 20 :width 380 :height 280
   :value nil
   :select-on-open t
   :right-attachment :scale
   :bottom-attachment :bottom
   :multiple-selections nil
   :scrollbars t
   :cuttable nil
   :resizable t
   :on-print #'(lambda (trie)
		 (princ-to-string
		  (trie::trie-sub-key trie)
		  #+nil
		  (cons (trie::trie-sub-key trie)
			(trie::trie-value trie))))
   :close-subtrees-on-close nil
))

#+(and allegro cg)
(defclass fileset-trie-outline-top-pane (cg:outline-top-pane) ())

#+(and allegro cg)
(defmethod  cg:widget-device ((dialog-item fileset-trie-outline) dialog)
  (declare (ignore dialog))
  'fileset-trie-outline-top-pane)

#+(and allegro cg)
(defmethod update-selection ((fileset-trie-outline1 fileset-trie-outline))
  (let ((item1 (or #+nil(cg:selected-outline-item fileset-trie-outline1)
		   (cg:focused-outline-item fileset-trie-outline1))))
    (with-slots (list-view1) fileset-trie-outline1
      (setf (cg:range list-view1)
	(if item1
	    (let* ((trie1 (and item1 (cg:value item1)))
		   (plist (and trie1 (trie::trie-value trie1))))
	      (loop for (prop val) on plist by #'cddr
		  collect (make-instance 'cg:list-view-item
			    :name prop
			    :value-plist
			    (list :property prop :value val))))
	    (progn
	      (format t "No FOCUSSED ITEM. SEL=~S"
		      (cg:selected-outline-item fileset-trie-outline1))
	      nil))))))

#+(and allegro cg)
(defmethod cg:mouse-left-down ((window fileset-trie-outline-top-pane)
			       buttons cursor-position)
  (declare (ignore buttons cursor-position))
  (update-selection (cg:dialog-item window))
  (call-next-method))

#+(and allegro cg)
(defun show-trie (trie)
  (let* ((outline1 (make-instance 'fileset-trie-outline
		     :range (list (make-subtrie-item-recursively trie)))))
    (with-slots (list-view1) outline1
      (cg:make-window 'my-dialog
		      :class 'cg:dialog
		      :title (format nil "Fileset Trie ~s" trie)
		      :resizable t
		      :title-bar t
		      :minimize-button t
		      :interior (cg:make-box-relative 200 200 720 320)
		      ;;:state :shrunk
		      :left-attachment nil
		      :top-attachment nil
		      :right-attachment nil
		      :dialog-items (list outline1 list-view1)))))

#||
#+nil
(setq $s (make-fileset-trie-from-filesystem "/home/src/emacs-w3m-rhea/"))
(user:in-directory "/" (fileset-trie-annotate-stat2 $s))
(cg:initialize-cg)
(cg.base:exit-cg)
(show-trie $s)
||#


;;;----------------------------------------------------------------------
;;;
;;; LISPWORKS/CAPI VIEWER. NOTE: CAPI:TREE-VIEW widget has only single
;;; selection.  FIXME. Dont try this except with CLOS-TRIE.
;;;

#+(and lispworks capi)
(capi:define-interface fileset-trie-pane ()
  ((trie :initarg :fileset-trie :initform (error "Must supply FILESET-TRIE")))
  (:panes
   (plist-pane
    capi:multi-column-list-panel
    :columns (list (list :title "Property"
                         :adjust :left)
                   (list :title "Value"
                         :adjust :center))
    :items nil
    :header-args (list
                  :alignments '(:left :left)
                  :selection-callback
                  (lambda (interface item) ;sort-columns
                    (declare (ignorable interface))
                    #+nil
                    (capi:display-message "Clicked on ~a" item)
		    (let* ((key
                              (cond ((equal item "Value")
                                     #'(lambda (x) (tostring (second x))))
                                    ((equal item "Property")
                                     #'(lambda (x) (tostring (first x))))
                                    (t (error "Sanity:"))))
                             (items (capi:collection-items plist-pane))
                             (pred
                              (if (string< (funcall key (elt items 0))
                                           (funcall key (elt items 1)))
                                  #'string>
                                #'string<)))
                        (setf (capi:collection-items plist-pane)
                              (sort items pred :key key))))))

   (trie-pane
    capi:tree-view
    :roots (list trie)
    :print-function (lambda (trie) (princ-to-string (trie::trie-sub-key trie)))
    :expandp-function (constantly t) ;
    :children-function #'trie::trie-sub-tries
    :visible-min-width 200
    :visible-min-height 200
    :retain-expanded-nodes t
    :selection-callback #'(lambda (item self)
                            (declare (ignore self))
                            (setf (capi:collection-items plist-pane)
                                  (loop for (prop val) on (trie::trie-value item)
                                        by #'cddr
                                        collect (list prop val)))
                            #+nil
                            (format t "~&Select item ~S~%" item))
    :action-callback #'(lambda (item self)
                         (declare (ignore self))
                         (format t "~&Activate item ~S~%" item))
    :delete-item-callback #'(lambda (self item)
                              (declare (ignore self))
                              (format t "~&Delete item ~S~%" item))))
  (:layouts
   (main-layout
    capi:row-layout
    '(trie-pane plist-pane)))
  (:default-initargs
   :layout 'main-layout
   :title "FILESET"))

#+(and lispworks capi)
(defun show-trie (trie)
  (capi:display (make-instance 'fileset-trie-pane :fileset-trie trie)))