(require 'rg-utils)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Dictionary - abstract associative maps for common Lisp
;;;  (Why should Python programmers have all the fun?)
;;;
;;;  Copyright (c) 2008 by Ron Garret.  This code is may be
;;;  freely distributed, modified and used for any purpose provided
;;;  this copyright notice is retained.
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Generic interface to associative maps
;;;
(defgeneric ref1 (map key))
(defgeneric refd (map key default))
(defgeneric del (map key))
(defgeneric setref (map key value))
(defgeneric keys (map))

(defmacro ref (map key &optional (default nil default-supplied-p))
  (if default-supplied-p `(refd ,map ,key ,default) `(ref1 ,map ,key)))

(defmacro refchain (map key &rest keys)
  (if keys `(refchain (ref ,map ,key) ,@keys) `(ref ,map ,key)))

(defsetf ref setref)

(defgeneric size (map))

(define-method (size (map t)) (length (keys map)))

(define-method (size (s sequence)) (length s))

(defgeneric has-key (map key))

(define-method (has-key (map t) key)
  (not (eq '#1=#.(gensym) (ref map key '#1#))))

(defgeneric copy-into (dest src))
(defmethod copy-into (dest src)
  (for (key value) in src do (setf (ref dest key) value))
  dest)

(define-method (refd! map key default)
  (setf (ref map key) (refd map key default)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Various ways to implement associative maps
;;;

;;;  Hash tables
(define-method (ref1 (h hash-table) key) (gethash key h))
(define-method (refd (h hash-table) key default) (gethash key h default))
(define-method (del (h hash-table) key) (remhash key h))
(define-method (setref (h hash-table) key value) (setf (gethash key h) value))
(define-method (keys (h hash-table)) (loop for k being the hash-keys of h collect k))
(define-method (size (h hash-table)) (hash-table-count h))
; Hash-table iterators are defined in utilities.lisp

;;; PLists
(define-class plist plist)
(define-method (ref1 (p plist plist) key) (getf plist key))
(define-method (refd (p plist plist) key default) (getf plist key default))
(define-method (del (p plist plist) key) (remf plist key))
(define-method (setref (p plist plist) key value) (setf (getf plist key) value))
(define-method (keys (p plist plist)) (loop for x in plist by #'cddr collect x))
(define-method (size (p plist plist)) (/ (length plist) 2))
(define-method (iterator (p plist plist))
  (let ( (l plist) ) (fn () (if l (values (pop l) (pop l)) +iterend+))))

;;; ALists
(define-class alist alist)
(define-method (ref1 (a alist alist) key) (cdr (assoc key alist)))
(define-method (refd (a alist alist) key default)
  (aif (assoc key alist) (cdr it) default))
(define-method (del (a alist alist) key) (deletef key alist :key #'car))
(define-method (setref (a alist alist) key value)
  (aif (assoc key alist)
    (setf (cdr it) value)
    (push (cons key value) alist)))
(define-method (keys (a alist alist)) (fn (n) (car (nth n alist))))
(define-method (size (a alist alist)) (length alist))
(define-method (iterator (a alist alist))
  (let ( (l alist) )
    (fn () (if l (let ( (kv (pop l)) ) (values (fst kv) (rst kv))) +iterend+))))

;;; DLists
(define-class dlist keys values)
(define-method (ref1 (d dlist keys values) key) (elt values (position key keys)))
(define-method (refd (d dlist keys values) key default)
  (aif (position key keys) (elt values it) default))
(define-method (del (d dlist keys values) key)
  (aif (position key keys)
       (progn (pop (nthcdr it keys)) (pop (nthcdr it values)))))
(define-method (setref (d dlist keys values) key value)
  (setf (elt values (position key keys)) value))
(define-method (keys (d dlist keys)) keys)
(define-method (size (d dlist keys)) (length keys))
(define-method (iterator (d dlist keys values))
  (let ( (k keys) (v values) ) (fn () (if k (values (pop k) (pop v)) +iterend+))))
(define-method (copy-into (d dlist keys values) src)
  (setf keys (copy-list (keys src)))
  (setf values (mapcar (fn (k) (ref src k)) keys))
  d)


;;; Extend the dictionary metaphor to Lisp built-in types

(define-method (ref1 (l list) n)
  (nth (if (< n 0) (+ (length l) n) n) l))

(define-method (setref (l list) n val)
  (setf (nth (if (< n 0) (+ (length l) n) n) l) val))

(define-method (size (s sequence)) (length s))

(define-method (ref1 (v vector) n)
  (aref v (if (< n 0) (+ (length v) n) n)))

(define-method (setref (v vector) n val)
  (setf (aref v (if (< n 0) (+ (length v) n) n)) val))


(define-method (ref1 (o standard-object) k) (slot-value o k))

(define-method (setref (o standard-object) k val) (setf (slot-value o k) val))

(define-method (keys (o standard-object))
  (mapcar 'slot-definition-name (class-slots (find-class (type-of o)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Dictionaries - abstract associative maps with dynamically changeable implementations
;;;
(defvar *default-dictionary-impl-type* 'plist)

(define-class dictionary (implementation
                          (make-dictionary-implementation *default-dictionary-impl-type*)))

(define-method (refd (d dictionary implementation) key default)
  (refd implementation key default))

(define-method (ref1 (d dictionary implementation) key)
  (ref1 implementation key))

(define-method (del (d dictionary implementation) key)
  (del implementation key)
  d)

(define-method (setref (d dictionary implementation) key value)
  (setref implementation key value)
  value)

(define-method (size (d dictionary implementation)) (size implementation))

(define-method (keys (d dictionary implementation)) (keys implementation))

(define-method (iterator (d dictionary implementation)) (iterator implementation))

(define-method (print-object (d dictionary implementation) stream)
  (format stream "#<~A ~A { " (type-of d) (type-of implementation))
  (if (<= (size d) 10) ; should be *print-length*
    (for (k v) in implementation do (format stream "~S ~S " k v))
    (format stream "~A items " (size d)))
  (format stream "}>"))

(defun make-dictionary-implementation (impl-type)
  (case impl-type
    ((hash-table eql-hash-table) (make-hash-table))
    (eq-hash-table (make-hash-table :test 'eq))
    (equal-hash-table (make-hash-table :test 'equal))
    (equalp-hash-table (make-hash-table :test 'equalp))
    (otherwise (make-instance impl-type))))

(define-method (change-implementation (d dictionary implementation) new-impl-type)
  (setf implementation (copy-into (make-dictionary-implementation new-impl-type)
				  implementation))
  d)

(defun plist->dictionary (l &optional (impl-type *default-dictionary-impl-type*))
  (let ( (impl (make-dictionary-implementation impl-type)) )
    (loop for (k v) on l by #'cddr do (setf (ref impl k) v))
    (make-dictionary :implementation impl)))


;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Histograms
;;;
(define-class (histogram dictionary) keyfn)

(defun make-histogram (&key (implementation (make-hash-table)) keyfn)
  (make-instance 'histogram :implementation implementation :keyfn keyfn))

(define-method (add (h histogram keyfn) item)
  (bb k (if keyfn (funcall keyfn item) item)
      (setf (ref h k) (1+ (refd h k 0)))))

;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  Indexes
;;;
(define-class (index dictionary) keyfn)

(defun make-index (&key (implementation (make-hash-table)) keyfn)
  (make-instance 'index :implementation implementation :keyfn keyfn))

(define-method (add (i index keyfn) item)
  (bb k (if keyfn (funcall keyfn item) item)
      (setf (ref i k) item)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Sets
;;;
(define-class (set dictionary))

(define-method (member? (s set) item) (refd s item nil))

(define-method (add (s set) item) (setf (ref s item) item) s)

(define-print-method (set) "#<Set ~A>" (keys self))

(shadow '(union intersection))

(define-method (union (s1 set) (s2 set))
  (bb s3 (make-set)
      (for i in s1 do (add s3 i))
      (for i in s2 do (add s3 i))
      s3))

(define-method (intersection (s1 set) (s2 set))
  (make-set :items (for i in s1 if (member? s2 i) collect i)))


;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Binner
;;;
(define-class (binner dictionary) keyfn bin-factory)

(defun make-binner (&key (implementation (make-hash-table)) keyfn (bin-factory 'make-set))
  (make-instance 'binner :implementation implementation
    :keyfn keyfn :bin-factory bin-factory))

(define-method (add (b binner keyfn bin-factory) item)
  (add (refd! b (if keyfn (funcall keyfn item) item) (funcall bin-factory)) item))

(define-method (del (b binner keyfn) item)
  (bb key (if keyfn (funcall keyfn item) item)
      (if (has-key b key) (del (ref b key) item))))

(defun bin (collection &optional keyfn (bin-factory 'make-set))
  (bb b (make-binner :implementation (make-hash-table :test 'equal)
                     :keyfn keyfn :bin-factory bin-factory)
      (for item in collection do (add b item))
      b))


#|
; Seems like a bad idea.  Collides with too many other things, including Parcil
(defun \{-reader (stream char)
  (declare (ignore char))
  (let* ( (l1 (read-delimited-list #\} stream))
          (l2 (loop for (k v) on l1 by #'cddr collect `',k collect v)) )
    `(plist->dictionary (list ,@l2))))

(set-macro-character #\{ '\{-reader)
(set-syntax-from-char #\} #\))
|#

; This seems better:

(defun -> (&rest args) (plist->dictionary args))
(defun dict (&rest args) (plist->dictionary args))
(defun hmap (&rest args) (plist->dictionary args 'hash-table))

;;; Python lists
#|
; Another bad idea
(defun \[-reader (stream char)
  (declare (ignore char))
  (let ( (l1 (read-delimited-list #\] stream)) )
    (make-array (list (length l1)) :initial-contents l1 :fill-pointer t :adjustable t)))

(set-macro-character #\[ '\[-reader)
(set-syntax-from-char #\] #\))
|#

; Let's try this instead

(defun >> (&rest l)
  (make-array (list (length l)) :initial-contents l :fill-pointer t :adjustable t))

(define-method (+= (v vector) elt)
  (vector-push-extend elt v)
  v)

(define-method (extend (v vector) seq)
  (map nil (fn (x) (vector-push-extend x v)) seq)
  v)

(provide :dictionary)