(in-package :free-clim-internal)

;;;; -- Protocol Classes ----------------------------------------------------------------------

(defvar *protocol-generic-functions*
  nil)

(defvar *protocol-classes*
  nil)

(defmacro define-protocol-class (name super-classes &rest clauses)
  (let ((define-predicate-p t)
        (define-class-p t)
	(k 0)
	methods)
    ;;
    (loop for clause in clauses do
	 (ecase (car clause)
	   ((:define-predicate-p)
	    (setf define-predicate-p (cadr clause)))
           ((:define-class-p)
            (setf define-class-p (cadr clause)))
	   ((:method)
	    (push (list (car clause)
			(cadr clause)
			(mapcar (lambda (x) (list (intern (format nil "_~D" (incf k))) x))
				(caddr clause)))
		  methods))
	   ((:fun)
	    (push clause methods))))
    ;;
    `(progn
       ,(and define-class-p
             `(defclass ,name ,super-classes
                ()))
       ;;
       ,(and define-predicate-p
	     `(defmethod ,(intern (concatenate 'string
					       (string name)
					       (if (find #\- (string name)) "-" "")
					       "P"))
		  (object)
		(typep object ',name)))
       ,@(loop for m in methods collect
	      `(define-protocol-generic-function ,@(cdr m)))
       ;;
       (pushnew ',name *protocol-classes*)
       ;;
       ',name
       )))

;; A protocol is not so much about classes, but about generic functions. And
;; some generic function could practically belong to multiple
;; protocols. Like TRANSFORM-REGION; Which is listed in the Affine
;; Transformation section of the CLIM Spec, but really is part of the region
;; protocol.

(defmacro define-protocol-generic-function (name arglist)
  `(progn
     (unless (fboundp ',name)
       (defgeneric ,name ,(loop for a in arglist collect
                                (if (listp a)
                                    (car a)
                                    a))))
     (define-protocol-generic-function-1 ',name
	 ',(loop for a in arglist
	      until (member a lambda-list-keywords) ;###
	      collect
	      (if (listp a) (cadr a) t)))))

(defmacro defprotofun (name arglist)
  `(define-protocol-generic-function ,name ,arglist))

(defmacro defprotofun* (name arglist)
  `(progn
     (define-protocol-generic-function-1 ',name
	 ',(loop for a in arglist
	      until (member a lambda-list-keywords) ;###
	      collect
                (if (listp a) (cadr a) t)))))

(defun define-protocol-generic-function-1 (name arglist)
  ;; lazy
  (pushnew (list* name arglist) *protocol-generic-functions* :test #'equal))

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

(defparameter *abstract-classes*
  '(STANDARD-REGION-SET))

;;;; -- Fixups --------------------------------------------------------------------------------

(defmacro defconstant* (name value &optional documentation)
  `(defvar ,name ,value ,@(and documentation (list documentation))))

(defmacro declfun (name arglist)
  `(declaim (ftype (function ,(let ((in-key-p nil))
				   (loop for arg in arglist collect
					(cond ((eq arg '&key)
					       (setf in-key-p t)
					       arg)
					      ((member arg lambda-list-keywords)
					       arg)
					      (in-key-p
					       (list (intern (string arg) :keyword) t))
					      (t
					       t))))
			     t)
		   ,name)))

(defmacro define-abstract-class (name supers slots &rest options)
  `(progn
     (defclass ,name ,supers ,slots
       ,@options)
     (pushnew ',name *abstract-classes*)
     ',name))

;;;; -- Coordinate Type -----------------------------------------------------------------------

(defun clamp (value min max)
  (max min (min max value)))

;;;; -- Weak Hash Tables ----------------------------------------------------------------------

(defun make-hash-table-with-weak-values (&rest rest)
  #+CCL
  (apply #'make-hash-table :weak :value rest)
  #-(OR CCL)
  #.(error "Implement MAKE-HASH-TABLE-WITH-WEAK-VALUES for your Lisp implementation."))

;;;; -- Checking Protocols --------------------------------------------------------------------

(defvar +everywhere+)
(defvar +nowhere+)

;; *sigh* Why don't we catch medium-copy-area?

(defun check-protocols (&key exclude only gfun templatep)
  (let ((methods-to-ignore
         (append
          (compute-applicable-methods-using-classes #'stream-write-char 
                                                    (list
                                                     (find-class 'stream)
                                                     (find-class 'character)))
          (compute-applicable-methods-using-classes #'region-intersection
                                                    (list
                                                     (find-class 'region)
                                                     (find-class 'region))))))
    ;; first collect all implementation classes for a given protocol class
    (unless (listp exclude)
      (setf exclude (list exclude)))
    (unless (listp only)
      (setf only (list only)))
    (let ((implementation-classes
           (loop for pc in *protocol-classes*
              collect (cons pc
                            (let ((bag nil))
                              (labels ((walk (class)
                                         (let ((type (class-name class)))
                                           (when (and (not (member (class-name class) *protocol-classes*))
                                                      (not (member (class-name class) *abstract-classes*))
                                                      (not (some (lambda (x) (subtypep type x)) exclude)))
                                             (pushnew class bag))
                                           (loop for c in (class-direct-subclasses class) do
                                                (walk c)))))
                                (walk (find-class pc))
                                bag))))))
      ;; (print `(implementation-classes ,implementation-classes))
      (let ((signatures nil))
        ;; all invokations
        (loop for (name . arglist) in (reverse *protocol-generic-functions*) do
             (when (and (or (null gfun) (eql name gfun))
                        (not (member name exclude)))
               (labels ((walk (q yet)
                          (cond ((null q)
                                 (push yet signatures))
                                ((eq (car q) 't)
                                 (walk (cdr q) (append yet (list 't))))
                                (t
                                 (let ((ic (cdr (assoc (car q) implementation-classes))))
                                   #+NIL
                                   (unless ic
                                     (warn "We miss implementations for class ~S." (car q)))
                                   (loop for c in ic do
                                        (walk (cdr q) (append yet (list (class-name c))))))))))
                 (walk arglist (list name)))))
        (let ((missing nil))
          ;;
          (loop for (name . arglist) in signatures do
               (when (or (null only)
                         (some #'(lambda (type) (some (lambda (x) (subtypep type x)) only))
                               arglist))
                 (let ((def (ignore-errors (fdefinition name))))
                   (cond ((not def)
                          (format t "~&;; ~S is not defined at all.~%" name))
                         (t
                          (let ((methods
                                 (compute-applicable-methods-using-classes
                                  def
                                  (loop for x in arglist collect
                                       #+CCL
                                       (cond ((eq x 'standard-everywhere-region)
                                              (ccl:intern-eql-specializer +everywhere+))
                                             ((eq x 'standard-nowhere-region)
                                              (ccl:intern-eql-specializer +nowhere+))
                                             (t
                                              (find-class x)))
                                       #-CCL
                                       (find-class x)
                                       ))))
                            (setf methods (remove-if (lambda (m)
                                                       (member m methods-to-ignore))
                                                     methods))
                            (unless methods
                              (push (list name arglist) missing))))))))
          ;;
          (setf missing
                (remove-if (lambda (sig-1)
                             (find-if (lambda (sig-2)
                                        (and (not (eq sig-1 sig-2))
                                             (eq (car sig-1) (car sig-2))
                                             (every #'subtypep (second sig-1) (second sig-2))))
                                      missing))
                           missing))
          (if templatep
              ;; could do better here.
              (loop for x in missing do
                   (let ((*print-case* :downcase))
                     (pprint `(defmethod ,(car x) ,(cadr x)
                                nil))))
              (loop for x in (sort missing #'string< :key (lambda (x) (prin1-to-string (first x)))) do
                   (format t "~&;; missing: ~S.~%" x))))))))


;;;; -- B.4 Multiple Value setf ---------------------------------------------------------------

(defmacro defgeneric* (name lambda-list &body options)
  (cond ((and (consp name) (eq (car name) 'setf))
         (let ((setter-name (intern (concatenate 'string (string 'setf*-) (string (cadr name)))
                                    (symbol-package (cadr name))))
               (values (butlast lambda-list))
               (place (car (last lambda-list))))
           `(progn (defsetf ,(cadr name) (,place) ,values
                     `(,',setter-name ,,@values ,,place))
                   (defgeneric ,setter-name ,lambda-list ,@options))))
        (t
         `(defgeneric ,name ,lambda-list ,@options))))

(defmacro defmethod* (name lambda-list &body body)
  (cond ((and (consp name) (eq (car name) 'setf))
         (let ((setter-name (intern (concatenate 'string (string 'setf*-) (string (cadr name)))
                                    (symbol-package (cadr name)))))
           `(defmethod ,setter-name ,lambda-list ,@body)))
        (t
         `(defmethod ,name ,lambda-list ,@body))))

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

(defun map-over-string-lines (fun string start end)
  (let ((p (position #\newline string :start start :end end)))
    (cond ((null p)
           (funcall fun string start end))
          (t
           (funcall fun string start p)
           (map-over-string-lines fun string (1+ p) end)))))

;;;; -- Gray Stream Protocol ------------------------------------------------------------------

(progn
  (pushnew 'fundamental-stream *protocol-classes*)
  (pushnew 'fundamental-input-stream *protocol-classes*)
  (pushnew 'fundamental-output-stream *protocol-classes*)
  (pushnew 'fundamental-character-stream *protocol-classes*)
  (pushnew 'fundamental-binary-stream *protocol-classes*)
  (pushnew 'fundamental-character-input-stream *protocol-classes*)
  (pushnew 'fundamental-character-output-stream *protocol-classes*)
  (pushnew 'fundamental-binary-input-stream *protocol-classes*)
  (pushnew 'fundamental-binary-output-stream *protocol-classes*)

  (defprotofun* stream-element-type ((stream fundamental-stream)))
                                        ;(defprotofun* open-stream-p ((stream fundamental-stream)))
                                        ;(defprotofun* close ((stream fundamental-stream) &key abort))
  (defprotofun* stream-read-char ((stream fundamental-character-input-stream)))
  (defprotofun* stream-unread-char ((stream fundamental-character-input-stream) character))
  (defprotofun* stream-read-char-no-hang ((stream fundamental-character-input-stream)))
  (defprotofun* stream-peek-char ((stream fundamental-character-input-stream)))
  (defprotofun* stream-listen ((stream fundamental-character-input-stream)))
  (defprotofun* stream-read-line ((stream fundamental-character-input-stream)))
  (defprotofun* stream-clear-input ((stream fundamental-character-input-stream)))

  (defprotofun* stream-write-char ((stream fundamental-character-output-stream) character))
  (defprotofun* stream-line-column ((stream fundamental-character-output-stream)))
  (defprotofun* stream-start-line-p ((stream fundamental-character-output-stream)))
  (defprotofun* stream-write-string ((stream fundamental-character-output-stream) string &optional start end))
  (defprotofun* stream-terpri ((stream fundamental-character-output-stream)))
  (defprotofun* stream-fresh-line ((stream fundamental-character-output-stream)))
  (defprotofun* stream-finish-output ((stream fundamental-character-output-stream)))
  (defprotofun* stream-force-output ((stream fundamental-character-output-stream)))
  (defprotofun* stream-clear-output ((stream fundamental-character-output-stream)))
  (defprotofun* stream-advance-to-column ((stream fundamental-character-output-stream) column))
  )

;;;; -- Printing Things Readably --------------------------------------------------------------

;; A lot of objects in CLIM are immutable, like regions, inks, text
;; styles and so on. I like those to be printed back as e.g. #.+nowhere+

;; (defgeneric make-print-form (object))

;; (defmethod make-print-form ((object t))
;;   `',object)

;; (defmethod make-print-form ((object real))
;;   object)

;; (defmethod make-print-form ((object character))
;;   object)

;; (defmethod make-print-form ((object array))
;;   object)

;; (defmethod make-print-form ((object standard-line))
;;   (multiple-value-bind (x1 y1) (line-start-point* object)
;;     (multiple-value-bind (x2 y2) (line-end-point* object)
;;       `(make-line* ,x1 ,y1 ,x2 ,y2))))

;; (defmethod make-print-form ((object standard-region-union))
;;   `(region-union ,@(mapcar #'make-print-form (region-set-regions object))))



(defmacro ensure-sequence-subseq-spec (sequence-place start-place end-place)
  `(progn
     (check-type ,sequence-place sequence)
     (unless ,start-place
       (setf ,start-place 0))
     (unless ,end-place
       (setf ,end-place (length ,sequence-place)))
     (check-type ,start-place fixnum)
     (check-type ,end-place fixnum)
     (unless (<= 0 ,start-place (length ,sequence-place))
       (error "The ~S, ~D, argument is outside the sequence."
              ',start-place ,start-place))
     (unless (<= 0 ,end-place (length ,sequence-place))
       (error "The ~S, ~D, argument is outside the sequence."
              ',end-place ,end-place))
     (unless (<= ,start-place ,end-place)
       (error "The ~S, ~D, argument is greater than the ~S, ~D, argument."
              ',start-place ,start-place
              ',end-place ,end-place))))

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

(defun plist-removed* (plist &rest keys)
  (loop for (key value) on plist by #'cddr
        for keep = (not (member key keys))
        when keep collect key
        when keep collect value))

;;;; -- MAXF and MINF -------------------------------------------------------------------------

(define-modify-macro maxf (&rest rest) max)
(define-modify-macro minf (&rest rest) min)

;;;; -- Lambda Lists --------------------------------------------------------------------------

#+NIL
(defun parse-lambda-list (lambda-list)
  ;; -> required-args
  ;;    optional-args as (var default svar)
  ;;    rest-arg or NIL
  ;;    keyword-args as (var default svar keyword)
  ;;    allow-other-keys-p
  ...)

;;;; -- Unbound Marker ------------------------------------------------------------------------

(defvar +unbound+
  (list "unbound")
  "Unique token to indicate, that some value was not supplied.
 Used by UPDATING-OUTPUT to interface with INVOKE-UPDATING-OUTPUT.")

;;;; -- Lambda Lists --------------------------------------------------------------------------

;; We deal a lot with lambda lists.

(defun parameter-name (parameter)
  (if (consp parameter)
      (if (consp (car parameter))
          (cadar parameter)
          (car parameter))
      parameter))

(defun parameter-default (parameter)
  (if (and (consp parameter) (cdr parameter))
      (values (cadr parameter) t)
      (values nil nil)))

(defun parameter-supplied-p (parameter)
  (if (and (consp parameter) (cddr parameter))
      (values (caddr parameter) t)
      (values nil nil)))

(defun parameter-keyword (parameter)
  (if (consp parameter)
      (if (consp (car parameter))
          (caar parameter)
          (intern (string (car parameter)) :keyword))
      (intern (string parameter) :keyword)))

(define-setf-expander parameter-default (parameter &environment env)
  ;; This is non-destructive on purpose
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion parameter env)
    (let* ((vars (append vars  (list (car store-vars))))
           (vals (append vals  (list reader-form)))
           (g-new (gensym)))
      (values vars
              vals
              (list g-new)
              `(let ((,(car store-vars) (set-parameter-default ,reader-form ,g-new)))
                 ,writer-form
                 ,g-new)
              `(attr ,reader-form)))))

(defun set-parameter-default (parameter new)
  (if (consp parameter)
      (append (list (car parameter)) (list new) (cddr parameter))
      (list parameter new)))

(defun parse-lambda-list (lambda-list)
  ;; -> req opt rest keys allow-p aux whole environment
  (let (req opt rest keys allow-p aux whole environment)
    (labels ((whole? ()
               (when (eq (car lambda-list) '&whole)
                 (pop lambda-list)
                 (setf whole (pop lambda-list)))))
      (whole?)
      (loop while (and (consp lambda-list) (not (member (car lambda-list) lambda-list-keywords))) do
           (push (pop lambda-list) req))
      (whole?)
      (when (eq (car lambda-list) '&optional)
        (pop lambda-list)
        (loop while (and (consp lambda-list) (not (member (car lambda-list) lambda-list-keywords))) do
             (push (pop lambda-list) opt)))
      (whole?)
      (when (member (car lambda-list) '(&rest &body))
        (pop lambda-list)
        (setf rest (pop lambda-list)))
      (whole?)
      (when (eq (car lambda-list) '&key)
        (pop lambda-list)
        (loop while (and (consp lambda-list) (not (member (car lambda-list) lambda-list-keywords))) do
             (push (pop lambda-list) keys))
        (when (eq (car lambda-list) '&allow-other-keys)
          (pop lambda-list)
          (setf allow-p t)))
      (when (eq (car lambda-list) '&aux)
        (pop lambda-list)
        (loop while (and (consp lambda-list) (not (member (car lambda-list) lambda-list-keywords))) do
             (push (pop lambda-list) aux)))
      ;;
      (values (reverse req) (reverse opt) rest
              (reverse keys) allow-p
              (reverse aux)
              whole
              environment))))

(defun unparse-lambda-list (req &optional opt rest key allow-p aux whole environment)
  (append req
          (and opt (cons '&optional opt))
          (and rest (list '&rest rest))
          (and key (cons '&key key))
          (and allow-p (list '&allow-other-keys))
          (and whole (list '&whole whole))
          (and environment (list '&environment environment))
          (and aux (cons '&aux aux))))

(defun lambda-list-parameters (lambda-list &aux all-vars)
  ;; ## reuse parse-lambda-list?
  "Returns a list of all the parameters defined by the given lambda list."
  (labels ((complain ()
             (error "Bad lambda list: ~S." lambda-list))
           (frob-1 (var)
             (cond ((symbolp var)
                    (push var all-vars))
                   (t
                    (complain))))
           (frob (q)
             (loop until (or (atom q) (member (car q) lambda-list-keywords)) do
                   (frob-1 (pop q)))
             (when (and (consp q) (eq '&optional (car q)))
               (pop q)
               (loop until (or (atom q) (member (car q) lambda-list-keywords)) do
                     (let ((x (pop q)))
                       (cond ((symbolp x)
                              (push x all-vars))
                             ((atom x) (complain))
                             ((destructuring-bind (var &optional init-form supplied-p) x
                                (declare (ignore init-form))
                                (when supplied-p (frob-1 supplied-p))
                                (frob-1 var)))))))
             (when (and (consp q) (member (car q) '(&rest &body)))
               (pop q)
               (unless (consp q) (complain))
               (frob-1 (pop q)))
             (when (and (consp q) (eq '&key (car q)))
               (pop q)
               (loop until (or (atom q) (member (car q) lambda-list-keywords)) do
                     (let ((x (pop q)))
                       (cond ((symbolp x) (frob-1 x))
                             ((destructuring-bind (var &optional init-form supplied-p) x
                                (declare (ignore init-form))
                                (when supplied-p (frob-1 supplied-p))
                                (cond ((atom var) (frob-1 var))
                                      ((destructuring-bind (keyword-name var) var
                                         (declare (ignore keyword-name))
                                         (frob-1 var)))))))))
               (when (and (consp q) (eq '&allow-other-keys (car q)))
                 (pop q)))
             (unless (null q)
               (complain))))
    (frob lambda-list)
    (reverse all-vars)))
    
;;;; -- Collect -------------------------------------------------------------------------------

(defmacro collecting-into-multiple (names &body body &environment env)
  (let ((item (gensym "ITEM."))
        (where (gensym "WHERE."))
        (whole (gensym "WOHLE."))
        (reses (mapcar (lambda (n) (declare (ignore n)) (gensym "RES.")) names)))
    `(let (,@reses)
       (macrolet
           ((collect-into (&whole ,whole ,where ,item)
              (cond ,@(loop for name in names
                         for res in reses
                         collect `((eq ,where ',name)
                                   `(push ,,item ,',res)))
                    (t
                     (macroexpand ,whole ',env)))))
         ,@body)
       (values
        ,@(loop for res in reses collect
               `(reverse ,res))))))

(defmacro collecting-into (name &body body)
  `(collecting-into-multiple (,name) ,@body))

(defmacro collect (item)
  `(collect-into nil ,item))

(defmacro collecting (&body body)
  `(collecting-into nil ,@body))

(defmacro collect-into (name item)
  (declare (ignore item))
  (error "Collection ~S not defined." name))

;;;; -- curry ---------------------------------------------------------------------------------

#+NIL
(defun curry (fun &rest args)
  (lambda (&rest args-2)
    (apply fun (append args args-2))))

(defmacro curry (fun &rest args)
  `(lambda (&rest args-2)
     (apply ',fun (list* ,@args args-2))))

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

(defmacro memo ((hash-table key) &rest forms)
  "Short hand for looking something up in a hash table and generate it if
   not found."
  (let ((ht (gensym "HT."))
        (gkey (gensym "KEY."))
        (val (gensym "VAL."))
        (foundp (gensym "FOUNDP.")))
    `(let ((,gkey ,key)
           (,ht ,hash-table))
       (multiple-value-bind (,val ,foundp) (gethash ,gkey ,ht)
         (if ,foundp
             ,val
             (setf (gethash ,gkey ,ht)
                   (progn ,@forms)))))))

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

#+NIL
(defmacro defunique (name args &body body)
  ;; ### parse-lambda!
  (let ((hash (gensym "HASH.")))
    `(let ((,hash (make-hash-table :weak :value :test #'equal)))
       (defun ,name ,args
         (or (gethash (list ,@args) ,hash)
             (setf (gethash (list ,@args) ,hash)
                   (progn ,@body)))))))

(defmacro defunique (name args &body body)
  ;; ### parse-lambda!
  (let ((hash (gensym "HASH.")))
    `(let ((,hash (make-hash-table :weak :value :test #'equal)))
       (defun ,name ,args
         (or (gethash (list ,@(lambda-list-parameters args)) ,hash)
             (setf (gethash (list ,@(lambda-list-parameters args)) ,hash)
                   (progn ,@body)))))))

(defmacro dada ((&rest substs) &body body)
  "This is an evil macro."
  (setf substs (sort substs #'> :key (lambda (s) (length (symbol-name (first s))))))
  `(progn
     ,@(loop for k from 1 below (length (first substs)) collect
             (labels ((subst-one (new old sym)
                        (let ((p (search (symbol-name old) (symbol-name sym))))
                          (cond ((not (null p))
                                 (let ((pack (if (eq (symbol-package sym)
                                                     (find-package :keyword))
                                                 (symbol-package sym)
                                               *package*)))
                                   (intern (concatenate 'string
                                             (subseq (symbol-name sym) 0 p)
                                             (symbol-name new)
                                             (subseq (symbol-name sym)
                                                     (+ p (length (symbol-name old)))))
                                           pack)))
                                (t
                                 sym))))
                      (walk (x)
                        (cond ((symbolp x)
                               (dolist (subst substs)
                                 (setf x (subst-one (elt subst k) (first subst) x)))
                               x)
                              ((atom x) x)
                              ((consp x)
                               (cons (walk (car x)) (walk (cdr x)))))))
               `(locally
                  ,@(walk body))))))