new file mode 100644

@@ -0,0 +1,41 @@

+(ql:quickload :alexandria)

+

+(defpackage generator-conditions

+  (:use :cl))

+(in-package generator-conditions)

+

+(define-condition generator-condition () ())

+(define-condition yield-value (generator-condition)

+  ((value :initarg :value :reader value)))

+(define-condition stop (generator-condition) ())

+

+(defmacro define-generator (name args &body body)

+  `(flet ((yield (v) (signal (make-condition 'yield-value :value v)))

+          (stop () (signal (make-condition 'stop))))

+     (defun ,name ,args

+       ,@body)))

+

+(defmacro with-generator (generator var &body body)

+  `(handler-case

+     (handler-bind

+       ((yield-value (lambda (c)

+                       (let ((,var (value c)))

+                         ,@body))))

+       ,generator)

+     (stop (c) (declare (ignore c)))))

+

+(define-generator to-ten ()

+  (loop for x from 0 to 10

+        do (yield x)))

+

+(defparameter outp nil)

+(with-generator (to-ten) x

+  (with-generator (to-ten) y

+    2))

+

+(defpackage generator-lambda

+  (:use :cl))

+(in-package generator-lambda)

+

+

+

@@ -15,6 +15,10 @@

 (in-package :math-test)

+(defmacro push-many (place &body items)

+  `(progn ,@(loop for item in items

+                  collect `(push ,item ,place))))

+

 (defmodel service-rating ()

           ((rating :cell t :accessor rating :initarg :rating :initform (c-in :normal))

            (rate   :cell t :accessor rate   :initform (c? (case (rating self)

@@ -27,6 +31,9 @@

            (rate :cell t :accessor rate :initarg :rate :initform (c-in 0.18))

            (tip  :cell t :accessor tip  :initform (c? (* (cost self)

                                                          (rate self))))))

+(defmodel fed-tip-calc (tip-calc)

+          ((rate-feeder :cell t :accessor rate-feeder :initarg :feeder)

+           (rate :cell t :accessor rate :initarg :rate :initform (c? (rate (rate-feeder self))))))

 (defmodel item ()

           ((kind :cell t :accessor kind :initarg :kind :initform (c-in :food))

@@ -47,38 +54,38 @@

                                                               (subtotal self))

                                                            (tip self))))))

+

+(defobserver rate ((self tip-calc))

+             (when old-value-boundp

+               (format t "The rate is: ~a It changed by: ~a~%" new-value (- new-value

+                                                                             old-value))))

+

 (defobserver tip ((self tip-calc))

              (when old-value-boundp

-               (format t "The tip is: ~a~%It changed by: ~a~%" new-value (- new-value

+               (format t "The tip is: ~a It changed by: ~a~%" new-value (- new-value

                                                                             old-value))))

-

-(defmacro push-many (place &body items)

-  `(progn ,@(loop for item in items

-                  collect `(push ,item ,place))))

-

-(defparameter s-r (make-instance 'service-rating))

-(defparameter bill (make-instance 'bill))

-(defparameter tc (make-instance 'tip-calc :cost (c? (cost bill)) :rate (c? (rate s-r))))

-(defparameter meal-calc (make-instance 'meal-expense-calculator

-                                       :subtotal (c? (cost bill))

-                                       :tip      (c? (tip tc))))

-

-(push-many (items bill)

-  (make-instance 'item :kind :meatloaf :cost 12.99)

-  (make-instance 'item :kind :salmon :cost 14.99)

-  (make-instance 'item :kind :frenchfries :cost 3.99)

-  (make-instance 'item :kind :tomatosoup :cost 3.99)

-  (make-instance 'item :kind :burgundy :cost 8.99)

-  (make-instance 'item :kind :icedtea :cost 3.99))

-(setf (rating s-r) :excellent)

-

-(format t "~{~a~20t~a~%~}------------------------------

-Subtotal:~20t~a~%Tax:~20t~a~%Tip:~20t~a~%Total:~20t~a~%"

-        (loop for item in (items bill)

-              append (list (kind item) (cost item)))

-        (subtotal meal-calc)

-        (* 0.08 (subtotal meal-calc))

-        (tip tc)

-        (total meal-calc))

+(let* ((s-r (make-instance 'service-rating))

+       (bill (make-instance 'bill))

+       (tc (make-instance 'fed-tip-calc :cost (c? (cost bill)) :feeder s-r))

+       (meal-calc (make-instance 'meal-expense-calculator

+                                 :subtotal (c? (cost bill))

+                                 :tip      (c? (tip tc)))))

+

+  (push-many (items bill)

+             (make-instance 'item :kind :meatloaf :cost 12.99)

+             (make-instance 'item :kind :salmon :cost 14.99)

+             (make-instance 'item :kind :frenchfries :cost 3.99)

+             (make-instance 'item :kind :tomatosoup :cost 3.99)

+             (make-instance 'item :kind :burgundy :cost 8.99)

+             (make-instance 'item :kind :icedtea :cost 3.99))

+  (setf (rating s-r) :excellent)

+

+  (format t "~{~a~20t~a~%~}------------------------------~%Subtotal:~20t~a~%Tax:~20t~a~%Tip:~20t~a~%Total:~20t~a~%"

+          (loop for item in (items bill)

+                append (list (kind item) (cost item)))

+          (subtotal meal-calc)

+          (* 0.08 (subtotal meal-calc))

+          (tip tc)

+          (total meal-calc)))

old mode 100644

new mode 100755

@@ -1,12 +1,18 @@

+#!/usr/local/bin/sbcl --script

+(declaim (optimize (speed 0) (safety 3) (debug 3)))

+(load #p"~/quicklisp/setup.lisp")

 (ql:quickload :qtools)

 (ql:quickload :cells)

 (ql:quickload :qtcore)

 (ql:quickload :qtgui)

+(ql:quickload :parse-number)

+(ql:quickload :alexandria)

+(ql:quickload :anaphora)

 (cl:defpackage :tipcalc.models

   (:use :cl :cells)

   (:export

-    service-rating tip-calc tax-calc item bill meal-expense-calculator

+    service-rating fed-tip-calc tip-calc tax-calc item bill meal-expense-calculator

     rating rate cost tip tax kind item subtotal subtotal total))

 (in-package :tipcalc.models)

@@ -23,6 +29,10 @@

            (rate :cell t :accessor rate :initarg :rate :initform (c-in 0.18))

            (tip  :cell t :accessor tip  :initform (c? (* (cost self)

                                                          (rate self))))))

+(defmodel fed-tip-calc (tip-calc)

+          ((rate-feeder :cell t :accessor rate-feeder :initarg :rate-feeder)

+           (rate :cell t :accessor rate :initarg :rate :initform (c? (rate (rate-feeder self))))))

+

 (defmodel tax-calc ()

           ((cost :cell t :accessor cost :initarg :cost :initform (c-in 0))

@@ -50,36 +60,185 @@

                                                            (tip self))))))

 (defpackage tipcalc

-  (:use :cl+qt :tipcalc.models))

+  (:use :cl+qt :parse-number :anaphora :tipcalc.models))

 (in-package :tipcalc)

 (in-readtable :qtools)

+;(defparameter *service-rating* (make-instance 'service-rating))

+;(defparameter *tip-calc* (make-instance 'tip-calc :rate (rate *service-rating*)))

+(define-widget edits (QWidget) ())

+(define-widget service-quality (QWidget) ())

 (define-widget main-window (QWidget) ())

-(define-subwidget (main-window cost-widg) (q+:make-qlineedit main-window)

-  (setf (q+:placeholder-text cost-widg) "Meal Cost?"))

-

-(define-subwidget (main-window rate-widg) (q+:make-qlineedit main-window)

-  (setf (q+:placeholder-text rate-widg) "Tip Rate?"))

-

-(define-subwidget (main-window tip-widg) (q+:make-qlineedit main-window)

-  (setf (q+:placeholder-text tip-widg) "Tip . . ."))

-

-(define-subwidget (main-window layout) (q+:make-qhboxlayout main-window)

-  (q+:add-widget layout cost-widg)

-  (q+:add-widget layout rate-widg)

-  (q+:add-widget layout tip-widg))

-

-(defparameter *tip-calc* (make-instance 'tip-calc))

-(cells:defobserver tip  ((self tip-calc))

-                   ; 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

-                   (when (or (not old-value-boundp) (/= new-value old-value))

-                     (setf (q+:text)

-                         (format nil "~a" new-value))))

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

 (defun main ()

   (with-main-window (window (make-instance 'main-window))))

+(ql:quickload  :swank)

+(swank:create-server :port 4006)

+(handler-case (main)

+  (sb-sys:interactive-interrupt (c) (declare (ignore c)) (format t "~cExiting on interrupt...~%" #\return)))

+