;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Time-stamp: <2009-09-09 15:09:35 IST>
;;;   Touched: Fri Feb 13 08:11:25 2009 +0530 <enometh@meer.net>
;;;   Bugs-To: enometh@meer.net
;;;   Status: Experimental.  Do not redistribute
;;;   Copyright (C) 2009 Madhu.  All Rights Reserved.
;;;
(defpackage "CLOS-TRIE"
  (:use "CL")
  (:export "MAKE-TRIE" "GETTRIE" "SETTRIE" "REMTRIE" "MAPTRIE"
   "FIND-SEQ" "INTERN-SEQ" "TRIE-COUNT"
   "*MAPTRIE-DEFAULT-SEQUENCE-TYPE*" "MAPTRIE-SKIP-DESCEND"
   "TRIE-COMPLETIONS"
   "COMM-TRIES"))
(in-package "CLOS-TRIE")

(defclass trie ()
  ((value :initform nil :initarg :value :accessor trie-value)
   (sub-key :initform nil :initarg :sub-key :accessor trie-sub-key)
   (sub-tries :initform nil :initarg :sub-tries :accessor trie-sub-tries)))

(defun make-trie (&rest args &key value sub-key sub-tries)
  (declare (ignorable  value sub-key sub-tries))
  (apply 'make-instance 'trie args))

(defconstant +explicit-null+ '+explicit-null)

(defun trie-descend (trie sub-key)
  (find sub-key (trie-sub-tries trie) :key 'trie-sub-key))

(defun gettrie (key trie &optional default)
  (map nil (lambda (sub-key)
	     (unless (setq trie (trie-descend trie sub-key))
	       (return-from gettrie (values default nil))))
       key)
  (let ((value (trie-value trie)))
    (if (eq value +explicit-null+)
	(values nil t)
	(if value
	    (values value t)
	    (values default nil)))))

(defsetf gettrie (key trie &optional default) (value)
  (let ((trie-var (gensym)) (value-var (gensym)))
    `(let ((,trie-var ,trie) (,value-var ,value))
       (map nil (lambda (sub-key)
		  (let ((sub-trie (trie-descend ,trie-var sub-key)))
		    (unless sub-trie
		      (setq sub-trie (make-trie :sub-key sub-key))
		      (push sub-trie (trie-sub-tries ,trie-var)))
		    (setq ,trie-var sub-trie)))
	    ,key)
       (setf (trie-value ,trie-var) (or ,value-var +explicit-null+))
       ,value-var)))

(defun remtrie (key trie)
  (labels ((rec (trie depth)
	     (if (= depth (length key))
		 (prog1 (not (null (trie-value trie)))
		   (setf (trie-value trie) nil))
		 (let ((sub-trie (trie-descend trie (elt key depth))))
		   (when sub-trie
		     (prog1 (rec sub-trie (1+ depth))
		       (unless (or (trie-value sub-trie)
				   (trie-sub-tries sub-trie))
			 (setf (trie-sub-tries trie)
			       (delete sub-trie (trie-sub-tries trie)
				       :test #'eq)))))))))
    (rec trie 0)))

(defvar *MAPTRIE-DEFAULT-SEQUENCE-TYPE* 'vector)

(defun maptrie (function trie &optional (type *MAPTRIE-DEFAULT-SEQUENCE-TYPE*))
  "FUNCTION takes two arguments: KEY and VALUE. KEY is coerced to TYPE which
must be a sequence type.  FUNCTION can throw the tag 'MAPTRIE-SKIP-DESCEND if
it wants to avoid descending sub tries."
  (let ((key (make-array 20 :adjustable t :fill-pointer 0)))
    (labels ((rec (trie)
	       (catch 'maptrie-skip-descend
		 (let ((value (trie-value trie)))
		   (when value
		     (funcall function
			      (ecase type
				(vector (copy-seq key)) ;XXX
				(string (coerce key 'string))
				(list (coerce key 'list)))
			      (if (eq value +explicit-null+)
				  nil
				  value))))
		 (let ((sub-tries (trie-sub-tries trie)))
		   (when sub-tries
		     (loop
		      (vector-push-extend (trie-sub-key (car sub-tries)) key)
		      (rec (car sub-tries))
		      (decf (fill-pointer key))
		      (unless (setq sub-tries (cdr sub-tries))
			(return))))))))
      (rec trie))
    nil))

(defun intern-seq (seq home-trie &key (start 0) end (copy-p t) value)
  (loop for i from start below (let ((length (length seq)))
				 (if end
				     (if (<= end length) end start)
				     length))
	for trie = home-trie then sub-trie
	for sub-key = (elt seq i)
	for sub-trie = (trie-descend trie sub-key)
	do (cond ((null sub-trie)
		  (push (setq sub-trie (make-trie :sub-key sub-key))
			(trie-sub-tries trie))))
	finally
	(return
	 (cond ((null (trie-value sub-trie))
		(setf (trie-value sub-trie)
		      (or value
			  (if (and (zerop start)
				   (or (null end)
				       (= end (length seq)))
				   (not copy-p))
			      seq
			      (subseq seq start end)))))
	       (t (trie-value sub-trie))))))

(defun find-seq (seq home-trie  &key (start 0) end shortest-p)
  (loop with retval and retidx = 0
	for i from start below (or end (length seq))
	for trie = home-trie then sub-trie
	for sub-key = (elt seq i)
	for sub-trie = (trie-descend trie sub-key)
	do (cond ((null sub-trie) (loop-finish))
		 ((trie-value sub-trie)
		  (setq retval (trie-value sub-trie) retidx (1+ i))
		  (if shortest-p (loop-finish))))
	finally
	(return (if retval (return (values retval retidx))))))

(defun descend-seq (seq home-trie &key (start 0) end)
  "Return the sub-trie after walking key SEQ."
  (loop for i from start below (or end (length seq))
	for sub-key = (elt seq i)
	for sub-trie = (trie-descend home-trie sub-key)
	then (trie-descend sub-trie sub-key)
	if (null sub-trie) return nil
	finally (return sub-trie)))

(defun trie-count (trie)
  (let ((n 0))
    (maptrie (lambda (k v) (declare (ignore k v)) (incf n)) trie)
    n))

(defun trie-completions (trie &optional prefix key-so-far)
  "Return a list of keys in TRIE with prefix PREFIX."
  (if prefix
      (let ((sub-trie (trie-descend trie (car prefix))))
	(when sub-trie
	  (trie-completions sub-trie (cdr prefix)
			    (cons (car prefix) key-so-far))))
      (nconc (if (trie-value trie) (list (reverse key-so-far)))
	     (loop for sub-trie in (trie-sub-tries trie)
		   for sub-key = (trie-sub-key sub-trie)
		   nconc (trie-completions
			  sub-trie prefix (cons sub-key key-so-far))))))

(defun trie-walk (trie &optional f g key-so-far (depth 0))
  "INTERNAL. F,G if non-NIL should be functions of 2 argument that receive the
fileset-trie node and the key (as a list).  F (PREPROCESS) is invoked
in-order, G (POSTPROCESS) is invoked when the recursion unwinds."
  (when f (funcall f trie (reverse key-so-far)))
  (loop for sub-trie in (trie-sub-tries trie)
      do (trie-walk sub-trie f g
		    (cons (trie-sub-key sub-trie) key-so-far)
		    (1+ depth)))
  (when g (funcall g trie (reverse key-so-far))))


(defun comm-tries (trie1 trie2 &key comm-23 comm-13 comm-12 skip-subtries)
  "Compare Trie1 and trie2 with the same headaches as unix COMM(1).  Call
COMM-23 with arguments (KEY VAL1) on elements unique to TRIE1.  Call COMM-13
with arguments (KEY VAL2) on elements unique to TRIE2.  Call COMM-12 with
arguments (KEY VAL1 VAL2) on elements common to TRIE1 and TRIE2. If
SKIP-SUBTRIES is non-NIL, do not descend subtries."
  (let ((seen-keys (MAKE-TRIE)))
    (MAPTRIE (lambda (k1 v1)
	       (let ((v2 (GETTRIE k1 trie2 '%%notexists)))
		 (cond ((eq v2 '%%notexists)
			(when comm-23
			  (funcall comm-23 k1 v1))
			(when skip-subtries
			  (throw 'maptrie-skip-descend nil)))
		       (T (when comm-12
			    (funcall comm-12 k1 v1 v2))
			  (setf (GETTRIE k1 seen-keys) T)))))
	     TRIE1)
    (MAPTRIE (lambda (k2 v2)
	       (let ((seen-p (GETTRIE k2 seen-keys '%%NOTEXISTS)))
		 (when (eq seen-p '%%NOTEXISTS)
		   (let ((v1 (GETTRIE k2 trie1 '%%notexists)))
		     (when (eq v1 '%%notexists)
		       (when comm-13
			 (funcall comm-13 k2 v2))
		       (when skip-subtries
			 (throw 'maptrie-skip-descend nil)))))))
	     TRIE2)))


#||
(setq $x (make-trie))
(setf (gettrie "abc" $x ) 10)
(setf (gettrie "def" $x ) 20)
(setf (gettrie "axy" $x ) nil)
(gettrie "axy" $x)
(maptrie #'(lambda (k v)
	     (print (list k v)))
	 $x
	 'vector)

(setf (gettrie "abcde" $x) 100)
(maptrie #'(lambda (k v)
	     (print (list k v))
	     (when (equalp k "axy")
	       (print "aborting")
	       (throw 'maptrie-skip-descend t)))
	 $x
	 'vector)
(pprint $x)
(setf (fdefinition 'parse-identifier) #'find-seq)
(export 'parse-identifier)
||#