96e86d25 |
(define-widget my-slider (QWidget) ())
(define-signal (my-slider val-changed) (float))
(define-subwidget (my-slider slider) (q+:make-qslider my-slider))
(define-subwidget (my-slider label) (q+:make-qlabel my-slider))
(define-subwidget (my-slider layout) (q+:make-qvboxlayout my-slider)
(q+:add-widget slider)
(q+:add-widget label))
(define-slot (my-slider slider) ((new-val integer))
(declare (connected slider (value-changed integer)))
(setf (q+:text label) (format nil "~a%" new-val))
(signal! my-slider (val-changed float) (coerce (/ new-val 100) 'float)))
(defmethod set-value ((my-slider my-slider) (new-value float))
(with-slots-bound (my-slider my-slider)
(setf (q+:value slider) (round (* new-value 100)))))
(defmacro alambda (&body body)
`(lambda (it) ,@body))
(defmacro with-no-signals (widget &body body)
(alexandria:once-only (widget)
`(progn
(q+:block-signals ,widget t)
(unwind-protect
(progn
,@body)
(q+:block-signals ,widget nil)))))
(defmacro connect-cell-to-widget ((widget sub-widget) (cell class) place widg-value-cb)
"This connects a widget to an observable cell. TODO: figure out the macro edge-cases here"
`(cells:defobserver ,cell ((self ,class))
; I want this to run:
; EITHER When the old value is not bound
; OR When the old value is not equal to the new value
(format t "--> changed: ~a is not ~a~%" ,(symbol-name cell) cells:new-value)
(with-slots-bound (,widget ,widget)
(with-signals-blocked (,sub-widget)
(setf ,place (funcall ,widg-value-cb cells:new-value))))))
(defmacro connect-widget-to-cell ((widget signal arg-type) place &key value-mod)
(alexandria:with-gensyms (arg)
`(define-slot (,widget ,signal) ((,arg ,arg-type))
(declare (connected ,widget (,signal ,arg-type)))
,(when value-mod
`(setf ,arg (funcall ,value-mod ,arg)))
(setf ,place ,arg))))
(defmacro connecting ((widget sub-widget) (cell-slot-name cell-class) cell-instance &body body)
`(macrolet ((cell->widget (place cb)
`(connect-cell-to-widget (,',widget ,',sub-widget) (,',cell-slot-name ,',cell-class) ,place ,cb))
(signal->cell (signal &key value-mod)
`(connect-widget-to-cell (,',widget ,@signal) (,',cell-slot-name ,',cell-instance) :value-mod ,value-mod)))
,@body))
(defmacro define-connections (&rest connections)
(list*
'progn
(loop for (widg-spec cell-spec cell-inst . body) in connections
collect `(connecting ,widg-spec ,cell-spec ,cell-inst
,@body))))
(let* ((s-r (make-instance 'service-rating))
(tc (make-instance 'tip-calc :rate (cells:c? (rate s-r)))))
(defun stringify (obj) (format nil "~a" obj))
(defun make-keyword (str)
(alexandria:make-keyword (string-upcase str)))
(define-signal (edits cost-changed) (float))
(define-signal (edits rate-changed) (float))
(define-signal (edits tip-changed) (float))
(define-subwidget (edits cost-widg) (q+:make-qlineedit edits)
(setf (q+:placeholder-text cost-widg) (stringify (cost tc))))
(connecting (edits cost-widg) (cost tip-calc) tc
(signal->cell
(cost-changed float)))
(define-slot (edits cost-widg) ((new-text string))
(declare (connected cost-widg (text-edited string)))
(handler-case
(let ((num (coerce (parse-number new-text) 'float)))
(signal! edits (cost-changed float) num))
((or parse-error type-error) (c) (declare (ignore c)))))
(define-subwidget (edits rate-widg) (q+:make-qslider edits)
(setf (q+:minimum rate-widg) 6)
(setf (q+:maximum rate-widg) 30)
(setf (q+:value rate-widg) (round (* 100 (rate s-r)))))
(connecting (edits rate-widg) (rate tip-calc) tc
(cell->widget
(q+:value rate-widg)
(alambda
(round (* 100 it))))
(signal->cell
(rate-changed float)))
(define-slot (edits rate-widg) ((new-value integer))
(declare (connected rate-widg (value-changed integer)))
(handler-case
(signal! edits (rate-changed float) (coerce (/ new-value 100) 'float))
((or parse-error type-error) (c) (declare (ignore c)))))
(define-subwidget (edits tip-widg) (q+:make-qlineedit edits)
(setf (q+:placeholder-text tip-widg) (stringify (tip tc))))
(connecting (edits tip-widg) (tip tip-calc) tc
(cell->widget
(q+:text tip-widg)
(alambda
(stringify it))))
(define-subwidget (edits edit-layout) (q+:make-qhboxlayout edits)
(q+:add-widget edit-layout cost-widg)
(q+:add-widget edit-layout rate-widg)
(q+:add-widget edit-layout tip-widg))
(define-signal (service-quality quality-chosen) (string))
(define-subwidget (service-quality choose-poor) (q+:make-qradiobutton service-quality)
(setf (q+:text choose-poor) "Poor"))
(define-slot (service-quality choose-poor) ()
(declare (connected choose-poor (toggled bool)))
(signal! service-quality (quality-chosen string) "poor"))
(define-subwidget (service-quality choose-normal) (q+:make-qradiobutton service-quality)
(setf (q+:text choose-normal) "Normal"))
(define-slot (service-quality choose-normal) ()
(declare (connected choose-normal (toggled bool)))
(signal! service-quality (quality-chosen string) "normal"))
(define-subwidget (service-quality choose-excellent) (q+:make-qradiobutton service-quality)
(setf (q+:text choose-excellent) "Excellent"))
(define-slot (service-quality choose-excellent) ()
(declare (connected choose-excellent (toggled bool)))
(signal! service-quality (quality-chosen string) "excellent"))
(connecting (service-quality nil) (rating service-rating) s-r
(signal->cell
(quality-chosen string)
:value-mod (alambda (make-keyword it))))
(define-subwidget (service-quality quality-layout) (q+:make-qhboxlayout service-quality)
(q+:add-widget quality-layout choose-poor)
(q+:add-widget quality-layout choose-normal)
(q+:add-widget quality-layout choose-excellent))
(define-subwidget (main-window edits) (make-instance 'edits))
(define-subwidget (main-window service-quality) (make-instance 'service-quality))
(define-subwidget (main-window layout) (q+:make-qvboxlayout main-window)
(q+:add-widget layout service-quality)
(q+:add-widget layout edits)))
|