;;; -*- Package: PAVP -*-
;;;
(defpackage "PAVP" (:use "CLIM-LISP" "CLIM")
  (:shadow "ACCEPT-VALUES-PANE")
  (:export "AV-PANE" "AV-PANE-DISPLAYER"))

(in-package :pavp)
;;; 
;;; By Paul Werkowski, April-2006 and placed into the public domain.
;;; This code was written from the viewpoint of a CLIM user and demonstrates
;;; how ACCEPT-VALUE-PANE could (not should) be implemented. A not quite
;;; achived goal was to use only documented CLIM features.
;;; A CLIM implementer might spot some obvious problems.
;;;
;;; Just wondering how ACCEPT-VALUES-PANE can be implemented and came up
;;; with some code that should be portable across CLIM 2.0 systems
;;; (but tested only on LispWorks for Windows 4.4.6). The only non-documented
;;; exceptions is VIEW-INITARGS and FOCUS-OUT-CALLBACK below.
;;;
;;; Accept-values-pane is probably easier to implement than accepting-values
;;; because it only uses gadgets (true?), does not block, and has no exit boxes.
;;;
;;; The basics:
;;;
;;; Local things
;;;  class av-query
;;;  class av-stream
;;;  class av-pane        ]  like clim:accept-values-pane
;;;  command-table av-pane]
;;;  command com-av-update-query
;;;  event av-query-update-event
;;;
;;; CLIM things
;;; GF accept-present-default] specialized on av-stream and views
;;; GF stream-accept         ]
;;; GF value-changed-callback]
;;;
;;; CLIM magic
;;; Gadget value-changed-callback queues an event containing query and new
;;; value. Event handler invokes presentation system to pass value to
;;; command com-update-query. Top-level-loop calls display function,
;;; stream-accept returns values found in associated query object.
;;; 
;;;
;;; Results:
;;;
;;; With 'Real' CLIM:
;;; Pretty close match to clim:accept-values-pane mechanism.
;;; Noticable are:
;;;   * Some difference in font style in gadget labels.
;;;
;;;   * Slight screen flash on redisplay not noticable in CLIM version.
;;;     Some doc (LW?) says that redisplay is handled differently
;;;     for efficiency. I'd like to know how. I've seen this before when
;;;     I've used with-output-to-gadget but have not figured out the cause.
;;;
;;; With McCLIM
;;;   * Works only when FRAME-STANDARD-INPUT returns the right thing such as
;;;     when there is an application-pane or interactor-pane in the frame.
;;;     READ-COMMAND must call (ACCEPT 'COMMAND ...) as noted in the spec.
;;;     FWIW CLIM calls READ-COMMAND with STREAM parameter bound to 
;;;     the frame's TOP-LEVEL-SHEET in gadget-only frame.
;;;
;;;   * CLIM ACCEPT does not pass NIL view to STREAM-ACCEPT. Instead it
;;;     passes one of +RADIO-BOX-VIEW+ +CHECK-BOX-VIEW+ or +TOGGLE-BUTTON-VIEW+,
;;;     probably by noticing GADGET-DIALOG-VIEW in STREAM-DEFAULT-VIEW.
;;;     I special case STREAM-ACCEPT to do that for McCLIM.
;;;
;;;   * Exposes problems in gadget layout, maybe do to playing poorly with
;;;     vbox-pane? Trace ALLOCATE-SPACE to see some strange stuff.
;;;

(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (find-class 'clim::accept-values-pane nil)
    (pushnew :have-avp *features*)))
;;;     
;;; 1st of 2 Implementation-specific hacks.
(defun view-initargs (view)
  #+lispworks (clim-internals::view-gadget-initargs view))

;;; Probably not the same as an accepting-values-query?
(defclass av-query ()
  ((active-p :initarg :active-p)
   (changed-p :initarg :changed-p :initform nil)
   (ptype     :initarg :ptype)
   (query-id  :initarg :query-identifier)
   (gadget) ; installed by A-P-D
   (prompt :initarg :prompt :initform nil)
   (value :initarg :value)))

(define-command-table av-pane #|like clim:accept-values-pane|#)

;; standard-encapsulating-stream is not part of CLIM API but is described
;; in spec in appendix C

;; Stream seen by user display function. Encapsulated stream is av-pane.
(defclass av-stream (standard-encapsulating-stream
                     #+McCLIM standard-extended-output-stream
                     #+McCLIM climi::updating-output-stream-mixin)
  (
   ;; LW seems to ignore this. Me too for now.
   ;; Implement such that NIL installs prompt as :label of gadget and
   ;; T installs prompt and gadget (with :label NIL) in a two column table
   (align-prompts :initform nil :initarg :align-prompts)
   (queries :initform (make-hash-table :test #'equal))
   ))

(defmethod stream-default-view ((stream av-stream))
  +gadget-dialog-view+)

(defclass av-pane (clim:clim-stream-pane)
  ((av-stream))
  (:default-initargs
   :display-function 'av-pane-displayer
   :incremental-redisplay nil
   :display-time :no-clear))

(defmacro make-av-pane (&rest initargs)
  `(make-pane 'av-pane ,@initargs))

(defun av-pane-displayer (frame pane &key displayer resynchronize-every-pass)
  (let ((output-record
         (first (output-record-children (stream-output-history pane)))))
    (with-slots (av-stream) pane
      (cond ((null output-record)
             (setq av-stream (make-instance 'av-stream :stream pane))
             (updating-output (av-stream)
               (funcall displayer frame av-stream)))
            (t (redisplay output-record av-stream)
               (when resynchronize-every-pass
                 (redisplay output-record av-stream)))))
    (unless output-record ; first time through
      (multiple-value-bind (w h)
          (bounding-rectangle-size (stream-output-history pane))
        (change-space-requirements pane :width w :height h :resize-frame t)
        ))))

(defun button-labels (ptype)
  ;; Needed to make toggle-buttons for radio-box and check-box gadgets.
  (let ((ptype (expand-presentation-type-abbreviation ptype)))
    (with-presentation-type-decoded (ptype-name) ptype
      (case ptype-name
        (completion ; one-of
         (with-presentation-type-parameters (completion ptype)
           (with-presentation-type-options (completion ptype)
             (values (mapcar name-key sequence) sequence))))
        (subset-completion ; some-of
         (with-presentation-type-parameters (subset-completion ptype)
           (with-presentation-type-options (subset-completion ptype)
             (values (mapcar name-key sequence) sequence))))))))

(defun encode-gadget-value (item ptype gadget)
  ;; for use with (setf gadget-value)
  (let ((ptype (expand-presentation-type-abbreviation ptype)))
    (with-presentation-type-decoded (ptype-name) ptype
      (case ptype-name
        (completion ; one-of
          (with-presentation-type-parameters (completion ptype)
            (with-presentation-type-options (completion ptype)
              (etypecase gadget
                (radio-box
                 (let ((name (funcall name-key item)))
                   (find name (radio-box-selections gadget)
                         :key 'gadget-label :test 'string=)))
                ((or list-pane option-pane)
                 item)))))
        (subset-completion ; some-of
         (with-presentation-type-parameters (subset-completion ptype)
           (with-presentation-type-options (subset-completion ptype)
             (etypecase gadget
               (check-box
                (loop
                 with buttons = (check-box-selections gadget)
                 for v in item
                 for p = (position v sequence :test test)
                 collect (elt buttons p)))
               ((or list-pane option-pane)
                item)))))
         (boolean
          (if item t nil))
         ((real integer) item)
         (t ; scalar - probably want error handler here?
          (present-to-string item ptype))))))

(defun decode-gadget-value (gadget gadget-value ptype)
  (flet ((ensure-number (v)
           ;; Slider gives a number, text-field gives a string
           (if (stringp v)(read-from-string v) v)))
    (let ((ptype (expand-presentation-type-abbreviation ptype)))
      (with-presentation-type-decoded (ptype-name) ptype
        (case ptype-name
          (boolean gadget-value)
          (integer (round (ensure-number gadget-value)))
          ((real number float) (ensure-number gadget-value))
          ;; The completion types return item(s) from the presentation-type
          ;; sequence parameter.
          (completion
           (with-presentation-type-parameters (completion ptype)
             (with-presentation-type-options (completion ptype)
               (etypecase gadget
                 (radio-box ; gadget-value is toggle-button
                  (let* ((key (gadget-label gadget-value)))
                    (find key sequence :key name-key :test 'string=)))
                 ((or option-pane list-pane)
                  gadget-value)))))
          (subset-completion ; some-of or :nonexclusive
           (with-presentation-type-parameters (subset-completion ptype)
             (with-presentation-type-options (subset-completion ptype)
               (etypecase gadget
                 (check-box ; gadget-value is list of toggle-buttons
                  (loop for button in gadget-value
                        for item = (find (gadget-label button)
                                         sequence
                                         :key name-key
                                         :test 'string=)
                        when item collect item))
                 ((or option-pane list-pane)
                  gadget-value)))))
          (t (accept-from-string ptype gadget-value)))))))

(defun make-the-damn-gadget (stream query-object gadget-type view &rest params)
  (with-slots (gadget ptype value active-p prompt) query-object
      (updating-output (stream :cache-value (cons value active-p))
        (with-output-as-gadget (stream :cache-value t) ; Runs one time only.
          (multiple-value-bind (button-labels items)(button-labels ptype)
            (#-McCLIM progn ; CLIM's w-l-a-f-r macro inserts this for free.
             #+McCLIM with-look-and-feel-realization
             #+McCLIM ((frame-manager *application-frame*) *application-frame*)
             (setq gadget
                   (apply #'make-pane gadget-type
                          :name       prompt
                          :label      (and (stringp prompt) prompt)
                          :active     active-p
                          :client     stream
                          :id         query-object
                          (append
                           (view-initargs view)
                           (list :background (medium-background stream)
                                 :foreground (medium-foreground stream))
                           (case gadget-type
                             ((radio-box check-box)
                              (list :choices
                                    (loop for label in button-labels
                                          collect (make-pane 'toggle-button
                                                             :label label))))
                             ((list-pane option-pane)
                              (list :items items)))
                           params))))))
        ;; Do any dynamic gadget field manipulation here.
        (let ((value (if (eq gadget-type 'text-field)
                         (princ-to-string value)
                         (encode-gadget-value value ptype gadget))))
          (setf (gadget-value gadget) value))
        (unless (eql active-p (gadget-active-p gadget))
          (if active-p
              (activate-gadget gadget)
              (deactivate-gadget gadget))))))
;;;
;;; Accept-present-default
;;;
(defmacro define-completion-a-p-d ((p-type view-type gadget-type)
                                   &rest gadget-args)
  `(define-presentation-method accept-present-default
     ((type ,p-type) ; McCLIM requires the argument name to be TYPE??
      (stream av-stream)
      (view ,view-type)
      default default-supplied-p
      present-p ; In all Specs - Documented in LW UG
      query-object
      #+lispworks &key
      )
     (declare (ignore present-p default-supplied-p))
     (assert (typep query-object 'av-query))
     (make-the-damn-gadget
      stream query-object ',gadget-type view ,@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 t) (stream av-stream) (view text-field-view)
   default default-supplied-p present-p query-object
   #+lispworks &key
   )
  ;; Default for anything not defined here is a text field.
  ;; Probably not what you wanted.
  (make-the-damn-gadget stream query-object 'text-field view
                        :value (present-to-string default type)
                        ;; McCLIM's text-field not yet editable
                        :editable t))

(define-presentation-method accept-present-default
  ((type boolean) (stream av-stream) (view option-pane-view)
   default default-supplied-p present-p query-object
   #+lispworks &key
   )
  (make-the-damn-gadget stream query-object 'option-pane view
                        :items '#.(list (present-to-string   t 'boolean)
                                       (present-to-string nil 'boolean))
                        :value (present-to-string default 'boolean)
                        :mode :exclusive
                        ))

(define-presentation-method accept-present-default
  ((type boolean) (stream av-stream) (view toggle-button-view)
   default default-supplied-p present-p query-object
   #+lispworks &key
   )
  (make-the-damn-gadget stream query-object 'toggle-button view))

(define-presentation-method accept-present-default
  ((type integer)(stream av-stream)(view slider-view)
   default default-supplied-p present-p query-object
   #+LispWorks &key)
  (make-the-damn-gadget
   stream query-object 'slider view
   :value (round default)
   :min-value 0 :max-value 100))

(define-presentation-method accept-present-default
  ((type real)(stream av-stream)(view slider-view)
   default default-supplied-p present-p query-object
   #+LispWorks &key)
  (make-the-damn-gadget
   stream query-object 'slider view
   :min-value 0.0 :max-value 100.0))

;;; Need a way to notify CLIM that it should run the display functions.
;;; Probably not right to do redisplay-frame-panes from inside a callback,
;;; so use the presentation system.

(define-command (com-av-update-query :command-table av-pane :name nil)
    ((query-object t)(gadget-value t))
  ;; This could all be done in the value-changed-callback, but since I have
  ;; to use the presentation system anyway I might as well do the work here.
  (with-slots (gadget value changed-p ptype) query-object
    (let ((new-value (decode-gadget-value gadget gadget-value ptype)))
      (unless (equal value new-value)
        (setq changed-p t
              value new-value)))))
;;;
;;; Not sure this is helping any, but it does let the callback return normally.
;;; CLIM does something similar, but not using throw-highlighted-presentation.
;;;
(defclass av-query-update-event (clim:device-event)
  ((query :initarg :query)
   (value :initarg :value)))

(defmethod handle-event :after ((client av-stream)(event av-query-update-event))
  (with-slots (query value) event
    (throw-highlighted-presentation
     (make-instance 'standard-presentation
                    :object `(com-av-update-query ,query ,value)
                    :type 'command
                    :single-box t)
     *input-context*
     (make-instance 'pointer-button-press-event
                    :sheet #-McCLIM client
                    #+McCLIM (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 av-stream)
                                   query-object
                                   g-value)
  (when (typep query-object 'av-query)
    (queue-event (frame-top-level-sheet (pane-frame client))
                 (make-instance 'av-query-update-event
                                :sheet client
                                :query query-object
                                :value g-value))))

(defmethod value-changed-callback ((gadget text-field)
                                   (client av-stream)
                                   query-object
                                   g-value)
  ;; Don't want to terminate operation until done, but how would I know?
  ;; I thought the disarmed-callback could be used but it seems to never
  ;; get called. Maybe I have to watch for a pointer-exit-event or something?
  ;; See next form.
  (com-av-update-query query-object g-value)
  (values))

;;; 2nd of 2 Implementation-specific hacks
#+Lispworks
(let ((lispworks:*redefinition-action* nil))
  (defmethod clim-silica:focus-out-callback
             ((gadget text-field) (client av-stream) (gid av-query))
    (with-slots (value changed-p) gid
      (when changed-p
        (queue-event (frame-top-level-sheet (pane-frame client))
                     (make-instance 'av-query-update-event
                                    :sheet client
                                    :query gid
                                    :value value))))))


;;;
;;; Now for the interface to CLIM:ACCEPT.
;;;

(defun accept-one (stream ptype
                          &key view prompt
                          default
                          active-p
                          query-identifier)
  (declare (ignore prompt active-p))
  (accept-present-default ptype stream view
                          default
                          t ; ignored
                          nil ; ignored
                          query-identifier)
  ;; Hmm, that was easy! Too easy?
  )

(defmethod stream-accept ((stream av-stream)
                          ptype
                          &key
                          view
                          default
                          query-identifier
                          prompt 
                          (active-p t)
                          &allow-other-keys
                          )
  (with-slots (queries) stream
    (let* ((qid (or query-identifier prompt))
           (query (gethash qid queries))
           (view (or view
                     #+McCLIM ;; CLIM passes default view instance, not NIL
                     (case (presentation-type-name
                            (expand-presentation-type-abbreviation ptype))
                       (completion +radio-box-view+)
                       (subset-completion +check-box-view+)
                       (boolean +toggle-button-view+)
                       (t +text-field-view+)))))
      (unless query
        (setf (gethash qid queries)
              (make-instance 'av-query
                             :query-identifier qid
                             :active-p active-p
                             :prompt prompt
                             :ptype  ptype
                             :value default)))
      (let* ((query (gethash qid queries))
             ;; Apparently present-p comes from accepting-values and is
             ;; (list 'accept-values-choice <query object>)
             ;;        ^ ptype of accepting-values query
             ;; See LW accept-present-default. Not documented in Franz
             (present-p (list 'av-choice query))
             )
        (declare (ignorable present-p))

        (with-slots ((active active-p) changed-p value) query
          (setq active active-p)

          (ecase 'my-way
            (my-way
             (accept-one stream ptype
                         :view view
                         :prompt prompt
                         :default default
                         :active-p active-p
                         :query-identifier query))
            (lw-way
             (accept-1 stream ptype
                       :view view
                       :prompt prompt
                       :default default
                       :active-p active-p
                       :query-identifier query
                       ;; This is REQUIRED in LW else hangs somewhere
                       ;; in read-token.
                       ;; Not in any spec or manual but appears in
                       ;; LW function doc string
                       #+LispWorks :present-p
                       #+Lispworks present-p
                       )))
          ;; Extract return values from query object
          (let ((changed changed-p))
            (setq changed-p nil)
            (values value ptype changed)))))))

;;;
;;; Example
;;;

;;; Dialog display function
(defun my-AV-dialog (frame stream)
  (format stream "~a AV Pane~%~%"
          (if (typep stream 'pavp::av-stream) "My" "CLIM"))
  
  (with-slots (slot1 slot2 slot3 slot4) frame

    (setq slot1 (accept 'boolean :stream stream
                        :prompt "Activate Bar & Baz"
                        :default slot1
                        ;:view '(toggle-button-view)
                        ))
    (terpri stream)

    (setq slot2
          (accept '(member-alist ((:a 1) (:b 2) (:c 3)) :test equal)
                  :stream stream
                  :default slot2
                  :prompt "Bar"
                  :active-p slot1
                  ;:view '(radio-box-view :orientation :vertical)
                  ))
    (terpri stream)

    (setq slot3 (accept 'integer
                        :stream stream
                        :default slot3
                        :prompt "Buz"
                        ; :view '(text-field-view :width 40)
                        :view '(slider-view :width 100)
                        ))
    (terpri stream)

    (setq slot4
          (accept '(member :a :b :c)
                  :stream stream
                  :default slot4
                  :prompt "Baz"
                  :active-p slot1
                  :view '(option-pane-view)))
    (terpri stream)

    (format *trace-output* "S1 ~s S2 ~s S3 ~s S4 ~s~%" slot1 slot2 slot3 slot4)
    ))

(define-application-frame tav ()
  ((slot1 :initform t)
   (slot2 :initform '(:b 2))
   (slot3 :initform 10)
   (slot4 :initform :A))
  #+McCLIM
  (:menu-bar nil)
  (:command-table
   (foo :inherit-from (#+:have-avp CLIM:accept-values-pane av-pane)))
  (:panes
   #+McCLIM ;; Needs this else uses "simple-loop" for gadget-only frames :(
   (stdin :application
          :scroll-bars nil
          :min-width 100 :min-height 20)
   #+:have-avp
   (real-av :accept-values
            :scroll-bars nil
            :display-function '(accept-values-pane-displayer
                                ; :resynchronize-every-pass t
                                :displayer my-av-dialog))
   (my-av (make-av-pane
           :display-function '(av-pane-displayer
                               ;:resynchronize-every-pass t
                               :displayer my-av-dialog)
           :scroll-bars nil
           #+McCLIM :min-width  #+McCLIM 10
           ;; Without this, cmucl locks up 100% cpu bound.
           ;; Still a problem though as some gadgets not displayed until
           ;; check box is unchecked!!!
           #+McCLIM :min-height #+McCLIM 50
           )))
  (:layouts
   (default (vertically ()
              #+McCLIM stdin
              ;; WARNING Be aware of conflicts from two panes using same slots!!
              #+:have-avp  real-av
              my-av
              ))))

(defun doit ()
  (let ((frame (make-application-frame 'tav)))
    (run-frame-top-level frame)
   ))