[initial
clinton@unknownlamer.org**20080510231305] {
addfile ./avg.lisp
hunk ./avg.lisp 1
+(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 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 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)
+      ;; rewrite (value-key may fail if item is not found)
+      (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 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)))
+
+;;; 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 stream 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
+
+(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))
+
+(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))
+
+;; broken
+(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
+    (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))))
+
+;;; Misc
+
+(defgeneric invoke-accept-values-command-button (stream continuation view prompt 
+						 &key
+						 documentation
+						 query-identifier
+						 cache-value
+						 cache-test
+						 resynchronize))
+
+(defmethod invoke-accept-values-command-button
+    (stream continuation (view gadget-dialog-view) prompt
+     &key
+     documentation
+     query-identifier
+     cache-value
+     cache-test
+     resynchronize
+     active-p)
+  (updating-output (stream :unique-id query-identifier
+			   :cache-value cache-value
+			   :cache-test cache-test)
+    (with-output-as-gadget (stream)
+      (with-look-and-feel-realization ((frame-manager *application-frame*)
+				       *application-frame*)
+	(make-pane 'push-button
+		   :label prompt
+		   :activate-callback (lambda (button)
+					(declare (ignore button))
+					(funcall continuation)))))))
+
+(define-presentation-type av-command-button () :inherit-from t)
+
+(define-command (com-button-call :command-table accept-values
+				 :name nil) ((function 'av-command-button))
+  (funcall function))
+
+(define-presentation-to-command-translator call-command-button
+    (av-command-button com-button-call accept-values
+      :gesture :select
+      :documentation "Activate command"
+      :pointer-documentation "Activate command"
+      :echo nil)
+    (object)
+  `(,object))
+
+(defmethod invoke-accept-values-command-button
+    (stream continuation (view textual-dialog-view) prompt
+     &key
+     documentation
+     query-identifier
+     cache-value
+     cache-test
+     resynchronize)
+  (updating-output (stream :unique-id query-identifier
+			   :cache-value cache-value
+			   :cache-test cache-test)
+    (with-output-as-presentation (stream continuation 'av-command-button
+					 :single-box t)
+      (princ prompt stream))))
+
+(defmacro accept-values-command-button
+    ((&optional stream
+		&key view documentation query-identifier
+		(cache-value t) (cache-test #'eql) resynchronize (active-p t))
+     prompt
+     &body body)
+  (with-gensyms (stream-name prompt-name)
+    `(let ((,stream-name ,stream)
+	   (,prompt-name ,prompt))
+       (invoke-accept-values-command-button
+	(or (encapsulating-stream-stream ,stream-name) t)
+	(lambda () ,@body)
+	(or ,view (stream-default-view ,stream-name))
+	,prompt-name
+	:documentation ,documentation
+	:query-identifier (or ,query-identifier ,prompt-name)
+	:cache-value ,cache-value
+	:cache-test ,cache-test
+	:resynchronize ,resynchronize
+	:active-p ,active-p))))
}