(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 accept-arguments)
  (: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)
  (:method-combination nconc)
  (:documentation "Generate list of initargs for gadget created in view"))

;;; 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)
  (if default-supplied-p
      (present-to-string default type)
      ""))

(define-presentation-method encode-gadget-value
    ((gadget radio-box) default default-supplied-p (type completion))
  (if default-supplied-p
      (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
      (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))

(define-presentation-method encode-gadget-value
    ((gadget slider-gadget) default default-supplied-p (type real))
  (if default-supplied-p
      default
      (if (eq low '*) 0 low)))

;;; Decode

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

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

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

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

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

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

;;; Initargs

(define-default-presentation-method gadget-initargs-for-view nconc
    (gadget-view stream default default-supplied-p type)
    (nconc (list :background (medium-background stream)
		 :foreground (medium-foreground stream))
	   (if default-supplied-p (list :value default))))

(define-presentation-method gadget-initargs-for-view nconc
  ((gadget-view slider-view) stream default default-supplied-p (type real))
  (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)
	:width (bounding-rectangle-width stream)))

(flet ((radio/check-box-initargs (name-key sequence stream)
	 (list :choices (mapcar
			 (lambda (label)
			   (make-pane 'toggle-button
				      :label label
				      :background (medium-background stream)
				      :foreground (medium-foreground stream)))
			 (mapcar name-key sequence)))))
  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view radio-box-view) stream default default-supplied-p (type completion))
    (radio/check-box-initargs name-key sequence stream))
  
  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view radio-box-view) stream default default-supplied-p (type subset-completion))
    (radio/check-box-initargs name-key sequence stream))
  
  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view check-box-view) stream default default-supplied-p (type completion))
    (radio/check-box-initargs name-key sequence stream))

  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view check-box-view) stream default default-supplied-p (type subset-completion))
    (radio/check-box-initargs name-key sequence stream)))

(flet ((list/option-pane-initargs (items name-key value-key test default-value)
	 (list :items items
	       :name-key name-key
	       :value-key value-key
	       :test test
	       :value default-value)))
(define-default-presentation-method gadget-initargs-for-view nconc
  ((gadget-view list-pane-view) stream default default-supplied-p type)
    (assert default-supplied-p (default)
	    "Must supply a default value for list-pane")
    nil)

(define-default-presentation-method gadget-initargs-for-view nconc
  ((gadget-view option-pane-view) stream default default-supplied-p type)
    (assert default-supplied-p (default)
	    "Must supply a default value for option-pane")
    nil)
  
  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view list-pane-view) stream default default-supplied-p (type completion))
    (nconc
     (list/option-pane-initargs sequence name-key value-key test default)
     (list :mode :exclusive)))

  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view list-pane-view) stream default default-supplied-p (type subset-completion))
    (nconc
     (list/option-pane-initargs sequence name-key value-key test default)
     (list :mode :nonexclusive)))

  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view option-pane-view) stream default default-supplied-p (type completion))
    (nconc
     (list/option-pane-initargs sequence name-key value-key test default)
     (list :mode :exclusive)))

  (define-presentation-method gadget-initargs-for-view nconc
    ((gadget-view option-pane-view) stream default default-supplied-p (type subset-completion))
    (nconc
     (list/option-pane-initargs sequence name-key value-key test default)
     (list :mode :nonexclusive))))

(define-presentation-method gadget-initargs-for-view nconc
  ((gadget-view option-pane-view) stream default default-supplied-p (type boolean))
  (list :items '(("Yes" . t) ("No" . nil))
	:name-key #'car
	:value-key #'cdr
	:mode :exclusive))

(define-default-presentation-method gadget-initargs-for-view nconc
  ((gadget-view text-editor-view) stream default default-supplied-p type)
  (list :ncolumns (round (/ (bounding-rectangle-width stream)
			    (stream-character-width stream #\m)
			    2))
	:nlines 1
	:background (multiple-value-bind (i h s)
			(color-ihs (medium-background stream))
		      (make-ihs-color (* 0.9 i) h s))))

(define-default-presentation-method gadget-initargs-for-view nconc
  ((gadget-view text-field-view) stream default default-supplied-p type)
  (list :width (round (/ (bounding-rectangle-width stream) 2))
	:background (multiple-value-bind (i h s)
			(color-ihs (medium-background stream))
		      (make-ihs-color (* 0.9 i) h s))))

;;; 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) (accept-arguments 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)))
    (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)
  (let* ((outer-stream stream)
	 (gadget nil)
	 (record 
	  (updating-output (stream :cache-value default
				   :unique-id query-id
				   :record-type 'av-gadget-record)
	    ;; 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 ((wrapped-gadget-record
		   (updating-output (stream :cache-value t)
		     (with-output-as-gadget (stream)
		       (with-look-and-feel-realization
			   ((frame-manager *application-frame*)
			    *application-frame*)
			 (apply #'make-pane gadget-type
				:client outer-stream
				:id query-id
				(append
				 (view-gadget-initargs view)
				 (funcall-presentation-generic-function
				  gadget-initargs-for-view
				  view stream default default-supplied-p ptype))))))))
	      (setf gadget
		    (block return-gadget
		      (labels ((find-gadget (record)
				 (cond
				   ((typep record 'gadget-output-record)
				    (return-from return-gadget (gadget record)))
				   ((output-record-children record)
				    (map-over-output-records #'find-gadget
							     record)))))
			(map-over-output-records #'find-gadget
						 wrapped-gadget-record)
			))))
	    (when default-supplied-p
	      (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
      ;; the franz userguide says to use a check-box-view, but an
      ;; option pane for completion looks nicer
      ((completion) +option-pane-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))
	     `(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))))
  (define-completion-a-p-d (completion radio-box-view radio-box))

  (define-completion-a-p-d (completion option-pane-view option-pane))

  (define-completion-a-p-d (completion list-pane-view list-pane))

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

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

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

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