(in-package :clim-internals)

;;; 2008 Clinton Ebadi
;;; Based upon code By Paul Werkowski, April-2006 and placed into the
;;; public domain as an example implementation of accept-values-pane

;;; Should be in McCLIM proper

(defmethod check-box-selections ((g check-box))
  ;; Should this filter out children that aren't toggle-buttons, or
  ;; are all the children guaranteed to be toggle-buttons?
  (sheet-children g))

(define-presentation-generic-function %encode-gadget-value encode-gadget-value
  (type-key parameters options gadget default default-supplied-p type)
  (:documentation "Encode value of presentation type into a form
  suitable for use by a gadget"))

(define-presentation-generic-function %decode-gadget-value decode-gadget-value
  (type-key parameters options gadget-type item type)
  (:documentation "Convert the value returned from a gadget into the
  proper type for the presentation type"))

(define-presentation-generic-function
    %gadget-initargs-for-view gadget-initargs-for-view
  (type-key parameters options gadget-view default default-supplied-p type)
  (:documentation "Generate list of initargs for gadget created in view"))

(define-presentation-generic-function
    %button-labels button-labels
  (type-key parameters options type)
  (:documentation "Return (values labels sequence) for button and list
  based views"))

;;; Encode

(define-default-presentation-method encode-gadget-value
     (gadget default default-supplied-p type)
   default)

(define-default-presentation-method encode-gadget-value
    ((gadget text-field) default default-supplied-p type)
  (present-to-string default))

(define-presentation-method encode-gadget-value
    ((gadget radio-box) default default-supplied-p (type completion))
  (if default-supplied-p
      (with-presentation-type-parameters (completion type)
	(with-presentation-type-options (completion type)
	  (let ((name (funcall name-key default)))
	    (find name (radio-box-selections gadget)
		  :key 'gadget-label :test 'string=))))))

(define-presentation-method encode-gadget-value
    ((gadget check-box) default default-supplied-p (type subset-completion))
  (if default-supplied-p
      (with-presentation-type-parameters (subset-completion type)
	(with-presentation-type-options (subset-completion type)
	  (let ((buttons (check-box-selections gadget)))
	    (mapcar (lambda (i) (find (funcall name-key i)
				 buttons :test #'string= :key #'gadget-label))
		    default))))))


(define-presentation-method encode-gadget-value
    ((gadget gadget) default default-supplied-p (type boolean))
  (if (and default-supplied-p default) t nil))

(macrolet ((define-real-e-g-v (type)
	     `(define-presentation-method encode-gadget-value
		  ((gadget slider-gadget) default default-supplied-p (type ,type))
		(with-presentation-type-parameters (,type type)
		  (if default-supplied-p
		      default
		      (if (eq low '*) 0 low))))))
  (define-real-e-g-v real)
  (define-real-e-g-v rational)
  (define-real-e-g-v integer)
  (define-real-e-g-v float))

;;; Decode

(define-default-presentation-method decode-gadget-value
    ((gadget gadget) (gadget-value string) type)
  (accept-from-string type gadget-value))

(define-default-presentation-method decode-gadget-value
    ((gadget gadget) gadget-value type)
  gadget-value)

(define-presentation-method decode-gadget-value
    ((gadget gadget) (gadget-value string) (type real))
  (funcall-presentation-generic-function
   decode-gadget-value
   gadget (read-from-string gadget-value) type))

(define-presentation-method decode-gadget-value
    ((gadget gadget) (gadget-value real) (type integer))
  (round gadget-value))

(define-presentation-method decode-gadget-value
    ((gadget gadget) (gadget-value real) (type float))
  (float gadget-value))

(define-presentation-method decode-gadget-value
    ((gadget radio-box) gadget-value (type completion))
  (with-presentation-type-parameters (completion type)
    (with-presentation-type-options (completion type)
      (let ((key (gadget-label gadget-value)))
	(funcall value-key (find key sequence :key name-key :test 'string=))))))

(define-presentation-method decode-gadget-value
    ((gadget check-box) gadget-value (type subset-completion))
  (with-presentation-type-parameters (subset-completion type)
    (with-presentation-type-options (subset-completion type)
      (loop for button in gadget-value
	 for item = (funcall value-key (find (gadget-label button)
					     sequence
					     :key name-key
					     :test 'string=))
	 when item collect item))))

;;; Button labels

(define-presentation-method button-labels
    ((type completion))
  (with-presentation-type-parameters (completion type)
    (with-presentation-type-options (completion type)
      (values (mapcar name-key sequence) sequence name-key value-key test))))

(define-presentation-method button-labels
    ((type subset-completion))
  (with-presentation-type-parameters (subset-completion type)
    (with-presentation-type-options (subset-completion type)
      (values (mapcar name-key sequence) sequence name-key value-key test))))

;;; Initargs

(define-default-presentation-method gadget-initargs-for-view
    (gadget-view default default-supplied-p type)
  (if default-supplied-p (list :value default)))

(macrolet ((define-real-g-i-f-v (type)
	     `(define-presentation-method gadget-initargs-for-view
		  ((gadget-view slider-view)
		   default default-supplied-p (type ,type))
		(with-presentation-type-parameters (,type type)
		  (list :value (if default-supplied-p
				   default
				   (if (eq low '*) 0 low))
			:min-value (if (eq low '*) -100 low)
			:max-value (if (eq high '*) 100 high))))))
  (define-real-g-i-f-v real)
  (define-real-g-i-f-v rational)
  (define-real-g-i-f-v integer)
  (define-real-g-i-f-v float))

(flet ((radio/check-box-initargs (ptype)
	 (list :choices (mapcar (lambda (label) (make-pane 'toggle-button
						      :label label))
				(funcall-presentation-generic-function
				 button-labels ptype)))))
  (define-default-presentation-method gadget-initargs-for-view
      ((gadget-view radio-box-view) default default-supplied-p type)
      (radio/check-box-initargs type))

  (define-default-presentation-method gadget-initargs-for-view
      ((gadget-view check-box-view) default default-supplied-p type)
    (radio/check-box-initargs type)))

(flet ((list/option-pane-initargs (ptype default-value)
	 (multiple-value-bind (button-labels items name-key value-key test)
	     (funcall-presentation-generic-function button-labels ptype)
	   (declare (ignore button-labels))
	   (list :items items
		 :name-key name-key
		 :value-key value-key
		 :test test
		 :value default-value))))
  (define-default-presentation-method gadget-initargs-for-view
      ((gadget-view list-pane-view) default default-supplied-p type)
    (assert default-supplied-p (default)
	    "Must supply a default value for list-pane")
    (list/option-pane-initargs type default))

  (define-default-presentation-method gadget-initargs-for-view
      ((gadget-view option-pane-view) default default-supplied-p type)
    (assert default-supplied-p (default)
	    "Must supply a default value for option-pane")
    (list/option-pane-initargs type default)))

;;; Utilities for accept-present-default methods

;; rename and reorganize argument list maybe
(defun make-gadget-for-view (stream query-id ptype gadget-type view
			     default default-supplied-p
			     &rest params)
  (declare (special *accepting-values-stream*))
  (let* ((value (if default-supplied-p
		   default
		   (ignore-errors
		     (accept-from-string ptype "" :view +textual-view+))))
	(gadget
	 (with-look-and-feel-realization
	     ((frame-manager *application-frame*) *application-frame*)
	   (apply #'make-pane gadget-type
		  :client *accepting-values-stream*
		  :id query-id
		  (append
		   (view-gadget-initargs view)
		   (list :background (medium-background stream)
			 :foreground (medium-foreground stream))
		   (funcall-presentation-generic-function
		    gadget-initargs-for-view view default default-supplied-p ptype)
		   params)))))
    (setf (gadget-value gadget)
	  (funcall-presentation-generic-function
	   encode-gadget-value gadget default default-supplied-p ptype))
    ;; accepting-values wants an incremental redisplay record, but the
    ;; gadget to be created and displayed once even when the value
    ;; changes. Therefore the cache-test is set to always return true.
    (updating-output (stream :cache-value value
			     :cache-test (lambda (o n) (declare (ignore o n)) t)
			     :unique-id query-id)
      (with-output-as-gadget (stream)
	gadget))))

;;; accept-present-default

(macrolet ((define-completion-a-p-d ((p-type view-type gadget-type)
				      &rest gadget-args)
	     `(define-presentation-method accept-present-default
		  ((type ,p-type)
		   stream 
		   (view ,view-type)
		   default default-supplied-p
		   present-p 
		   query-id)
		(make-gadget-for-view
		 stream query-id type ',gadget-type view default default-supplied-p
		 ,@gadget-args))))
  (define-completion-a-p-d (completion radio-box-view radio-box))

  (define-completion-a-p-d (completion option-pane-view option-pane)
      :mode :exclusive)

  (define-completion-a-p-d (completion list-pane-view list-pane)
      :mode :exclusive)

  (define-completion-a-p-d (subset-completion check-box-view check-box)
      :mode :nonexclusive)

  (define-completion-a-p-d (subset-completion list-pane-view list-pane)
      :mode :nonexclusive))

(defun resolve-gadget-view (ptype)
  (with-presentation-type-decoded (ptype-name) ptype
    (case ptype-name
      ((completion) +radio-box-view+)
      ((subset-completion) +check-box-view+)
      ((boolean) +toggle-button-view+)
      (t +text-field-view+))))

(define-default-presentation-method accept-present-default
    (type stream (view gadget-dialog-view)
     default default-supplied-p present-p query-id)
  (funcall-presentation-generic-function
   accept-present-default
   type stream (resolve-gadget-view type)
   default default-supplied-p present-p query-id))

(define-presentation-method accept-present-default
  ((type boolean)  stream  (view option-pane-view)
   default default-supplied-p present-p query-id)
  (make-gadget-for-view stream query-id type 'option-pane view
			default default-supplied-p
                        :items '(t nil)
			:mode :exclusive))

(define-presentation-method accept-present-default
  ((type boolean)  stream  (view toggle-button-view)
   default default-supplied-p present-p query-id)
  (make-gadget-for-view stream query-id type 'toggle-button view
			default default-supplied-p))

(define-presentation-method accept-present-default
  ((type real) stream (view slider-view)
   default default-supplied-p present-p query-id)
  (make-gadget-for-view stream query-id type 'slider view
			default default-supplied-p))


;;; Event handlers

(defclass av-gadget-query-update-event (clim:device-event)
  ((gadget :initarg :gadget)
   (query-object :initarg :query-object)
   (value :initarg :value)))

(defmethod handle-event :after (client (event av-gadget-query-update-event))
  (with-slots (gadget query-object value) event
    (throw-highlighted-presentation
     (make-instance 'standard-presentation
                    :object `(com-change-query
			      ,(query-identifier query-object)
			      ,(funcall-presentation-generic-function
				decode-gadget-value
				gadget value (ptype query-object)))
		    :type 'command
                    :single-box t)
     *input-context*
     (make-instance 'pointer-button-press-event
                    :sheet (frame-top-level-sheet (pane-frame client))
                    :x 0 :y 0 :modifier-state 0
                    :button +pointer-left-button+))))

(defmethod value-changed-callback :after ((gadget value-gadget)
					  (client accepting-values-stream)
					  query-id
					  value)
   (format (frame-standard-output *application-frame*) "Gadget ~A Value ~A~%"
	   gadget value)
  (queue-event (frame-top-level-sheet (pane-frame
				       (encapsulating-stream-stream  client)))
	       (make-instance 'av-gadget-query-update-event
			      :sheet client
			      :gadget gadget
			      :value value
			      :query-object (find query-id (queries client)
						  :key #'query-identifier))))