(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))

(defmethod pane-frame ((pane accepting-values-stream))
  (pane-frame (encapsulating-stream-stream pane)))

(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"))

;; Rename default-g-i-f-v and make this :nconc/:most-specific-first maybe
(define-presentation-generic-function
    %gadget-initargs-for-view gadget-initargs-for-view
  (type-key parameters options gadget-view stream 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 type))

(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 string))
  gadget-value)

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

(define-presentation-method decode-gadget-value
    ((gadget slider-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)
      (mapcar (lambda (button)
		(funcall value-key (find (gadget-label button)
					 sequence
					 :key name-key
					 :test 'string=)))
	      gadget-value))))

;;; 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 stream 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) stream
		   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 stream)
	 (list :choices (mapcar
			 (lambda (label)
			   (make-pane 'toggle-button
				      :label label
				      :background (medium-background stream)
				      :foreground (medium-foreground stream)))
			 (funcall-presentation-generic-function
			  button-labels ptype)))))
  (define-default-presentation-method gadget-initargs-for-view
      ((gadget-view radio-box-view) stream default default-supplied-p type)
      (radio/check-box-initargs type stream))

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

(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) stream 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) stream default default-supplied-p type)
    (assert default-supplied-p (default)
	    "Must supply a default value for option-pane")
    (list/option-pane-initargs type default)))

(define-default-presentation-method gadget-initargs-for-view
    ((gadget-view text-editor-view) stream default default-supplied-p type)
  (list :ncolumns 40 :nlines 5))

(define-default-presentation-method gadget-initargs-for-view
    ((gadget-view text-field-view) stream default default-supplied-p type)
  (list :width 300))

;;; Utilities for accept-present-default methods

(defun av-do-gadget-decode (query gadget value)
  (block decode-condition-handler
    (handler-bind
	((error (lambda (condition)
		  (setf (accept-condition query) condition)
		  (return-from decode-condition-handler (values nil nil)))))
      (values
       (funcall-presentation-generic-function
	decode-gadget-value
	gadget value (ptype query))
       t))))

(defclass av-gadget-record (standard-updating-output-record)
  ((gadget :accessor av-gadget)
   (last-value :initform nil :accessor last-value)))

(defmethod finalize-query-record (query (record av-gadget-record))
  (let* ((gadget (av-gadget record))
	 (value (gadget-value gadget)))
    (format (frame-standard-output *application-frame*) "F Gadget ~A Value ~A~%"
	    (gadget-id  gadget) value)
    (unless (equalp value (slot-value record 'last-value))
      (setf (accept-condition query) nil)
      (multiple-value-bind (new-value succeeded)
	  (av-do-gadget-decode query gadget value)
	(when succeeded
	  (setf (changedp query) t)
	  (setf (value query) new-value))))))

(defun make-gadget-for-view (stream query-id ptype gadget-type view
			     default default-supplied-p
			     &rest params)
  ;; 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.
  ;;
  ;; The gadget creation must be placed within the updating-output to
  ;; prevent new gadgets from being created on every run. This
  ;; necessitates some very evil trickery here.
  (let* ((gadget nil)
	 (record 
	  (updating-output (stream :cache-value t
				   :cache-test (lambda (o n) (declare (ignore o n)) t)
				   :unique-id query-id
				   :record-type 'av-gadget-record)
	    (setf gadget 
		  (with-look-and-feel-realization
		      ((frame-manager *application-frame*) *application-frame*)
		    (apply #'make-pane gadget-type
			   :client 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 stream default default-supplied-p ptype)
			    params))))
	    (format t "made gadget ~A/~A~%" query-id gadget)
	    (surrounding-output-with-border (stream)
	      (with-output-as-gadget (stream)
		gadget))
	    (setf (gadget-value gadget)
		  (funcall-presentation-generic-function
		   encode-gadget-value
		   gadget default default-supplied-p ptype)))))
    (when gadget (setf (av-gadget record) gadget
		       (last-value record) (gadget-value gadget)))
    record))

;;; accept-present-default

(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+)
      ((string) +text-editor-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-default-presentation-method accept-present-default
    (type stream (view text-field-view)
     default default-supplied-p present-p query-id)
  (make-gadget-for-view stream query-id type 'text-field view
			default default-supplied-p))

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

(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))

(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))

(define-presentation-method accept-present-default
    ((type string) stream (view text-editor-view)
     default default-supplied-p present-p query-id)
  (make-gadget-for-view stream query-id type 'text-editor 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
    (unless (equalp value (last-value (record query-object)))
      (setf (accept-condition query-object) nil)
      (multiple-value-bind (new-value succeeded)
	  (av-do-gadget-decode query-object gadget value)
	(when succeeded
	  (setf (last-value (record query-object)) new-value)
	  (throw-highlighted-presentation
	   (make-instance 'standard-presentation
			  :object `(com-change-query
				    ,(query-identifier query-object)
				    ,new-value)
			  :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 ((gadget value-gadget)
				   (client accepting-values-stream)
				   query-id
				   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))))

(defmethod value-changed-callback ((gadget editor-substrate-mixin)
				   (client accepting-values-stream)
				   query-id
				   value)
  nil)

(defmethod armed-callback ((gadget editor-substrate-mixin)
			   (client accepting-values-stream)
			   query-id)
  (queue-event (frame-top-level-sheet (pane-frame
				       (encapsulating-stream-stream client)))
	       (make-instance 'av-gadget-query-update-event
			      :sheet client
			      :gadget gadget
			      :value (gadget-value gadget)
			      :query-object (find query-id (queries client)
						  :key #'query-identifier))))

(defmethod disarmed-callback ((gadget editor-substrate-mixin)
			      (client accepting-values-stream)
			      query-id)
  (queue-event (frame-top-level-sheet (pane-frame
				       (encapsulating-stream-stream client)))
	       (make-instance 'av-gadget-query-update-event
			      :sheet client
			      :gadget gadget
			      :value (gadget-value gadget)
			      :query-object (find query-id (queries client)
						  :key #'query-identifier))))